diff --git a/thys/Bicategory/Bicategory.thy b/thys/Bicategory/Bicategory.thy
--- a/thys/Bicategory/Bicategory.thy
+++ b/thys/Bicategory/Bicategory.thy
@@ -1,2433 +1,2434 @@
 (*  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"
-            using VVV.comp_char VVV.arr_char CCC.seq_char VV.arr_char
-            by (elim CCC.seqE CC.seqE seqE, simp)
+            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
     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
     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
 
     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
       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
         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 "src \<nu> = src (src \<nu>)" using \<nu> by simp
         also have "... = src (trg \<mu>)"
           using \<nu> 1 [of "src \<nu>"] src_in_sources a weak_unit_self_composable seq_if_composable
           by auto
         also have "... = trg (trg \<mu>)" using \<mu> by simp
         also have "... = trg \<mu>" using \<mu> by simp
         finally show "src \<nu> = trg \<mu>" by blast
       qed
     qed
 
     lemma is_associative_weak_composition:
     shows "associative_weak_composition V H \<a>"
     proof -
       have 1: "\<And>\<nu> \<mu>. \<nu> \<star> \<mu> \<noteq> null \<Longrightarrow> src \<nu> = trg \<mu>"
         using H.is_extensional VV.arr_char by force
       show "associative_weak_composition V H \<a>"
       proof
         show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
                       \<guillemotleft>\<a>[f, g, h] : (f \<star> g) \<star> h \<Rightarrow> f \<star> g \<star> h\<guillemotright>"
           using 1 by auto
         show "\<And>f g h. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> f \<star> g \<noteq> null \<Longrightarrow> g \<star> h \<noteq> null \<Longrightarrow>
                       iso \<a>[f, g, h]"
           using 1 iso_assoc by presburger
         show "\<And>\<tau> \<mu> \<nu>. \<tau> \<star> \<mu> \<noteq> null \<Longrightarrow> \<mu> \<star> \<nu> \<noteq> null \<Longrightarrow>
                       \<a>[cod \<tau>, cod \<mu>, cod \<nu>] \<cdot> ((\<tau> \<star> \<mu>) \<star> \<nu>) = (\<tau> \<star> \<mu> \<star> \<nu>) \<cdot> \<a>[dom \<tau>, dom \<mu>, dom \<nu>]"
            using 1 assoc_naturality hseq_char hseq_char' by metis
         show "\<And>f g h k. ide f \<Longrightarrow> ide g \<Longrightarrow> ide h \<Longrightarrow> ide k \<Longrightarrow>
                          sources f \<inter> targets g \<noteq> {} \<Longrightarrow>
                          sources g \<inter> targets h \<noteq> {} \<Longrightarrow>
                          sources h \<inter> targets k \<noteq> {} \<Longrightarrow>
                         (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k) =
                         \<a>[f, g, h \<star> k] \<cdot> \<a>[f \<star> g, h, k]"
            using 1 connected_iff_seq pentagon ideD(1) by auto
       qed
     qed
 
     interpretation associative_weak_composition V H \<a>
       using is_associative_weak_composition by auto
 
     theorem is_prebicategory:
     shows "prebicategory V H \<a>"
       using src_in_sources trg_in_targets by (unfold_locales, auto)
 
     interpretation prebicategory V H \<a>
       using is_prebicategory by auto
 
     corollary is_prebicategory_with_homs:
     shows "prebicategory_with_homs V H \<a> src trg"
       ..
 
     interpretation prebicategory_with_homs V H \<a> src trg
       using is_prebicategory_with_homs by auto
 
     text \<open>
       In a bicategory, an arrow is a weak unit if and only if it is
       isomorphic to its chosen source (or to its chosen target).
     \<close>
 
     lemma weak_unit_char:
     shows "weak_unit a \<longleftrightarrow> a \<cong> src a"
     and "weak_unit a \<longleftrightarrow> a \<cong> trg a"
     proof -
       show "weak_unit a \<longleftrightarrow> a \<cong> src a"
         using isomorphism_respects_weak_units isomorphic_symmetric
         by (meson ideD(1) isomorphic_implies_ide(2) obj_is_weak_unit obj_src source_iso_src
             weak_unit_iff_self_source weak_unit_self_composable(1))
       show "weak_unit a \<longleftrightarrow> a \<cong> trg a"
         using isomorphism_respects_weak_units isomorphic_symmetric
         by (metis \<open>weak_unit a = isomorphic a (src a)\<close> ideD(1) isomorphic_implies_hpar(3)
             isomorphic_implies_ide(1) src_trg target_iso_trg weak_unit_iff_self_target)
     qed
         
     interpretation H: partial_magma H
       using is_partial_magma by auto
 
     text \<open>
       Every arrow with respect to horizontal composition is also an arrow with respect
       to vertical composition.  The converse is not necessarily true.
     \<close>
 
     lemma harr_is_varr:
     assumes "H.arr \<mu>"
     shows "arr \<mu>"
     proof -
       have "H.domains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
       proof -
         assume 1: "H.domains \<mu> \<noteq> {}"
         obtain a where a: "H.ide a \<and> \<mu> \<star> a \<noteq> null"
           using 1 H.domains_def by auto
         show "arr \<mu>"
           using a hseq_char' H.ide_def by blast
       qed
       moreover have "H.codomains \<mu> \<noteq> {} \<Longrightarrow> arr \<mu>"
       proof -
         assume 1: "H.codomains \<mu> \<noteq> {}"
         obtain a where a: "H.ide a \<and> a \<star> \<mu> \<noteq> null"
           using 1 H.codomains_def by auto
         show "arr \<mu>"
           using a hseq_char' ide_def by blast
       qed
       ultimately show ?thesis using assms H.arr_def by auto
     qed
 
     text \<open>
       An identity for horizontal composition is also an identity for vertical composition.
     \<close>
 
     lemma horizontal_identity_is_ide:
     assumes "H.ide \<mu>"
     shows "ide \<mu>"
     proof -
       have \<mu>: "arr \<mu>"
         using assms H.ide_def composable_implies_arr(2) by auto
       hence 1: "\<mu> \<star> dom \<mu> \<noteq> null"
         using assms hom_connected H.ide_def by auto
       have "\<mu> \<star> dom \<mu> = dom \<mu>"
         using assms 1 H.ide_def by simp
       moreover have "\<mu> \<star> dom \<mu> = \<mu>"
         using assms 1 H.ide_def [of \<mu>] null_agreement
         by (metis \<mu> cod_cod cod_dom hcomp_simps\<^sub>W\<^sub>C(3) ideD(2) ide_char' paste_1)
       ultimately have "dom \<mu> = \<mu>"
         by simp
       thus ?thesis
         using \<mu> by (metis ide_dom)
     qed
 
     text \<open>
       Every identity for horizontal composition is a weak unit.
     \<close>
 
     lemma horizontal_identity_is_weak_unit:
     assumes "H.ide \<mu>"
     shows "weak_unit \<mu>"
       using assms weak_unit_char
       by (metis H.ide_def comp_target_ide horizontal_identity_is_ide ideD(1)
           isomorphism_respects_weak_units null_agreement targetsD(2-3) trg_in_targets)
 
   end
 
   subsection "Vertically Discrete Bicategories are Categories"
 
   text \<open>
     In this section we show that if a bicategory is discrete with respect to vertical
     composition, then it is a category with respect to horizontal composition.
     To obtain this result, we need to establish that the set of arrows for the horizontal
     composition coincides with the set of arrows for the vertical composition.
     This is not true for a general bicategory, and even with the assumption that the
     vertical category is discrete it is not immediately obvious from the definitions.
     The issue is that the notion ``arrow'' for the horizontal composition is defined
     in terms of the existence of ``domains'' and ``codomains'' with respect to that
     composition, whereas the axioms for a bicategory only relate the notion ``arrow''
     for the vertical category to the existence of sources and targets with respect
     to the horizontal composition.
     So we have to establish that, under the assumption of vertical discreteness,
     sources coincide with domains and targets coincide with codomains.
     We also need the fact that horizontal identities are weak units, which previously
     required some effort to show.
   \<close>
 
   locale vertically_discrete_bicategory =
     bicategory +
   assumes vertically_discrete: "ide = arr"
   begin
 
     interpretation prebicategory_with_homs V H \<a> src trg
       using is_prebicategory_with_homs by auto
 
     interpretation H: partial_magma H
       using is_partial_magma(1) by auto
 
     lemma weak_unit_is_horizontal_identity:
     assumes "weak_unit a"
     shows "H.ide a"
     proof -
       have "a \<star> a \<noteq> H.null"
         using assms 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>"
-        using assms unit_in_hom iso_unit weak_unit_def isomorphic_def by blast
+        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
 
     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,14697 @@
 (*  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: "\<And>r. ide r \<Longrightarrow> \<exists>f g. is_left_adjoint f \<and> is_left_adjoint g \<and> isomorphic r (g \<star> f\<^sup>*)"
-  and BS2: "\<And>f g. \<lbrakk> is_left_adjoint f; is_left_adjoint g; src f = src g \<rbrakk>
+  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: "\<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>
+  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
               have "C.commutative_square r0 ?u1 (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
               proof
                 have 1: "r0 \<cdot> ?p1' = ?u1 \<cdot> \<theta>'.chine"
                   using \<theta>'.leg1_commutes Cod_\<theta>'_1 Dom_\<theta>'_1 fw'.leg1_composite by simp
                 show "C.cospan r0 ?u1"
                   using ru.legs_form_cospan(1) by blast
                 show "C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
                   using \<beta>.chine_in_hom \<theta>'.chine_in_hom
                   by (metis "1" C.dom_comp C.in_homE C.prj1_simps(1) C.prj1_simps(2)
                       C.seqI Cod_\<theta>'_1 Dom_\<theta>'.leg_simps(3) Chn_\<beta> \<theta>'.leg1_commutes cospan')
                 show "C.dom r0 = C.cod (?p1' \<cdot> \<beta>.chine)"
                   using \<beta>.chine_in_hom
                   by (metis C.cod_comp C.prj1_simps(3)
                       \<open>C.span (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
                       cospan' r.dom.apex_def r.chine_eq_apex r.chine_simps(2))
                 show "r0 \<cdot> ?p1' \<cdot> \<beta>.chine = ?u1 \<cdot> \<theta>'.chine \<cdot> \<beta>.chine"
                   using 1 \<beta>.chine_in_hom C.comp_assoc by metis
               qed
               have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
                 using ru.legs_form_cospan(1) Dom_\<theta>.is_span Dom_\<theta>_1
                       C.comp_assoc C.pullback_commutes' r\<theta>.legs_form_cospan(1)
                 apply (intro C.commutative_squareI)
                    apply auto
                 by (metis C.comp_assoc Cod_\<theta>_1 \<theta>.leg1_commutes)
               hence "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1] (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])"
                 using fw.leg1_composite by auto
               have "C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1'] (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])"
                 using C.tuple_is_extensional Chn_r\<theta>'_eq r\<theta>'.chine_simps(1) fw' by force
               have "C.commutative_square ra ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0"
                 using C.pullback_commutes' gw.legs_form_cospan(1) rfw.prj_simps(2) C.comp_assoc
                       C.comp_cod_arr
                 apply (intro C.commutative_squareI) by auto
               have "C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0"
                 using cospan'
                 apply (intro C.commutative_squareI)
                    apply simp_all
                 by (metis C.comp_assoc C.prj0_simps_arr C.pullback_commutes'
                     arrow_of_spans_data.select_convs(2) rfw'.prj_simps(3)
                     span_data.select_convs(1-2))
               have "C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1 \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
               proof -
                 have "C.arr rfw.chine_assoc"
                   by (metis C.seqE rfw.prj_chine_assoc(1) rfw.prj_simps(1))
                 thus ?thesis
                   using C.tuple_is_extensional rfw.chine_assoc_def by fastforce
               qed
               have "C.commutative_square r0 (r0 \<cdot> ?p1') rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>"
                 by (metis (no_types, lifting) C.not_arr_null C.seqE C.tuple_is_extensional
                     arrow_of_spans_data.select_convs(2) rfw'.chine_assoc_def
                     rfw'.prj_chine_assoc(1) rfw'.prj_simps(1) span_data.select_convs(1-2))
               have "C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0"
                 using C.tuple_is_extensional Chn_\<rho>w_eq \<rho>w.chine_simps(1) by fastforce
               have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')"
                 using C.tuple_is_extensional \<rho>w'.chine_composite \<rho>w'.chine_simps(1) by force
               have "C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'"
                 using C.tuple_is_extensional Chn_\<rho>w'_eq \<rho>w'.chine_simps(1) by force
               text \<open>
                 Now, derive the consequences of the equation:
                 \[
                   \<open>(r \<star> \<theta>) \<bullet> \<a>[r, ?f, w] \<bullet> (?\<rho> \<star> w) = (r \<star> \<theta>') \<bullet> \<a>[r, ?f, w'] \<bullet> (?\<rho> \<star> w') \<bullet> \<beta>\<close>
                 \]
                 The strategy is to expand and simplify the left and right hand side to tuple form,
                 then compose with projections and equate corresponding components.
 
                 We first work on the right-hand side.
               \<close>
               have R: "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
                        \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
               proof -
                 have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) =
                       r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                 proof -
                   have 1: "\<guillemotleft>T.composite_cell w' \<theta>' \<bullet> \<beta> : g \<star> w \<Rightarrow> r \<star> u\<guillemotright>"
                     using \<beta> \<rho>w' arfw' r\<theta>' by auto
                   have "Chn (T.composite_cell w' \<theta>' \<bullet> \<beta>) = Chn (T.composite_cell w' \<theta>') \<cdot> \<beta>.chine"
                     using 1 Chn_vcomp by blast
                   also have "... = (r\<theta>'.chine \<cdot> Chn (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))) \<cdot> \<beta>.chine"
                   proof -
                     have "seq (r \<star> \<theta>') (\<a>[r, f, w'] \<bullet> (\<rho> \<star> w'))"
                       using 1 by blast
                     thus ?thesis
                       using 1 Chn_vcomp by presburger
                   qed
                   also have "... = (r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                   proof -
                     have "seq \<a>[r, f, w'] (\<rho> \<star> w')"
                       using 1 by blast
                     thus ?thesis
                       using 1 Chn_vcomp by presburger
                   qed
                   finally show ?thesis
                     using C.comp_assoc by auto
                 qed
                 also have "... = \<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
                 proof -
                   let ?LHS = "r\<theta>'.chine \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                   let ?RHS = "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle>"
          
                   have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                   proof (intro C.comp_in_homI)
                     show "\<guillemotleft>\<beta>.chine : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C ?R \<down>\<down> ?w1'\<guillemotright>"
                       using Chn_\<beta> by simp
                     show "\<guillemotleft>\<rho>w'.chine : ?R \<down>\<down> ?w1' \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
                       using Chn_\<rho>w' by simp
                     show "\<guillemotleft>Chn \<a>[r, f, w'] : Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C rfw'.chine\<guillemotright>"
                       using arfw'
                       by (metis (no_types, lifting) Chn_in_hom Cod_\<rho>_0
                           arrow_of_spans_data.simps(2) rf rf.leg0_composite rfw'.chine_composite(1)
                           span_data.select_convs(1) w'.cod_simps(3))
                     show "\<guillemotleft>r\<theta>'.chine : rfw'.chine \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                       using Chn_r\<theta>' by auto
                   qed
                   have 2: "C.commutative_square r0 ?u1
                              (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)"
                     by fact
                   have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r\<theta>'.cod.apex\<guillemotright>"
                     using 2 Chn_\<beta> r\<theta>'_cod_apex_eq
                           C.tuple_in_hom [of r0 ?u1 "?p1' \<cdot> \<beta>.chine" "\<theta>'.chine \<cdot> \<beta>.chine"]
                     by fastforce
 
                   show ?thesis
                   proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
                     show "C.cospan r0 ?u1"
                       using ru.legs_form_cospan(1) by blast
                     show "C.seq ru.prj\<^sub>1 ?LHS"
                       using LHS r\<theta>'_cod_apex_eq by auto
                     show "C.seq ru.prj\<^sub>1 ?RHS"
                       using RHS r\<theta>'_cod_apex_eq by auto
                     show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>0 \<cdot> ?LHS =
                             (ru.prj\<^sub>0 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = ((\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1']) \<cdot> Chn \<a>[r, f, w']) \<cdot>
                                          \<rho>w'.chine \<cdot> \<beta>.chine"
                         using Chn_r\<theta>'_eq C.comp_assoc fw'
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
                                   (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
                         by simp
                       also have "... = \<theta>'.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1'] \<cdot> Chn \<a>[r, f, w']) \<cdot>
                                          \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = \<theta>'.chine \<cdot> (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine) \<cdot>
                                          \<beta>.chine"
                         using ide_f hseq_rf hseq_char \<alpha>_ide C.comp_assoc
                               rfw'.chine_assoc_def fw'.leg1_composite C.prj_tuple(1)
                               \<open>C.commutative_square r0 (r0 \<cdot> ?p1')
                                  rfw'.Prj\<^sub>1\<^sub>1 \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>\<close>
                         by simp
                       also have "... = \<theta>'.chine \<cdot> \<beta>.chine"
                       proof -
                         have "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine = gw'.apex"
                         proof (intro C.prj_joint_monic
                                        [of ?R ?w1' "\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine"
                                            gw'.apex])
                           show "C.cospan ?R ?w1'"
                             using fw'.legs_form_cospan(1) by simp
                           show "C.seq ?p1' (\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine)"
                           proof (intro C.seqI' C.comp_in_homI)
                             show "\<guillemotleft>\<rho>w'.chine : Dom_\<rho>.leg0 \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1\<guillemotright>"
                               using \<rho>w'.chine_composite_in_hom by simp
                             show "\<guillemotleft>\<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, w'.leg1\<rbrakk> rfw'.Prj\<^sub>0\<rangle> :
                                       Cod_\<rho>.leg0 \<down>\<down> w'.cod.leg1 \<rightarrow>\<^sub>C ?R \<down>\<down> w'.leg1\<guillemotright>"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close>
                                     C.tuple_in_hom [of ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0]
                                     rf rf.leg0_composite
                               by auto
                             show "\<guillemotleft>?p1' : ?R \<down>\<down> w'.leg1 \<rightarrow>\<^sub>C f.apex\<guillemotright>"
                               using fw'.prj_in_hom(1) by auto
                           qed
                           show "C.seq ?p1' gw'.apex"
                             using gw'.dom.apex_def gw'.leg0_composite fw'.prj_in_hom by auto
                           show "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                          ?p0' \<cdot> gw'.apex"
                           proof -
                             have "?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                   (?p0' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw'.Prj\<^sub>0 \<cdot> \<rho>w'.chine"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by auto
                             also have
                               "... = \<p>\<^sub>0[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
                               using \<rho>w'.chine_composite Dom_\<rho>_0 Cod_\<rho>_0 C.comp_cod_arr by simp
                             also have "... = w'.chine \<cdot> ?p0'"
                               using \<open>C.commutative_square k0 ?w1'
                                       (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
                               by simp
                             also have "... = ?p0' \<cdot> gw'.apex"
                               using cospan C.comp_cod_arr C.comp_arr_dom gw'.chine_is_identity
                                     gw'.chine_eq_apex gw'.chine_composite fw'.prj_in_hom
                               by auto
                             finally show ?thesis by simp
                           qed
                           show "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                          ?p1' \<cdot> gw'.apex"
                           proof -
                             have "?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle> \<cdot> \<rho>w'.chine =
                                   (?p1' \<cdot> \<langle>rfw'.Prj\<^sub>0\<^sub>1 \<lbrakk>ra, ?w1'\<rbrakk> rfw'.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w'.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw'.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w'.chine"
                               using \<open>C.commutative_square ?R ?w1' rfw'.Prj\<^sub>0\<^sub>1 rfw'.Prj\<^sub>0\<close> by simp
                             also have
                               "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1' \<lbrakk>k0, ?w1'\<rbrakk> w'.chine \<cdot> ?p0'\<rangle>"
                               using \<rho>w'.chine_composite Cod_\<rho>_0 C.comp_assoc C.comp_cod_arr
                               by simp
                             also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1'"
                               using \<open>C.commutative_square k0 ?w1'
                                       (\<rho>.chine \<cdot> ?p1') (w'.chine \<cdot> ?p0')\<close>
                               by simp
                             also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1'"
                               using C.comp_assoc by metis
                             also have "... = ?p1'"
                               using \<rho>.leg0_commutes C.comp_cod_arr cospan' by simp
                             also have "... = ?p1' \<cdot> gw'.apex"
                               using C.comp_arr_dom cospan' gw'.chine_eq_apex gw'.chine_composite
                               by simp
                             finally show ?thesis by simp
                           qed
                         qed
                         thus ?thesis
                           using Chn_\<beta> C.comp_cod_arr gw'.apex_composite by auto
                       qed
                       also have "... = \<p>\<^sub>0[r0, ?u1] \<cdot> ?RHS"
                         using RHS 2 C.prj_tuple [of r0 ?u1] by simp
                       finally show ?thesis by simp
                     qed
                     show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>1 \<cdot> ?LHS =
                             (ru.prj\<^sub>1 \<cdot> r\<theta>'.chine) \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = \<p>\<^sub>1[r0, fw'.leg1] \<cdot> Chn \<a>[r, f, w'] \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using Chn_r\<theta>' Chn_r\<theta>'_eq fw'
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1']
                                  (\<theta>'.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1'])\<close>
                         by simp
                       also have "... = (rfw'.Prj\<^sub>1 \<cdot> rfw'.chine_assoc) \<cdot> \<rho>w'.chine \<cdot> \<beta>.chine"
                         using ide_f ide_w' hseq_rf hseq_char \<alpha>_ide fw'.leg1_composite C.comp_assoc
                         by auto
                       also have "... = (rfw'.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using rfw'.prj_chine_assoc C.comp_assoc by simp
                       also have "... = ((k1 \<cdot> \<p>\<^sub>1[k0, ?w1']) \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using C.comp_cod_arr by simp
                       also have "... = (k1 \<cdot> \<p>\<^sub>1[k0, ?w1'] \<cdot> \<rho>w'.chine) \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = (k1 \<cdot> \<rho>.chine \<cdot> ?p1') \<cdot> \<beta>.chine"
                         using Chn_\<rho>w'_eq Dom_\<rho>_0 Cod_\<rho>_0
                               \<open>C.commutative_square k0 ?w1' (\<rho>.chine \<cdot> ?p1') ?p0'\<close>
                         by simp
                       also have "... = (k1 \<cdot> \<rho>.chine) \<cdot> ?p1' \<cdot> \<beta>.chine"
                         using C.comp_assoc by metis
                       also have "... = (?R \<cdot> ?p1') \<cdot> \<beta>.chine"
                         using C.comp_assoc by simp
                       also have "... = ?p1' \<cdot> \<beta>.chine"
                         using C.comp_cod_arr C.prj1_in_hom [of ?R ?w1'] cospan' by simp
                      also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
                         using RHS 2 by simp
                       finally show ?thesis by simp
                     qed
                   qed
                 qed
                 finally show ?thesis by simp
               qed
 
               text \<open>
                 Now we work on the left-hand side.
               \<close>
               have L: "Chn (T.composite_cell w \<theta>) = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
               proof -
                 have "Chn (T.composite_cell w \<theta>) = r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                   using Chn_vcomp arfw C.comp_assoc by auto
                 moreover have "... = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                 proof -
                   let ?LHS = "r\<theta>.chine \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                   let ?RHS = "\<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                   have 2: "C.commutative_square r0 ?u1 ?p1 \<theta>.chine" by fact
                   have LHS: "\<guillemotleft>?LHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
                     using Chn_r\<theta> Chn_\<rho>w rfw.chine_assoc_in_hom
                     by (metis (no_types, lifting) "8" Chn_in_hom Dom_\<rho>_0
                         arrow_of_spans_data.simps(2) calculation gw.chine_composite
                         r\<theta>_cod_apex_eq ru.chine_composite)
                   have RHS: "\<guillemotleft>?RHS : ?R \<down>\<down> ?w1 \<rightarrow>\<^sub>C r0 \<down>\<down> ?u1\<guillemotright>"
                     using 2 C.tuple_in_hom [of r0 ?u1 "?p1" \<theta>.chine] cospan r\<theta>_cod_apex_eq
                     by simp
                   show ?thesis
                   proof (intro C.prj_joint_monic [of r0 ?u1 ?LHS ?RHS])
                     show "C.cospan r0 ?u1"
                       using ru.legs_form_cospan(1) by blast
                     show "C.seq ru.prj\<^sub>1 ?LHS"
                       using LHS r\<theta>_cod_apex_eq by auto
                     show "C.seq ru.prj\<^sub>1 ?RHS"
                       using RHS r\<theta>_cod_apex_eq by auto
                     show "ru.prj\<^sub>0 \<cdot> ?LHS = ru.prj\<^sub>0 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>0 \<cdot> ?LHS = (ru.prj\<^sub>0 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, f.leg1 \<cdot> fw.prj\<^sub>1]) \<cdot>
                                          Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using Chn_r\<theta>_eq Dom_\<theta>_1 Cod_\<theta>_1 fw.leg1_composite
                               \<open>C.commutative_square r0 ?u1 \<p>\<^sub>1[r0, r0 \<cdot> ?p1]
                                  (\<theta>.chine \<cdot> \<p>\<^sub>0[r0, r0 \<cdot> ?p1])\<close>
                         by simp
                       also have "... = \<theta>.chine \<cdot> (\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = \<theta>.chine \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
                       proof -
                         have "Chn \<a>[r, f, w] = rfw.chine_assoc"
                           using ide_f ide_w hseq_rf hseq_char \<alpha>_ide by auto
                         moreover have "\<p>\<^sub>0[r0, r0 \<cdot> ?p1] \<cdot> rfw.chine_assoc =
                                        \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>"
                           using rfw.chine_assoc_def
                                 \<open>C.commutative_square r0 (r0 \<cdot> ?p1) rfw.Prj\<^sub>1\<^sub>1
                                    \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>\<close>
                           by simp
                         ultimately show ?thesis by simp
                       qed
                       also have "... = \<theta>.chine \<cdot> (?R \<down>\<down> ?w1)"
                       proof -
                         have "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine = ?R \<down>\<down> ?w1"
                         proof (intro C.prj_joint_monic
                                        [of ?R ?w1 "\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine"
                                            "?R \<down>\<down> ?w1"])
                           show "C.cospan ?R ?w1" by fact
                           show "C.seq ?p1 (\<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine)"
                           proof -
                             have "C.seq rfw.Prj\<^sub>0\<^sub>1 \<rho>w.chine"
                               by (meson C.seqI' Chn_in_hom \<rho>w rfw.prj_in_hom(2)
                                   \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>)
                             thus ?thesis
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close>
                               by (metis (no_types) C.comp_assoc C.prj_tuple(2))
                           qed
                           show "C.seq ?p1 (?R \<down>\<down> ?w1)"
                             using gw.dom.apex_def gw.leg0_composite gw.prj_in_hom by auto
                           show "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                 ?p0 \<cdot> (?R \<down>\<down> ?w1)"
                           proof -
                             have "?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                   (?p0 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw.Prj\<^sub>0 \<cdot> \<rho>w.chine"
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
                             also have "... = \<p>\<^sub>0[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using Chn_\<rho>w_eq C.comp_cod_arr by simp
                             also have "... = ?p0"
                               using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close>
                                     C.prj_tuple(1)
                               by blast
                             also have "... = ?p0 \<cdot> (?R \<down>\<down> ?w1)"
                               using C.comp_arr_dom gw.chine_eq_apex gw.chine_is_identity
                               by (metis C.arr_dom_iff_arr C.pbdom_def Dom_g gw.chine_composite
                                   gw.chine_simps(1) span_data.select_convs(1))
                             finally show ?thesis by simp
                           qed
                           show "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                 ?p1 \<cdot> (?R \<down>\<down> ?w1)"
                           proof -
                             have "?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle> \<cdot> \<rho>w.chine =
                                   (?p1 \<cdot> \<langle>rfw.Prj\<^sub>0\<^sub>1 \<lbrakk>?R, ?w1\<rbrakk> rfw.Prj\<^sub>0\<rangle>) \<cdot> \<rho>w.chine"
                               using C.comp_assoc by simp
                             also have "... = rfw.Prj\<^sub>0\<^sub>1 \<cdot> \<rho>w.chine"
                               using \<open>C.commutative_square ?R ?w1 rfw.Prj\<^sub>0\<^sub>1 rfw.Prj\<^sub>0\<close> by simp
                             also have "... = (k0 \<cdot> \<p>\<^sub>1[k0, ?w1]) \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using Chn_\<rho>w_eq C.comp_cod_arr by simp
                             also have "... = k0 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<langle>\<rho>.chine \<cdot> ?p1 \<lbrakk>k0, ?w1\<rbrakk> ?p0\<rangle>"
                               using C.comp_assoc by simp
                             also have "... = k0 \<cdot> \<rho>.chine \<cdot> ?p1"
                               using \<open>C.commutative_square k0 ?w1 (\<rho>.chine \<cdot> ?p1) ?p0\<close> by simp
                             also have "... = (k0 \<cdot> \<rho>.chine) \<cdot> ?p1"
                               using C.comp_assoc by metis
                             also have "... = ?p1 \<cdot> (?R \<down>\<down> ?w1)"
                               using C.comp_arr_dom C.comp_cod_arr cospan by simp
                             finally show ?thesis by blast
                           qed
                         qed
                         thus ?thesis by simp
                       qed
                       also have "... = \<theta>.chine"
                         using C.comp_arr_dom \<theta>.chine_in_hom gw.chine_eq_apex gw.chine_is_identity
                               Dom_\<theta>_0 Cod_\<theta>_0 Dom_\<theta>.apex_def Cod_\<theta>.apex_def
                         by (metis Dom_g \<theta>.chine_simps(1) \<theta>.chine_simps(2) gw.chine_composite
                             gw.dom.apex_def gw.leg0_composite span_data.select_convs(1))
                       also have "... = ru.prj\<^sub>0 \<cdot> ?RHS"
                         using 2 by simp
                       finally show ?thesis by blast
                     qed
                     show "ru.prj\<^sub>1 \<cdot> ?LHS = ru.prj\<^sub>1 \<cdot> ?RHS"
                     proof -
                       have "ru.prj\<^sub>1 \<cdot> ?LHS = (ru.prj\<^sub>1 \<cdot> r\<theta>.chine) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                         using C.comp_assoc by simp
                       also have "... = (r.chine \<cdot> \<p>\<^sub>1[r0, r0 \<cdot> ?p1]) \<cdot> Chn \<a>[r, f, w] \<cdot> \<rho>w.chine"
                       proof -
                         have "r\<theta>.chine \<noteq> C.null \<Longrightarrow>
                                 \<p>\<^sub>1[r.cod.leg0, Cod_\<theta>.leg1] \<cdot> r\<theta>.chine =
                                 r.chine \<cdot> \<p>\<^sub>1[r0, Dom_\<theta>.leg1]"
                           by (metis (lifting) C.prj_tuple(2) C.tuple_is_extensional r.cod_simps(2)
                               r\<theta>.chine_composite)
                         thus ?thesis
                           using Cod_\<theta>_1 Dom_\<theta>_1 r\<theta>.chine_simps(1) fw by fastforce
                       qed
                       also have "... = r.chine \<cdot> (rfw.Prj\<^sub>1 \<cdot> Chn \<a>[r, f, w]) \<cdot> \<rho>w.chine"
                         using C.comp_assoc fw.leg1_composite by simp
                       also have "... = r.chine \<cdot> rfw.Prj\<^sub>1\<^sub>1 \<cdot> \<rho>w.chine"
                         using ide_f ide_w hseq_rf hseq_char \<alpha>_ide
                               rfw.prj_chine_assoc(1)
                         by auto
                       also have "... = r.chine \<cdot> k1 \<cdot> \<p>\<^sub>1[k0, ?w1] \<cdot> \<rho>w.chine"
                         using C.comp_cod_arr C.comp_assoc by simp
                       also have "... = r.chine \<cdot> k1 \<cdot> \<rho>.chine \<cdot> \<p>\<^sub>1[Dom_\<rho>.leg0, ?w1]"
                         using Chn_\<rho>w_eq
                               \<open>C.commutative_square k0 ?w1
                                 (\<rho>.chine \<cdot> \<p>\<^sub>1[ra, w.leg1]) \<p>\<^sub>0[ra, w.leg1]\<close>
                         by auto
                       also have "... = r.chine \<cdot> (k1 \<cdot> \<rho>.chine) \<cdot> ?p1"
                         using C.comp_assoc Dom_\<rho>_0 by metis
                       also have "... = r.chine \<cdot> ra \<cdot> ?p1"
                         by simp
                       also have "... = r.chine \<cdot> ?p1"
                         using C.comp_cod_arr
                         by (metis C.comp_assoc r.cod_simps(1) r.chine_eq_apex r.chine_simps(1)
                             r.chine_simps(3))
                       also have "... = ?p1"
                         using C.comp_cod_arr r.chine_eq_apex r.chine_is_identity
                         by (metis 2 C.commutative_squareE r.dom.apex_def)
                       also have "... = ru.prj\<^sub>1 \<cdot> ?RHS"
                         using 2 by simp
                       finally show ?thesis by simp
                     qed
                   qed
                 qed
                 ultimately show ?thesis
                   by simp
               qed
               text \<open>
                 This is the main point: the equation E boils down to the following:
                 \[
                    \<open>?p1' \<cdot> \<beta>.chine = ?p1 \<and> \<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine\<close>
                 \]
                 The first equation gets us close to what we need, but we still need
                 \<open>?p1 \<cdot> C.inv ?p0 = ?w1\<close>, which follows from the fact that ?p0 is the
                 pullback of ?R.
               \<close>
               have *: "\<langle>?p1' \<cdot> \<beta>.chine \<lbrakk>r0, ?u1\<rbrakk> \<theta>'.chine \<cdot> \<beta>.chine\<rangle> = \<langle>?p1 \<lbrakk>r0, ?u1\<rbrakk> \<theta>.chine\<rangle>"
                 using L R E by simp
               have **: "?p1' \<cdot> \<beta>.chine = ?p1"
                 by (metis "*" C.in_homE C.not_arr_null C.prj_tuple(2) C.tuple_in_hom
                     C.tuple_is_extensional
                     \<open>C.commutative_square r0 u.leg1
                        (\<p>\<^sub>1[ra, w'.leg1] \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>)
               have ***: "\<theta>'.chine \<cdot> \<beta>.chine = \<theta>.chine"
                 by (metis "*" C.prj_tuple(1) \<open>C.commutative_square r0 ?u1
                     (?p1' \<cdot> \<beta>.chine) (\<theta>'.chine \<cdot> \<beta>.chine)\<close>
                     \<open>C.commutative_square r0 ?u1 ?p1 \<theta>.chine\<close>)
               text \<open>
                 CKS say to take \<open>\<gamma> = \<beta>\<close>, but obviously this cannot work as
                 literally described, because \<open>\<guillemotleft>\<beta> : g \<star> w \<Rightarrow> g \<star> w'\<guillemotright>\<close>, whereas we must have
                 \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright>\<close>.  Instead, we have to define \<open>\<gamma>\<close> by transporting \<open>\<beta>\<close> along the
                 projections from \<open>?R \<down>\<down> ?w1\<close> to \<open>?W\<close> and \<open>?R \<down>\<down> ?w1'\<close> to \<open>?W'\<close>.
                 These are isomorphisms by virtue of their being pullbacks of identities,
                 but they are not themselves necessarily identities.
                 Specifically, we take \<open>Chn \<gamma> = ?p0' \<cdot> Chn \<beta> \<cdot> C.inv ?p0\<close>.
               \<close>
               let ?\<gamma> = "\<lparr>Chn = ?p0' \<cdot> \<beta>.chine \<cdot> C.inv ?p0, Dom = Dom w, Cod = Cod w'\<rparr>"
               interpret Dom_\<gamma>: span_in_category C \<open>Dom ?\<gamma>\<close>
                 using w.dom.span_in_category_axioms by simp
               interpret Cod_\<gamma>: span_in_category C \<open>Cod ?\<gamma>\<close>
                 using w'.cod.span_in_category_axioms by simp
               text \<open>
                 It has to be shown that \<open>\<gamma>\<close> is an arrow of spans.
               \<close>
               interpret \<gamma>: arrow_of_spans C ?\<gamma>
               proof
                 show "\<guillemotleft>Chn ?\<gamma> : Dom_\<gamma>.apex \<rightarrow>\<^sub>C Cod_\<gamma>.apex\<guillemotright>"
                 proof -
                   have "\<guillemotleft>Chn \<beta>: gw.apex \<rightarrow>\<^sub>C gw'.apex\<guillemotright>"
                     using Chn_in_hom \<beta> gw'.chine_eq_apex gw.chine_eq_apex by force
                   moreover have "\<guillemotleft>?p0' : gw'.apex \<rightarrow>\<^sub>C w'.apex\<guillemotright>"
                     using cospan' hseq_gw' hseq_char hcomp_def gw'.dom.apex_def w'.dom.apex_def
                     by auto
                   moreover have "\<guillemotleft>C.inv ?p0 : w.apex \<rightarrow>\<^sub>C gw.apex\<guillemotright>"
                     using cospan hseq_gw hseq_char hcomp_def gw.dom.apex_def w.dom.apex_def
                           C.iso_pullback_ide
                     by auto
                   ultimately show ?thesis
                     using Dom_\<gamma>.apex_def Cod_\<gamma>.apex_def by auto
                 qed
                 text \<open>
                   The commutativity property for the ``input leg'' follows directly from that
                   for \<open>\<beta>\<close>.
                 \<close>
                 show "Cod_\<gamma>.leg0 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg0"
                   using C.comp_assoc C.comp_arr_dom cospan C.iso_pullback_ide C.comp_arr_inv'
                   by (metis C.invert_side_of_triangle(2) Dom_\<beta>.leg_simps(1) Dom_\<beta>_eq \<beta>0
                       arrow_of_spans_data.select_convs(1,3) arrow_of_spans_data.simps(2)
                       r.dom.ide_apex span_data.select_convs(1) w'.cod_simps(2))
                 text \<open>
                   The commutativity property for the ``output leg'' is a bit more subtle.
                 \<close>
                 show "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = Dom_\<gamma>.leg1"
                 proof -
                   have "Cod_\<gamma>.leg1 \<cdot> Chn ?\<gamma> = ((?w1' \<cdot> ?p0') \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
                     using C.comp_assoc by simp
                   also have "... = ((?R \<cdot> ?p1') \<cdot> Chn \<beta>) \<cdot> C.inv ?p0"
                     using cospan' C.pullback_commutes [of ?R ?w1'] by auto
                   also have "... = (?p1' \<cdot> \<beta>.chine) \<cdot> C.inv ?p0"
                     using cospan' C.comp_cod_arr by simp
                   also have "... = ?p1 \<cdot> C.inv ?p0"
                     using ** by simp
                   also have "... = ?w1"
                   text \<open>
                      Sledgehammer found this at a time when I was still struggling to
                      understand what was going on.
                   \<close>
                     by (metis C.comp_cod_arr C.invert_side_of_triangle(2) C.iso_pullback_ide
                         C.prj1_simps(1,3) C.pullback_commutes' cospan r.dom.ide_apex
                         r.chine_eq_apex r.chine_simps(2))
                   also have "... = Dom_\<gamma>.leg1" by auto
                   finally show ?thesis by simp
                 qed
               qed
               text \<open>
                 What remains to be shown is that \<open>\<gamma>\<close> is unique with the properties asserted
                 by \<open>T2\<close>; \emph{i.e.} \<open>\<guillemotleft>\<gamma> : w \<Rightarrow> w'\<guillemotright> \<and> \<beta> = g \<star> \<gamma> \<and> \<theta> = \<theta>' \<bullet> (f \<star> \<gamma>)\<close>.
                 CKS' assertion that the equation \<open>(r\<theta>)(\<rho>w) = (r\<theta>')(\<rho>w')\<beta>\<close> gives \<open>w\<^sub>1 = w\<^sub>1'\<close>
                 does not really seem to be true.  The reason \<open>\<gamma>\<close> is unique is because it is
                 obtained by transporting \<open>\<beta>\<close> along isomorphisms.
               \<close>
               have \<gamma>: "\<guillemotleft>?\<gamma> : w \<Rightarrow> w'\<guillemotright>"
                 using \<gamma>.arrow_of_spans_axioms arr_char dom_char cod_char by auto
               have hseq_f\<gamma>: "hseq f ?\<gamma>"
                 using \<gamma> src_def trg_def arrI fw.composable 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
               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)"
         proof -
           have "(g \<star> w) \<star> src (g \<star> w) \<cong> g \<star> w"
             using calculation isomorphic_implies_ide(2) by auto
           moreover have "isomorphic (src (g \<star> w)) (src w)\<^sup>*"
           proof -
             interpret src_w: map_in_bicategory V H \<a> \<i> src trg \<open>src w\<close>
               using assms obj_is_self_adjoint by unfold_locales auto
             interpret src_w: adjunction_in_bicategory V H \<a> \<i> src trg
                                \<open>src w\<close> \<open>(src w)\<^sup>*\<close> src_w.\<eta> src_w.\<epsilon>
               using src_w.is_map left_adjoint_extends_to_adjunction by simp
             have "adjoint_pair (src w) (src w)"
               using assms obj_is_self_adjoint by simp
             moreover have "adjoint_pair (src w) (src w)\<^sup>*"
               using adjoint_pair_def src_w.adjunction_in_bicategory_axioms by auto
             ultimately have "src w \<cong> (src w)\<^sup>*"
               using left_adjoint_determines_right_up_to_iso by simp
             moreover have "src w = src (g \<star> w)"
               using assms isomorphic_def hcomp_simps(1) left_adjoint_is_ide by simp
             ultimately show ?thesis by simp
           qed
           moreover have "src (g \<star> w) = trg (src (g \<star> w))"
             using assms left_adjoint_is_ide by simp
           ultimately show ?thesis
             using assms left_adjoint_is_ide isomorphic_transitive isomorphic_symmetric
                   hcomp_ide_isomorphic
             by blast
         qed
         ultimately show ?thesis
           using assms obj_is_self_adjoint
                 left_adjoint_is_ide BS2' [of "src w" "g \<star> w" "g \<star> w"]
           by auto
       qed
       obtain \<rho> where \<rho>: "tabulation V H \<a> \<i> src trg (g \<star> w) \<rho> (src w) (g \<star> w)"
         using ex_\<rho> by auto
       obtain m n where mn: "is_left_adjoint m \<and> is_left_adjoint n \<and> isomorphic w (n \<star> m\<^sup>*)"
         using assms BS1 [of w] by auto
       have m\<^sub>a: "adjoint_pair m m\<^sup>* \<and> isomorphic w (n \<star> m\<^sup>*)"
         using mn adjoint_pair_def left_adjoint_extends_to_adjoint_pair by blast
       have ex_\<sigma>: "\<exists>\<sigma>. tabulation V H \<a> \<i> src trg (g \<star> w) \<sigma> m (g \<star> n)"
       proof -
         have "hseq n m\<^sup>*"
           using mn isomorphic_implies_ide by auto
         have "trg (n \<star> m\<^sup>*) = trg w"
           using mn m\<^sub>a isomorphic_def
           by (metis (no_types, lifting) 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
       have "hseq (src w) e'"
         using * ide_dom [of \<theta>']
         apply (elim conjE in_homE) by simp
 
       have "e'e.trnr\<^sub>\<eta> m \<theta> \<in> hom m (src w \<star> e')"
       proof -
         have "src m = trg e"
           using \<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
              moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
                using 1 hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def
                by (metis B.hseq_char B.ideD(1-3) B.isomorphic_implies_hpar(1)
                    B.trg_hcomp calculation)
              moreover have hg: "\<guillemotleft>h \<star> g : b \<rightarrow>\<^sub>B d\<guillemotright>"
                using G H 1 in_HomD(4) by blast
              moreover have "h \<star> g \<in> Comp H G"
                unfolding Comp_def
                using 1 hgf F G H in_HomD [of F a b] in_HomD [of G b c] in_HomD [of H c d]
                      B.isomorphic_reflexive B.hcomp_ide_isomorphic B.hseqI'
                by (metis (no_types, lifting) B.hseqE B.hseqI mem_Collect_eq)
              ultimately show "x \<in> Comp (Comp H G) F"
                using 1 F G H hgf B.is_iso_class_def is_iso_class_Comp [of H G]
                      B.isomorphic_reflexive [of "h \<star> g"]
                apply (intro in_CompI)
                            apply auto[7]
                  apply blast
                 apply simp
                by (meson B.isomorphic_symmetric B.isomorphic_transitive)
            qed
            show "Comp (Comp H G) F \<subseteq> Comp H (Comp G F)"
            proof
              fix x
              assume x: "x \<in> Comp (Comp H G) F"
              obtain f g h hg
              where 1: "B.is_iso_class F \<and> B.is_iso_class G \<and> B.is_iso_class H \<and>
                        h \<in> H \<and> g \<in> G \<and> f \<in> F \<and> hg \<in> Comp H G \<and> h \<star> g \<cong>\<^sub>B hg \<and> hg \<star> f \<cong>\<^sub>B x"
                using x unfolding Comp_def by blast
              have hgf: "B.ide f \<and> B.ide g \<and> B.ide h \<and> src h = trg g \<and> src g = trg f"
                using 1 F G H in_HomD B.left_adjoint_is_ide
                by (metis (no_types, lifting) B.hseq_char' B.ideD(1) B.ide_dom
                    B.in_homE B.isomorphic_def B.isomorphic_symmetric B.seqI'
                    B.seq_if_composable B.src_dom B.src_hcomp B.vseq_implies_hpar(1))
              have 2: "(h \<star> g) \<star> f \<cong>\<^sub>B x"
              proof -
                have "(h \<star> g) \<star> f \<cong>\<^sub>B hg \<star> f"
                  using 1 F G H hgf
                  by (simp add: B.hcomp_isomorphic_ide)
                also have "hg \<star> f \<cong>\<^sub>B x"
                  using 1 by simp
                finally show ?thesis by blast
              qed
              moreover have "(h \<star> g) \<star> f \<cong>\<^sub>B h \<star> g \<star> f"
                using hgf B.iso_assoc B.assoc_in_hom B.isomorphic_def by auto
              moreover have "g \<star> f \<in> Comp G F"
                using 1 F G hgf B.isomorphic_reflexive by blast
              ultimately show "x \<in> Comp H (Comp G F)"
                using 1 hgf is_iso_class_Comp [of G F] B.isomorphic_reflexive [of "g \<star> f"]
                apply (intro in_CompI)
                        apply auto[6]
                  apply simp
                 apply auto[1]
                by (meson B.isomorphic_symmetric B.isomorphic_transitive)
            qed
          qed
        qed
      qed
 
      lemma is_concrete_category:
      shows "concrete_category (Collect B.obj) Hom B.iso_class (\<lambda>_ _ _. Comp)"
        ..
 
      sublocale concrete_category \<open>Collect B.obj\<close> Hom B.iso_class \<open>\<lambda>_ _ _. Comp\<close>
        using is_concrete_category by simp
 
      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 -
                   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,3957 @@
 (*  Title:       Coherence
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Coherence"
 
 theory Coherence
 imports Bicategory
 begin
 
  text \<open>
    \sloppypar
    In this section, we generalize to bicategories the proof of the Coherence Theorem
    that we previously gave for monoidal categories
    (see \<open>MonoidalCategory.evaluation_map.coherence\<close> in @{session MonoidalCategory}).
    As was the case for the previous proof, the current proof takes a syntactic approach.
    First we define a formal ``bicategorical language'' of terms constructed using
    syntactic operators that correspond to the various operations (vertical and horizontal
    composition, associators and unitors) found in a bicategory.
    Terms of the language are classified as formal ``arrows'', ``identities'', or ``objects''
    according to the syntactic operators used in their formation.
    A class of terms called ``canonical'' is also defined in this way.
    Functions that map ``arrows'' to their ``domain'' and ``codomain'', and to their
    ``source'' and ``target'' are defined by recursion on the structure of terms.
    Next, we define a notion of ``normal form'' for terms in this language and we
    give a recursive definition of a function that maps terms to their normal forms.
    Normalization moves vertical composition inside of horizontal composition and
    ``flattens'' horizontal composition by associating all horizontal compositions to the right.
    In addition, normalization deletes from a term any horizontal composites involving an arrow
    and its source or target, replacing such composites by just the arrow itself.
    We then define a ``reduction function'' that maps each identity term \<open>t\<close> to a
    ``canonical'' term \<open>t\<^bold>\<down>\<close> that connects \<open>t\<close> with its normal form.  The definition of reduction
    is also recursive, but it is somewhat more complex than normalization in that it
    involves two mutually recursive functions: one that applies to any identity term
    and another that applies only to terms that are the horizontal composite
    of two identity terms.
 
    The next step is to define an ``evaluation function'' that evaluates terms in a given
    bicategory (which is left as an unspecified parameter).  We show that evaluation respects
    bicategorical structure:
    the domain, codomain, source, and target mappings on terms correspond under evaluation
    to the actual domain, codomain, source and target mappings on the given bicategory,
    the vertical and horizontal composition on terms correspond to the actual vertical
    and horizontal composition of the bicategory, and unit and associativity terms evaluate
    to the actual unit and associativity isomorphisms of the bicategory.
    In addition, ``object terms'' evaluate to objects (\emph{i.e.}~0-cells),
    ``identity terms'' evaluate to identities (\emph{i.e.}~1-cells),
    ``arrow terms'' evaluate to arrows (\emph{i.e.}~2-cells), and ``canonical terms'' evaluate
    to canonical isomorphisms.
    A term is defined to be ``coherent'' if, roughly speaking, it is a formal arrow
    whose evaluation commutes with the evaluations of the reductions to normal form of
    its domain and codomain.
    We then prove the Coherence Theorem, expressed in the form: ``every arrow is coherent.''
    This implies a more classical version of the Coherence Theorem, which says that:
    ``syntactically parallel arrows with the same normal form have equal evaluations''.
   \<close>
 
   subsection "Bicategorical Language"
 
     text \<open>
       For the most part, the definition of the ``bicategorical language'' of terms is
       a straightforward generalization of the ``monoidal language'' that we used for
       monoidal categories.
       Some modifications are required, however, due to the fact that horizontal composition
       in a bicategory is a partial operation, whereas the the tensor product in a monoidal
       category is well-defined for all pairs of arrows.
       One difference is that we have found it necessary to introduce a new class of primitive
       terms whose elements represent ``formal objects'', so that there is some way to
       identify the source and target of what would otherwise be an empty horizontal composite.
       This was not an issue for monoidal categories, because the totality of horizontal
       composition meant that there was no need for syntactically defined sources and targets.
       Another difference is what we have chosen for the ``generators'' of the language
       and how they are used to form primitive terms.  For monoidal categories,
       we supposed that we were given a category \<open>C\<close> and the syntax contained a constructor
       to form a primitive term corresponding to each arrow of \<open>C\<close>.
       We assumed a category as the given data, rather than something less structured,
       such as a graph, because we were primarily interested in the tensor product and
       the associators and unitors, and were relatively uninterested in the strictly
       associative and unital composition of the underlying category.
       For bicategories, we also take the vertical composition as given for the same
       reasons; however, this is not yet sufficient due to the fact that horizontal
       composition in a bicategory is a partial operation, in contrast to the tensor
       product in a monoidal category, which is defined for all pairs of arrows.
       To deal with this issue, for bicategories we assume that source and target
       mappings are also given, so that the given data forms a category with
       ``horizontal homs''.  The given source and target mappings are extended to all terms
       and used to define when two terms are ``formally horizontally composable''.
   \<close>
 
   locale bicategorical_language =
     category V +
     horizontal_homs V src trg
     for V :: "'a comp"                       (infixr "\<cdot>" 55)
     and src :: "'a \<Rightarrow> 'a"
     and trg :: "'a \<Rightarrow> 'a"
   begin
 
     text \<open>
       Constructor \<open>Prim\<^sub>0\<close> is used to construct ``formal objects'' and \<open>Prim\<close> is used to
       construct primitive terms that are not formal objects.
     \<close>
 
     datatype (discs_sels) 't "term" =
       Prim\<^sub>0 't                             ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sub>0")
     | Prim 't                              ("\<^bold>\<langle>_\<^bold>\<rangle>")
     | Hcomp "'t term" "'t term"            (infixr "\<^bold>\<star>" 53)
     | Vcomp "'t term" "'t term"            (infixr "\<^bold>\<cdot>" 55)
     | Lunit "'t term"                      ("\<^bold>\<l>\<^bold>[_\<^bold>]")
     | Lunit' "'t term"                     ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Runit "'t term"                      ("\<^bold>\<r>\<^bold>[_\<^bold>]")
     | Runit' "'t term"                     ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Assoc "'t term" "'t term" "'t term"  ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
     | Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
 
     text \<open>
       We define formal domain, codomain, source, and target functions on terms.
     \<close>
 
     primrec Src :: "'a term \<Rightarrow> 'a term"
     where "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Src \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>src \<mu>\<^bold>\<rangle>\<^sub>0"
         | "Src (t \<^bold>\<star> u) = Src u"
         | "Src (t \<^bold>\<cdot> u) = Src t"
         | "Src \<^bold>\<l>\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<r>\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Src t"
         | "Src \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Src v"
         | "Src \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Src v"
 
     primrec Trg :: "'a term \<Rightarrow> 'a term"
     where "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Trg \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>trg \<mu>\<^bold>\<rangle>\<^sub>0"
         | "Trg (t \<^bold>\<star> u) = Trg t"
         | "Trg (t \<^bold>\<cdot> u) = Trg t"
         | "Trg \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<r>\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t"
         | "Trg \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Trg t"
         | "Trg \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Trg t"
 
     primrec Dom :: "'a term \<Rightarrow> 'a term"
     where "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Dom \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>dom \<mu>\<^bold>\<rangle>"
         | "Dom (t \<^bold>\<star> u) = Dom t \<^bold>\<star> Dom u"
         | "Dom (t \<^bold>\<cdot> u) = Dom u"
         | "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Dom t"
         | "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = Dom t \<^bold>\<star> Src t"
         | "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<star> Dom u) \<^bold>\<star> Dom v"
         | "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = Dom t \<^bold>\<star> (Dom u \<^bold>\<star> Dom v)"
 
     primrec Cod :: "'a term \<Rightarrow> 'a term"
     where "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0"
         | "Cod \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>"
         | "Cod (t \<^bold>\<star> u) = Cod t \<^bold>\<star> Cod u"
         | "Cod (t \<^bold>\<cdot> u) = Cod t"
         | "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Trg t \<^bold>\<star> Cod t"
         | "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Cod t \<^bold>\<star> Src t"
         | "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = Cod t \<^bold>\<star> (Cod u \<^bold>\<star> Cod v)"
         | "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<star> Cod u) \<^bold>\<star> Cod v"
 
     text \<open>
       A term is a ``formal arrow'' if it is constructed from primitive arrows in such a way
       that horizontal and vertical composition are applied only to formally composable pairs
       of terms.  The definitions of ``formal identity'' and ``formal object'' follow a
       similar pattern.
     \<close>
 
     primrec Arr :: "'a term \<Rightarrow> bool"
     where "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Arr \<^bold>\<langle>\<mu>\<^bold>\<rangle> = arr \<mu>"
         | "Arr (t \<^bold>\<star> u) = (Arr t \<and> Arr u \<and> Src t = Trg u)"
         | "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
         | "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
         | "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v \<and> Src t = Trg u \<and> Src u = Trg v)"
 
     primrec Ide :: "'a term \<Rightarrow> bool"
     where "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Ide \<^bold>\<langle>\<mu>\<^bold>\<rangle> = ide \<mu>"
         | "Ide (t \<^bold>\<star> u) = (Ide t \<and> Ide u \<and> Src t = Trg u)"
         | "Ide (t \<^bold>\<cdot> u) = False"
         | "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
 
     primrec Obj :: "'a term \<Rightarrow> bool"
     where "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = obj \<mu>"
         | "Obj \<^bold>\<langle>\<mu>\<^bold>\<rangle> = False"
         | "Obj (t \<^bold>\<star> u) = False"
         | "Obj (t \<^bold>\<cdot> u) = False"
         | "Obj \<^bold>\<l>\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<r>\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Obj \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
         | "Obj \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
 
     abbreviation HSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "HSeq t u \<equiv> Arr t \<and> Arr u \<and> Src t = Trg u"
 
     abbreviation VSeq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "VSeq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
 
     abbreviation HPar :: "'a term => 'a term \<Rightarrow> bool"
     where "HPar t u \<equiv> Arr t \<and> Arr u \<and> Src t = Src u \<and> Trg t = Trg u"
 
     abbreviation VPar :: "'a term => 'a term \<Rightarrow> bool"
     where "VPar t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
 
     abbreviation HHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
     where "HHom a b \<equiv> { t. Arr t \<and> Src t = a \<and> Trg t = b }"
 
     abbreviation VHom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
     where "VHom f g \<equiv> { t. Arr t \<and> Dom t = f \<and> Cod t = g }"
 
     lemma is_Prim0_Src:
     shows "is_Prim\<^sub>0 (Src t)"
       by (induct t; simp)
 
     lemma is_Prim0_Trg:
     shows "is_Prim\<^sub>0 (Trg t)"
       by (induct t; simp)
 
     lemma Src_Src [simp]:
     shows "Arr t \<Longrightarrow> Src (Src t) = Src t"
       by (induct t) auto
 
     lemma Trg_Trg [simp]:
     shows "Arr t \<Longrightarrow> Trg (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Src_Trg [simp]:
     shows "Arr t \<Longrightarrow> Src (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Trg_Src [simp]:
     shows "Arr t \<Longrightarrow> Trg (Src t) = Src t"
       by (induct t) auto
 
     lemma Dom_Src [simp]:
     shows "Arr t \<Longrightarrow> Dom (Src t) = Src t"
       by (induct t) auto
 
     lemma Dom_Trg [simp]:
     shows "Arr t \<Longrightarrow> Dom (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Cod_Src [simp]:
     shows "Arr t \<Longrightarrow> Cod (Src t) = Src t"
       by (induct t) auto
 
     lemma Cod_Trg [simp]:
     shows "Arr t \<Longrightarrow> Cod (Trg t) = Trg t"
       by (induct t) auto
 
     lemma Src_Dom_Cod:
     shows "Arr t \<Longrightarrow> Src (Dom t) = Src t \<and> Src (Cod t) = Src t"
        using src_dom src_cod by (induct t) auto
 
     lemma Src_Dom [simp]:
     shows "Arr t \<Longrightarrow> Src (Dom t) = Src t"
       using Src_Dom_Cod by blast
 
     lemma Src_Cod [simp]:
     shows "Arr t \<Longrightarrow> Src (Cod t) = Src t"
       using Src_Dom_Cod by blast
 
     lemma Trg_Dom_Cod:
     shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t \<and> Trg (Cod t) = Trg t"
        using trg_dom trg_cod by (induct t) auto
 
     lemma Trg_Dom [simp]:
     shows "Arr t \<Longrightarrow> Trg (Dom t) = Trg t"
       using Trg_Dom_Cod by blast
 
     lemma Trg_Cod [simp]:
     shows "Arr t \<Longrightarrow> Trg (Cod t) = Trg t"
       using Trg_Dom_Cod by blast
 
     lemma VSeq_implies_HPar:
     shows "VSeq t u \<Longrightarrow> HPar t u"
       using Src_Dom [of t] Src_Cod [of u] Trg_Dom [of t] Trg_Cod [of u] by auto
 
     lemma Dom_Dom [simp]:
     shows "Arr t \<Longrightarrow> Dom (Dom t) = Dom t"
       by (induct t, auto)
 
     lemma Cod_Cod [simp]:
     shows "Arr t \<Longrightarrow> Cod (Cod t) = Cod t"
       by (induct t, auto)
 
     lemma Dom_Cod [simp]:
     shows "Arr t \<Longrightarrow> Dom (Cod t) = Cod t"
       by (induct t, auto)
 
     lemma Cod_Dom [simp]:
     shows "Arr t \<Longrightarrow> Cod (Dom t) = Dom t"
       by (induct t, auto)
       
     lemma Obj_implies_Ide (*[simp]*):
     shows "Obj t \<Longrightarrow> Ide t"
       by (induct t) auto
 
     lemma Ide_implies_Arr [simp]:
     shows "Ide t \<Longrightarrow> Arr t"
       by (induct t, auto)
 
     lemma Dom_Ide:
     shows "Ide t \<Longrightarrow> Dom t = t"
       by (induct t, auto)
 
     lemma Cod_Ide:
     shows "Ide t \<Longrightarrow> Cod t = t"
       by (induct t, auto)
 
     lemma Obj_Src [simp]:
     shows "Arr t \<Longrightarrow> Obj (Src t)"
       by (induct t) auto
 
     lemma Obj_Trg [simp]:
     shows "Arr t \<Longrightarrow> Obj (Trg t)"
       by (induct t) auto
 
     lemma Ide_Dom [simp]:
     shows "Arr t \<Longrightarrow> Ide (Dom t)"
       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
           have w: "Nml w \<and> \<not> is_Prim\<^sub>0 w \<and> \<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w"
             using vw Nml_HcompD [of v w] by blast
           have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           proof -
             have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u v 2 by (cases u, simp_all)
             also have "... = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u w I2 by fastforce
             also have "... = v \<^bold>\<star> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using v by simp
             finally show ?thesis by simp
           qed
           thus ?thesis using 1 by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text \<open>
       The following function defines the ``dimension'' of a term,
       which is the number of inputs (or outputs) when the term is regarded as an
       interconnection matrix.
       For normal terms, this is just the length of the term when regarded as a list
       of arrows of @{term C}.
       This function is used as a ranking of terms in the subsequent associativity proof.
     \<close>
 
     primrec dim :: "'a term \<Rightarrow> nat"
     where "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = 0"
         | "dim \<^bold>\<langle>\<mu>\<^bold>\<rangle> = 1"
         | "dim (t \<^bold>\<star> u) = (dim t + dim u)"
         | "dim (t \<^bold>\<cdot> u) = dim t"
         | "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
         | "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
 
     lemma HcompNml_assoc:
     assumes "Nml t" and "Nml u" and "Nml v" and "Src t = Trg u" and "Src u = Trg v"
     shows "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
     proof -
       have "\<And>n t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
       proof -
         fix n
         show "\<And>t u v. \<lbrakk> dim t = n; Nml t; Nml u; Nml v; Src t = Trg u; Src u = Trg v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
         proof (induction n rule: nat_less_induct)
           fix n :: nat and t :: "'a term" and u v
           assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Nml t \<longrightarrow> Nml u \<longrightarrow> Nml v \<longrightarrow>
                                    Src t = Trg u \<longrightarrow> Src u = Trg v \<longrightarrow>
                                    (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
           assume dim: "dim t = n"
           assume t: "Nml t"
           assume u: "Nml u"
           assume v: "Nml v"
           assume tu: "Src t = Trg u"
           assume uv: "Src u = Trg v"
           show "(t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
           proof -
             have "is_Prim\<^sub>0 t \<Longrightarrow> ?thesis" by (cases t; simp)
             moreover have "\<not>is_Prim\<^sub>0 t \<Longrightarrow> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
               by (cases t; simp; cases u; simp)
             moreover have "\<not> is_Prim\<^sub>0 t \<Longrightarrow> \<not> is_Prim\<^sub>0 u \<Longrightarrow> is_Prim\<^sub>0 v \<Longrightarrow> ?thesis"
             proof -
               assume 1: "\<not> is_Prim\<^sub>0 t"
               assume 2: "\<not> is_Prim\<^sub>0 u"
               assume 3: "is_Prim\<^sub>0 v"
               have "\<not>is_Prim\<^sub>0 (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
                 using 1 2 t u tu is_Hcomp_HcompNml [of t u]
                 by (cases t, simp, cases u, auto)
               thus ?thesis
                 using 1 2 3 tu uv by (cases v, simp, cases "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u", simp_all)
             qed
             moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Prim t \<Longrightarrow> ?thesis"
               using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
             moreover have "\<not>is_Prim\<^sub>0 t \<and> \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v \<and> is_Hcomp t \<Longrightarrow> ?thesis"
             proof (cases t, simp_all)
               fix w :: "'a term" and x :: "'a term"
               assume 1: " \<not> is_Prim\<^sub>0 u \<and> \<not> is_Prim\<^sub>0 v"
               assume 2: "t = (w \<^bold>\<star> x)"
               show "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
               proof -
                 have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
                   using t 1 2 Nml_HcompD by auto
                 have x: "Nml x"
                   using t w 1 2 by (metis Nml.simps(3))
                 have "((w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
                   using u v w x 1 2 by (cases u, simp_all)
                 also have "... = (w \<^bold>\<star> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
                   using t w u 1 2 HcompNml_Prim is_Hcomp_HcompNml Nml_HcompD
                   by (metis Src.simps(3) term.distinct_disc(3) tu)
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                   using u v w x 1 by (cases u, simp_all; cases v, simp_all)
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v))"
                 proof -
                   have "dim x < dim t"
                     using 2 w by (cases w; simp)
                   moreover have "Src x = Trg u \<and> Src u = Trg v"
                     using tu uv 2 by auto
                   ultimately show ?thesis 
                     using u v x dim I by simp
                 qed
                 also have "... = (w \<^bold>\<star> x) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                 proof -
                   have 3: "is_Hcomp (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v)"
                     using u v uv 1 is_Hcomp_HcompNml by auto
                   obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v = u' \<^bold>\<star> v'"
                     using 3 is_Hcomp_def by blast
                   thus ?thesis by simp
                 qed
                 finally show ?thesis by simp
               qed
             qed
             moreover have "is_Prim\<^sub>0 t \<or> is_Prim t \<or> is_Hcomp t"
               using t by (cases t, simp_all)
             ultimately show ?thesis by blast
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma HcompNml_Trg_Nml:
     assumes "Nml t"
     shows "Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
     proof -
       have "Nml t \<Longrightarrow> Trg t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> t = t"
       proof (induct t, simp_all add: Nml_HcompD)
         fix u v
         assume uv: "Nml (u \<^bold>\<star> v)"
         assume I1: "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
         have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
           using uv Nml_HcompD by blast
         have 2: "Trg (u \<^bold>\<star> v) = Trg u"
           using uv by auto
         show "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = u \<^bold>\<star> v"
         proof -
           have "Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<star> v = Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
             using uv HcompNml_Nml by simp
           also have "... = (Trg u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v"
             using 1 2 HcompNml_assoc Src_Trg Nml_Trg Nml_implies_Arr by simp
           also have "... = u \<^bold>\<star> v"
             using I1 uv HcompNml_Nml by simp
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis using assms by simp
     qed
 
     lemma HcompNml_Nml_Src:
     assumes "Nml t"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
     proof -
       have "Nml t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src t = t"
       proof (induct t, simp_all add: Nml_HcompD)
         fix u v
         assume uv: "Nml (u \<^bold>\<star> v)"
         assume I2: "v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = v"
         have 1: "Nml u \<and> Nml v \<and> Src u = Trg v"
           using uv Nml_HcompD by blast
         have 2: "Src (u \<^bold>\<star> v) = Src v"
           using uv Trg_HcompNml by auto
         show "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = u \<^bold>\<star> v"
         proof -
           have "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v = (u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v"
             using uv HcompNml_Nml by simp
           also have "... = u \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Src v)"
             using 1 2 HcompNml_assoc Trg_Src Nml_Src Nml_implies_Arr by simp
           also have "... = u \<^bold>\<star> v"
             using I2 uv HcompNml_Nml by simp
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis using assms by simp
     qed
 
     lemma HcompNml_Obj_Nml:
     assumes "Obj t" and "Nml u" and "Src t = Trg u"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = u"
       using assms by (cases t, simp_all add: HcompNml_Trg_Nml)
 
     lemma HcompNml_Nml_Obj:
     assumes "Nml t" and "Obj u" and "Src t = Trg u"
     shows "t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u = t"
       using assms by (cases u, simp_all)
 
     lemma Ide_HcompNml:
     assumes "Ide t" and "Ide u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Ide (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
       using assms
       by (metis (mono_tags, lifting) Nml_HcompNml(1) Nml_implies_Arr Dom_HcompNml
           Ide_Dom Ide_in_Hom(2) mem_Collect_eq)
 
     lemma Can_HcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
       proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
         show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           by (metis Ide.simps(1-2) Ide_implies_Can Can.simps(3) Nml.elims(2)
               Nml.simps(2) HcompNml.simps(12) HcompNml_Prim Ide_HcompNml
               Src.simps(2) term.disc(2))
         show "\<And>v w u.
                  (\<And>u. Nml v \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> Trg w = Trg u \<Longrightarrow> Can (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)) \<Longrightarrow>
                  (\<And>ua. Nml w \<Longrightarrow> Can ua \<and> Nml ua \<Longrightarrow> Trg u = Trg ua \<Longrightarrow> Can (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> ua)) \<Longrightarrow>
                  Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w) \<Longrightarrow>
                  Can u \<and> Nml u \<Longrightarrow> Src w = Trg u \<Longrightarrow> Can ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
           by (metis Nml_HcompD(3-4) HcompNml_Nml Nml_HcompNml(1)
               HcompNml_assoc Trg_HcompNml)
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Inv_HcompNml:
     assumes "Can t" and "Can u" and "Nml t" and "Nml u" and "Src t = Trg u"
     shows "Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Nml t; Can u \<and> Nml u; Src t = Trg u \<rbrakk>
                    \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
       proof (induct t, simp_all add: HcompNml_Trg_Nml HcompNml_Nml_Src)
         show "\<And>x u. \<lbrakk> obj x; Can u \<and> Nml u; \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Trg u \<rbrakk> \<Longrightarrow> Inv u = Inv (Trg u) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
           by (metis HcompNml.simps(1) Inv.simps(1))
         show "\<And>x u. ide x \<and> arr x \<Longrightarrow> Can u \<and> Nml u \<Longrightarrow> \<^bold>\<langle>src x\<^bold>\<rangle>\<^sub>0 = Trg u \<Longrightarrow>  
                     Inv (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = \<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
           by (metis Ide.simps(2) HcompNml.simps(2) HcompNml_Prim Inv.simps(1,3)
                     Inv_Ide Inv_Inv is_Prim\<^sub>0_def)
         fix v w u
         assume I1: "\<And>x. Nml v \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg w = Trg x \<Longrightarrow>
                         Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
         assume I2: "\<And>x. Nml w \<Longrightarrow> Can x \<and> Nml x \<Longrightarrow> Trg u = Trg x \<Longrightarrow>
                               Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> x) = Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv x"
         assume vw: "Can v \<and> Can w \<and> Src v = Trg w \<and> Nml (v \<^bold>\<star> w)"
         assume wu: "Src w = Trg u"
         assume u: "Can u \<and> Nml u"
         have v: "Can v \<and> Nml v"
           using vw Nml_HcompD by blast
         have w: "Can w \<and> Nml w"
           using v vw by (cases v, simp_all)
         show "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
         proof -
           have "is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
             apply (cases u) by simp_all
           moreover have "\<not> is_Prim\<^sub>0 u \<Longrightarrow> ?thesis"
           proof -
             assume 1: "\<not> is_Prim\<^sub>0 u"
             have "Inv ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u) = Inv (v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u))"
               using 1 by (cases u, simp_all)
             also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv (w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> u)"
               using u v w vw wu I1 Nml_HcompNml Can_HcompNml Nml_Inv Can_Inv
               by simp
             also have "... = Inv v \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> (Inv w \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u)"
               using u v w I2 Nml_HcompNml by simp
             also have "... = (Inv v \<^bold>\<star> Inv w) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Inv u"
               using v 1 by (cases u, simp_all)
             finally show ?thesis by blast
           qed
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text \<open>
        The following function defines vertical composition for compatible normal terms,
        by ``pushing the composition down'' to arrows of @{text V}.
     \<close>
 
     fun VcompNml :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term"  (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
     where "\<^bold>\<langle>\<nu>\<^bold>\<rangle>\<^sub>0 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
         | "\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle> = \<^bold>\<langle>\<nu> \<cdot> \<mu>\<^bold>\<rangle>"
         | "(u \<^bold>\<star> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<star> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<star> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>\<mu>\<^bold>\<rangle>\<^sub>0 = t"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
 
     text \<open>
       Note that the last clause above is not relevant to normal terms.
       We have chosen a provably non-normal value in order to validate associativity.
     \<close>
 
     lemma Nml_VcompNml:
     assumes "Nml t" and "Nml u" and "Dom t = Cod u"
     shows "Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
     and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
     proof -
       have 0: "\<And>u. \<lbrakk> Nml t; Nml u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
                      Nml (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
       proof (induct t, simp_all add: Nml_HcompD)
         show "\<And>x u. obj x \<Longrightarrow> Nml u \<Longrightarrow> \<^bold>\<langle>x\<^bold>\<rangle>\<^sub>0 = Cod u \<Longrightarrow>
                      Nml (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
                      Cod (Cod u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod (Cod u)"
           by (metis Cod.simps(1) VcompNml.simps(1))
         fix \<nu> u
         assume \<nu>: "arr \<nu>"
         assume u: "Nml u"
         assume 1: "\<^bold>\<langle>dom \<nu>\<^bold>\<rangle> = Cod u"
         show "Nml (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>\<nu>\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>cod \<nu>\<^bold>\<rangle>"
           using \<nu> u 1 by (cases u, simp_all)
         next
         fix u v w
         assume I2: "\<And>u. \<lbrakk> Nml u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
                           Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
         assume vw: "Nml (v \<^bold>\<star> w)"
         have v: "Nml v"
           using vw Nml_HcompD by force
         have w: "Nml w"
           using vw Nml_HcompD by force
         assume u: "Nml u"
         assume 1: "(Dom v \<^bold>\<star> Dom w) = Cod u"
         show "Nml ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
                                      Cod ((v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<star> Cod w"
           using u v w 1
         proof (cases u, simp_all)
           fix x y
           assume 2: "u = x \<^bold>\<star> y"
           have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> arr (un_Prim x) \<and> Nml y \<and> \<not> is_Prim\<^sub>0 y"
             using u 2 by (cases x, cases y, simp_all)
           have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> arr (un_Prim v) \<and> Nml w \<and> \<not> is_Prim\<^sub>0 w"
             using v w vw by (cases v, simp_all)
           have 6: "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
           proof -
             have "\<^bold>\<langle>src (un_Prim v)\<^bold>\<rangle>\<^sub>0 = Trg w" using vw Nml_HcompD [of v w] by simp
             thus "dom (un_Prim v) = cod (un_Prim x) \<and> Dom w = Cod y"
               using 1 2 4 5 apply (cases u, simp_all)
               by (metis Cod.simps(2) Dom.simps(2) term.simps(2))
           qed
           have "(v \<^bold>\<star> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
             using 2 4 5 6 VcompNml.simps(2) [of "un_Prim v" "un_Prim x"] by simp
           moreover have "Nml (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
           proof -
             have "Nml (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using I2 4 5 6 by simp
             moreover have "\<not> is_Prim\<^sub>0 (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using vw 4 5 6 I2 Nml_Cod Nml_HcompD(5) is_Prim\<^sub>0_def
               by (metis Cod.simps(1) Cod.simps(3))
             moreover have "\<^bold>\<langle>src (un_Prim v \<cdot> un_Prim x)\<^bold>\<rangle>\<^sub>0 = Trg (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using vw 4 5 6 I2 Nml_HcompD(6) Nml_implies_Arr
                     src.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
           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
           have y: "Nml y"
             using u x 1 3 Nml_HcompD by simp
           assume 4: "Arr v \<and> Arr w \<and> Src v = Trg w \<and> Dom v = Cod x \<and> Dom w = Cod y"
           have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<star> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
             using v w x y 4 HcompNml_in_Hom by simp
           moreover have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>" by simp
           moreover have "... = \<lbrace>v\<rbrace> \<cdot> \<lbrace>x\<rbrace> \<star> \<lbrace>w\<rbrace> \<cdot> \<lbrace>y\<rbrace>"
             using v w x y 4 I1 [of x] I2 [of y] Nml_implies_Arr by simp
           moreover have "... = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
             using v w x y 4 Nml_implies_Arr interchange [of "\<lbrace>v\<rbrace>" "\<lbrace>x\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>y\<rbrace>"]
             by (simp add: eval_simps')
           ultimately have "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)" by presburger
           moreover have "arr \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<and> arr \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace>"
             using v w x y 4 VcompNml_in_Hom by simp
           ultimately show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<star> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<star> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<star> \<lbrace>y\<rbrace>)"
             by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma eval_red_Hcomp:
     assumes "Ide a" and "Ide b"
     shows "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
     proof -
       have "Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
       proof -
         assume 1: "Nml (a \<^bold>\<star> b)"
         hence 2: "Nml a \<and> Nml b \<and> Src a = Trg b"
           using Nml_HcompD(3-4,7) by simp
         have "\<lbrace>(a \<^bold>\<star> b)\<^bold>\<down>\<rbrace> = \<lbrace>a\<rbrace> \<star> \<lbrace>b\<rbrace>"
           using 1 Nml_HcompD by simp
         also have "... = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<star> \<lbrace>b\<^bold>\<down>\<rbrace>)"
           using assms 1 2 ide_eval_Ide Nmlize_in_Hom red2_Nml Nmlize_Nml
           by (simp add: eval_simps')
         finally show ?thesis by simp
       qed
       moreover have "\<not> Nml (a \<^bold>\<star> b) \<Longrightarrow> ?thesis"
         using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
       ultimately show ?thesis by blast
     qed
 
     (* TODO: Would the following still be useful if \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 is replaced by Src t? *)
     lemma eval_red2_Nml_Prim\<^sub>0:
     assumes "Ide t" and "Nml t" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
     shows "\<lbrace>t \<^bold>\<Down> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<rbrace> = \<r>[\<lbrace>t\<rbrace>]"
       using assms \<rr>_ide_simp
       apply (cases t)
                apply simp_all
     proof -
       show "C.obj a \<Longrightarrow> t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<Longrightarrow> \<ll> (E a) = \<r>[E a]"
         using unitor_coincidence obj_eval_Obj [of t] \<ll>_ide_simp by auto
       show "\<And>b c. Ide b \<and> Ide c \<and> Src b = Trg c \<Longrightarrow> \<rr> (\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>) = \<r>[\<lbrace>b\<rbrace> \<star> \<lbrace>c\<rbrace>]"
         using \<rr>_ide_simp by (simp add: eval_simps' ide_eval_Ide)
     qed
 
   end
 
   text \<open>
     Most of the time when we interpret the @{locale evaluation_map} locale, we are evaluating
     terms formed from the arrows in a bicategory as arrows of the bicategory itself.
     The following locale streamlines that use case.
   \<close>
 
   locale self_evaluation_map =
     bicategory
   begin
 
     sublocale bicategorical_language V src trg ..
 
     sublocale evaluation_map V src trg V H \<a> \<i> src trg \<open>\<lambda>\<mu>. if arr \<mu> then \<mu> else null\<close>
       using src.is_extensional trg.is_extensional
       by (unfold_locales, auto)
 
     notation eval ("\<lbrace>_\<rbrace>")
     notation Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
 
   end
 
   subsection "Coherence"
 
   text \<open>
     We define an individual term to be \emph{coherent} if it commutes, up to evaluation,
     with the reductions of its domain and codomain.  We then formulate the coherence theorem
     as the statement ``every formal arrow is coherent''.  Because reductions evaluate
     to isomorphisms, this implies the standard version of coherence, which says that
     ``parallel canonical terms have equal evaluations''.
   \<close>
 
   context evaluation_map
   begin
 
     abbreviation coherent
     where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
 
     lemma Nml_implies_coherent:
     assumes "Nml t"
     shows "coherent t"
       using assms Nml_implies_Arr Ide_Dom Ide_Cod Nml_Dom Nml_Cod Nmlize_Nml red_Nml
       by (metis Dom_Cod VcompNml_Cod_Nml arr_eval_Arr comp_arr_dom eval_VcompNml
           eval_simps(4))
 
     lemma canonical_factorization:
     assumes "Arr t"
     shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
     proof
       assume 1: "coherent t"
       have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
         using 1 by simp
       also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>t\<rbrace>"
         using assms red_in_Hom Ide_Cod Can_red iso_eval_Can comp_cod_arr
         by (simp add: comp_inv_arr' eval_simps'(4) eval_simps'(5))
       finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         by presburger
       next
       assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
       hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
       also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
       proof -
         have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> = cod \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
           using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
                 inv_is_inverse Nmlize_in_Hom comp_arr_inv
           by (simp add: eval_simps')
         thus ?thesis
           using assms red_in_Hom Ide_Cod Can_red iso_eval_Can
                 Ide_Dom Nmlize_in_Hom comp_cod_arr
           by (auto simp add: eval_simps')
       qed
       finally show "coherent t" by blast
     qed
 
     lemma coherent_iff_coherent_Inv:
     assumes "Can t"
     shows "coherent t \<longleftrightarrow> coherent (Inv t)"
     proof
       have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
       proof -
         fix t
         assume "Can t"
         hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
                   arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
                   Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> VHom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                   inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> VHom (Cod t) (Dom t)"
           using assms Can_implies_Arr Ide_Dom Ide_Cod iso_eval_Can inv_is_inverse
                 Nmlize_in_Hom Can_Nmlize_Can Inv_in_Hom
           by simp
         assume coh: "coherent t"
         have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
           using t comp_inv_arr red_in_Hom
                 comp_cod_arr [of "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>" "inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"]
           by (auto simp add: eval_simps')
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
           using t eval_Inv_Can comp_assoc by auto
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
           using comp_assoc by simp
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
           using t coh by simp
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace>"
           using comp_assoc by simp
         also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
         proof -
           have "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> inv \<lbrace>t\<rbrace> = \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
             using t eval_Inv_Can red_in_Hom comp_arr_inv comp_arr_dom
             by (simp add: eval_simps')
           thus ?thesis
             using t Nmlize_Inv eval_Inv_Can by simp
         qed
         finally show "coherent (Inv t)" by blast
       qed
       show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
       show "coherent (Inv t) \<Longrightarrow> coherent t"
       proof -
         assume "coherent (Inv t)"
         hence "coherent (Inv (Inv t))"
           using assms 1 Can_Inv by blast
         thus ?thesis using assms by simp
       qed
     qed
 
     text \<open>
       The next two facts are trivially proved by the simplifier, so formal named facts
       are not really necessary, but we include them for logical completeness of the
       following development, which proves coherence by structural induction.
     \<close>
 
     lemma coherent_Prim\<^sub>0:
     assumes "C.obj a"
     shows "coherent \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
       by simp
 
     lemma coherent_Prim:
     assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
     shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
       using assms by simp
 
     lemma coherent_Lunit_Ide:
     assumes "Ide t"
     shows "coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
     proof -
       have t: "Ide t \<and> Arr t \<and> Dom t = t \<and> Cod t = t \<and>
                ide \<lbrace>t\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>t\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>t\<rbrace> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_in_Hom Ide_Nmlize_Ide
               red_in_Hom eval_in_hom ide_eval_Ide
         by force
       have 1: "Obj (Trg t)" using t by auto
       have "\<lbrace>Cod \<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
         using t \<ll>_ide_simp lunit_naturality [of "\<lbrace>t\<^bold>\<down>\<rbrace>"] red_in_Hom
         by (simp add: eval_simps')
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<l>[\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>Trg t\<rbrace> \<star> \<lbrace>t\<^bold>\<down>\<rbrace>)"
          using t 1 lunit_in_hom Nmlize_in_Hom ide_eval_Ide red_in_Hom comp_cod_arr
                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
       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 (cases v) auto
+          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 (cases v) auto
+          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
           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/InternalEquivalence.thy b/thys/Bicategory/InternalEquivalence.thy
--- a/thys/Bicategory/InternalEquivalence.thy
+++ b/thys/Bicategory/InternalEquivalence.thy
@@ -1,1444 +1,1445 @@
 (*  Title:       InternalEquivalence
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Internal Equivalences"
 
 theory InternalEquivalence
 imports Bicategory
 begin
 
   text \<open>
     An \emph{internal equivalence} in a bicategory consists of antiparallel 1-cells \<open>f\<close> and \<open>g\<close>
     together with invertible 2-cells \<open>\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>\<close> and \<open>\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>\<close>.
     Objects in a bicategory are said to be \emph{equivalent} if they are connected by an
     internal equivalence.
     In this section we formalize the definition of internal equivalence and the related notions
     ``equivalence map'' and ``equivalent objects'', and we establish some basic facts about
     these notions.
   \<close>
 
   subsection "Definition of Equivalence"
 
   text \<open>
     The following locale is defined to prove some basic facts about an equivalence
     (or an adjunction) in a bicategory that are ``syntactic'' in the sense that they depend
     only on the configuration (source, target, domain, codomain) of the arrows
     involved and not on further properties such as the triangle identities (for adjunctions)
     or assumptions about invertibility (for equivalences).  Proofs about adjunctions and
     equivalences become more automatic once we have introduction and simplification rules in
     place about this syntax.
   \<close>
 
   locale adjunction_data_in_bicategory =
      bicategory +
   fixes f :: 'a
   and g :: 'a
   and \<eta> :: 'a
   and \<epsilon> :: 'a
   assumes ide_left [simp]: "ide f"
   and ide_right [simp]: "ide g"
   and unit_in_vhom: "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
   and counit_in_vhom: "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> src g\<guillemotright>"
   begin
 
     (*
      * TODO: It is difficult to orient the following equations to make them useful as
      * default simplifications, so they have to be cited explicitly where they are used.
      *)
     lemma antipar (*[simp]*):
     shows "trg g = src f" and "src g = trg f"
        apply (metis counit_in_vhom hseqE ideD(1) ide_right src.preserves_reflects_arr
                     vconn_implies_hpar(3))
       by (metis arrI not_arr_null seq_if_composable src.preserves_reflects_arr
                 unit_in_vhom vconn_implies_hpar(1) vconn_implies_hpar(3))
 
     lemma counit_in_hom [intro]:
     shows "\<guillemotleft>\<epsilon> : trg f \<rightarrow> trg f\<guillemotright>" and "\<guillemotleft>\<epsilon> : f \<star> g \<Rightarrow> trg f\<guillemotright>"
       using counit_in_vhom vconn_implies_hpar antipar by auto
 
     lemma unit_in_hom [intro]:
     shows "\<guillemotleft>\<eta> : src f \<rightarrow> src f\<guillemotright>" and "\<guillemotleft>\<eta> : src f \<Rightarrow> g \<star> f\<guillemotright>"
       using unit_in_vhom vconn_implies_hpar antipar by auto
 
     lemma unit_simps [simp]:
     shows "arr \<eta>" and "dom \<eta> = src f" and "cod \<eta> = g \<star> f"
     and "src \<eta> = src f" and "trg \<eta> = src f"
       using unit_in_hom antipar by auto
 
     lemma counit_simps [simp]:
     shows "arr \<epsilon>" and "dom \<epsilon> = f \<star> g" and "cod \<epsilon> = trg f"
     and "src \<epsilon> = trg f" and "trg \<epsilon> = trg f"
       using counit_in_hom antipar by auto
 
     text \<open>
       The expressions found in the triangle identities for an adjunction come up
       relatively frequently, so it is useful to have established some basic facts
       about them, even if the triangle identities themselves have not actually been
       introduced as assumptions in the current context.
     \<close>
 
     lemma triangle_in_hom:
     shows "\<guillemotleft>(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) : f \<star> src f \<Rightarrow> trg f \<star> f\<guillemotright>"
     and "\<guillemotleft>(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) : trg g \<star> g \<Rightarrow> g \<star> src g\<guillemotright>"
     and "\<guillemotleft>\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] : f \<Rightarrow> f\<guillemotright>"
     and "\<guillemotleft>\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g\<guillemotright>"
       using antipar by auto
 
     lemma triangle_equiv_form:
     shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
            \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
     and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
          \<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
     proof -
       show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
             \<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
       proof
         assume 1: "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
         have "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] =
               \<l>[f] \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
           using comp_assoc by simp
         also have "... = \<l>[f] \<cdot> (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) \<cdot> \<r>\<^sup>-\<^sup>1[f]"
           using 1 by simp
         also have "... = f"
           using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
                 comp_arr_dom comp_cod_arr
           by simp
         finally show "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
           by simp
         next
         assume 2: "\<l>[f] \<cdot> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) \<cdot> \<r>\<^sup>-\<^sup>1[f] = f"
         have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = \<l>\<^sup>-\<^sup>1[f] \<cdot> f \<cdot> \<r>[f]"
           using comp_cod_arr by simp
         also have "... = (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<l>[f]) \<cdot> ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) \<cdot> (\<r>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
           using 2 comp_assoc by (metis (no_types, lifting))
         also have "... = (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)"
           using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
                 hseqI' antipar
           by (metis ide_left in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(1))
         finally show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
           by simp
       qed
       show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<longleftrightarrow>
             \<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
       proof
         assume 1: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         have "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] =
               \<r>[g] \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
           using comp_assoc by simp
         also have "... = \<r>[g] \<cdot> (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) \<cdot> \<l>\<^sup>-\<^sup>1[g]"
           using 1 by simp
         also have "... = g"
           using comp_assoc comp_arr_inv' comp_inv_arr' iso_lunit iso_runit
                 comp_arr_dom comp_cod_arr
           by simp
         finally show "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
           by simp
         next
         assume 2: "\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] = g"
         have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = \<r>\<^sup>-\<^sup>1[g] \<cdot> g \<cdot> \<l>[g]"
           using comp_cod_arr by simp
         also have "... = \<r>\<^sup>-\<^sup>1[g] \<cdot> (\<r>[g] \<cdot> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g]) \<cdot> \<l>[g]"
           using 2 by simp
         also have "... = (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<r>[g]) \<cdot> ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) \<cdot> (\<l>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g])"
           using comp_assoc by simp
         also have "... = (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)"
           using comp_arr_inv' comp_inv_arr' iso_lunit iso_runit comp_arr_dom comp_cod_arr
                 hseqI' antipar
           by (metis ide_right in_homE lunit_simps(4) runit_simps(4) triangle_in_hom(2))
         finally show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
           by simp
       qed
     qed
 
   end
 
   locale equivalence_in_bicategory =
     adjunction_data_in_bicategory +
   assumes unit_is_iso [simp]: "iso \<eta>"
   and counit_is_iso [simp]: "iso \<epsilon>"
   begin
 
     lemma dual_equivalence:
     shows "equivalence_in_bicategory V H \<a> \<i> src trg g f (inv \<epsilon>) (inv \<eta>)"
       using antipar by unfold_locales auto
 
   end
 
   abbreviation (in bicategory) internal_equivalence
     where "internal_equivalence f g \<phi> \<psi> \<equiv> equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
 
   subsection "Quasi-Inverses and Equivalence Maps"
 
   text \<open>
     Antiparallel 1-cells \<open>f\<close> and \<open>g\<close> are \emph{quasi-inverses} if they can be extended to
     an internal equivalence.  We will use the term \emph{equivalence map} to refer to a 1-cell
     that has a quasi-inverse.
   \<close>
 
   context bicategory
   begin
 
     definition quasi_inverses
     where "quasi_inverses f g \<equiv> \<exists>\<phi> \<psi>. internal_equivalence f g \<phi> \<psi>"
 
     lemma quasi_inversesI:
     assumes "ide f" and "ide g"
     and "src f \<cong> g \<star> f" and "f \<star> g \<cong> trg f"
     shows "quasi_inverses f g"
     proof (unfold quasi_inverses_def)
       have 1: "src g = trg f"
         using assms ideD(1) isomorphic_implies_ide(2) by blast
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : src f \<Rightarrow> g \<star> f\<guillemotright> \<and> iso \<phi>"
         using assms isomorphic_def by auto
       obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : f \<star> g \<Rightarrow> trg f\<guillemotright> \<and> iso \<psi>"
         using assms isomorphic_def by auto
      have "equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
         using assms 1 \<phi> \<psi> by unfold_locales auto
       thus "\<exists>\<phi> \<psi>. internal_equivalence f g \<phi> \<psi>" by auto
     qed
 
     lemma quasi_inversesE:
     assumes "quasi_inverses f g"
     and "\<lbrakk>ide f; ide g; src f \<cong> g \<star> f; f \<star> g \<cong> trg f\<rbrakk> \<Longrightarrow> T"
     shows T
     proof -
       obtain \<phi> \<psi> where \<phi>\<psi>: "internal_equivalence f g \<phi> \<psi>"
         using assms quasi_inverses_def by auto
       interpret \<phi>\<psi>: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
         using \<phi>\<psi> by simp
       have "ide f \<and> ide g"
         by simp
       moreover have "src f \<cong> g \<star> f"
         using isomorphic_def \<phi>\<psi>.unit_in_hom by auto
       moreover have "f \<star> g \<cong> trg f"
         using isomorphic_def \<phi>\<psi>.counit_in_hom by auto
       ultimately show T
         using assms by blast
     qed
 
     lemma quasi_inverse_unique:
     assumes "quasi_inverses f g" and "quasi_inverses f g'"
     shows "isomorphic g g'"
     proof -
       obtain \<phi> \<psi> where \<phi>\<psi>: "internal_equivalence f g \<phi> \<psi>"
         using assms quasi_inverses_def by auto
       interpret \<phi>\<psi>: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
         using \<phi>\<psi> by simp
       obtain \<phi>' \<psi>' where \<phi>'\<psi>': "internal_equivalence f g' \<phi>' \<psi>'"
         using assms quasi_inverses_def by auto
       interpret \<phi>'\<psi>': equivalence_in_bicategory V H \<a> \<i> src trg f g' \<phi>' \<psi>'
         using \<phi>'\<psi>' by simp
       have "\<guillemotleft>\<r>[g'] \<cdot> (g' \<star> \<psi>) \<cdot> \<a>[g', f, g] \<cdot> (\<phi>' \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g] : g \<Rightarrow> g'\<guillemotright>"
         using \<phi>\<psi>.unit_in_hom \<phi>\<psi>.unit_is_iso \<phi>\<psi>.antipar \<phi>'\<psi>'.antipar
         by (intro comp_in_homI' hseqI') auto
       moreover have "iso (\<r>[g'] \<cdot> (g' \<star> \<psi>) \<cdot> \<a>[g', f, g] \<cdot> (\<phi>' \<star> g) \<cdot> \<l>\<^sup>-\<^sup>1[g])"
         using \<phi>\<psi>.unit_in_hom \<phi>\<psi>.unit_is_iso \<phi>\<psi>.antipar \<phi>'\<psi>'.antipar
         by (intro isos_compose) auto
       ultimately show ?thesis
         using isomorphic_def by auto
     qed
 
     lemma quasi_inverses_symmetric:
     assumes "quasi_inverses f g"
     shows "quasi_inverses g f"
       using assms quasi_inverses_def equivalence_in_bicategory.dual_equivalence by metis
 
     definition equivalence_map
     where "equivalence_map f \<equiv> \<exists>g \<eta> \<epsilon>. equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
 
     lemma equivalence_mapI:
     assumes "quasi_inverses f g"
     shows "equivalence_map f"
       using assms quasi_inverses_def equivalence_map_def by auto
 
     lemma equivalence_mapE:
     assumes "equivalence_map f"
     obtains g where "quasi_inverses f g"
       using assms equivalence_map_def quasi_inverses_def by auto
 
     lemma equivalence_map_is_ide:
     assumes "equivalence_map f"
     shows "ide f"
       using assms adjunction_data_in_bicategory.ide_left equivalence_in_bicategory_def
             equivalence_map_def
       by fastforce
 
     lemma obj_is_equivalence_map:
     assumes "obj a"
     shows "equivalence_map a"
       using assms
       by (metis equivalence_mapI isomorphic_symmetric objE obj_self_composable(2) quasi_inversesI)
 
     lemma equivalence_respects_iso:
     assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
     and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>" and "\<guillemotleft>\<psi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<psi>"
     shows "internal_equivalence f' g' ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
     proof -
       interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
         using assms by auto
       show ?thesis
       proof
         show f': "ide f'" using assms by auto
         show g': "ide g'" using assms by auto
         show 1: "\<guillemotleft>(g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta> : src f' \<Rightarrow> g' \<star> f'\<guillemotright>"
           using assms f' g' E.unit_in_hom E.antipar(2) vconn_implies_hpar(3)
          apply (intro comp_in_homI)
             apply auto
           by (intro hcomp_in_vhom) auto
         show "iso ((g' \<star> \<phi>) \<cdot> (\<psi> \<star> f) \<cdot> \<eta>)"
           using assms 1 g' vconn_implies_hpar(3) E.antipar(2) iso_hcomp
           by (intro isos_compose) auto
         show 1: "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>) : f' \<star> g' \<Rightarrow> src g'\<guillemotright>"
           using assms f' ide_in_hom(2) vconn_implies_hpar(3-4) E.antipar(1-2)
           by (intro comp_in_homI) auto
         show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv \<psi>))"
           using assms 1 isos_compose
           by (metis E.counit_is_iso E.ide_right arrI f' hseqE ide_is_iso iso_hcomp
               iso_inv_iso seqE)
       qed
     qed
 
     lemma equivalence_map_preserved_by_iso:
     assumes "equivalence_map f" and "f \<cong> f'"
     shows "equivalence_map f'"
     proof -
       obtain g \<eta> \<epsilon> where E: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
         using assms equivalence_map_def by auto
       interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
         using E by auto
       obtain \<phi> where \<phi>: "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright> \<and> iso \<phi>"
         using assms isomorphic_def isomorphic_symmetric by blast
       have "equivalence_in_bicategory V H \<a> \<i> src trg f' g
               ((g \<star> \<phi>) \<cdot> (g \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g) \<cdot> (f' \<star> inv g))"
         using E \<phi> equivalence_respects_iso [of f g \<eta> \<epsilon> \<phi> f' g g] by fastforce
       thus ?thesis
         using equivalence_map_def by auto
     qed
 
     lemma equivalence_preserved_by_iso_right:
     assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
     and "\<guillemotleft>\<phi> : g \<Rightarrow> g'\<guillemotright>" and "iso \<phi>"
     shows "equivalence_in_bicategory V H \<a> \<i> src trg f g' ((\<phi> \<star> f) \<cdot> \<eta>) (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
     proof
       interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
         using assms by auto
       show "ide f" by simp
       show "ide g'"
         using assms(2) isomorphic_def by auto
       show "\<guillemotleft>(\<phi> \<star> f) \<cdot> \<eta> : src f \<Rightarrow> g' \<star> f\<guillemotright>"
         using assms E.antipar(2) E.ide_left by blast
       show "\<guillemotleft>\<epsilon> \<cdot> (f \<star> inv \<phi>) : f \<star> g' \<Rightarrow> src g'\<guillemotright>"
         using assms vconn_implies_hpar(3-4) E.counit_in_vhom E.antipar(1) ide_in_hom(2)
         by (intro comp_in_homI, auto)
       show "iso ((\<phi> \<star> f) \<cdot> \<eta>)"
         using assms E.antipar isos_compose by auto
       show "iso (\<epsilon> \<cdot> (f \<star> inv \<phi>))"
         using assms E.antipar isos_compose by auto
     qed
 
     lemma equivalence_preserved_by_iso_left:
     assumes "equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>"
     and "\<guillemotleft>\<phi> : f \<Rightarrow> f'\<guillemotright>" and "iso \<phi>"
     shows "equivalence_in_bicategory V H \<a> \<i> src trg f' g ((g \<star> \<phi>) \<cdot> \<eta>) (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
     proof
       interpret E: equivalence_in_bicategory V H \<a> \<i> src trg f g \<eta> \<epsilon>
         using assms by auto
       show "ide f'"
         using assms by auto
       show "ide g"
         by simp
       show "\<guillemotleft>(g \<star> \<phi>) \<cdot> \<eta> : src f' \<Rightarrow> g \<star> f'\<guillemotright>"
         using assms E.unit_in_hom E.antipar by auto
       show "\<guillemotleft>\<epsilon> \<cdot> (inv \<phi> \<star> g) : f' \<star> g \<Rightarrow> src g\<guillemotright>"
         using assms E.counit_in_hom E.antipar ide_in_hom(2) vconn_implies_hpar(3) by auto
       show "iso ((g \<star> \<phi>) \<cdot> \<eta>)"
         using assms E.antipar isos_compose by auto
       show "iso (\<epsilon> \<cdot> (inv \<phi> \<star> g))"
         using assms E.antipar isos_compose by auto
     qed
 
     definition some_quasi_inverse
     where "some_quasi_inverse f = (SOME g. quasi_inverses f g)"
 
     notation some_quasi_inverse  ("_\<^sup>~" [1000] 1000)
 
     lemma quasi_inverses_some_quasi_inverse:
     assumes "equivalence_map f"
     shows "quasi_inverses f f\<^sup>~"
     and "quasi_inverses f\<^sup>~ f"
       using assms some_quasi_inverse_def quasi_inverses_def equivalence_map_def
             someI_ex [of "\<lambda>g. quasi_inverses f g"] quasi_inverses_symmetric
       by auto
 
     lemma quasi_inverse_antipar:
     assumes "equivalence_map f"
     shows "src f\<^sup>~ = trg f" and "trg f\<^sup>~ = src f"
     proof -
       obtain \<phi> \<psi> where \<phi>\<psi>: "equivalence_in_bicategory V H \<a> \<i> src trg f f\<^sup>~ \<phi> \<psi>"
         using assms equivalence_map_def quasi_inverses_some_quasi_inverse quasi_inverses_def
         by blast
       interpret \<phi>\<psi>: equivalence_in_bicategory V H \<a> \<i> src trg f \<open>f\<^sup>~\<close> \<phi> \<psi>
         using \<phi>\<psi> by simp
       show "src f\<^sup>~ = trg f"
         using \<phi>\<psi>.antipar by simp
       show "trg f\<^sup>~ = src f"
         using \<phi>\<psi>.antipar by simp
     qed
 
     lemma quasi_inverse_in_hom [intro]:
     assumes "equivalence_map f"
     shows "\<guillemotleft>f\<^sup>~ : trg f \<rightarrow> src f\<guillemotright>"
     and "\<guillemotleft>f\<^sup>~ : f\<^sup>~ \<Rightarrow> f\<^sup>~\<guillemotright>"
       using assms equivalence_mapE
       apply (intro in_homI in_hhomI)
          apply (metis equivalence_map_is_ide ideD(1) not_arr_null quasi_inverse_antipar(2)
                       src.preserves_ide trg.is_extensional)
         apply (simp_all add: quasi_inverse_antipar)
       using assms quasi_inversesE quasi_inverses_some_quasi_inverse(2) by blast
 
     lemma quasi_inverse_simps [simp]:
     assumes "equivalence_map f"
     shows "equivalence_map f\<^sup>~" and "ide f\<^sup>~"
     and "src f\<^sup>~ = trg f" and "trg f\<^sup>~ = src f"
     and "dom f\<^sup>~ = f\<^sup>~" and "cod f\<^sup>~ = f\<^sup>~"
-      using assms equivalence_mapE quasi_inverse_in_hom quasi_inverses_some_quasi_inverse equivalence_map_is_ide
+      using assms equivalence_mapE quasi_inverse_in_hom quasi_inverses_some_quasi_inverse
+            equivalence_map_is_ide
            apply auto
       by (meson equivalence_mapI)
 
     lemma quasi_inverse_quasi_inverse:
     assumes "equivalence_map f"
     shows "(f\<^sup>~)\<^sup>~ \<cong> f"
     proof -
       have "quasi_inverses f\<^sup>~ (f\<^sup>~)\<^sup>~"
         using assms quasi_inverses_some_quasi_inverse by simp
       moreover have "quasi_inverses f\<^sup>~ f"
         using assms quasi_inverses_some_quasi_inverse quasi_inverses_symmetric by simp
       ultimately show ?thesis
         using quasi_inverse_unique by simp
     qed
 
     lemma comp_quasi_inverse:
     assumes "equivalence_map f"
     shows "f\<^sup>~ \<star> f \<cong> src f" and "f \<star> f\<^sup>~ \<cong> trg f"
     proof -
       obtain \<phi> \<psi> where \<phi>\<psi>: "equivalence_in_bicategory V H \<a> \<i> src trg f f\<^sup>~ \<phi> \<psi>"
         using assms equivalence_map_def quasi_inverses_some_quasi_inverse
               quasi_inverses_def
         by blast
       interpret \<phi>\<psi>: equivalence_in_bicategory V H \<a> \<i> src trg f \<open>f\<^sup>~\<close> \<phi> \<psi>
         using \<phi>\<psi> by simp
       show "f\<^sup>~ \<star> f \<cong> src f"
         using quasi_inverses_some_quasi_inverse quasi_inverses_def
               \<phi>\<psi>.unit_in_hom \<phi>\<psi>.unit_is_iso isomorphic_def
         by blast
       show "f \<star> f\<^sup>~ \<cong> trg f"
         using quasi_inverses_some_quasi_inverse quasi_inverses_def
               \<phi>\<psi>.counit_in_hom \<phi>\<psi>.counit_is_iso isomorphic_def
         by blast
     qed
 
     lemma quasi_inverse_transpose:
     assumes "ide f" and "ide g" and "ide h" and "f \<star> g \<cong> h"
     shows "equivalence_map g \<Longrightarrow> f \<cong> h \<star> g\<^sup>~"
     and "equivalence_map f \<Longrightarrow> g \<cong> f\<^sup>~ \<star> h"
     proof -
       have 1: "src f = trg g"
         using assms equivalence_map_is_ide by fastforce
       show "equivalence_map g \<Longrightarrow> f \<cong> h \<star> g\<^sup>~"
       proof -
         assume g: "equivalence_map g"
         have 2: "ide g\<^sup>~"
           using g by simp
         have "f \<cong> f \<star> src f"
           using assms isomorphic_unit_right isomorphic_symmetric by blast
         also have "... \<cong> f \<star> trg g"
           using assms 1 isomorphic_reflexive by auto
         also have "... \<cong> f \<star> g \<star> g\<^sup>~"
           using assms g 1 comp_quasi_inverse(2) isomorphic_symmetric hcomp_ide_isomorphic
           by simp
         also have "... \<cong> (f \<star> g) \<star> g\<^sup>~"
           using assms g 1 2 assoc'_in_hom [of f g "g\<^sup>~"] iso_assoc' isomorphic_def by auto
         also have "... \<cong> h \<star> g\<^sup>~"
           using assms g 1 2
           by (simp add: hcomp_isomorphic_ide)
         finally show ?thesis by blast
       qed
       show "equivalence_map f \<Longrightarrow> g \<cong> f\<^sup>~ \<star> h"
       proof -
         assume f: "equivalence_map f"
         have 2: "ide f\<^sup>~"
           using f by simp
         have "g \<cong> src f \<star> g"
           using assms 1 isomorphic_unit_left isomorphic_symmetric by metis
         also have "... \<cong> (f\<^sup>~ \<star> f) \<star> g"
           using assms f 1 comp_quasi_inverse(1) [of f] isomorphic_symmetric
                 hcomp_isomorphic_ide
           by simp
         also have "... \<cong> f\<^sup>~ \<star> f \<star> g"
           using assms f 1 assoc_in_hom [of "f\<^sup>~" f g] iso_assoc isomorphic_def by auto
         also have "... \<cong> f\<^sup>~ \<star> h"
           using assms f 1 equivalence_map_is_ide quasi_inverses_some_quasi_inverse
                 hcomp_ide_isomorphic
           by simp
         finally show ?thesis by blast
       qed
     qed
 
   end
 
   subsection "Composing Equivalences"
 
   locale composite_equivalence_in_bicategory =
     bicategory V H \<a> \<i> src trg +
     fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<zeta> \<xi> +
     hk: equivalence_in_bicategory V H \<a> \<i> src trg h k \<sigma> \<tau>
   for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"        (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"        (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"              ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and f :: "'a"
   and g :: "'a"
   and \<zeta> :: "'a"
   and \<xi> :: "'a"
   and h :: "'a"
   and k :: "'a"
   and \<sigma> :: "'a"
   and \<tau> :: "'a" +
   assumes composable: "src h = trg f"
   begin
 
     abbreviation \<eta>
     where "\<eta> \<equiv> \<a>\<^sup>-\<^sup>1[g, k, h \<star> f] \<cdot> (g \<star> \<a>[k, h, f]) \<cdot> (g \<star> \<sigma> \<star> f) \<cdot> (g \<star> \<l>\<^sup>-\<^sup>1[f]) \<cdot> \<zeta>"
 
     abbreviation \<epsilon>
     where "\<epsilon> \<equiv> \<tau> \<cdot> (h \<star> \<l>[k]) \<cdot> (h \<star> \<xi> \<star> k) \<cdot> (h \<star> \<a>\<^sup>-\<^sup>1[f, g, k]) \<cdot> \<a>[h, f, g \<star> k]"
 
     interpretation adjunction_data_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
     proof
       show "ide (h \<star> f)"
         using composable by simp
       show "ide (g \<star> k)"
         using fg.antipar hk.antipar composable by simp
       show "\<guillemotleft>\<eta> : src (h \<star> f) \<Rightarrow> (g \<star> k) \<star> h \<star> f\<guillemotright>"
         using fg.antipar hk.antipar composable by fastforce
       show "\<guillemotleft>\<epsilon> : (h \<star> f) \<star> g \<star> k \<Rightarrow> src (g \<star> k)\<guillemotright>"
         using fg.antipar hk.antipar composable by fastforce
     qed
 
     interpretation equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
     proof
       show "iso \<eta>"
         using fg.antipar hk.antipar composable fg.unit_is_iso hk.unit_is_iso iso_hcomp
               iso_lunit' hseq_char
         by (intro isos_compose, auto)
       show "iso \<epsilon>"
         using fg.antipar hk.antipar composable fg.counit_is_iso hk.counit_is_iso iso_hcomp
               iso_lunit hseq_char
         by (intro isos_compose, auto)
     qed
 
     lemma is_equivalence:
     shows "equivalence_in_bicategory V H \<a> \<i> src trg (h \<star> f) (g \<star> k) \<eta> \<epsilon>"
       ..
 
     sublocale equivalence_in_bicategory V H \<a> \<i> src trg \<open>h \<star> f\<close> \<open>g \<star> k\<close> \<eta> \<epsilon>
       using is_equivalence by simp
 
   end
 
   context bicategory
   begin
 
     lemma equivalence_maps_compose:
     assumes "equivalence_map f" and "equivalence_map f'" and "src f' = trg f"
     shows "equivalence_map (f' \<star> f)"
     proof -
       obtain g \<phi> \<psi> where fg: "equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>"
         using assms(1) equivalence_map_def by auto
       interpret fg: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
         using fg by auto
       obtain g' \<phi>' \<psi>' where f'g': "equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'"
         using assms(2) equivalence_map_def by auto
       interpret f'g': equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'
         using f'g' by auto
       interpret composite_equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi> f' g' \<phi>' \<psi>'
         using assms(3) by (unfold_locales, auto)
       show ?thesis
         using equivalence_map_def equivalence_in_bicategory_axioms by auto
     qed
 
     lemma quasi_inverse_hcomp':
     assumes "equivalence_map f" and "equivalence_map f'" and "equivalence_map (f \<star> f')"
     and "quasi_inverses f g" and "quasi_inverses f' g'"
     shows "quasi_inverses (f \<star> f') (g' \<star> g)"
     proof -
       obtain \<phi> \<psi> where g: "internal_equivalence f g \<phi> \<psi>"
         using assms quasi_inverses_def by auto
       interpret g: equivalence_in_bicategory V H \<a> \<i> src trg f g \<phi> \<psi>
         using g by simp
       obtain \<phi>' \<psi>' where g': "internal_equivalence f' g' \<phi>' \<psi>'"
         using assms quasi_inverses_def by auto
       interpret g': equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>'
         using g' by simp
       interpret gg': composite_equivalence_in_bicategory V H \<a> \<i> src trg f' g' \<phi>' \<psi>' f g \<phi> \<psi>
         using assms equivalence_map_is_ide [of "f \<star> f'"]
         apply unfold_locales
         using ideD(1) by fastforce
       show ?thesis
         unfolding quasi_inverses_def
         using gg'.equivalence_in_bicategory_axioms by auto
     qed
 
     lemma quasi_inverse_hcomp:
     assumes "equivalence_map f" and "equivalence_map f'" and "equivalence_map (f \<star> f')"
     shows "(f \<star> f')\<^sup>~ \<cong> f'\<^sup>~ \<star> f\<^sup>~"
       using assms quasi_inverses_some_quasi_inverse quasi_inverse_hcomp' quasi_inverse_unique
       by metis
 
     lemma quasi_inverse_respects_isomorphic:
     assumes "equivalence_map f" and "equivalence_map f'" and "f \<cong> f'"
     shows "f\<^sup>~ \<cong> f'\<^sup>~"
     proof -
       have hpar: "src f = src f' \<and> trg f = trg f'"
         using assms isomorphic_implies_hpar by simp
       have "f\<^sup>~ \<cong> f\<^sup>~ \<star> trg f"
         using isomorphic_unit_right
         by (metis assms(1) isomorphic_symmetric quasi_inverse_simps(2-3))
       also have "... \<cong> f\<^sup>~ \<star> f' \<star> f'\<^sup>~"
       proof -
         have "trg f \<cong> f' \<star> f'\<^sup>~"
           using assms quasi_inverse_hcomp
           by (simp add: comp_quasi_inverse(2) hpar isomorphic_symmetric)
         thus ?thesis
           using assms hpar hcomp_ide_isomorphic isomorphic_implies_hpar(2) by auto
       qed
       also have "... \<cong> (f\<^sup>~ \<star> f') \<star> f'\<^sup>~"
         using assms hcomp_assoc_isomorphic hpar isomorphic_implies_ide(2) isomorphic_symmetric
         by auto
       also have "... \<cong> (f\<^sup>~ \<star> f) \<star> f'\<^sup>~"
       proof -
         have "f\<^sup>~ \<star> f' \<cong> f\<^sup>~ \<star> f"
           using assms isomorphic_symmetric hcomp_ide_isomorphic isomorphic_implies_hpar(1)
           by auto
         thus ?thesis
           using assms hcomp_isomorphic_ide isomorphic_implies_hpar(1) by auto
       qed
       also have "... \<cong> src f \<star> f'\<^sup>~"
       proof -
         have "f\<^sup>~ \<star> f \<cong> src f"
           using assms comp_quasi_inverse by simp
         thus ?thesis
           using assms hcomp_isomorphic_ide isomorphic_implies_hpar by simp
       qed
       also have "... \<cong> f'\<^sup>~"
         using assms isomorphic_unit_left
         by (metis hpar quasi_inverse_simps(2,4))
       finally show ?thesis by blast
     qed
 
   end
 
   subsection "Equivalent Objects"
 
   context bicategory
   begin
 
     definition equivalent_objects
     where "equivalent_objects a b \<equiv> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
 
     lemma equivalent_objects_reflexive:
     assumes "obj a"
     shows "equivalent_objects a a"
       using assms
       by (metis equivalent_objects_def ide_in_hom(1) objE obj_is_equivalence_map)
 
     lemma equivalent_objects_symmetric:
     assumes "equivalent_objects a b"
     shows "equivalent_objects b a"
       using assms
       by (metis equivalent_objects_def in_hhomE quasi_inverse_in_hom(1) quasi_inverse_simps(1))
 
     lemma equivalent_objects_transitive [trans]:
     assumes "equivalent_objects a b" and "equivalent_objects b c"
     shows "equivalent_objects a c"
     proof -
       obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> equivalence_map f"
         using assms equivalent_objects_def by auto
       obtain g where g: "\<guillemotleft>g : b \<rightarrow> c\<guillemotright> \<and> equivalence_map g"
         using assms equivalent_objects_def by auto
       have "\<guillemotleft>g \<star> f : a \<rightarrow> c\<guillemotright> \<and> equivalence_map (g \<star> f)"
         using f g equivalence_maps_compose by auto
       thus ?thesis
         using equivalent_objects_def by auto
     qed
 
   end
 
   subsection "Transporting Arrows along Equivalences"
 
   text \<open>
     We show in this section that transporting the arrows of one hom-category to another
     along connecting equivalence maps yields an equivalence of categories.
     This is useful, because it seems otherwise hard to establish that the transporting
     functor is full.
   \<close>
 
   locale two_equivalences_in_bicategory =
     bicategory V H \<a> \<i> src trg +
     e\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>0 d\<^sub>0 \<eta>\<^sub>0 \<epsilon>\<^sub>0 +
     e\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg e\<^sub>1 d\<^sub>1 \<eta>\<^sub>1 \<epsilon>\<^sub>1
   for V :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"       (infixr "\<cdot>" 55)
   and H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"       (infixr "\<star>" 53)
   and \<a> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<a>[_, _, _]")
   and \<i> :: "'a \<Rightarrow> 'a"             ("\<i>[_]")
   and src :: "'a \<Rightarrow> 'a"
   and trg :: "'a \<Rightarrow> 'a"
   and e\<^sub>0 :: "'a"
   and d\<^sub>0 :: "'a"
   and \<eta>\<^sub>0 :: "'a"
   and \<epsilon>\<^sub>0 :: "'a"
   and e\<^sub>1 :: "'a"
   and d\<^sub>1 :: "'a"
   and \<eta>\<^sub>1 :: "'a"
   and \<epsilon>\<^sub>1 :: "'a"
   begin
 
     interpretation hom: subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>\<close>
       using hhom_is_subcategory by simp
 
     (* TODO: The preceding interpretation somehow brings in unwanted notation. *)
     no_notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     interpretation hom': subcategory V \<open>\<lambda>\<mu>. \<guillemotleft>\<mu> : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>\<close>
       using hhom_is_subcategory by simp
 
     no_notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     abbreviation (input) F
     where "F \<equiv> \<lambda>\<mu>. e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0"
 
     interpretation F: "functor" hom.comp hom'.comp F
     proof
       show 1: "\<And>f. hom.arr f \<Longrightarrow> hom'.arr (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
         using hom.arr_char hom'.arr_char in_hhom_def e\<^sub>0.antipar(1-2) by simp
       show "\<And>f. \<not> hom.arr f \<Longrightarrow> e\<^sub>1 \<star> f \<star> d\<^sub>0 = hom'.null"
         using 1 hom.arr_char hom'.null_char in_hhom_def
         by (metis e\<^sub>0.antipar(1) hseqE hseq_char' hcomp_simps(2))
       show "\<And>f. hom.arr f \<Longrightarrow> hom'.dom (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.dom f \<star> d\<^sub>0"
         using hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char
         by (metis 1 hcomp_simps(3) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
       show "\<And>f. hom.arr f \<Longrightarrow> hom'.cod (e\<^sub>1 \<star> f \<star> d\<^sub>0) = e\<^sub>1 \<star> hom.cod f \<star> d\<^sub>0"
         using hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char
         by (metis 1 hcomp_simps(4) e\<^sub>0.ide_right e\<^sub>1.ide_left hom'.inclusion hseq_char ide_char)
       show "\<And>g f. hom.seq g f \<Longrightarrow>
                    e\<^sub>1 \<star> hom.comp g f \<star> d\<^sub>0 = hom'.comp (e\<^sub>1 \<star> g \<star> d\<^sub>0) (e\<^sub>1 \<star> f \<star> d\<^sub>0)"
         using 1 hom.seq_char hom.arr_char hom.comp_char hom'.arr_char hom'.comp_char
               whisker_left [of e\<^sub>1] whisker_right [of d\<^sub>0]
         apply auto
          apply (metis hseq_char seqE src_vcomp)
         by (metis hseq_char hseq_char')
     qed
 
     abbreviation (input) G
     where "G \<equiv> \<lambda>\<mu>'. d\<^sub>1 \<star> \<mu>' \<star> e\<^sub>0"
 
     interpretation G: "functor" hom'.comp hom.comp G
     proof
       show 1: "\<And>f. hom'.arr f \<Longrightarrow> hom.arr (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
         using hom.arr_char hom'.arr_char in_hhom_def e\<^sub>1.antipar(1) e\<^sub>1.antipar(2)
         by simp
       show "\<And>f. \<not> hom'.arr f \<Longrightarrow> d\<^sub>1 \<star> f \<star> e\<^sub>0 = hom.null"
         using 1 hom.arr_char hom'.null_char in_hhom_def
         by (metis e\<^sub>1.antipar(2) hom'.arrI hom.null_char hseqE hseq_char' hcomp_simps(2))
       show "\<And>f. hom'.arr f \<Longrightarrow> hom.dom (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.dom f \<star> e\<^sub>0"
         using 1 hom.arr_char hom.dom_char hom'.arr_char hom'.dom_char
         by (metis hcomp_simps(3) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
       show "\<And>f. hom'.arr f \<Longrightarrow> hom.cod (d\<^sub>1 \<star> f \<star> e\<^sub>0) = d\<^sub>1 \<star> hom'.cod f \<star> e\<^sub>0"
         using 1 hom.arr_char hom.cod_char hom'.arr_char hom'.cod_char
         by (metis hcomp_simps(4) e\<^sub>0.ide_left e\<^sub>1.ide_right hom.inclusion hseq_char ide_char)
       show "\<And>g f. hom'.seq g f \<Longrightarrow>
                    d\<^sub>1 \<star> hom'.comp g f \<star> e\<^sub>0 = hom.comp (d\<^sub>1 \<star> g \<star> e\<^sub>0) (d\<^sub>1 \<star> f \<star> e\<^sub>0)"
         using 1 hom'.seq_char hom'.arr_char hom'.comp_char hom.arr_char hom.comp_char
               whisker_left [of d\<^sub>1] whisker_right [of e\<^sub>0]
         apply auto
          apply (metis hseq_char seqE src_vcomp)
         by (metis hseq_char hseq_char')
     qed
 
     interpretation GF: composite_functor hom.comp hom'.comp hom.comp F G ..
     interpretation FG: composite_functor hom'.comp hom.comp hom'.comp G F ..
 
     abbreviation (input) \<phi>\<^sub>0
     where "\<phi>\<^sub>0 f \<equiv> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, f \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (f \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                     ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> f \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[f \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[f]"
 
     lemma \<phi>\<^sub>0_in_hom:
     assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
     shows "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
     and "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
     proof -
       show "\<guillemotleft>\<phi>\<^sub>0 f : f \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> f \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
         using assms e\<^sub>0.antipar e\<^sub>1.antipar by fastforce
       thus "\<guillemotleft>\<phi>\<^sub>0 f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
         using assms src_dom [of "\<phi>\<^sub>0 f"] trg_dom [of "\<phi>\<^sub>0 f"]
         by (metis arrI dom_comp in_hhom_def runit'_simps(4) seqE)
     qed
 
     lemma iso_\<phi>\<^sub>0:
     assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
     shows "iso (\<phi>\<^sub>0 f)"
       using assms iso_lunit' iso_runit' e\<^sub>0.antipar e\<^sub>1.antipar
       by (intro isos_compose) auto
 
     interpretation \<phi>: transformation_by_components hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>\<^sub>0
     proof
       fix f
       assume f: "hom.ide f"
       show "hom.in_hom (\<phi>\<^sub>0 f) (hom.map f) (GF.map f)"
       proof (unfold hom.in_hom_char, intro conjI)
         show "hom.arr (hom.map f)"
           using f by simp
         show "hom.arr (GF.map f)"
           using f by simp
         show "hom.arr (\<phi>\<^sub>0 f)"
           using f hom.ide_char hom.arr_char \<phi>\<^sub>0_in_hom by simp
         show "\<guillemotleft>\<phi>\<^sub>0 f : hom.map f \<Rightarrow> GF.map f\<guillemotright>"
           using f hom.ide_char hom.arr_char hom'.ide_char hom'.arr_char F.preserves_arr
                 \<phi>\<^sub>0_in_hom
           by auto
       qed
       next
       fix \<mu>
       assume \<mu>: "hom.arr \<mu>"
       show "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) =
             hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
       proof -
         have "hom.comp (\<phi>\<^sub>0 (hom.cod \<mu>)) (hom.map \<mu>) = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
         proof -
           have "hom.map \<mu> = \<mu>"
             using \<mu> by simp
           moreover have "\<phi>\<^sub>0 (hom.cod \<mu>) = \<phi>\<^sub>0 (cod \<mu>)"
             using \<mu> hom.arr_char hom.cod_char by simp
           moreover have "hom.arr (\<phi>\<^sub>0 (cod \<mu>))"
             using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom [of "cod \<mu>"]
             by (metis hom.arr_cod hom.cod_simp ide_cod in_hhom_def)
           moreover have "seq (\<phi>\<^sub>0 (cod \<mu>)) \<mu>"
           proof
             show 1: "\<guillemotleft>\<mu> : dom \<mu> \<Rightarrow> cod \<mu>\<guillemotright>"
               using \<mu> hom.arr_char by auto
             show "\<guillemotleft>\<phi>\<^sub>0 (cod \<mu>) : cod \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
               using \<mu> hom.arr_char \<phi>\<^sub>0_in_hom
               by (metis 1 arrI hom.arr_cod hom.cod_simp ide_cod)
           qed
           ultimately show ?thesis
             using \<mu> hom.comp_char by simp
         qed
         also have "... = (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
                            \<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[cod \<mu>] \<cdot> \<mu>"
           using \<mu> hom.arr_char comp_assoc by auto
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
                            \<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] \<cdot> (\<mu> \<star> src e\<^sub>0)) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using \<mu> hom.arr_char runit'_naturality [of \<mu>] comp_assoc by auto
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
                            (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0]) \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using \<mu> hom.arr_char lunit'_naturality [of "\<mu> \<star> src e\<^sub>0"] by force
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> (\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot>
                            (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0)) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using comp_assoc by simp
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0)) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
         proof -
           have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) = \<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0"
             using \<mu> hom.arr_char comp_arr_dom comp_cod_arr
                   interchange [of \<eta>\<^sub>1 "src e\<^sub>1" "cod \<mu> \<star> \<eta>\<^sub>0" "\<mu> \<star> src e\<^sub>0"]
                   interchange [of "cod \<mu>" \<mu> \<eta>\<^sub>0 "src e\<^sub>0"]
             by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(2) e\<^sub>1.unit_simps(1) e\<^sub>1.unit_simps(2)
                 hseqI' in_hhom_def)
           also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
           proof -
             have "\<eta>\<^sub>1 \<star> \<mu> \<star> \<eta>\<^sub>0 = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> \<mu> \<cdot> dom \<mu> \<star> (d\<^sub>0 \<star> e\<^sub>0) \<cdot> \<eta>\<^sub>0"
               using \<mu> hom.arr_char comp_arr_dom comp_cod_arr by auto
             also have "... = (d\<^sub>1 \<star> e\<^sub>1) \<cdot> \<eta>\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (dom \<mu> \<star> \<eta>\<^sub>0)"
               using \<mu> hom.arr_char comp_cod_arr
                     interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
               by auto
             also have "... = ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
               using \<mu> hom.arr_char comp_arr_dom comp_cod_arr
                     interchange [of "d\<^sub>1 \<star> e\<^sub>1" \<eta>\<^sub>1 "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0" "dom \<mu> \<star> \<eta>\<^sub>0"]
                     interchange [of \<mu> "dom \<mu>" "d\<^sub>0 \<star> e\<^sub>0" \<eta>\<^sub>0]
               by (metis e\<^sub>0.unit_in_hom(1) e\<^sub>0.unit_simps(1) e\<^sub>0.unit_simps(3) e\<^sub>1.unit_simps(1)
                   e\<^sub>1.unit_simps(3) hom.inclusion hseqI)
             finally show ?thesis by simp
           qed
           finally have "(\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0) \<cdot> (src e\<^sub>1 \<star> \<mu> \<star> src e\<^sub>0) =
                           ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0) \<cdot> (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0)"
             by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0])) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar assoc'_naturality [of \<mu> d\<^sub>0 e\<^sub>0]
                 whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "\<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0]" "\<mu> \<star> d\<^sub>0 \<star> e\<^sub>0"]
                 whisker_left [of "d\<^sub>1 \<star> e\<^sub>1" "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]"]
           by auto
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> \<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot>
                            ((d\<^sub>1 \<star> e\<^sub>1) \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using comp_assoc by simp
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot>
                            \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0]) \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar
                 assoc_naturality [of d\<^sub>1 e\<^sub>1 "(\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"] hseqI
           by auto
         also have "... = ((d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]) \<cdot> (d\<^sub>1 \<star> e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0)) \<cdot>
                            \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using comp_assoc by simp
         also have "... = ((d\<^sub>1 \<star> (e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0) \<cdot> (d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0])) \<cdot>
                            \<a>[d\<^sub>1, e\<^sub>1, (dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] \<cdot> ((d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[dom \<mu>, d\<^sub>0, e\<^sub>0]) \<cdot>
                            (\<eta>\<^sub>1 \<star> dom \<mu> \<star> \<eta>\<^sub>0) \<cdot> \<l>\<^sup>-\<^sup>1[dom \<mu> \<star> src e\<^sub>0] \<cdot> \<r>\<^sup>-\<^sup>1[dom \<mu>]"
           using \<mu> hom.arr_char e\<^sub>0.antipar e\<^sub>1.antipar
                 assoc'_naturality [of e\<^sub>1 "\<mu> \<star> d\<^sub>0" e\<^sub>0]
                 whisker_left [of d\<^sub>1 "\<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0]" "e\<^sub>1 \<star> (\<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"]
                 whisker_left [of d\<^sub>1 "(e\<^sub>1 \<star> \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0" "\<a>\<^sup>-\<^sup>1[e\<^sub>1, dom \<mu> \<star> d\<^sub>0, e\<^sub>0]"]
           by auto
         also have "... = hom.comp (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
         proof -
           have "hom.arr (GF.map \<mu>)"
             using \<mu> by blast
           moreover have "hom.arr (\<phi>\<^sub>0 (hom.dom \<mu>))"
             using \<mu> hom.arr_char hom.in_hom_char \<phi>\<^sub>0_in_hom(1) hom.dom_closed hom.dom_simp
                   hom.inclusion ide_dom
             by metis
           moreover have "seq (GF.map \<mu>) (\<phi>\<^sub>0 (hom.dom \<mu>))"
           proof
             show "\<guillemotleft>\<phi>\<^sub>0 (hom.dom \<mu>) : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
               using \<mu> hom.arr_char hom.dom_char hom.in_hom_char \<phi>\<^sub>0_in_hom hom.dom_closed
                     hom.dom_simp hom.inclusion ide_dom
               by metis
             show "\<guillemotleft>GF.map \<mu> : d\<^sub>1 \<star> (e\<^sub>1 \<star> dom \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
               using \<mu> hom.arr_char hom'.arr_char F.preserves_arr
               apply simp
               apply (intro hcomp_in_vhom)
               by (auto simp add: e\<^sub>0.antipar e\<^sub>1.antipar in_hhom_def)
           qed
           ultimately show ?thesis
             using \<mu> hom.comp_char comp_assoc hom.dom_simp by auto
         qed
         finally show ?thesis by blast
       qed
     qed
 
     lemma transformation_by_components_\<phi>\<^sub>0:
     shows "transformation_by_components hom.comp hom.comp hom.map (G o F) \<phi>\<^sub>0"
       ..
 
     interpretation \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>.map
     proof
       fix f
       assume "hom.ide f"
       hence f: "ide f \<and> \<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
         using hom.ide_char hom.arr_char by simp
       show "hom.iso (\<phi>.map f)"
       proof (unfold hom.iso_char hom.arr_char, intro conjI)
         show "iso (\<phi>.map f)"
           using f iso_\<phi>\<^sub>0 \<phi>.map_simp_ide hom.ide_char hom.arr_char by simp
         moreover show "\<guillemotleft>\<phi>.map f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
           using f hom.ide_char hom.arr_char by blast
         ultimately show "\<guillemotleft>inv (\<phi>.map f) : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
           by auto
       qed
     qed
 
     lemma natural_isomorphism_\<phi>:
     shows "natural_isomorphism hom.comp hom.comp hom.map (G o F) \<phi>.map"
       ..
 
     definition \<phi>
     where "\<phi> \<equiv> \<phi>.map"
 
     lemma \<phi>_ide_simp:
     assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
     shows "\<phi> f = \<phi>\<^sub>0 f"
       unfolding \<phi>_def
       using assms hom.ide_char hom.arr_char by simp
 
     lemma \<phi>_components_are_iso:
     assumes "\<guillemotleft>f : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>" and "ide f"
     shows "iso (\<phi> f)"
       using assms \<phi>_def \<phi>.components_are_iso hom.ide_char hom.arr_char hom.iso_char
       by simp
 
     lemma \<phi>_eq:
     shows "\<phi> = (\<lambda>\<mu>. if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
     proof
       fix \<mu>
       have "\<not> \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = null"
         using hom.comp_char hom.null_char hom.arr_char
         by (simp add: \<phi>.is_extensional)
       moreover have "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> \<Longrightarrow> \<phi>.map \<mu> = \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu>"
         unfolding \<phi>.map_def
         apply auto
         using hom.comp_char hom.arr_char hom.dom_simp hom.cod_simp
         apply simp
         by (metis (no_types, lifting) \<phi>\<^sub>0_in_hom(1) hom.cod_closed hom.inclusion ide_cod local.ext)
       ultimately show "\<phi> \<mu> = (if \<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright> then \<phi>\<^sub>0 (cod \<mu>) \<cdot> \<mu> else null)"
         unfolding \<phi>_def by auto
     qed
 
     lemma \<phi>_in_hom [intro]:
     assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
     shows "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
     and "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
     proof -
       show "\<guillemotleft>\<phi> \<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
         using assms \<phi>_eq \<phi>_def hom.arr_char \<phi>.preserves_reflects_arr by presburger
       show "\<guillemotleft>\<phi> \<mu> : dom \<mu> \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
         unfolding \<phi>_eq
         using assms apply simp
         apply (intro comp_in_homI)
               apply auto
       proof -
         show "\<guillemotleft>\<r>\<^sup>-\<^sup>1[cod \<mu>] : cod \<mu> \<Rightarrow> cod \<mu> \<star> src e\<^sub>0\<guillemotright>"
           using assms by auto
         show "\<guillemotleft>\<l>\<^sup>-\<^sup>1[cod \<mu> \<star> src e\<^sub>0] : cod \<mu> \<star> src e\<^sub>0 \<Rightarrow> src e\<^sub>1 \<star> cod \<mu> \<star> src e\<^sub>0\<guillemotright>"
           using assms by auto
         show "\<guillemotleft>\<eta>\<^sub>1 \<star> cod \<mu> \<star> \<eta>\<^sub>0 : src e\<^sub>1 \<star> cod \<mu> \<star> src e\<^sub>0 \<Rightarrow> (d\<^sub>1 \<star> e\<^sub>1) \<star> cod \<mu> \<star> (d\<^sub>0 \<star> e\<^sub>0)\<guillemotright>"
           using assms e\<^sub>0.unit_in_hom(2) e\<^sub>1.unit_in_hom(2)
           apply (intro hcomp_in_vhom)
               apply auto
           by fastforce
         show "\<guillemotleft>(d\<^sub>1 \<star> e\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[cod \<mu>, d\<^sub>0, e\<^sub>0] :
                  (d\<^sub>1 \<star> e\<^sub>1) \<star> cod \<mu> \<star> d\<^sub>0 \<star> e\<^sub>0 \<Rightarrow> (d\<^sub>1 \<star> e\<^sub>1) \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
           using assms assoc'_in_hom e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(2)
           apply (intro hcomp_in_vhom) by auto
         show "\<guillemotleft>\<a>[d\<^sub>1, e\<^sub>1, (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0] :
                 (d\<^sub>1 \<star> e\<^sub>1) \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> e\<^sub>1 \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
           using assms assoc_in_hom e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(2) by auto
         show "\<guillemotleft>d\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[e\<^sub>1, cod \<mu> \<star> d\<^sub>0, e\<^sub>0] :
                  d\<^sub>1 \<star> e\<^sub>1 \<star> (cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0 \<Rightarrow> d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0\<guillemotright>"
           using assms assoc'_in_hom [of "d\<^sub>1" "e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0" "e\<^sub>0"]
                 e\<^sub>0.antipar(1-2) e\<^sub>1.antipar(1-2)
           apply (intro hcomp_in_vhom)
             apply auto
           by fastforce
       qed
     qed
 
     lemma \<phi>_simps [simp]:
     assumes "\<guillemotleft>\<mu> : src e\<^sub>0 \<rightarrow> src e\<^sub>1\<guillemotright>"
     shows "arr (\<phi> \<mu>)"
     and "src (\<phi> \<mu>) = src e\<^sub>0" and "trg (\<phi> \<mu>) = src e\<^sub>1"
     and "dom (\<phi> \<mu>) = dom \<mu>" and "cod (\<phi> \<mu>) = d\<^sub>1 \<star> (e\<^sub>1 \<star> cod \<mu> \<star> d\<^sub>0) \<star> e\<^sub>0"
       using assms \<phi>_in_hom by auto
 
     interpretation d\<^sub>0: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close>
       using e\<^sub>0.dual_equivalence by simp
     interpretation d\<^sub>1: equivalence_in_bicategory V H \<a> \<i> src trg d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
       using e\<^sub>1.dual_equivalence by simp
     interpretation d\<^sub>0e\<^sub>0: two_equivalences_in_bicategory V H \<a> \<i> src trg
                            d\<^sub>0 e\<^sub>0 \<open>inv \<epsilon>\<^sub>0\<close> \<open>inv \<eta>\<^sub>0\<close> d\<^sub>1 e\<^sub>1 \<open>inv \<epsilon>\<^sub>1\<close> \<open>inv \<eta>\<^sub>1\<close>
       ..
 
     interpretation \<psi>: inverse_transformation hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
     proof -
       interpret \<psi>': natural_isomorphism hom'.comp hom'.comp hom'.map \<open>F o G\<close> d\<^sub>0e\<^sub>0.\<phi>
         using d\<^sub>0e\<^sub>0.natural_isomorphism_\<phi> e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_def by metis
       show "inverse_transformation hom'.comp hom'.comp hom'.map (F o G) d\<^sub>0e\<^sub>0.\<phi>"
         ..
     qed
 
     definition \<psi>
     where "\<psi> \<equiv> \<psi>.map"
 
     lemma \<psi>_ide_simp:
     assumes "\<guillemotleft>f': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
     shows "\<psi> f' = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
                     \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
     proof -
       have "hom'.ide f'"
         using assms hom'.ide_char hom'.arr_char by simp
       hence "\<psi>.map f' = hom'.inv (d\<^sub>0e\<^sub>0.\<phi> f')"
         using assms by simp
       also have "... = inv (d\<^sub>0e\<^sub>0.\<phi> f')"
         using hom'.inv_char \<open>hom'.ide f'\<close> by simp
       also have "... = inv (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
         using assms e\<^sub>0.antipar e\<^sub>1.antipar d\<^sub>0e\<^sub>0.\<phi>_eq d\<^sub>0e\<^sub>0.\<phi>_ide_simp [of f'] by simp
       also have "... = ((((inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]) \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)) \<cdot>
                          inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]) \<cdot>
                          inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
       proof -
         text \<open>There has to be a better way to do this.\<close>
         have 1: "\<And>A B C D E F.
                  \<lbrakk> iso A; iso B; iso C; iso D; iso E; iso F;
                    arr (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) \<rbrakk> \<Longrightarrow>
                  inv (((((A \<cdot> B) \<cdot> C) \<cdot> D) \<cdot> E) \<cdot> F) =
                  inv F \<cdot> inv E \<cdot> inv D \<cdot> inv C \<cdot> inv B \<cdot> inv A"
           using inv_comp isos_compose seqE by metis
         have "arr (d\<^sub>0e\<^sub>0.\<phi>\<^sub>0 f')"
           using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) d\<^sub>0e\<^sub>0.iso_\<phi>\<^sub>0 [of f'] iso_is_arr by simp
         moreover have "iso \<r>\<^sup>-\<^sup>1[f']"
           using assms iso_runit' by simp
         moreover have "iso \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]"
           using assms iso_lunit' by auto
         moreover have "iso (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0)"
           using assms e\<^sub>0.antipar(2) e\<^sub>1.antipar(2) in_hhom_def by simp
         moreover have "iso ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0])"
           using assms e\<^sub>0.antipar e\<^sub>1.antipar(1) e\<^sub>1.antipar(2) in_hhom_def iso_hcomp
           by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right hseqE
               ide_is_iso iso_assoc' seqE)
         moreover have "iso \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
           using assms e\<^sub>0.antipar e\<^sub>1.antipar by auto
         moreover have "iso (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
           using assms e\<^sub>0.antipar e\<^sub>1.antipar
           by (metis calculation(1) e\<^sub>0.ide_left e\<^sub>0.ide_right e\<^sub>1.ide_left e\<^sub>1.ide_right
               iso_hcomp ide_hcomp hseqE ideD(1) ide_is_iso in_hhomE iso_assoc'
               seqE hcomp_simps(1-2))
         ultimately show ?thesis
           using 1 [of "e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0]" "\<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0]"
                       "(e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]" "inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0" "\<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0]" "\<r>\<^sup>-\<^sup>1[f']"]
                 comp_assoc
           by (metis e\<^sub>0.antipar(2))
       qed
       also have "... = inv \<r>\<^sup>-\<^sup>1[f'] \<cdot> inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] \<cdot> inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) \<cdot>
                          inv ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>\<^sup>-\<^sup>1[f', e\<^sub>0, d\<^sub>0]) \<cdot> inv \<a>[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
                          inv (e\<^sub>1 \<star> \<a>\<^sup>-\<^sup>1[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
         using comp_assoc by simp
       also have "... = \<r>[f'] \<cdot> \<l>[f' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0) \<cdot> ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[f', e\<^sub>0, d\<^sub>0]) \<cdot>
                          \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (f' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot> (e\<^sub>1 \<star> \<a>[d\<^sub>1, f' \<star> e\<^sub>0, d\<^sub>0])"
       proof -
         have "inv \<r>\<^sup>-\<^sup>1[f'] = \<r>[f']"
           using assms inv_inv iso_runit by blast
         moreover have "inv \<l>\<^sup>-\<^sup>1[f' \<star> trg e\<^sub>0] = \<l>[f' \<star> trg e\<^sub>0]"
           using assms iso_lunit by auto
         moreover have "inv (inv \<epsilon>\<^sub>1 \<star> f' \<star> inv \<epsilon>\<^sub>0) = \<epsilon>\<^sub>1 \<star> f' \<star> \<epsilon>\<^sub>0"
         proof -
           have "src (inv \<epsilon>\<^sub>1) = trg f'"
             using assms(1) e\<^sub>1.antipar(2) by auto
           moreover have "src f' = trg (inv \<epsilon>\<^sub>0)"
             using assms(1) e\<^sub>0.antipar(2) by auto
           ultimately show ?thesis
             using assms(2) e\<^sub>0.counit_is_iso e\<^sub>1.counit_is_iso by simp
         qed
         ultimately show ?thesis
           using assms e\<^sub>0.antipar e\<^sub>1.antipar by auto
       qed
       finally show ?thesis
         using \<psi>_def by simp
     qed
 
     lemma \<psi>_components_are_iso:
     assumes "\<guillemotleft>f' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>" and "ide f'"
     shows "iso (\<psi> f')"
       using assms \<psi>_def \<psi>.components_are_iso hom'.ide_char hom'.arr_char hom'.iso_char
       by simp
 
     lemma \<psi>_eq:
     shows "\<psi> = (\<lambda>\<mu>'. if \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
                           \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
                             ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
                             (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
                      else null)"
     proof
       fix \<mu>'
       have "\<not> \<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow> \<psi>.map \<mu>' = null"
         using \<psi>.is_extensional hom'.arr_char hom'.null_char by simp
       moreover have "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> \<Longrightarrow>
                      \<psi>.map \<mu>' = \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
                                   ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot> \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
                                   (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])"
       proof -
         assume \<mu>': "\<guillemotleft>\<mu>': trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
         have "\<guillemotleft>\<psi>.map (dom \<mu>') : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
           using \<mu>' hom'.arr_char hom'.dom_closed by auto
         moreover have "seq \<mu>' (\<psi>.map (dom \<mu>'))"
         proof -
           have "hom'.seq \<mu>' (\<psi>.map (dom \<mu>'))"
             using \<mu>' \<psi>.preserves_cod hom'.arrI hom'.dom_simp hom'.cod_simp
             apply (intro hom'.seqI) by auto
           thus ?thesis
             using hom'.seq_char by blast
         qed
         ultimately show ?thesis
           using \<mu>' \<psi>.is_natural_1 [of \<mu>'] hom'.comp_char hom'.arr_char hom'.dom_closed
                 \<psi>_ide_simp [of "dom \<mu>'"] hom'.dom_simp hom'.cod_simp
           apply auto
           by (metis \<psi>_def hom'.inclusion ide_dom)
       qed
       ultimately show "\<psi> \<mu>' = (if \<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright> then
                                   \<mu>' \<cdot> \<r>[dom \<mu>'] \<cdot> \<l>[dom \<mu>' \<star> trg e\<^sub>0] \<cdot> (\<epsilon>\<^sub>1 \<star> dom \<mu>' \<star> \<epsilon>\<^sub>0) \<cdot>
                                     ((e\<^sub>1 \<star> d\<^sub>1) \<star> \<a>[dom \<mu>', e\<^sub>0, d\<^sub>0]) \<cdot>
                                     \<a>\<^sup>-\<^sup>1[e\<^sub>1, d\<^sub>1, (dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0] \<cdot>
                                     (e\<^sub>1 \<star> \<a>[d\<^sub>1, dom \<mu>' \<star> e\<^sub>0, d\<^sub>0])
                                else null)"
         unfolding \<psi>_def by argo
     qed
 
     lemma \<psi>_in_hom [intro]:
     assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
     shows "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
     and "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
     proof -
       have 0: "\<psi> \<mu>' = \<psi>.map \<mu>'"
         using \<psi>_def by auto
       hence 1: "hom'.arr (\<psi> \<mu>')"
         using assms hom'.arr_char \<psi>.preserves_reflects_arr by auto
       show "\<guillemotleft>\<psi> \<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
         using 1 hom'.arr_char by blast
       show "\<guillemotleft>\<psi> \<mu>' : e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0 \<Rightarrow> cod \<mu>'\<guillemotright>"
         using assms 0 1 \<psi>.preserves_hom hom'.in_hom_char hom'.arr_char
               e\<^sub>0.antipar e\<^sub>1.antipar \<psi>.preserves_dom \<psi>.preserves_cod hom'.dom_char
         apply (intro in_homI)
           apply auto[1]
       proof -
         show "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0"
         proof -
           have "hom'.dom (\<psi> \<mu>') = FG.map (hom'.dom \<mu>')"
             using assms 0 \<psi>.preserves_dom hom'.arr_char
             by (metis (no_types, lifting))
           thus ?thesis
             using assms 0 1 hom.arr_char hom'.arr_char hom'.dom_char G.preserves_arr
                   hom'.dom_closed
             by auto
         qed
         show "cod (\<psi> \<mu>') = cod \<mu>'"
         proof -
           have "hom'.cod (\<psi> \<mu>') = cod \<mu>'"
             using assms 0 \<psi>.preserves_cod hom'.arr_char hom'.cod_simp by auto
           thus ?thesis
             using assms 0 1 hom'.arr_char hom'.cod_char G.preserves_arr hom'.cod_closed by auto
         qed
       qed
     qed
 
     lemma \<psi>_simps [simp]:
     assumes "\<guillemotleft>\<mu>' : trg e\<^sub>0 \<rightarrow> trg e\<^sub>1\<guillemotright>"
     shows "arr (\<psi> \<mu>')"
     and "src (\<psi> \<mu>') = trg e\<^sub>0" and "trg (\<psi> \<mu>') = trg e\<^sub>1"
     and "dom (\<psi> \<mu>') = e\<^sub>1 \<star> (d\<^sub>1 \<star> dom \<mu>' \<star> e\<^sub>0) \<star> d\<^sub>0" and "cod (\<psi> \<mu>') = cod \<mu>'"
       using assms \<psi>_in_hom by auto
 
     interpretation equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>
     proof -
       interpret \<phi>: natural_isomorphism hom.comp hom.comp hom.map \<open>G o F\<close> \<phi>
         using \<phi>.natural_isomorphism_axioms \<phi>_def by simp
       interpret \<psi>: natural_isomorphism hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi>
         using \<psi>.natural_isomorphism_axioms \<psi>_def by simp
       show "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
         ..
     qed
 
     lemma induces_equivalence_of_hom_categories:
     shows "equivalence_of_categories hom'.comp hom.comp F G \<phi> \<psi>"
       ..
 
     lemma equivalence_functor_F:
     shows "equivalence_functor hom.comp hom'.comp F"
     proof -
       interpret \<phi>': inverse_transformation hom.comp hom.comp hom.map \<open>G o F\<close> \<phi> ..
       interpret \<psi>': inverse_transformation hom'.comp hom'.comp \<open>F o G\<close> hom'.map \<psi> ..
       interpret E: equivalence_of_categories hom.comp hom'.comp G F \<psi>'.map \<phi>'.map ..
       show ?thesis
         using E.equivalence_functor_axioms by simp
     qed
 
     lemma equivalence_functor_G:
     shows "equivalence_functor hom'.comp hom.comp G"
       using equivalence_functor_axioms by simp
 
   end
 
   context bicategory
   begin
 
     text \<open>
       We now use the just-established equivalence of hom-categories to prove some cancellation
       laws for equivalence maps.  It is relatively straightforward to prove these results
       directly, without using the just-established equivalence, but the proofs are somewhat
       longer that way.
     \<close>
 
     lemma equivalence_cancel_left:
     assumes "equivalence_map e"
     and "par \<mu> \<mu>'" and "src e = trg \<mu>" and "e \<star> \<mu> = e \<star> \<mu>'"
     shows "\<mu> = \<mu>'"
     proof -
       obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
         using assms equivalence_map_def by auto
       interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
         using d\<eta>\<epsilon> by simp
       interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
                      \<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close>
         using assms iso_unit obj_src
         by unfold_locales simp_all
       interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
                      \<open>src \<mu>\<close> \<open>src \<mu>\<close> \<open>inv \<i>[src \<mu>]\<close> \<open>\<i>[src \<mu>]\<close> e d \<eta> \<epsilon>
         ..
       interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src (src \<mu>)) (src e)\<close>
         using hhom_is_subcategory by blast
       interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg (src \<mu>)) (trg e)\<close>
         using hhom_is_subcategory by blast
       interpret F: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. e \<star> \<mu>' \<star> src \<mu>\<close>
         using equivalence_functor_F by simp
       have "F \<mu> = F \<mu>'"
         using assms hom.arr_char
         apply simp
         by (metis e.ide_left hcomp_reassoc(2) i.ide_right ideD(1) src_dom trg_dom trg_src)
       moreover have "hom.par \<mu> \<mu>'"
         using assms hom.arr_char hom.dom_char hom.cod_char
         by (metis (no_types, lifting) in_hhomI src_dom src_src trg_dom)
       ultimately show "\<mu> = \<mu>'"
         using F.is_faithful by blast
     qed
 
     lemma equivalence_cancel_right:
     assumes "equivalence_map e"
     and "par \<mu> \<mu>'" and "src \<mu> = trg e" and "\<mu> \<star> e = \<mu>' \<star> e"
     shows "\<mu> = \<mu>'"
     proof -
       obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
         using assms equivalence_map_def by auto
       interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
         using d\<eta>\<epsilon> by simp
       interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
                      \<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
         using assms iso_unit obj_src
         by unfold_locales simp_all
       interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
                       e d \<eta> \<epsilon> \<open>trg \<mu>\<close> \<open>trg \<mu>\<close> \<open>inv \<i>[trg \<mu>]\<close> \<open>\<i>[trg \<mu>]\<close>
         ..
       interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg e) (trg (trg \<mu>))\<close>
         using hhom_is_subcategory by blast
       interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src e) (src (trg \<mu>))\<close>
         using hhom_is_subcategory by blast
       interpret G: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. trg \<mu> \<star> \<mu>' \<star> e\<close>
         using equivalence_functor_G by simp
       have "G \<mu> = G \<mu>'"
         using assms hom.arr_char by simp
       moreover have "hom.par \<mu> \<mu>'"
         using assms hom.arr_char hom.dom_char hom.cod_char
         by (metis (no_types, lifting) in_hhomI src_dom trg_dom trg_trg)
       ultimately show "\<mu> = \<mu>'"
         using G.is_faithful by blast
     qed
 
     lemma equivalence_isomorphic_cancel_left:
     assumes "equivalence_map e" and "ide f" and "ide f'"
     and "src f = src f'" and "src e = trg f" and "e \<star> f \<cong> e \<star> f'"
     shows "f \<cong> f'"
     proof -
       have ef': "src e = trg f'"
         using assms R.as_nat_iso.components_are_iso iso_is_arr isomorphic_implies_hpar(2)
         by blast
       obtain d \<eta> \<epsilon> where e: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
         using assms equivalence_map_def by auto
       interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
         using e by simp
       interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
                      \<open>src f\<close> \<open>src f\<close> \<open>inv \<i>[src f]\<close> \<open>\<i>[src f]\<close>
         using assms iso_unit obj_src
         by unfold_locales auto
       interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
                      \<open>src f\<close> \<open>src f\<close> \<open>inv \<i>[src f]\<close> \<open>\<i>[src f]\<close> e d \<eta> \<epsilon>
         ..
       interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src (src f)) (src e)\<close>
         using hhom_is_subcategory by blast
       interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg (src f)) (trg e)\<close>
         using hhom_is_subcategory by blast
       interpret F: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. e \<star> \<mu>' \<star> src f\<close>
         using equivalence_functor_F by simp
       have 1: "F f \<cong> F f'"
       proof -
         have "F f \<cong> (e \<star> f) \<star> src f"
           using assms hcomp_assoc_isomorphic equivalence_map_is_ide isomorphic_symmetric
           by auto
         also have "... \<cong> (e \<star> f') \<star> src f'"
           using assms ef' by (simp add: hcomp_isomorphic_ide)
         also have "... \<cong> F f'"
           using assms ef' hcomp_assoc_isomorphic equivalence_map_is_ide by auto
         finally show ?thesis by blast
       qed
       show "f \<cong> f'"
       proof -
         obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F f \<Rightarrow> F f'\<guillemotright> \<and> iso \<psi>"
           using 1 isomorphic_def by auto
         have 2: "hom'.iso \<psi>"
           using assms \<psi> hom'.iso_char hom'.arr_char vconn_implies_hpar(1,2)
           by auto
         have 3: "hom'.in_hom \<psi> (F f) (F f')"
           using assms 2 \<psi> ef' hom'.in_hom_char hom'.arr_char
           by (metis F.preserves_reflects_arr hom'.iso_is_arr hom.arr_char i.antipar(1)
               ideD(1) ide_in_hom(1) trg_src)
         obtain \<phi> where \<phi>: "hom.in_hom \<phi> f f' \<and> F \<phi> = \<psi>"
           using assms 3 \<psi> F.is_full F.preserves_reflects_arr hom'.in_hom_char hom.ide_char
           by fastforce
         have "hom.iso \<phi>"
           using 2 \<phi> F.reflects_iso by auto
         thus ?thesis
           using \<phi> isomorphic_def hom.in_hom_char hom.arr_char hom.iso_char by auto
       qed
     qed
 
     lemma equivalence_isomorphic_cancel_right:
     assumes "equivalence_map e" and "ide f" and "ide f'"
     and "trg f = trg f'" and "src f = trg e" and "f \<star> e \<cong> f' \<star> e"
     shows "f \<cong> f'"
     proof -
       have f'e: "src f' = trg e"
         using assms R.as_nat_iso.components_are_iso iso_is_arr isomorphic_implies_hpar(2)
         by blast
       obtain d \<eta> \<epsilon> where d\<eta>\<epsilon>: "equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>"
         using assms equivalence_map_def by auto
       interpret e: equivalence_in_bicategory V H \<a> \<i> src trg e d \<eta> \<epsilon>
         using d\<eta>\<epsilon> by simp
       interpret i: equivalence_in_bicategory V H \<a> \<i> src trg
                      \<open>trg f\<close> \<open>trg f\<close> \<open>inv \<i>[trg f]\<close> \<open>\<i>[trg f]\<close>
         using assms iso_unit obj_src
         by unfold_locales auto
       interpret two_equivalences_in_bicategory V H \<a> \<i> src trg
                       e d \<eta> \<epsilon> \<open>trg f\<close> \<open>trg f\<close> \<open>inv \<i>[trg f]\<close> \<open>\<i>[trg f]\<close>
         ..
       interpret hom: subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (trg e) (trg (trg f))\<close>
         using hhom_is_subcategory by blast
       interpret hom': subcategory V \<open>\<lambda>\<mu>'. in_hhom \<mu>' (src e) (src (trg f))\<close>
         using hhom_is_subcategory by blast
       interpret G: equivalence_functor hom.comp hom'.comp \<open>\<lambda>\<mu>'. trg f \<star> \<mu>' \<star> e\<close>
         using equivalence_functor_G by simp
       have 1: "G f \<cong> G f'"
         using assms hcomp_isomorphic_ide hcomp_ide_isomorphic by simp
       show "f \<cong> f'"
       proof -
         obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : G f \<Rightarrow> G f'\<guillemotright> \<and> iso \<psi>"
           using 1 isomorphic_def by auto
         have 2: "hom'.iso \<psi>"
           using assms \<psi> hom'.iso_char hom'.arr_char vconn_implies_hpar(1-2) by auto
         have 3: "hom'.in_hom \<psi> (G f) (G f')"
           using assms 2 \<psi> f'e hom'.in_hom_char hom'.arr_char
           by (metis G.preserves_arr hom'.iso_is_arr hom.ideI hom.ide_char ideD(1)
               ide_in_hom(1) trg_trg)
         obtain \<phi> where \<phi>: "hom.in_hom \<phi> f f' \<and> G \<phi> = \<psi>"
           using assms 3 \<psi> G.is_full G.preserves_reflects_arr hom'.in_hom_char hom.ide_char
           by fastforce
         have "hom.iso \<phi>"
           using 2 \<phi> G.reflects_iso by auto
         thus ?thesis
           using \<phi> isomorphic_def hom.in_hom_char hom.arr_char hom.iso_char by auto
       qed
     qed
 
   end
 
 end
 
diff --git a/thys/Bicategory/Modification.thy b/thys/Bicategory/Modification.thy
--- a/thys/Bicategory/Modification.thy
+++ b/thys/Bicategory/Modification.thy
@@ -1,1299 +1,1299 @@
 (*  Title:       Modification
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Modifications"
 
 text \<open>
   Modifications are morphisms of pseudonatural transformations.
   In this section, we give a definition of ``modification'', and we prove that
   the mappings \<open>\<eta>\<close> and \<open>\<epsilon>\<close>, which were chosen in the course of showing that a
   pseudonatural equivalence \<open>\<tau>\<close> has a converse pseudonatural equivalence \<open>\<tau>'\<close>,
   are invertible modifications that relate the composites \<open>\<tau>'\<tau>\<close> and \<open>\<tau>\<tau>'\<close>
   to the identity pseudonatural transformations on \<open>F\<close> and \<open>G\<close>.
   This means that \<open>\<tau>\<close> and \<open>\<tau>'\<close> are quasi-inverses in a suitable bicategory
   of pseudofunctors, pseudonatural transformations, and modifications, though
   we do not go so far as to give a formal construction of such a bicategory.
 \<close>
 
 theory Modification
 imports PseudonaturalTransformation
 begin
 
   locale modification =  (* 12 sec *)
     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 +
     \<tau>: pseudonatural_transformation
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<tau>\<^sub>0 \<tau>\<^sub>1 +
     \<tau>': pseudonatural_transformation
           V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<tau>\<^sub>0' \<tau>\<^sub>1'
   for V\<^sub>C :: "'c comp"                   (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                   (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>F :: "'c * 'c \<Rightarrow> 'd"
   and G :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>G :: "'c * 'c \<Rightarrow> 'd"
   and \<tau>\<^sub>0 :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>1 :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>0' :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>1' :: "'c \<Rightarrow> 'd"
   and \<Gamma> :: "'c \<Rightarrow> 'd" +
   assumes \<Gamma>_in_hom: "C.obj a \<Longrightarrow> \<guillemotleft>\<Gamma> a : \<tau>\<^sub>0 a \<Rightarrow>\<^sub>D \<tau>\<^sub>0' a\<guillemotright>"
   and naturality: "\<lbrakk> \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>; C.ide f \<rbrakk> \<Longrightarrow> \<tau>\<^sub>1' f \<cdot>\<^sub>D (G f \<star>\<^sub>D \<Gamma> a) = (\<Gamma> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<tau>\<^sub>1 f"
 
   locale invertible_modification =  (* 13 sec *)
     modification +
     assumes components_are_iso: "C.obj a \<Longrightarrow> D.iso (\<Gamma> a)"
 
   locale identity_modification =  (* 12 sec *)
     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 +
     \<tau>: pseudonatural_transformation
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<tau>\<^sub>0 \<tau>\<^sub>1
   for V\<^sub>C :: "'c comp"                   (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                   (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>F :: "'c * 'c \<Rightarrow> 'd"
   and G :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>G :: "'c * 'c \<Rightarrow> 'd"
   and \<tau>\<^sub>0 :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>1 :: "'c \<Rightarrow> 'd"
   begin
 
     abbreviation map
     where "map \<equiv> \<tau>\<^sub>0"
 
     sublocale invertible_modification
                 V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<tau>\<^sub>0 \<tau>\<^sub>1 \<tau>\<^sub>0 \<tau>\<^sub>1 map
       using D.comp_arr_dom D.comp_cod_arr
       by unfold_locales auto
 
   end
 
   locale composite_modification =  (* 13 sec *)
     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 +
     \<rho>: pseudonatural_transformation
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<rho>\<^sub>0 \<rho>\<^sub>1 +
     \<sigma>: pseudonatural_transformation
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<sigma>\<^sub>0 \<sigma>\<^sub>1 +
     \<tau>: pseudonatural_transformation
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<tau>\<^sub>0 \<tau>\<^sub>1 +
     \<Gamma>: modification
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<rho>\<^sub>0 \<rho>\<^sub>1 \<sigma>\<^sub>0 \<sigma>\<^sub>1 \<Gamma> +
     \<Delta>: modification
          V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<sigma>\<^sub>0 \<sigma>\<^sub>1 \<tau>\<^sub>0 \<tau>\<^sub>1 \<Delta>
   for V\<^sub>C :: "'c comp"                   (infixr "\<cdot>\<^sub>C" 55)
   and H\<^sub>C :: "'c comp"                   (infixr "\<star>\<^sub>C" 53)
   and \<a>\<^sub>C :: "'c \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> 'c"       ("\<a>\<^sub>C[_, _, _]")
   and \<i>\<^sub>C :: "'c \<Rightarrow> 'c"                   ("\<i>\<^sub>C[_]")
   and src\<^sub>C :: "'c \<Rightarrow> 'c"
   and trg\<^sub>C :: "'c \<Rightarrow> 'c"
   and V\<^sub>D :: "'d comp"                   (infixr "\<cdot>\<^sub>D" 55)
   and H\<^sub>D :: "'d comp"                   (infixr "\<star>\<^sub>D" 53)
   and \<a>\<^sub>D :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd"       ("\<a>\<^sub>D[_, _, _]")
   and \<i>\<^sub>D :: "'d \<Rightarrow> 'd"                   ("\<i>\<^sub>D[_]")
   and src\<^sub>D :: "'d \<Rightarrow> 'd"
   and trg\<^sub>D :: "'d \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>F :: "'c * 'c \<Rightarrow> 'd"
   and G :: "'c \<Rightarrow> 'd"
   and \<Phi>\<^sub>G :: "'c * 'c \<Rightarrow> 'd"
   and \<rho>\<^sub>0 :: "'c \<Rightarrow> 'd"
   and \<rho>\<^sub>1 :: "'c \<Rightarrow> 'd"
   and \<sigma>\<^sub>0 :: "'c \<Rightarrow> 'd"
   and \<sigma>\<^sub>1 :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>0 :: "'c \<Rightarrow> 'd"
   and \<tau>\<^sub>1 :: "'c \<Rightarrow> 'd"
   and \<Gamma> :: "'c \<Rightarrow> 'd"
   and \<Delta> :: "'c \<Rightarrow> 'd"
   begin
 
     abbreviation map
     where "map a \<equiv> \<Delta> a \<cdot>\<^sub>D \<Gamma> a"
 
     sublocale modification
                 V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G \<rho>\<^sub>0 \<rho>\<^sub>1 \<tau>\<^sub>0 \<tau>\<^sub>1 map
       using \<Delta>.\<Gamma>_in_hom \<Gamma>.\<Gamma>_in_hom \<Delta>.naturality \<Gamma>.naturality
       apply unfold_locales
        apply auto[1]
     proof -
       fix f a b
       assume f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>" and ide_f: "C.ide f"
       have "\<tau>\<^sub>1 f \<cdot>\<^sub>D (G f \<star>\<^sub>D map a) = (\<tau>\<^sub>1 f \<cdot>\<^sub>D (G f \<star>\<^sub>D \<Delta> a)) \<cdot>\<^sub>D (G f \<star>\<^sub>D \<Gamma> a)"
       proof -
         have "D.seq (\<Delta> a) (\<Gamma> a)"
           using f \<Delta>.\<Gamma>_in_hom \<Gamma>.\<Gamma>_in_hom by blast
         thus ?thesis
           using f ide_f D.whisker_left [of "G f" "\<Delta> a" "\<Gamma> a"] D.comp_assoc
           by simp
       qed
       also have "... = (\<Delta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<sigma>\<^sub>1 f \<cdot>\<^sub>D (G f \<star>\<^sub>D \<Gamma> a)"
         using f ide_f \<Delta>.naturality [of f a b] D.comp_assoc by simp
       also have "... = ((\<Delta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<Gamma> b \<star>\<^sub>D F f)) \<cdot>\<^sub>D \<rho>\<^sub>1 f"
         using f ide_f \<Gamma>.naturality [of f a b] D.comp_assoc by simp
       also have "...  = (map b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<rho>\<^sub>1 f"
       proof -
         have "D.seq (\<Delta> b) (\<Gamma> b)"
           using f \<Delta>.\<Gamma>_in_hom \<Gamma>.\<Gamma>_in_hom by blast
         thus ?thesis
           using f ide_f D.whisker_right [of "F f" "\<Delta> b" "\<Gamma> b"] by simp
       qed
       finally show "\<tau>\<^sub>1 f \<cdot>\<^sub>D (G f \<star>\<^sub>D map a) = (map b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<rho>\<^sub>1 f" by simp
     qed
 
   end
 
   context converse_pseudonatural_equivalence
   begin
 
     interpretation EV: self_evaluation_map V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D ..
     notation EV.eval ("\<lbrace>_\<rbrace>")
 
     interpretation \<iota>\<^sub>F: identity_pseudonatural_transformation
                         V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F
       ..
     interpretation \<iota>\<^sub>G: identity_pseudonatural_transformation
                         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
       ..
 
     interpretation \<tau>'\<tau>: composite_pseudonatural_equivalence
                           V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F G \<Phi>\<^sub>G F \<Phi>\<^sub>F
                           \<tau>\<^sub>0 \<tau>\<^sub>1 map\<^sub>0 map\<^sub>1
       ..
     interpretation \<tau>\<tau>': composite_pseudonatural_equivalence
                           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 F \<Phi>\<^sub>F G \<Phi>\<^sub>G
                           map\<^sub>0 map\<^sub>1 \<tau>\<^sub>0 \<tau>\<^sub>1
       ..
 
     interpretation \<eta>: invertible_modification
                         V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F F \<Phi>\<^sub>F
                         \<iota>\<^sub>F.map\<^sub>0 \<iota>\<^sub>F.map\<^sub>1 \<tau>'\<tau>.map\<^sub>0 \<tau>'\<tau>.map\<^sub>1 \<eta>
     proof
       show "\<And>a. C.obj a \<Longrightarrow> \<guillemotleft>\<eta> a : F.map\<^sub>0 a \<Rightarrow>\<^sub>D \<tau>'\<tau>.map\<^sub>0 a\<guillemotright>"
         using unit_in_hom \<tau>'\<tau>.map\<^sub>0_def by simp
       show "\<And>a. C.obj a \<Longrightarrow> D.iso (\<eta> a)"
         by simp
       show "\<And>f a b. \<lbrakk> \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>; C.ide f\<rbrakk>
                        \<Longrightarrow> \<tau>'\<tau>.map\<^sub>1 f \<cdot>\<^sub>D (F f \<star>\<^sub>D \<eta> a) = (\<eta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
       proof -
         fix f a b
         assume f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>" and ide_f: "C.ide f"
         have a: "C.obj a" and b: "C.obj b"
           using f by auto
         have "\<tau>'\<tau>.map\<^sub>1 f \<cdot>\<^sub>D (F f \<star>\<^sub>D \<eta> a) =
                 (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                 (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                 \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                  (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                  (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                  \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                  ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                  (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                  ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                  (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a)
                     \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 \<a>\<^sub>D\<^sup>-\<^sup>1[F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                 (F f \<star>\<^sub>D \<eta> a)"
           unfolding \<tau>'\<tau>.map\<^sub>1_def map\<^sub>1_def
           using a b f D.comp_assoc by auto
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          (F f \<star>\<^sub>D \<eta> a)"
         proof -
           have "(\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a)
                    \<star>\<^sub>D \<tau>\<^sub>0 a
                   = ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     (((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     ((\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a)"
           proof -
             have "D.arr ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a))"
               using a b f ide_f \<tau>.iso_map\<^sub>1_ide
-              by (intro D.seqI) auto
+              by (metis (no_types, lifting) C.in_hhomE map\<^sub>1_def map\<^sub>1_simps(1))
             thus ?thesis
               using a b f D.whisker_right [of "\<tau>\<^sub>0 a"] by fastforce
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[F\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (F f \<star>\<^sub>D \<eta> a)"
         proof -
           have "((\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] =
                 \<a>\<^sub>D\<^sup>-\<^sup>1[F\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a)"
             using a b f ide_f D.assoc'_naturality [of "\<l>\<^sub>D\<^sup>-\<^sup>1[F f]" "\<tau>\<^sub>0' a" "\<tau>\<^sub>0 a"] by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[F\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<eta> a) = \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<eta> a"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "\<l>\<^sub>D\<^sup>-\<^sup>1[F f]" "F f" "\<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a" "\<eta> a"]
             by simp
           also have "... = ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "F\<^sub>0 b \<star>\<^sub>D F f" "\<l>\<^sub>D\<^sup>-\<^sup>1[F f]" "\<eta> a" "F\<^sub>0 a"]
             by auto
           finally have "(\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<eta> a) =
                         ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a)) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] =
                 \<a>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a)"
             using a b f ide_f D.assoc'_naturality [of "\<eta> b \<star>\<^sub>D F f" "\<tau>\<^sub>0' a" "\<tau>\<^sub>0 a"] by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a)
                   = (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "\<eta> b \<star>\<^sub>D F f" "F\<^sub>0 b \<star>\<^sub>D F f" "\<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a" "\<eta> a"]
             by auto
           also have "... = (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a)"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f" "\<eta> b \<star>\<^sub>D F f" "\<eta> a" "F\<^sub>0 a"]
             by auto
           finally have "((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D ((F\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) =
                         (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                   ((\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) =
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a"
             using a b f ide_f D.whisker_right \<tau>.iso_map\<^sub>1_ide by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a)) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                   \<a>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] =
                 \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a)"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
                   D.assoc'_naturality
                     [of "(\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]" "\<tau>\<^sub>0' a" "\<tau>\<^sub>0 a"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                   (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) =
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]) \<cdot>\<^sub>D ((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D
                   (\<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D \<eta> a"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
                   D.interchange [of "(\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]"
                                     "(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f" "\<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a" "\<eta> a"]
             by auto
           also have "... = (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<eta> a"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_arr_dom D.comp_cod_arr D.comp_assoc
             by auto
           also have "... = (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                            (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D
                            \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]
                              \<star>\<^sub>D \<eta> a \<cdot>\<^sub>D F\<^sub>0 a"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_arr_dom D.comp_cod_arr by auto
           also have "... = ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                              ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a)"
           proof -
             have "D.seq (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f])"
               using a b f ide_f \<tau>.iso_map\<^sub>1_ide
               by (intro D.seqI D.hseqI') auto
             thus ?thesis
               using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_arr_dom D.comp_cod_arr
                     D.interchange [of "(\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a)"
                                       "(\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]"
                                       "\<eta> a" "F\<^sub>0 a"]
               by simp
           qed
           finally have "((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                           (((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f) \<star>\<^sub>D \<eta> a) =
                         ((\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                           ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a
                   = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                     ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                     (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a)"
           proof -
             have "(\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a
                     = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                       (((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                       (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a)"
               using a b f ide_f D.hcomp_reassoc D.whisker_right [of "\<tau>\<^sub>0 a"] by auto
             also have "... = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                              ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                              \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a)"
               using a b f ide_f D.hcomp_reassoc(1) [of "\<tau>\<^sub>0' b \<star>\<^sub>D G f" "\<epsilon> a" "\<tau>\<^sub>0 a"]
               by auto
             finally show ?thesis by blast
           qed
           moreover have "(\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a
                            = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                              ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                              \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)"
           proof -
             have "(\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a =
                   \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D
                     (\<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D \<eta> a \<cdot>\<^sub>D F\<^sub>0 a"
               using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                     D.hcomp_reassoc(2) [of "\<tau>\<^sub>0' b" "G f" "\<tau>\<^sub>0 a"]
               by auto
             also have "... = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                              (((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a) \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)"
               using a b f ide_f D.inv_inv D.iso_inv_iso D.interchange by auto
             also have "... = (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                              ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a) \<cdot>\<^sub>D
                              \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                              (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)"
               using a b f ide_f D.hcomp_reassoc(1) [of "\<tau>\<^sub>0' b \<star>\<^sub>D G f" "\<tau>\<^sub>0 a" "\<eta> a"] by auto
             finally show ?thesis by blast
           qed
           ultimately show ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          (((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "\<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a] =
                 (\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]"
           proof -
             have "\<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                     (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     ((\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D (G f \<star>\<^sub>D \<tau>\<^sub>0 a), \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                     (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a \<star>\<^sub>D \<tau>\<^sub>0 a]
                       = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                         ((\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[ \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                         (\<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                         \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>G f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>), \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                         (\<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                         \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char
               by auto
             also have "... = \<lbrace>(\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f by (intro EV.eval_eqI, auto)
             also have "... = (\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char
               by auto
             finally show ?thesis by blast
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           interpret adjoint_equivalence_in_bicategory
                       V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>\<tau>\<^sub>0 a\<close> \<open>\<tau>\<^sub>0' a\<close> \<open>\<eta> a\<close> \<open>\<epsilon> a\<close>
             using a chosen_adjoint_equivalence by simp
           have "((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a)
                   = (\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D (\<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                     \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a)"
             using a b f ide_f D.whisker_left by auto
           also have "... = (\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 a]"
             using triangle_left by simp
           finally have "((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<epsilon> a \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                         ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a, \<tau>\<^sub>0' a, \<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                         ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<eta> a)
                           = (\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 a]"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          (\<r>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a)) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                 (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                 \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                 (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)
                   = \<r>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a]"
           proof -
             have "\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                   (\<a>\<^sub>D[\<tau>\<^sub>0' b, G f, G\<^sub>0 a] \<star>\<^sub>D \<tau>\<^sub>0 a) \<cdot>\<^sub>D
                   (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D G f, G\<^sub>0 a, \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0' b \<star>\<^sub>D G f) \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 a] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 a]) \<cdot>\<^sub>D
                   \<a>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f, \<tau>\<^sub>0 a, F\<^sub>0 a]) \<cdot>\<^sub>D
                   (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, G f, \<tau>\<^sub>0 a] \<star>\<^sub>D F\<^sub>0 a)
                     = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                       ((\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<r>\<^bold>[\<^bold>\<langle>G f\<^bold>\<rangle>\<^bold>]) \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                       (\<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>G\<^sub>0 a\<^bold>\<rangle>\<^sub>0\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>) \<^bold>\<cdot>
                       (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>G\<^sub>0 a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                       ((\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                       \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>, \<^bold>\<langle>F\<^sub>0 a\<^bold>\<rangle>\<^sub>0\<^bold>]) \<^bold>\<cdot>
                       (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>G f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>F\<^sub>0 a\<^bold>\<rangle>\<^sub>0)\<rbrace>"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char D.\<ll>_ide_simp D.\<rr>_ide_simp
               by auto
             also have "... = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>G f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f by (intro EV.eval_eqI, auto)
             also have "... = \<r>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a]"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char D.\<ll>_ide_simp D.\<rr>_ide_simp
               by auto
             finally show ?thesis by blast
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)))) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D \<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f] \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "\<r>\<^sub>D[\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a] \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D F\<^sub>0 a)
                   = (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D
                     \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                     \<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f]"
             using a b f ide_f D.comp_assoc \<tau>.iso_map\<^sub>1_ide
                   D.runit_naturality [of "(\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = ((\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D
                           \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]) \<cdot>\<^sub>D
                           \<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f]) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D ((\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>1 f) \<cdot>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)))
                   = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]"
             using a b f ide_f D.comp_arr_inv' D.comp_arr_dom \<tau>.iso_map\<^sub>1_ide
                   D.whisker_left [of "\<tau>\<^sub>0' b" "\<tau>\<^sub>1 f" "D.inv (\<tau>\<^sub>1 f)"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f] \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a)) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "(\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f]) \<cdot>\<^sub>D \<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f]
                   = \<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f]"
             using a b f ide_f D.comp_inv_arr' D.comp_cod_arr by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<eta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<r>\<^sub>D[F\<^sub>0 b \<star>\<^sub>D F f] \<cdot>\<^sub>D (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D F\<^sub>0 a)"
         proof -
           have "\<r>\<^sub>D[(\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f] \<cdot>\<^sub>D ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D F\<^sub>0 a)
                   = (\<eta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<r>\<^sub>D[F\<^sub>0 b \<star>\<^sub>D F f]"
             using a b f ide_f D.runit_naturality [of "\<eta> b \<star>\<^sub>D F f"] by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<eta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D  \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
           using a b f ide_f D.runit_naturality [of "\<l>\<^sub>D\<^sup>-\<^sup>1[F f]"] by auto
         finally show "\<tau>'\<tau>.map\<^sub>1 f \<cdot>\<^sub>D (F f \<star>\<^sub>D \<eta> a) = (\<eta> b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<cdot>\<^sub>D \<r>\<^sub>D[F f]"
           by blast
       qed
     qed
 
     lemma unit_is_invertible_modification:
     shows "invertible_modification
                      V\<^sub>C H\<^sub>C \<a>\<^sub>C \<i>\<^sub>C src\<^sub>C trg\<^sub>C V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D F \<Phi>\<^sub>F F \<Phi>\<^sub>F
                      \<iota>\<^sub>F.map\<^sub>0 \<iota>\<^sub>F.map\<^sub>1 \<tau>'\<tau>.map\<^sub>0 \<tau>'\<tau>.map\<^sub>1 \<eta>"
       ..
 
     interpretation \<epsilon>: invertible_modification
                         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 G \<Phi>\<^sub>G
                         \<tau>\<tau>'.map\<^sub>0 \<tau>\<tau>'.map\<^sub>1 \<iota>\<^sub>G.map\<^sub>0 \<iota>\<^sub>G.map\<^sub>1 \<epsilon>
     proof
       show "\<And>a. C.obj a \<Longrightarrow> \<guillemotleft>\<epsilon> a : \<tau>\<tau>'.map\<^sub>0 a \<Rightarrow>\<^sub>D G\<^sub>0 a\<guillemotright>"
         using counit_in_hom \<tau>\<tau>'.map\<^sub>0_def by simp
       show "\<And>a. C.obj a \<Longrightarrow> D.iso (\<epsilon> a)"
         by simp
       show "\<And>f a b. \<lbrakk>\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>; C.ide f\<rbrakk>
                        \<Longrightarrow> (\<l>\<^sub>D\<^sup>-\<^sup>1[G f] \<cdot>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (G f \<star>\<^sub>D \<epsilon> a) = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D \<tau>\<tau>'.map\<^sub>1 f"
       proof -
         fix f a b
         assume f: "\<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>" and ide_f: "C.ide f"
         have a: "C.obj a" and b: "C.obj b"
           using f by auto
         have "(\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D \<tau>\<tau>'.map\<^sub>1 f
                 = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                   \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f] \<cdot>\<^sub>D
                   (\<tau>\<^sub>0 b \<star>\<^sub>D
                      (\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                      (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                      (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                      \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                      ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                      (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                      ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                      (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                   \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                   (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
           unfolding \<tau>\<tau>'.map\<^sub>1_def map\<^sub>1_def
           using a b f D.comp_assoc by auto
         also have "... = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "\<tau>\<^sub>0 b \<star>\<^sub>D
                   (\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                   (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                   (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                   \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a)
                   = (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                     (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a)"
           proof -
             have "D.arr ((\<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          ((\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a))"
               using a b f ide_f \<tau>.iso_map\<^sub>1_ide
               by (intro D.seqI) auto
             thus ?thesis
               using a b f D.whisker_left [of "\<tau>\<^sub>0 b"] by fastforce
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0 b \<star>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a)
                   = \<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                            ((\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f D.whisker_left [of "\<tau>\<^sub>0 b"] \<tau>.iso_map\<^sub>1_ide by auto
           also have "... = \<tau>\<^sub>0 b \<star>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                                   \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
                   D.assoc_naturality [of "\<tau>\<^sub>0' b" "D.inv (\<tau>\<^sub>1 f)" "\<tau>\<^sub>0' a"]
             by auto
           also have "... = (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                            (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a])"
             using a b f ide_f D.whisker_left [of "\<tau>\<^sub>0 b"] \<tau>.iso_map\<^sub>1_ide by auto
           finally have "(\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                         (\<tau>\<^sub>0 b \<star>\<^sub>D (\<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f)) \<star>\<^sub>D \<tau>\<^sub>0' a)
                           = (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                             (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a])"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f])) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)
                   = \<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f D.whisker_left \<tau>.iso_map\<^sub>1_ide by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D G\<^sub>0 a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a)) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f] \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<r>\<^sub>D[G f])
                   = ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D G\<^sub>0 a]"
             using a b f ide_f D.assoc'_naturality [of "\<tau>\<^sub>0 b" "\<tau>\<^sub>0' b" "\<r>\<^sub>D[G f]"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D G\<^sub>0 a] \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a)
                   = ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a]"
             using a b f ide_f D.assoc'_naturality [of "\<tau>\<^sub>0 b" "\<tau>\<^sub>0' b" "G f \<star>\<^sub>D \<epsilon> a"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = ((\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D 
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f])) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                 (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))
                   = ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                     \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a]"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
                   D.assoc'_naturality
                     [of "\<tau>\<^sub>0 b" "\<tau>\<^sub>0' b" "\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          ((\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D G\<^sub>0 a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a)) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f]) = \<epsilon> b \<star>\<^sub>D \<r>\<^sub>D[G f]"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "\<epsilon> b" "\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b" "G f" "\<r>\<^sub>D[G f]"]
             by simp
           also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D G\<^sub>0 a)"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "G\<^sub>0 b" "\<epsilon> b" "\<r>\<^sub>D[G f]" "G f \<star>\<^sub>D G\<^sub>0 a"]
             by auto
           finally have "(\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<r>\<^sub>D[G f]) =
                         (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D G\<^sub>0 a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          ((\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D G\<^sub>0 a) \<cdot>\<^sub>D ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a)
                   = \<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "\<epsilon> b" "\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b" "G f \<star>\<^sub>D G\<^sub>0 a" "G f \<star>\<^sub>D \<epsilon> a"]
             by auto
           also have "... = (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D (\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                   D.interchange [of "G\<^sub>0 b" "\<epsilon> b" "G f \<star>\<^sub>D \<epsilon> a" "G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a"]
             by auto
           finally have "(\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D G\<^sub>0 a) \<cdot>\<^sub>D ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) =
                         (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D (\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (\<epsilon> b \<star>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have 1: "D.seq (G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a)
                          (\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
             by (intro D.seqI D.hseqI') auto
           have 2: "D.seq (\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
             by (intro D.seqI D.hseqI') auto
           have "(\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) =
                 \<epsilon> b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using 1 a b f ide_f D.comp_arr_dom D.comp_cod_arr \<tau>.iso_map\<^sub>1_ide
                   D.interchange [of "\<epsilon> b" "\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b" "G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a"
                                     "\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"]
             by auto
           also have "... = G\<^sub>0 b \<cdot>\<^sub>D \<epsilon> b \<star>\<^sub>D
                              (\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                              ((\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_arr_dom D.comp_cod_arr by auto
           also have "... = (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                            (\<epsilon> b \<star>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using 2 a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_assoc
                   D.interchange [of "G\<^sub>0 b" "\<epsilon> b"
                                     "\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
                                     "(\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a"]
             by simp
           finally have "(\<epsilon> b \<star>\<^sub>D G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                         ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a))
                           = (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                             (\<epsilon> b \<star>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             by blast
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          ((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "\<epsilon> b \<star>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a
                   = (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                     (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                     ((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                     \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                     ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
           proof -
             have "\<epsilon> b \<star>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a
                     = (G\<^sub>0 b \<cdot>\<^sub>D \<epsilon> b \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b)) \<star>\<^sub>D
                       \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]"
               using a b f ide_f D.comp_arr_dom D.comp_cod_arr
                     D.hcomp_reassoc(1) [of "\<tau>\<^sub>0 b" "F f" "\<tau>\<^sub>0' a"]
               by auto
            also have "... = (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                             (\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                             ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
              using a b f ide_f D.comp_arr_dom D.comp_cod_arr D.assoc'_is_natural_1
                    D.interchange [of "G\<^sub>0 b" "\<epsilon> b \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b)" "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]"
                                      "(\<tau>\<^sub>0 b \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]"]
                    D.interchange [of "\<epsilon> b" "\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b" "\<tau>\<^sub>0 b \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
                                      "\<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]"]
              by fastforce
            also have "... = (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                             (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                             ((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                             \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                             ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
               using a b f ide_f D.hcomp_reassoc(2) [of "\<epsilon> b" "\<tau>\<^sub>0 b" "F f \<star>\<^sub>D \<tau>\<^sub>0' a"]
               by auto
            finally show ?thesis by blast
          qed
          moreover have "\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a
                           = (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                             (\<a>\<^sub>D[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                             ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                             \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                             (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
          proof -
            have "\<tau>\<^sub>0 b \<star>\<^sub>D (\<eta> b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a =
                  (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                    (\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                    (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
              using a b f ide_f D.hcomp_reassoc(1) [of "\<eta> b" "F f" "\<tau>\<^sub>0' a"]
                    D.whisker_left [of "\<tau>\<^sub>0 b"]
              by auto
            also have "... = (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                               (\<a>\<^sub>D[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                               ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                               \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                               (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a])"
              using a b f ide_f D.hcomp_reassoc(2) [of "\<tau>\<^sub>0 b" "\<eta> b" "F f \<star>\<^sub>D \<tau>\<^sub>0' a"]
              by auto
            finally show ?thesis by blast
          qed
          ultimately show ?thesis
            using D.comp_assoc by simp
        qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
        proof -
          have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                \<a>\<^sub>D[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]
                  = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
          proof -
            have "\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                  ((\<tau>\<^sub>0 b \<star>\<^sub>D \<tau>\<^sub>0' b) \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                  \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, (\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                  (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b \<star>\<^sub>D F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                  (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[\<tau>\<^sub>0' b, \<tau>\<^sub>0 b, F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                  (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                  \<a>\<^sub>D[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b \<star>\<^sub>D \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]
                    = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                      ((\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                      \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>F f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                      (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                      (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>) \<^bold>\<cdot>
                      (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                      \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char
               by auto
             also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' b\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<rbrace>"
               using a b f ide_f by (intro EV.eval_eqI, auto)
             also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char
               by auto
             finally show ?thesis by blast
           qed
           thus ?thesis
             using D.comp_assoc by auto
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          ((G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          (\<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a)
                   = \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
           proof -
             interpret adjoint_equivalence_in_bicategory
                         V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>\<tau>\<^sub>0 b\<close> \<open>\<tau>\<^sub>0' b\<close> \<open>\<eta> b\<close> \<open>\<epsilon> b\<close>
               using b chosen_adjoint_equivalence by simp
             have "((\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   (\<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   ((\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a)
                     = (\<epsilon> b \<star>\<^sub>D \<tau>\<^sub>0 b) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, \<tau>\<^sub>0' b, \<tau>\<^sub>0 b] \<cdot>\<^sub>D (\<tau>\<^sub>0 b \<star>\<^sub>D \<eta> b) \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
               using a b f ide_f D.whisker_right by auto
             also have "... = \<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a"
               using triangle_left by simp
             finally show ?thesis by blast
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          ((G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          \<l>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                 (\<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                 (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                 \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]
                   = \<l>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a]"
           proof -
             have "(G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                   (\<a>\<^sub>D[G\<^sub>0 b, \<tau>\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                   (\<l>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b] \<cdot>\<^sub>D \<r>\<^sub>D[\<tau>\<^sub>0 b] \<star>\<^sub>D F f \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   \<a>\<^sub>D\<^sup>-\<^sup>1[\<tau>\<^sub>0 b, F\<^sub>0 b, F f \<star>\<^sub>D \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                   (\<tau>\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[F\<^sub>0 b, F f, \<tau>\<^sub>0' a]) \<cdot>\<^sub>D
                   (\<tau>\<^sub>0 b \<star>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[F f] \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                   \<a>\<^sub>D[\<tau>\<^sub>0 b, F f, \<tau>\<^sub>0' a]
                     = \<lbrace>(\<^bold>\<langle>G\<^sub>0 b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                       (\<^bold>\<a>\<^bold>[\<^bold>\<langle>G\<^sub>0 b\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot>
                       (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>\<^bold>] \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>) \<^bold>\<cdot>
                       \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F\<^sub>0 b\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>F f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                       (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<a>\<^bold>[\<^bold>\<langle>F\<^sub>0 b\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]) \<^bold>\<cdot>
                       (\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<langle>F f\<^bold>\<rangle>\<^bold>] \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>) \<^bold>\<cdot>
                       \<^bold>\<a>\<^bold>[\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle>, \<^bold>\<langle>F f\<^bold>\<rangle>, \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char D.\<ll>_ide_simp D.\<rr>_ide_simp
               by auto
             also have "... = \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[(\<^bold>\<langle>\<tau>\<^sub>0 b\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>F f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>\<tau>\<^sub>0' a\<^bold>\<rangle>\<^bold>]\<rbrace>"
               using a b f ide_f by (intro EV.eval_eqI, auto)
             also have "... = \<l>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a]"
               using a b f ide_f D.\<alpha>_def D.\<alpha>'.map_ide_simp D.VVV.ide_char D.VVV.arr_char
                     D.VV.ide_char D.VV.arr_char D.\<ll>_ide_simp
               by auto
             finally show ?thesis by blast
           qed
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          ((D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D
                          (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "(G\<^sub>0 b \<star>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D
                 \<l>\<^sub>D\<^sup>-\<^sup>1[(\<tau>\<^sub>0 b \<star>\<^sub>D F f) \<star>\<^sub>D \<tau>\<^sub>0' a]
                   = \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                     \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                     (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide
                   D.lunit'_naturality [of "\<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D (D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a)"]
             by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D
                          \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
         proof -
           have "((D.inv (\<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D (\<tau>\<^sub>1 f \<star>\<^sub>D \<tau>\<^sub>0' a)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] =
                 ((D.inv (\<tau>\<^sub>1 f) \<cdot>\<^sub>D \<tau>\<^sub>1 f) \<star>\<^sub>D \<tau>\<^sub>0' a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.whisker_right [of "\<tau>\<^sub>0' a"] by simp
           also have "... = \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a]"
             using a b f ide_f \<tau>.iso_map\<^sub>1_ide D.comp_inv_arr' D.comp_cod_arr by auto
           finally show ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D
                          (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D
                          \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a]"
         proof -
           have "\<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] \<cdot>\<^sub>D \<a>\<^sub>D[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[G f, \<tau>\<^sub>0 a, \<tau>\<^sub>0' a] =
                 \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a]"
             using a b f ide_f D.comp_arr_inv' D.comp_arr_dom by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = ((G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D G\<^sub>0 a]) \<cdot>\<^sub>D (G f \<star>\<^sub>D \<epsilon> a)"
         proof -
           have "(G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (G\<^sub>0 b \<star>\<^sub>D G f \<star>\<^sub>D \<epsilon> a) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D \<tau>\<^sub>0 a \<star>\<^sub>D \<tau>\<^sub>0' a] =
                 (G\<^sub>0 b \<star>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D \<l>\<^sub>D\<^sup>-\<^sup>1[G f \<star>\<^sub>D G\<^sub>0 a] \<cdot>\<^sub>D (G f \<star>\<^sub>D \<epsilon> a)"
             using a b f ide_f D.lunit'_naturality [of "G f \<star>\<^sub>D \<epsilon> a"] by auto
           thus ?thesis
             using D.comp_assoc by simp
         qed
         also have "... = (\<l>\<^sub>D\<^sup>-\<^sup>1[G f] \<cdot>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (G f \<star>\<^sub>D \<epsilon> a)"
           using a b f ide_f D.lunit'_naturality [of "\<r>\<^sub>D[G f]"] by auto
         finally show "(\<l>\<^sub>D\<^sup>-\<^sup>1[G f] \<cdot>\<^sub>D \<r>\<^sub>D[G f]) \<cdot>\<^sub>D (G f \<star>\<^sub>D \<epsilon> a) = (\<epsilon> b \<star>\<^sub>D G f) \<cdot>\<^sub>D \<tau>\<tau>'.map\<^sub>1 f"
           by simp
       qed
     qed
 
     lemma counit_is_invertible_modification:
     shows "invertible_modification
              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 G \<Phi>\<^sub>G
              \<tau>\<tau>'.map\<^sub>0 \<tau>\<tau>'.map\<^sub>1 \<iota>\<^sub>G.map\<^sub>0 \<iota>\<^sub>G.map\<^sub>1 \<epsilon>"
       ..
 
   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,2970 +1,2960 @@
 (*  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"
-          using assms \<mu>\<nu> right_def right_respects_isomorphic isomorphic_implies_equicomposable
-                R.hom_char R.dom_char R.cod_char R.inclusion in_homI R.arrE
-          by (elim R.seqE R.arrE) auto
+          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"
-          using assms \<mu>\<nu> left_def left_respects_isomorphic isomorphic_implies_equicomposable
-                L.hom_char L.dom_char L.cod_char L.inclusion in_homI L.arrE
-          by (elim L.seqE L.arrE) auto
+          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'"
-        using \<mu> assms(1) comp_ide_source comp_target_ide [of b b']
-              weak_unit_self_composable(1) [of b] weak_unit_self_composable(1) [of b']
-              isomorphic_transitive isomorphic_symmetric
-              sources_determine_composability targetsD(2-3)
-        by (metis (full_types) connected_if_composable)
+        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'"
-        using assms \<phi> weak_unit_self_composable hom_connected weak_unit_self_composable(3)
-              Left_a.ide_char Left_a.arr_char left_def in_homE
-        by auto metis+
+        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))"
-            using assms Left_a.natural_isomorphism_\<ll> naturally_isomorphic_def
-                  \<Phi>.natural_isomorphism_axioms naturally_isomorphic_symmetric
-                  naturally_isomorphic_transitive
-            by blast
+            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
         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'))"
-            using assms Right_a.natural_isomorphism_\<rr> naturally_isomorphic_def
-                  \<Psi>.natural_isomorphism_axioms naturally_isomorphic_symmetric
-                  naturally_isomorphic_transitive
         proof -
           have "naturally_isomorphic (Right a) (Right a) (H\<^sub>R a') Right_a.map"
-            using assms Right_a.natural_isomorphism_\<rr> naturally_isomorphic_def
-                  \<Psi>.natural_isomorphism_axioms naturally_isomorphic_symmetric
-                  naturally_isomorphic_transitive
-            by blast
+            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 blast
+      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,3131 +1,2960 @@
 (*  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>)"
-    proof -
-      have "src\<^sub>C \<mu> = trg\<^sub>C \<nu>"
-        using assms by auto
-      hence "D.isomorphic (F (src\<^sub>C \<mu>)) (trg\<^sub>D (F \<nu>))"
-        using assms weakly_preserves_trg by auto
-      moreover have "D.isomorphic (src\<^sub>D (F \<mu>)) (F (src\<^sub>C \<mu>))"
-        using assms weakly_preserves_src D.isomorphic_symmetric by blast
-      ultimately have "D.isomorphic (src\<^sub>D (F \<mu>)) (trg\<^sub>D (F \<nu>))"
-        using D.isomorphic_transitive by blast
-      hence "src\<^sub>D (F \<mu>) = trg\<^sub>D (F \<nu>)"
-        using assms D.isomorphic_objects_are_equal by auto
-      thus ?thesis
-        using assms by auto
-    qed
+      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)
           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>"
-      proof -
-        have "H\<^sub>DoFF.map (a, b) = F a \<star>\<^sub>D F b"
-          using assms C.VV.ide_char FF_def by auto
-        moreover have "FoH\<^sub>C.map (a, b) = F (a \<star>\<^sub>C b)"
-          using assms C.VV.ide_char by simp
-        ultimately show ?thesis
-          using assms C.VV.ide_char \<Phi>.preserves_hom
-          apply simp
-          by (metis (no_types, lifting) C.VV.ideI C.VV.ide_in_hom C.VxV.ide_Ide C.ideD(1)
-              fst_conv snd_conv)
-      qed
-      show "\<guillemotleft>\<Phi> (a, b) : map\<^sub>0 (src\<^sub>C b) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C a)\<guillemotright>"
-      proof -
-        have "C.hseq a b"
-          by (simp add: assms(1-3))
-        thus ?thesis
-          by (metis C.src_hcomp C.trg_hcomp D.in_hhom_def D.in_homE D.src_cod D.trg_cod
-              \<open>\<guillemotleft>\<Phi> (a, b) : F a \<star>\<^sub>D F b \<Rightarrow>\<^sub>D F (a \<star>\<^sub>C b)\<guillemotright>\<close> preserves_src preserves_trg)
-      qed
+        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)"
-    proof -
-      show "D.arr (\<Phi> (f, g))"
-        using assms cmp_in_hom by auto
-      show "src\<^sub>D (\<Phi> (f, g)) = src\<^sub>D (F g)"
-        using assms cmp_in_hom by auto
-      show "trg\<^sub>D (\<Phi> (f, g)) = trg\<^sub>D (F f)"
-        using assms cmp_in_hom by auto
-      show "D.dom (\<Phi> (f, g)) = F f \<star>\<^sub>D F g"
-        using assms cmp_in_hom by blast
-      show "D.cod (\<Phi> (f, g)) = F (f \<star>\<^sub>C g)"
-        using assms cmp_in_hom by blast
-    qed
+      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 1: "\<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 \<Phi>.preserves_hom FF_def C.VV.dom_simp C.VV.cod_simp
-        by auto
-      show "\<guillemotleft>\<Phi> (\<mu>, \<nu>) : map\<^sub>0 (src\<^sub>C \<nu>) \<rightarrow>\<^sub>D map\<^sub>0 (trg\<^sub>C \<mu>)\<guillemotright>"
-        using assms 1 D.src_dom [of "\<Phi> (\<mu>, \<nu>)"] D.trg_dom [of "\<Phi> (\<mu>, \<nu>)"]
-              C.VV.dom_simp C.VV.cod_simp D.vconn_implies_hpar(1-2)
-        by auto
+      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>)"
-    proof -
-      show "D.arr (\<Phi> (\<mu>, \<nu>))"
-        using assms cmp_in_hom by auto
-      show "src\<^sub>D (\<Phi> (\<mu>, \<nu>)) = map\<^sub>0 (src\<^sub>C \<nu>)"
-        using assms cmp_in_hom' by auto
-      show "trg\<^sub>D (\<Phi> (\<mu>, \<nu>)) = map\<^sub>0 (trg\<^sub>C \<mu>)"
-        using assms cmp_in_hom' by auto
-      show "D.dom (\<Phi> (\<mu>, \<nu>)) = F (C.dom \<mu>) \<star>\<^sub>D F (C.dom \<nu>)"
-        using assms cmp_in_hom' by blast
-      show "D.cod (\<Phi> (\<mu>, \<nu>)) = F (C.cod \<mu> \<star>\<^sub>C C.cod \<nu>)"
-        using assms cmp_in_hom' by blast
-    qed
+      using assms cmp_in_hom' by simp_all 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"
-    proof -
-      show "src\<^sub>D \<i>[a] = map\<^sub>0 a"
-        unfolding map\<^sub>0_def
-        using assms \<i>_in_hom D.src_cod [of "F a"]
-        by (metis C.unit_simps(1) C.unit_simps(5) D.arrI D.src_vcomp D.vseq_implies_hpar(1)
-            as_nat_trans.is_natural_2 preserves_arr)
-      show "trg\<^sub>D \<i>[a] = map\<^sub>0 a"
-        unfolding map\<^sub>0_def
-        using assms \<i>_in_hom D.trg_cod [of "F a"]
-        by (metis C.obj_def C.unit_simps(1) C.unit_simps(3) D.arrI D.trg_vcomp preserves_hseq)
-      show "D.arr \<i>[a]"
-        using assms \<i>_in_hom by auto
-      show "D.dom \<i>[a] = F a \<star>\<^sub>D F a"
-        using assms \<i>_in_hom by auto
-      show "D.cod \<i>[a] = F a"
-        using assms \<i>_in_hom by auto
-    qed
+      using assms \<i>_in_hom by auto
 
     lemma iso_\<i>:
     assumes "C.obj a"
     shows "D.iso \<i>[a]"
-    proof -
-      have "D.iso (\<Phi> (a, a))"
-        using assms by auto
-      moreover have "D.iso (F \<i>\<^sub>C[a])"
-        using assms C.iso_unit by simp
-      moreover have "D.seq (F \<i>\<^sub>C[a]) (\<Phi> (a, a))"
-        using assms C.obj_self_composable(1) C.seq_if_composable by simp
-      ultimately show ?thesis by auto
-    qed
+      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"
-    proof -
-      show "D.arr (unit a)"
-        using assms unit_char(1) by auto
-      show 1: "D.dom (unit a) = map\<^sub>0 a"
-        using assms unit_char(1) by auto
-      show 2: "D.cod (unit a) = F a"
-        using assms unit_char(1) by auto
-      show "src\<^sub>D (unit a) = map\<^sub>0 a"
-        using assms 1 D.src_dom
-        unfolding map\<^sub>0_def
-        by (metis C.obj_def D.src_src preserves_arr)
-      show "trg\<^sub>D (unit a) = map\<^sub>0 a"
-        unfolding map\<^sub>0_def
-        using assms 2 unit_char
-        by (metis 1 D.trg_dom map\<^sub>0_def map\<^sub>0_simps(3))
-    qed
+      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
-          apply unfold_locales by simp
+          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>
-        proof
-          show "Df.weak_unit (F (trg\<^sub>C f))"
-            using assms D.weak_unit_char
-            by (metis C.ideD(1) C.trg.preserves_reflects_arr C.trg_trg weakly_preserves_trg)
-          show "\<guillemotleft>\<i>[trg\<^sub>C f] : F (trg\<^sub>C f) \<star>\<^sub>D F (trg\<^sub>C f) \<Rightarrow>\<^sub>D F (trg\<^sub>C f)\<guillemotright>"
-            using assms \<i>_in_hom by simp
-          show "D.iso \<i>[trg\<^sub>C f]"
-            using assms iso_\<i> by simp
-        qed
+          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.assoc'_eq_inv_assoc D.ext D.hseqE D.seqE
-              D.vconn_implies_hpar(1) D.vconn_implies_hpar(3) Df.characteristic_iso(4)
-              Df.equivalence_functor_L Df.iso_unit(2) S.comp_simp S.ext S.ide_char
-              S.in_hom_char S.iso_is_arr S.null_char calculation(1) category.ide_cod
-              category.in_homE equivalence_functor_def)
+          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) calculation(2))
+          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_in_hom [of ?b f] lF_simps by auto
+        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)"
-          proof -
-            have "(\<i> ?b \<star>\<^sub>D F f) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F ?b, F ?b, F f] = F ?b \<star>\<^sub>D lF f"
-              using assms lF_char by auto
-            thus ?thesis
-              using assms D.inv_is_inverse \<i>_in_hom cmp_in_hom D.invert_side_of_triangle(2)
-              by (simp add: D.comp_assoc)
-          qed
+            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)"
-            proof -
-              have "D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]) \<cdot>\<^sub>D \<Phi> (?b, ?b \<star>\<^sub>C f)) =
-                    D.inv (\<Phi> (?b, ?b \<star>\<^sub>C f)) \<cdot>\<^sub>D D.inv (F (?b \<star>\<^sub>C \<l>\<^sub>C[f]))"
-                using assms D.isos_compose C.VV.arr_char C.iso_lunit D.inv_comp
-                      C.VV.dom_simp C.VV.cod_simp
-                by simp
-              thus ?thesis using D.comp_assoc by simp
-            qed
+              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 1: "\<l>\<^sub>D[F f] \<cdot>\<^sub>D D.inv (unit (trg\<^sub>C f) \<star>\<^sub>D F f) = F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)"
-        using assms lunit_coherence1 lunit_coherence2 by simp
       have "\<l>\<^sub>D[F f] = (F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)) \<cdot>\<^sub>D (unit (trg\<^sub>C f) \<star>\<^sub>D F f)"
-      proof -
-        have "D.seq (F \<l>\<^sub>C[f]) (\<Phi> (trg\<^sub>C f, f))"
-          using assms cmp_in_hom [of "trg\<^sub>C f" f] C.unit_in_vhom by auto
-        moreover have "D.iso (D.inv (unit (trg\<^sub>C f) \<star>\<^sub>D F f))"
-          using assms unit_char unit_char(1-2)
-          by (simp add: preserves_hseq)
-        ultimately show ?thesis
-          using assms 1 unit_char(2) cmp_in_hom D.inv_inv
-                D.invert_side_of_triangle(2)
-                  [of "F \<l>\<^sub>C[f] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C f, f)" "\<l>\<^sub>D[F f]" "D.inv (unit (trg\<^sub>C f) \<star>\<^sub>D F f)"]
-          by auto
-      qed
+        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 unit_char(1) D.comp_assoc by auto
+        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>))"
-          using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char B.arr_dom_iff_arr src_dom
-                trg_dom
-          apply simp
-          by (metis (no_types, lifting) VV.arrE VVV.arrE)
+          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>))"
-          using \<mu>\<nu>\<tau> VVV_arr_char B.VV.arr_char B.VVV.arr_char
-          apply simp
-          by (metis (no_types, lifting) B.arr_cod_iff_arr VV.arrE VVV.arrE)
+          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
-      apply unfold_locales by auto
+      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)
+        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 -
-      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]"
+      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 "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
+        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
-      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 "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))"
-        by simp
-      hence "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 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 "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]"
-        by simp
+      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 -
-      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)))"
+      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 "\<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
+        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
-      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 "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))"
-        by simp
-      hence "F \<r>\<^sub>C\<^sup>-\<^sup>1[f] =
-             D.inv (\<r>\<^sub>D[F f] \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv (unit (src\<^sub>C f))) \<cdot>\<^sub>D D.inv (\<Phi> (f, src\<^sub>C f)))"
-        using assms preserves_inv C.iso_runit by simp
-      also have "... = \<Phi> (f, src\<^sub>C f) \<cdot>\<^sub>D (F f \<star>\<^sub>D 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 "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]"
-        by simp
+      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 -
-      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 1: "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 1 C.VV.arr_char FF_def D.inv_comp C.VV.dom_simp C.VV.cod_simp
-        by simp
-      ultimately show 1: "F \<a>\<^sub>C[f, g, h] =
-                          \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
-                            (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
-        using D.invert_side_of_triangle(2)
-                [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
-                    "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
-              D.comp_assoc
-        by simp
-      hence "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
-             D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] \<cdot>\<^sub>D
-               (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
-        using assms preserves_inv by simp
-      also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
-                         (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
+      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 "\<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)
+        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 assms D.isos_compose D.comp_assoc
-          by (elim conjE D.in_homE) (auto simp add: D.inv_comp)
+          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
-      finally show "F \<a>\<^sub>C\<^sup>-\<^sup>1[f, g, h] =
-                    \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F f, F g, F h] \<cdot>\<^sub>D
-                      (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
-        by simp
+      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)
+        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
-    proof
-      show "\<And>\<mu>. B.arr \<mu> \<Longrightarrow> B.isomorphic (map (src\<^sub>B \<mu>)) (src\<^sub>B (map \<mu>))"
-        by (simp add: B.isomorphic_reflexive)
-      show "\<And>\<mu>. B.arr \<mu> \<Longrightarrow> B.isomorphic (map (trg\<^sub>B \<mu>)) (trg\<^sub>B (map \<mu>))"
-        by (simp add: B.isomorphic_reflexive)
-    qed
+      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 cmp_def S.dom_simp S.cod_simp S.VV.arr_char S.arr_char S.hcomp_def
-                S.inclusion S.cod_closed
-          apply auto
-          using S.hcomp_closed apply auto[1]
-          by (metis (no_types, lifting) B.VV.arrE)
+          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)"
+                     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>"
       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 -
+          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
-            F.cmp_simps'(4) 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 F.cmp_simps'(5)
+            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)
 
     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"
-    proof (intro unit_eqI)
-      show "C'.obj a" by fact
-      show "\<guillemotleft>F.unit a : map\<^sub>0 a \<Rightarrow>\<^sub>D map a\<guillemotright>"
-        using assms map\<^sub>0_def F.unit_in_hom(2) [of a] C'.obj_char by auto
-      show "D.iso (F.unit a)"
-        using assms by (simp add: C'.obj_char F.unit_char(2))
-      show "F.unit a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = (map \<i>\<^sub>C[a] \<cdot>\<^sub>D cmp (a, a)) \<cdot>\<^sub>D (F.unit a \<star>\<^sub>D F.unit a)"
-      proof -
-        have "F.unit a \<cdot>\<^sub>D \<i>\<^sub>D[map\<^sub>0 a] = F.unit a \<cdot>\<^sub>D \<i>\<^sub>D[F.map\<^sub>0 a]"
-          using assms map\<^sub>0_def F.map\<^sub>0_def by auto
-        also have "... = (F \<i>\<^sub>C[a] \<cdot>\<^sub>D \<Phi> (a, a)) \<cdot>\<^sub>D (F.unit a \<star>\<^sub>D F.unit a)"
-          using assms C'.obj_char F.unit_char(3) [of a] by simp
-        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 C.VV.arr_char D.iso_is_arr iso_\<i> by auto
-        finally show ?thesis by simp
-      qed
-    qed
+      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 (intro D'.in_homI) auto
+        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 (intro D'.in_homI) auto
+        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)"
-          using f g h fg gh D'.arr_char C.VV.arr_char
-          by (metis (no_types, lifting) C.ideD(1) D'.hcomp_closed F.\<Phi>.preserves_reflects_arr
-              F.cmp_simps(1) F.cmp_simps(2) F.preserves_hseq preserves_reflects_arr)
+          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)"
-      proof -
-        have "D.in_hom (F.unit a) (F.map\<^sub>0 a) (map a)"
-          using assms by auto
-        moreover have "map\<^sub>0 a = map\<^sub>0 a"
-          using assms map\<^sub>0_def D'.src_def by auto
-        ultimately show ?thesis
-          using assms D'.in_hom_char preserves_arr D'.arr_char
-          by (metis (no_types, lifting) C.obj_def' D'.obj_def D'.src_def D.arrI
-              D.vconn_implies_hpar(1,3) F.unit_simps(2-3) map\<^sub>0_def map\<^sub>0_simps(1))
-      qed
+        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
-            using assms 1 D'.comp_char D'.hcomp_def C.VV.arr_char D'.hseq_char
-                  D'.arr_char F.\<i>_simps(2)
-            by auto
+            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"
-      proof -
-        assume 1: "faithful_functor V\<^sub>C V\<^sub>D F"
-        interpret faithful_functor V\<^sub>C V\<^sub>D F
-          using 1 by blast
-        show "locally_faithful"
-          unfolding locally_faithful_def using is_faithful by blast
-      qed
+        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
-      have E'': "equivalence_in_bicategory (\<cdot>\<^sub>D) (\<star>\<^sub>D) \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D (F f) (F g)
-                   ((F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>)
-                   (\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>))"
+      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
-      interpret E'': equivalence_in_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D \<open>F f\<close> \<open>F g\<close>
-                       \<open>(F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi>\<close>
-                       \<open>\<psi> \<cdot>\<^sub>D (D.inv (F f) \<star>\<^sub>D g') \<cdot>\<^sub>D (F f \<star>\<^sub>D D.inv \<mu>)\<close>
-        using E'' by auto
       let ?\<eta>' = "\<Phi> (g, f) \<cdot>\<^sub>D (F g \<star>\<^sub>D F f) \<cdot>\<^sub>D (\<mu> \<star>\<^sub>D F f) \<cdot>\<^sub>D \<phi> \<cdot>\<^sub>D D.inv (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 E''.antipar cmp_in_hom unit_char
-              E'.unit_in_hom E'.unit_is_iso
-        by (intro D.isos_compose) auto
+        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 E''.antipar D.ide_in_hom(2) by auto
+          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 E''.antipar D.ide_is_iso
-          by (simp add: D.ide_in_hom(2))
+          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 E'.antipar by auto
+          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
-          using assms g \<mu> E'.antipar E''.antipar cmp_in_hom unit_char
-                E'.counit_in_hom D.iso_inv_iso E'.counit_is_iso \<epsilon>'
-          by (metis C.ideD(1) C.obj_src D.arrI D.iso_hcomp D.hseq_char D.ide_is_iso
-              D.isos_compose D.seqE E'.ide_right as_nat_iso.components_are_iso)
+          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>"
-            using f f' \<nu> hhom\<^sub>C.in_hom_char hhom\<^sub>D.in_hom_char hhom\<^sub>C.ide_char locally_full
-            by simp
+            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"
-          proof -
-            have 2: "hhom\<^sub>C.arr f' \<and> hhom\<^sub>C.arr f"
-              using f f' hhom\<^sub>C.arr_char hhom\<^sub>C.ide_char by simp
-            moreover have "hhom\<^sub>C.arr \<mu>"
-              using \<mu> 1 2 hhom\<^sub>C.arr_char C.arrI C.vconn_implies_hpar(1-2) by auto
-            ultimately show ?thesis
-              using f f' \<mu> hhom\<^sub>C.arr_char hhom\<^sub>C.ide_char hhom\<^sub>C.in_hom_char by simp
-          qed
+            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>)"
-              using f 1 hhom\<^sub>D.arr_char D.in_hhom_def by auto
+              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>"
-              using f g hhom\<^sub>D.in_hom_char hhom\<^sub>D.iso_char hhom\<^sub>C.arr_char hhom\<^sub>D.arr_char
-                    hhom\<^sub>D.ideD(1) preserves_arr
-              by (simp add: C.in_hhom_def)
+              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
-    proof
-      show "\<And>a'. B.obj a' \<Longrightarrow> \<exists>a. B.obj a \<and> B.equivalent_objects (map\<^sub>0 a) a'"
-        by (auto simp add: B.equivalent_objects_reflexive map\<^sub>0_def B.obj_simps)
-      show "\<And>a b g. \<lbrakk>B.obj a; B.obj b; B.in_hhom g (map\<^sub>0 a) (map\<^sub>0 b); B.ide g\<rbrakk>
-                       \<Longrightarrow> \<exists>f. B.in_hhom f a b \<and> B.ide f \<and> B.isomorphic (map f) g"
-        using B.isomorphic_reflexive map\<^sub>0_def B.obj_simps by auto
-      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> : map f \<rightarrow>\<^sub>B map f'\<guillemotright>\<rbrakk>
-                       \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<rightarrow>\<^sub>B f'\<guillemotright> \<and> map \<mu> = \<nu>"
-        using B.arrI by auto
-     qed
+      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"
-        proof -
-          have "(G o F) f = G (F f)"
-            by simp
-          also have "D.isomorphic ... (G g)"
-            using f G.preserves_iso D.isomorphic_def by blast
-          also have "D.isomorphic ... h"
-            using g by simp
-          finally show "D.isomorphic ((G \<circ> F) f) h" by simp
-        qed
+          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/Strictness.thy b/thys/Bicategory/Strictness.thy
--- a/thys/Bicategory/Strictness.thy
+++ b/thys/Bicategory/Strictness.thy
@@ -1,4253 +1,4210 @@
 (*  Title:       Strictness
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 section "Strictness"
 
 theory Strictness
 imports Category3.ConcreteCategory Pseudofunctor CanonicalIsos
 begin
 
   text \<open>
     In this section we consider bicategories in which some or all of the canonical isomorphisms
     are assumed to be identities.  A \emph{normal} bicategory is one in which the unit
     isomorphisms are identities, so that unit laws for horizontal composition are satisfied
     ``on the nose''.
     A \emph{strict} bicategory (also known as a \emph{2-category}) is a bicategory in which both
     the unit and associativity isomoprhisms are identities, so that horizontal composition is
     strictly associative as well as strictly unital.
 
     From any given bicategory \<open>B\<close> we may construct a related strict bicategory \<open>S\<close>,
     its \emph{strictification}, together with a pseudofunctor that embeds \<open>B\<close> in \<open>S\<close>.
     The Strictness Theorem states that this pseudofunctor is an equivalence pseudofunctor,
     so that bicategory \<open>B\<close> is biequivalent to its strictification.
     The Strictness Theorem is often used informally to justify suppressing canonical
     isomorphisms; which amounts to proving a theorem about 2-categories and asserting that
     it holds for all bicategories.  Here we are working formally, so we can't just wave
     our hands and mutter something about the Strictness Theorem when we want to avoid
     dealing with units and associativities.  However, in cases where we can establish that the
     property we would like to prove is reflected by the embedding of a bicategory in its
     strictification, then we can formally apply the Strictness Theorem to generalize to all
     bicategories a result proved for 2-categories.  We will apply this approach here to
     simplify the proof of some facts about internal equivalences in a bicategory.
   \<close>
 
   subsection "Normal and Strict Bicategories"
 
   text \<open>
     A \emph{normal} bicategory is one in which the unit isomorphisms are identities,
     so that unit laws for horizontal composition are satisfied ``on the nose''.
   \<close>
 
   locale normal_bicategory =
     bicategory +
   assumes strict_lunit: "\<And>f. ide f \<Longrightarrow> \<l>[f] = f"
   and strict_runit: "\<And>f. ide f \<Longrightarrow> \<r>[f] = f"
   begin
 
     lemma strict_unit:
     assumes "obj a"
     shows "ide \<i>[a]"
       using assms strict_runit unitor_coincidence(2) [of a] by auto
 
     lemma strict_lunit':
     assumes "ide f"
     shows "\<l>\<^sup>-\<^sup>1[f] = f"
       using assms strict_lunit by simp
 
     lemma strict_runit':
     assumes "ide f"
     shows "\<r>\<^sup>-\<^sup>1[f] = f"
       using assms strict_runit by simp
 
     lemma hcomp_obj_arr:
     assumes "obj b" and "arr f" and "b = trg f"
     shows "b \<star> f = f"
       using assms strict_lunit
       by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom lunit_naturality)
 
     lemma hcomp_arr_obj:
     assumes "arr f" and "obj a" and "src f = a"
     shows "f \<star> a = f"
       using assms strict_runit
       by (metis comp_arr_dom comp_ide_arr ide_cod ide_dom runit_naturality)
 
   end
 
   text \<open>
     A \emph{strict} bicategory is a normal bicategory in which the associativities are also
     identities, so that associativity of horizontal composition holds ``on the nose''.
   \<close>
 
   locale strict_bicategory =
     normal_bicategory +
   assumes strict_assoc: "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow>
                                   ide \<a>[f, g, h]"
   begin
 
     lemma strict_assoc':
     assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
     shows "ide \<a>\<^sup>-\<^sup>1[f, g, h]"
       using assms strict_assoc by simp
 
     lemma hcomp_assoc:
     shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
     proof (cases "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>")
       show "\<not> (hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>) \<Longrightarrow> ?thesis"
         by (metis hseqE hseq_char' match_1 match_2)
       show "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau> \<Longrightarrow> ?thesis"
       proof -
         assume 1: "hseq \<mu> \<nu> \<and> hseq \<nu> \<tau>"
         have 2: "arr \<mu> \<and> arr \<nu> \<and> arr \<tau> \<and> src \<mu> = trg \<nu> \<and> src \<nu> = trg \<tau>"
           using 1 by blast
         have "(\<mu> \<star> \<nu>) \<star> \<tau> = \<a>[cod \<mu>, cod \<nu>, cod \<tau>] \<cdot> ((\<mu> \<star> \<nu>) \<star> \<tau>)"
           using 1 assoc_in_hom strict_assoc comp_cod_arr assoc_simps(4) hseq_char
           by simp
         also have "... = (\<mu> \<star> \<nu> \<star> \<tau>) \<cdot> \<a>[dom \<mu>, dom \<nu>, dom \<tau>]"
           using 1 assoc_naturality by auto
         also have "... = \<mu> \<star> \<nu> \<star> \<tau>"
           using 2 assoc_in_hom [of "dom \<mu>" "dom \<nu>" "dom \<tau>"] strict_assoc comp_arr_dom
           by auto
         finally show ?thesis by simp
       qed
     qed
 
     text \<open>
       In a strict bicategory, every canonical isomorphism is an identity.
     \<close>
 
     interpretation bicategorical_language ..
     interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
     notation E.eval ("\<lbrace>_\<rbrace>")
 
     lemma ide_eval_Can:
     assumes "Can t"
     shows "ide \<lbrace>t\<rbrace>"
     proof -
       have 1: "\<And>u1 u2. \<lbrakk> ide \<lbrace>u1\<rbrace>; ide \<lbrace>u2\<rbrace>; Arr u1; Arr u2; Dom u1 = Cod u2 \<rbrakk>
                            \<Longrightarrow> ide (\<lbrace>u1\<rbrace> \<cdot> \<lbrace>u2\<rbrace>)"
         by (metis (no_types, lifting) E.eval_simps'(4-5) comp_ide_self ide_char)
       have "\<And>u. Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
       proof -
         fix u
         show "Can u \<Longrightarrow> ide \<lbrace>u\<rbrace>"
           (* TODO: Rename \<ll>_ide_simp \<rr>_ide_simp to \<ll>_ide_eq \<rr>_ide_eq *)
           using 1 \<alpha>_def \<a>'_def strict_lunit strict_runit strict_assoc strict_assoc'
                 \<ll>_ide_simp \<rr>_ide_simp Can_implies_Arr comp_ide_arr E.eval_simps'(2-3)
           by (induct u) auto
       qed
       thus ?thesis
         using assms by simp
     qed
 
     lemma ide_can:
     assumes "Ide f" and "Ide g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
     shows "ide (can g f)"
       using assms Can_red Can_Inv red_in_Hom Inv_in_Hom can_def ide_eval_Can
             Can.simps(4) Dom_Inv red_simps(4)
       by presburger
 
   end
 
   context bicategory
   begin
 
     text \<open>
       The following result gives conditions for strictness of a bicategory that are typically
       somewhat easier to verify than those used for the definition.
     \<close>
 
     lemma is_strict_if:
     assumes "\<And>f. ide f \<Longrightarrow> f \<star> src f = f"
     and "\<And>f. ide f \<Longrightarrow> trg f \<star> f = f"
     and "\<And>a. obj a \<Longrightarrow> ide \<i>[a]"
     and "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow> ide \<a>[f, g, h]"
     shows "strict_bicategory V H \<a> \<i> src trg"
     proof
       show "\<And>f g h. \<lbrakk>ide f; ide g; ide h; src f = trg g; src g = trg h\<rbrakk> \<Longrightarrow> ide \<a>[f, g, h]"
         by fact
       fix f
       assume f: "ide f"
       show "\<l>[f] = f"
       proof -
         have "f = \<l>[f]"
           using assms f unit_simps(5)
           by (intro lunit_eqI) (auto simp add: comp_arr_ide)
         thus ?thesis by simp
       qed
       show "\<r>[f] = f"
       proof -
         have "f = \<r>[f]"
         proof (intro runit_eqI)
           show "ide f" by fact
           show "\<guillemotleft>f : f \<star> src f \<Rightarrow> f\<guillemotright>"
             using f assms(1) by auto
           show "f \<star> src f = (f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f]"
           proof -
             have "(f \<star> \<i>[src f]) \<cdot> \<a>[f, src f, src f] = (f \<star> src f) \<cdot> \<a>[f, src f, src f]"
               using f assms(2-3) unit_simps(5) by simp
             also have "... = (f \<star> src f \<star> src f) \<cdot> \<a>[f, src f, src f]"
               using f assms(1-2) ideD(1) trg_src src.preserves_ide by metis
             also have "... = f \<star> src f"
               using f comp_arr_ide assms(1,4) assoc_in_hom [of f "src f" "src f"] by auto
             finally show ?thesis by simp
           qed
         qed
         thus ?thesis by simp
       qed
     qed
 
   end
 
   subsection "Strictification"
 
   (*
    * TODO: Perhaps change the typeface used for a symbol that stands for a bicategory;
    * for example, to avoid the clashes here between B used as the name of a bicategory
    * and B used to denote a syntactic identity term.
    *)
 
   text \<open>
     The Strictness Theorem asserts that every bicategory is biequivalent to a
     strict bicategory.  More specifically, it shows how to construct, given an arbitrary
     bicategory, a strict bicategory (its \emph{strictification}) that is biequivalent to it.
     Consequently, given a property \<open>P\<close> of bicategories that is ``bicategorical''
     (\emph{i.e.}~respects biequivalence), if we want to show that \<open>P\<close> holds for a bicategory \<open>B\<close>
     then it suffices to show that \<open>P\<close> holds for the strictification of \<open>B\<close>, and if we want to show
     that \<open>P\<close> holds for all bicategories, it is sufficient to show that it holds for all
     strict bicategories.  This is very useful, because it becomes quite tedious, even
     with the aid of a proof assistant, to do ``diagram chases'' with all the units and
     associativities fully spelled out.
 
     Given a bicategory \<open>B\<close>, the strictification \<open>S\<close> of \<open>B\<close> may be constructed as the bicategory
     whose arrows are triples \<open>(A, B, \<mu>)\<close>, where \<open>X\<close> and \<open>Y\<close> are ``normal identity terms''
     (essentially, nonempty horizontally composable lists of 1-cells of \<open>B\<close>) having the same
     syntactic source and target, and \<open>\<guillemotleft>\<mu> : \<lbrace>X\<rbrace> \<Rightarrow> \<lbrace>Y\<rbrace>\<guillemotright>\<close> in \<open>B\<close>.
     Vertical composition in \<open>S\<close> is given by composition of the underlying arrows in \<open>B\<close>.
     Horizontal composition in \<open>S\<close> is given by \<open>(A, B, \<mu>) \<star> (A', B', \<mu>') = (AA', BB', \<nu>)\<close>,
     where \<open>AA'\<close> and \<open>BB'\<close> denote concatenations of lists and where \<open>\<nu>\<close> is defined as the
     composition \<open>can BB' (B \<^bold>\<star> B') \<cdot> (\<mu> \<star> \<mu>') \<cdot> can (A \<^bold>\<star> A') AA'\<close>, where \<open>can (A \<^bold>\<star> A') AA'\<close> and
     \<open>can BB' (B \<^bold>\<star> B')\<close> are canonical isomorphisms in \<open>B\<close>.  The canonical isomorphism
     \<open>can (A \<^bold>\<star> A') AA'\<close> corresponds to taking a pair of lists \<open>A \<^bold>\<star> A'\<close> and
     ``shifting the parentheses to the right'' to obtain a single list \<open>AA'\<close>.
     The canonical isomorphism can \<open>BB' (B \<^bold>\<star> B')\<close> corresponds to the inverse rearrangement.
 
     The bicategory \<open>B\<close> embeds into its strictification \<open>S\<close> via the functor \<open>UP\<close> that takes
     each arrow \<open>\<mu>\<close> of \<open>B\<close> to \<open>(\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>, \<^bold>\<langle>cod \<mu>\<^bold>\<rangle>, \<mu>)\<close>, where \<open>\<^bold>\<langle>dom \<mu>\<^bold>\<rangle>\<close> and \<open>\<^bold>\<langle>cod \<mu>\<^bold>\<rangle>\<close> denote
     one-element lists.  This mapping extends to a pseudofunctor.
     There is also a pseudofunctor \<open>DN\<close>, which maps \<open>(A, B, \<mu>)\<close> in \<open>S\<close> to \<open>\<mu>\<close> in \<open>B\<close>;
     this is such that \<open>DN o UP\<close> is the identity on \<open>B\<close> and \<open>UP o DN\<close> is equivalent to the
     identity on \<open>S\<close>, so we obtain a biequivalence between \<open>B\<close> and \<open>S\<close>.
 
     It seems difficult to find references that explicitly describe a strictification
     construction in elementary terms like this (in retrospect, it ought to have been relatively
     easy to rediscover such a construction, but my thinking got off on the wrong track).
     One reference that I did find useful was \cite{unapologetic-strictification},
     which discusses strictification for monoidal categories.
   \<close>
 
   locale strictified_bicategory =
     B: bicategory V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
   for V\<^sub>B :: "'a comp"                  (infixr "\<cdot>\<^sub>B" 55)
   and H\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"           (infixr "\<star>\<^sub>B" 53)
   and \<a>\<^sub>B :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"      ("\<a>\<^sub>B[_, _, _]")
   and \<i>\<^sub>B :: "'a \<Rightarrow> 'a"                  ("\<i>\<^sub>B[_]")
   and src\<^sub>B :: "'a \<Rightarrow> 'a"
   and trg\<^sub>B :: "'a \<Rightarrow> 'a"
   begin
 
     sublocale E: self_evaluation_map V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B ..
 
     notation B.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
     notation B.in_hom  ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>B _\<guillemotright>")
 
     notation E.eval ("\<lbrace>_\<rbrace>")
     notation E.Nmlize ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
 
     text \<open>
       The following gives the construction of a bicategory whose arrows are triples \<open>(A, B, \<mu>)\<close>,
       where \<open>Nml A \<and> Ide A\<close>, \<open>Nml B \<and> Ide B\<close>, \<open>Src A = Src B\<close>, \<open>Trg A = Trg B\<close>, and \<open>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow> \<lbrace>B\<rbrace>\<close>.
       We use @{locale concrete_category} to construct the vertical composition, so formally the
       arrows of the bicategory will be of the form \<open>MkArr A B \<mu>\<close>.
     \<close>
 
     text \<open>
       The 1-cells of the bicategory correspond to normal, identity terms \<open>A\<close>
       in the bicategorical language associated with \<open>B\<close>.
     \<close>
 
     abbreviation IDE
     where "IDE \<equiv> {A. E.Nml A \<and> E.Ide A}"
 
     text \<open>
       If terms \<open>A\<close> and \<open>B\<close> determine 1-cells of the strictification and have a
       common source and target, then the 2-cells between these 1-cells correspond
       to arrows \<open>\<mu>\<close> of the underlying bicategory such that \<open>\<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>\<close>.
     \<close>
 
     abbreviation HOM
     where "HOM A B \<equiv> {\<mu>. E.Src A = E.Src B \<and> E.Trg A = E.Trg B \<and> \<guillemotleft>\<mu> : \<lbrace>A\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>B\<rbrace>\<guillemotright>}"
 
     text \<open>
       The map taking term \<open>A \<in> OBJ\<close> to its evaluation \<open>\<lbrace>A\<rbrace> \<in> HOM A A\<close> defines the
       embedding of 1-cells as identity 2-cells.
     \<close>
 
     abbreviation EVAL
     where "EVAL \<equiv> E.eval"
 
     sublocale concrete_category IDE HOM EVAL \<open>\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>\<close>
       using E.ide_eval_Ide B.comp_arr_dom B.comp_cod_arr B.comp_assoc
       by (unfold_locales, auto)
 
     lemma is_concrete_category:
     shows "concrete_category IDE HOM EVAL (\<lambda>_ _ _ \<mu> \<nu>. \<mu> \<cdot>\<^sub>B \<nu>)"
       ..
 
     abbreviation vcomp     (infixr "\<cdot>" 55)
     where "vcomp \<equiv> COMP"
 
     lemma arr_char:
     shows "arr F \<longleftrightarrow>
            E.Nml (Dom F) \<and> E.Ide (Dom F) \<and> E.Nml (Cod F) \<and> E.Ide (Cod F) \<and>
            E.Src (Dom F) = E.Src (Cod F) \<and> E.Trg (Dom F) = E.Trg (Cod F) \<and>
            \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright> \<and> F \<noteq> Null"
       using arr_char by auto
 
     lemma arrI (* [intro] *):
     assumes "E.Nml (Dom F)" and "E.Ide (Dom F)" and "E.Nml (Cod F)" and "E.Ide (Cod F)"
     and "E.Src (Dom F) = E.Src (Cod F)" and "E.Trg (Dom F) = E.Trg (Cod F)"
     and "\<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>" and "F \<noteq> Null"
     shows "arr F"
       using assms arr_char by blast
 
     lemma arrE [elim]:
     assumes "arr F"
     shows "(\<lbrakk> E.Nml (Dom F); E.Ide (Dom F); E.Nml (Cod F); E.Ide (Cod F);
               E.Src (Dom F) = E.Src (Cod F); E.Trg (Dom F) = E.Trg (Cod F);
               \<guillemotleft>Map F : \<lbrace>Dom F\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod F\<rbrace>\<guillemotright>; F \<noteq> Null \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
       using assms arr_char by simp
 
     lemma ide_char:
     shows "ide F \<longleftrightarrow> endo F \<and> B.ide (Map F)"
     proof
       show "ide F \<Longrightarrow> endo F \<and> B.ide (Map F)"
         using ide_char by (simp add: E.ide_eval_Ide)
       show "endo F \<and> B.ide (Map F) \<Longrightarrow> ide F"
         by (metis (no_types, lifting) B.ide_char B.in_homE arr_char ide_char
             mem_Collect_eq seq_char)
     qed
 
     lemma ideI [intro]:
     assumes "arr F" and "Dom F = Cod F" and "B.ide (Map F)"
     shows "ide F"
       using assms ide_char dom_char cod_char seq_char by presburger
 
     lemma ideE [elim]:
     assumes "ide F"
     shows "(\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
               Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T) \<Longrightarrow> T"
-    proof -
-      assume 1: "\<lbrakk> arr F; Dom F = Cod F; B.ide (Map F); Map F = \<lbrace>Dom F\<rbrace>;
-                   Map F = \<lbrace>Cod F\<rbrace> \<rbrakk> \<Longrightarrow> T"
-      show T
-      proof -
-        have "arr F"
-          using assms by auto
-        moreover have "Dom F = Cod F"
-          using assms ide_char dom_char cod_char
-          by (metis (no_types, lifting) Dom_cod calculation ideD(3))
-        moreover have "B.ide (Map F)"
-          using assms ide_char by blast
-        moreover have "Map F = \<lbrace>Dom F\<rbrace>"
-          using assms ide_char dom_char Map_ide(1) by blast
-        ultimately show T
-          using 1 by simp
-      qed
-    qed
+      using assms
+      by (metis (no_types, lifting) Map_ide(2) ide_char seq_char)
 
     text \<open>
       Source and target are defined by the corresponding syntactic operations on terms.
     \<close>
 
     definition src
     where "src F \<equiv> if arr F then MkIde (E.Src (Dom F)) else null"
 
     definition trg
     where "trg F \<equiv> if arr F then MkIde (E.Trg (Dom F)) else null"
 
     lemma src_simps [simp]:
     assumes "arr F"
     shows "Dom (src F) = E.Src (Dom F)" and "Cod (src F) = E.Src (Dom F)"
     and "Map (src F) = \<lbrace>E.Src (Dom F)\<rbrace>"
       using assms src_def arr_char by auto
 
     lemma trg_simps [simp]:
     assumes "arr F"
     shows "Dom (trg F) = E.Trg (Dom F)" and "Cod (trg F) = E.Trg (Dom F)"
     and "Map (trg F) = \<lbrace>E.Trg (Dom F)\<rbrace>"
       using assms trg_def arr_char by auto
 
     interpretation src: endofunctor vcomp src
       using src_def comp_char E.Obj_implies_Ide
       apply (unfold_locales)
           apply auto[4]
     proof -
       show "\<And>g f. seq g f \<Longrightarrow> src (g \<cdot> f) = src g \<cdot> src f"
       proof -
         fix g f
         assume gf: "seq g f"
         have "src (g \<cdot> f) = MkIde (E.Src (Dom (g \<cdot> f)))"
           using gf src_def comp_char by simp
         also have "... = MkIde (E.Src (Dom f))"
           using gf by (simp add: seq_char)
         also have "... = MkIde (E.Src (Dom g)) \<cdot> MkIde (E.Src (Dom f))"
           using gf seq_char E.Obj_implies_Ide by auto
         also have "... = src g \<cdot> src f"
           using gf src_def comp_char by auto
         finally show "src (g \<cdot> f) = src g \<cdot> src f" by blast
       qed
     qed
 
     interpretation trg: endofunctor vcomp trg
       using trg_def comp_char E.Obj_implies_Ide
       apply (unfold_locales)
           apply auto[4]
     proof -
       show "\<And>g f. seq g f \<Longrightarrow> trg (g \<cdot> f) = trg g \<cdot> trg f"
       proof -
         fix g f
         assume gf: "seq g f"
         have "trg (g \<cdot> f) = MkIde (E.Trg (Dom (g \<cdot> f)))"
           using gf trg_def comp_char by simp
         also have "... = MkIde (E.Trg (Dom f))"
           using gf by (simp add: seq_char)
         also have "... = MkIde (E.Trg (Dom g)) \<cdot> MkIde (E.Trg (Dom f))"
           using gf seq_char E.Obj_implies_Ide by auto
         also have "... = trg g \<cdot> trg f"
           using gf trg_def comp_char by auto
         finally show "trg (g \<cdot> f) = trg g \<cdot> trg f" by blast
       qed
     qed
 
     interpretation horizontal_homs vcomp src trg
       using src_def trg_def Cod_in_Obj Map_in_Hom E.Obj_implies_Ide
       by unfold_locales auto
 
     notation in_hhom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     definition hcomp    (infixr "\<star>" 53)
     where "\<mu> \<star> \<nu> \<equiv> if arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>
                    then MkArr (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)
                               (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                                 (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                                 B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))
                    else null"
 
     lemma arr_hcomp:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "arr (\<mu> \<star> \<nu>)"
     proof -
       have 1: "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and> E.Nml (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<and>
                E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and> E.Nml (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
         using assms arr_char src_def trg_def E.Ide_HcompNml E.Nml_HcompNml(1) by auto
       moreover
       have "\<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
                   \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
       proof -
         have "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
           using assms arr_char dom_char cod_char src_def trg_def E.eval_simps'(2-3)
           by auto
         moreover
         have "\<guillemotleft>B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) :
                   \<lbrace>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace>\<guillemotright> \<and>
                \<guillemotleft>B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) :
                   \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<rbrace>\<guillemotright>"
           using assms 1 arr_char src_def trg_def
           apply (intro conjI B.in_homI) by auto
         ultimately show ?thesis by auto
       qed
       moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<and>
                      E.Trg (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
         using assms arr_char src_def trg_def
         by (simp add: E.Src_HcompNml E.Trg_HcompNml)
       ultimately show ?thesis
         unfolding hcomp_def
         using assms by (intro arrI, auto)
     qed
 
     lemma src_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "src (\<mu> \<star> \<nu>) = src \<nu>"
       using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Src_HcompNml by simp
 
     lemma trg_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "trg (hcomp \<mu> \<nu>) = trg \<mu>"
       using assms arr_char hcomp_def src_def trg_def arr_hcomp E.Trg_HcompNml by simp
 
     lemma hseq_char:
     shows "arr (\<mu> \<star> \<nu>) \<longleftrightarrow> arr \<mu> \<and> arr \<nu> \<and> src \<mu> = trg \<nu>"
       using arr_hcomp hcomp_def by simp
 
     lemma Dom_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Dom (\<mu> \<star> \<nu>) = Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     lemma Cod_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Cod (\<mu> \<star> \<nu>) = Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     lemma Map_hcomp [simp]:
     assumes "arr \<mu>" and "arr \<nu>" and "src \<mu> = trg \<nu>"
     shows "Map (\<mu> \<star> \<nu>) = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                            (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                            B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
       using assms hcomp_def [of \<mu> \<nu>] by simp
 
     interpretation "functor" VV.comp vcomp \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close>
     proof
       show "\<And>f. \<not> VV.arr f \<Longrightarrow> fst f \<star> snd f = null"
         using hcomp_def by auto
       show A: "\<And>f. VV.arr f \<Longrightarrow> arr (fst f \<star> snd f)"
         using VV.arrE hseq_char by blast
       show "\<And>f. VV.arr f \<Longrightarrow> dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
       proof -
         fix f
         assume f: "VV.arr f"
         have "dom (fst f \<star> snd f) = MkIde (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
           using f VV.arrE [of f] dom_char arr_hcomp hcomp_def by simp
         also have "... = fst (VV.dom f) \<star> snd (VV.dom f)"
         proof -
           have "hcomp (fst (VV.dom f)) (snd (VV.dom f)) =
                 MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))
                       (B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
                         (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
             using f VV.arrE [of f] arr_hcomp hcomp_def VV.dom_simp by simp
           moreover have "B.can (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Dom (fst f) \<^bold>\<star> Dom (snd f)) \<cdot>\<^sub>B
                            (\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                               B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
                          \<lbrace>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<rbrace>"
           proof -
             have 1: "E.Ide (Dom (fst f) \<^bold>\<star> Dom (snd f))"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) src_simps(1) trg_simps(1))
             have 2: "E.Ide (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
             have 3: "\<^bold>\<lfloor>Dom (fst f) \<^bold>\<star> Dom (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)\<^bold>\<rfloor>"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
                   src_simps(1) trg_simps(1))
             have "(\<lbrace>Dom (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom (snd f)\<rbrace>) \<cdot>\<^sub>B
                     B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) =
                   B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               using "1" "2" "3" B.comp_cod_arr by force
             thus ?thesis
               using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
           qed
           ultimately show ?thesis by simp
         qed
         finally show "dom (fst f \<star> snd f) = fst (VV.dom f) \<star> snd (VV.dom f)"
           by simp
       qed
       show "\<And>f. VV.arr f \<Longrightarrow> cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
       proof -
         fix f
         assume f: "VV.arr f"
         have "cod (fst f \<star> snd f) = MkIde (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
           using f VV.arrE [of f] cod_char arr_hcomp hcomp_def by simp
         also have "... = fst (VV.cod f) \<star> snd (VV.cod f)"
         proof -
           have "hcomp (fst (VV.cod f)) (snd (VV.cod f)) =
                 MkArr (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
                       (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                         (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                         B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)))"
             using f VV.arrE [of f] arr_hcomp hcomp_def VV.cod_simp by simp
           moreover have "B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                            (\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                              B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
                          \<lbrace>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<rbrace>"
           proof -
             have 1: "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) src_simps(1) trg_simps(1))
             have 2: "E.Ide (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
             have 3: "\<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)\<^bold>\<rfloor>"
               using f VV.arr_char arr_char dom_char
               apply simp
               by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
                   src_simps(1) trg_simps(1))
             have "(\<lbrace>Cod (fst f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace>) \<cdot>\<^sub>B
                     B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) =
                   B.can (Cod (fst f) \<^bold>\<star> Cod (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))"
               using "1" "2" "3" B.comp_cod_arr by force
             thus ?thesis
               using 1 2 3 f VV.arr_char B.can_Ide_self B.vcomp_can by simp
           qed
           ultimately show ?thesis by simp
         qed
         finally show "cod (fst f \<star> snd f) = fst (VV.cod f) \<star> snd (VV.cod f)"
           by simp
       qed
       show "\<And>g f. VV.seq g f \<Longrightarrow>
                    fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
       proof -
         fix f g
         assume fg: "VV.seq g f"
         have f: "arr (fst f) \<and> arr (snd f) \<and> src (fst f) = trg (snd f)"
           using fg VV.seq_char VV.arr_char by simp
         have g: "arr (fst g) \<and> arr (snd g) \<and> src (fst g) = trg (snd g)"
           using fg VV.seq_char VV.arr_char by simp
         have 1: "arr (fst (VV.comp g f)) \<and> arr (snd (VV.comp g f)) \<and>
                  src (fst (VV.comp g f)) = trg (snd (VV.comp g f))"
           using fg VV.arrE by blast
         have 0: "VV.comp g f = (fst g \<cdot> fst f, snd g \<cdot> snd f)"
           using fg 1 VV.comp_char VxV.comp_char
           by (metis (no_types, lifting) VV.seq_char VxV.seqE)
         let ?X = "MkArr (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f)))
                         (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
                         (B.can (Cod (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd (VV.comp g f)))
                                (Cod (fst (VV.comp g f)) \<^bold>\<star> Cod (snd (VV.comp g f))) \<cdot>\<^sub>B
                            (Map (fst (VV.comp g f)) \<star>\<^sub>B Map (snd (VV.comp g f))) \<cdot>\<^sub>B
                            B.can (Dom (fst (VV.comp g f)) \<^bold>\<star> Dom (snd (VV.comp g f)))
                                  (Dom (fst (VV.comp g f)) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd (VV.comp g f))))"
         have 2: "fst (VV.comp g f) \<star> snd (VV.comp g f) = ?X"
           unfolding hcomp_def using 1 by simp
         also have "... = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
         proof -
           let ?GG = "MkArr (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g))
                            (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                              (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                              B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)))"
           let ?FF = "MkArr (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)) (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f))
                            (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                              (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                              B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
           have 4: "arr ?FF \<and> arr ?GG \<and> Dom ?GG = Cod ?FF"
           proof -
             have "arr ?FF \<and> arr ?GG"
               using f g fg VV.arr_char VV.seqE hcomp_def A by presburger
             thus ?thesis
               using 0 1 by (simp add: fg seq_char)
           qed
           have "(fst g \<star> snd g) \<cdot> (fst f \<star> snd f) = ?GG \<cdot> ?FF"
             unfolding hcomp_def
             using 1 f g fg VV.arr_char VV.seqE by simp
           also have "... = ?X"
           proof (intro arr_eqI)
             show "seq ?GG ?FF"
               using fg 4 seq_char by blast
             show "arr ?X"
               using fg 1 arr_hcomp hcomp_def by simp
             show "Dom (?GG \<cdot> ?FF) = Dom ?X"
               using fg 0 1 4 seq_char by simp
             show "Cod (?GG \<cdot> ?FF) = Cod ?X"
               using fg 0 1 4 seq_char by simp
             show "Map (?GG \<cdot> ?FF) = Map ?X"
             proof -
               have "Map (?GG \<cdot> ?FF) = Map ?GG \<cdot>\<^sub>B Map ?FF"
                 using 4 by auto
               also have
                 "... = (B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                          (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                          B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                        (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                          (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                          B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f)))"
                 using fg by simp
               also have
                 "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                          ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                          B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               proof -
                 have "(B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                         (Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                         B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                         (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f)) \<cdot>\<^sub>B
                         (Map (fst f) \<star>\<^sub>B Map (snd f)) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))) =
                       B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                         ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B
                         (B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                         B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                         (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                         B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
                   using B.comp_assoc by simp
                 also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                                   ((Map (fst g) \<star>\<^sub>B Map (snd g)) \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))) \<cdot>\<^sub>B
                                    B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
                 proof -
                   have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                           (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
                         \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
                   proof -
                     have "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))) \<cdot>\<^sub>B
                           (B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) =
                           B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Cod (fst f) \<^bold>\<star> Cod (snd f))"
                     proof -
                       have "E.Ide (Dom (fst g) \<^bold>\<star> Dom (snd g))"
                         using g arr_char
-                        apply simp
-                        by (metis (no_types, lifting) src_simps(1) trg_simps(1))
+                        by (metis (no_types, lifting) E.Ide.simps(3) src_simps(2) trg_simps(2))
                       moreover have "E.Ide (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g))"
-                        using g arr_char
-                        apply simp
-                        by (metis (no_types, lifting) E.Ide_HcompNml src_simps(1) trg_simps(1))
+                        using 4 by auto
                       moreover have "E.Ide (Cod (fst f) \<^bold>\<star> Cod (snd f))"
                         using f arr_char
-                        apply simp
-                        by (metis (no_types, lifting) src_simps(1) trg_simps(1))
+                        by (metis (no_types, lifting) E.Ide.simps(3) src_simps(2) trg_simps(2))
                       moreover have
                         "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<star> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor>"
-                        using g
-                        apply simp
-                        by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize_Nml
-                            arrE src_simps(1) trg_simps(1))
+                        using g E.Nml_HcompNml(1) calculation(1) by fastforce
                       moreover have
                         "\<^bold>\<lfloor>Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst f) \<^bold>\<star> Cod (snd f)\<^bold>\<rfloor>"
-                        using g
-                        apply simp
-                        by (metis (no_types, lifting) "0" "1" E.Nmlize.simps(3)
-                            calculation(4) fst_conv seq_char snd_conv)
+                        using g fg seq_char
+                        by (metis (no_types, lifting) VV.seq_char VxV.seqE calculation(4))
                       moreover have
                         "Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g) = Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)"
                         using 0 1 by (simp add: seq_char)
                       ultimately show ?thesis
                         using B.vcomp_can by simp
                     qed
                     also have "... = \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace>"
                     proof -
                       have "Dom (fst g) \<^bold>\<star> Dom (snd g) = Cod (fst f) \<^bold>\<star> Cod (snd f)"
                         using 0 f g fg seq_char VV.seq_char VV.arr_char
                         by simp
                       thus ?thesis
                         using f B.can_Ide_self [of "Dom (fst f) \<^bold>\<star> Dom (snd f)"]
-                        apply simp
-                        by (metis (no_types, lifting) B.can_Ide_self E.eval.simps(3)
-                            E.Ide.simps(3) arr_char src_simps(2) trg_simps(2))
+                        by (metis (no_types, lifting) B.can_Ide_self E.Ide.simps(3)
+                            arrE src_simps(2) trg_simps(2))
                     qed
                     finally show ?thesis by simp
                   qed
                   hence "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                            B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                            (Map (fst f) \<star>\<^sub>B Map (snd f)) =
                          \<lbrace>Cod (fst f) \<^bold>\<star> Cod (snd f)\<rbrace> \<cdot>\<^sub>B (Map (fst f) \<star>\<^sub>B Map (snd f))"
                     by simp
                   also have "... = Map (fst f) \<star>\<^sub>B Map (snd f)"
                   proof -
                     have 1: "\<forall>p. arr p \<longrightarrow> map (cod p) \<cdot> map p = map p"
                       by blast
                     have 3: "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) = Map (map (cod (fst f)) \<cdot> map (fst f))"
                       by (simp add: f)
                     have 4: "map (cod (fst f)) \<cdot> map (fst f) = fst f"
                       using 1 f map_simp by simp
                     show ?thesis
                     proof -
                       have 2: "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) = Map (snd f)"
-                      proof -
-                        have "\<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
-                              Map (map (cod (snd f)) \<cdot> map (snd f))"
-                          by (simp add: f)
-                        moreover have "map (cod (snd f)) \<cdot> map (snd f) = snd f"
-                          using 1 f map_simp by simp
-                        ultimately show ?thesis by presburger
-                      qed
+                        using 1 f map_simp
+                        by (metis (no_types, lifting) Dom_cod Map_cod Map_comp arr_cod)
                       have "B.seq \<lbrace>Cod (snd f)\<rbrace> (Map (snd f))"
                         using f 2 by auto
                       moreover have "B.seq \<lbrace>Cod (fst f)\<rbrace> (Map (fst f))"
                         using 4 f 3 by auto
                       moreover have
                         "\<lbrace>Cod (fst f)\<rbrace> \<cdot>\<^sub>B Map (fst f) \<star>\<^sub>B \<lbrace>Cod (snd f)\<rbrace> \<cdot>\<^sub>B Map (snd f) =
                          Map (fst f) \<star>\<^sub>B Map (snd f)"
                         using 2 3 4 by presburger
                       ultimately show ?thesis
                         by (simp add: B.interchange)
                     qed
                   qed
                   finally have
                     "(B.can (Dom (fst g) \<^bold>\<star> Dom (snd g)) (Dom (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd g)) \<cdot>\<^sub>B
                        B.can (Cod (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd f)) (Cod (fst f) \<^bold>\<star> Cod (snd f))) \<cdot>\<^sub>B
                        (Map (fst f) \<star>\<^sub>B Map (snd f)) =
                      Map (fst f) \<star>\<^sub>B Map (snd f)"
                     by simp
                   thus ?thesis
                     using fg B.comp_cod_arr by simp
                 qed
                 finally show ?thesis by simp
               qed
               also have "... = B.can (Cod (fst g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd g)) (Cod (fst g) \<^bold>\<star> Cod (snd g)) \<cdot>\<^sub>B
                                  (Map (fst g \<cdot> fst f) \<star>\<^sub>B Map (snd g \<cdot> snd f)) \<cdot>\<^sub>B
                                  B.can (Dom (fst f) \<^bold>\<star> Dom (snd f)) (Dom (fst f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd f))"
               proof -
                 have 2: "Dom (fst g) = Cod (fst f)"
                   using 0 f g fg VV.seq_char [of g f] VV.arr_char arr_char seq_char
                   by (metis (no_types, lifting) fst_conv)
                 hence "Map (fst g \<cdot> fst f) = Map (fst g) \<cdot>\<^sub>B Map (fst f)"
                   using f g Map_comp [of "fst f" "fst g"] by simp
                 moreover have "B.seq (Map (fst g)) (Map (fst f)) \<and>
                                B.seq (Map (snd g)) (Map (snd f))"
                   using f g 0 1 2 arr_char
                   by (metis (no_types, lifting) B.seqI' prod.sel(2) seq_char)
                 ultimately show ?thesis
                   using 0 1 seq_char Map_comp B.interchange by auto
               qed
               also have "... = Map ?X"
                 using fg 0 1 by (simp add: seq_char)
               finally show ?thesis by simp
             qed
           qed
           finally show ?thesis by simp
         qed
         finally show "fst (VV.comp g f) \<star> snd (VV.comp g f) = (fst g \<star> snd g) \<cdot> (fst f \<star> snd f)"
           by simp
       qed
     qed
 
     interpretation horizontal_composition vcomp hcomp src trg
       using hseq_char by (unfold_locales, auto)
 
     lemma hcomp_assoc:
     assumes "arr \<mu>" and "arr \<nu>" and "arr \<tau>"
     and "src \<mu> = trg \<nu>" and "src \<nu> = trg \<tau>"
     shows "(\<mu> \<star> \<nu>) \<star> \<tau> = \<mu> \<star> \<nu> \<star> \<tau>"
     proof (intro arr_eqI)
       have \<mu>\<nu>: "\<guillemotleft>Map \<mu> \<star>\<^sub>B Map \<nu> : \<lbrace>Dom \<mu> \<^bold>\<star> Dom \<nu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<mu> \<^bold>\<star> Cod \<nu>\<rbrace>\<guillemotright>"
         using assms src_def trg_def arr_char
         by (auto simp add: E.eval_simps'(2-3) Pair_inject)
       have \<nu>\<tau>: "\<guillemotleft>Map \<nu> \<star>\<^sub>B Map \<tau> : \<lbrace>Dom \<nu> \<^bold>\<star> Dom \<tau>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod \<nu> \<^bold>\<star> Cod \<tau>\<rbrace>\<guillemotright>"
         using assms src_def trg_def arr_char
         by (auto simp add: E.eval_simps'(2-3) Pair_inject)
       show "hseq (\<mu> \<star> \<nu>) \<tau>"
         using assms \<mu>\<nu> \<nu>\<tau> by auto
       show "hseq \<mu> (\<nu> \<star> \<tau>)"
         using assms \<mu>\<nu> \<nu>\<tau> by auto
       show "Dom ((\<mu> \<star> \<nu>) \<star> \<tau>) = Dom (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "E.Nml (Dom \<mu>) \<and> E.Nml (Dom \<nu>) \<and> E.Nml (Dom \<tau>)"
           using assms by blast
         moreover have "E.Src (Dom \<mu>) = E.Trg (Dom \<nu>) \<and> E.Src (Dom \<nu>) = E.Trg (Dom \<tau>)"
           using assms \<mu>\<nu> \<nu>\<tau>
           by (metis (no_types, lifting) src_simps(2) trg_simps(2))
         ultimately show ?thesis
           using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
       qed
       show "Cod ((\<mu> \<star> \<nu>) \<star> \<tau>) = Cod (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "E.Nml (Cod \<mu>) \<and> E.Nml (Cod \<nu>) \<and> E.Nml (Cod \<tau>)"
           using assms by blast
         moreover have "E.Src (Cod \<mu>) = E.Trg (Cod \<nu>) \<and> E.Src (Cod \<nu>) = E.Trg (Cod \<tau>)"
           using assms \<mu>\<nu> \<nu>\<tau>
           by (metis (no_types, lifting) arrE src_simps(2) trg_simps(2))
         ultimately show ?thesis
           using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc by simp
       qed
      show "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
       proof -
         have "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
               B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                 (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                    B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
         proof -
           have 1: "Map ((\<mu> \<star> \<nu>) \<star> \<tau>) =
                    B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                        B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms \<mu>\<nu> \<nu>\<tau> hcomp_def E.HcompNml_assoc src_def trg_def arr_char
                   E.Nml_HcompNml E.Ide_HcompNml
             by auto (* 5 sec *)
           also have
             "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
                        B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have
               "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                  (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau> =
                B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                  (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                  B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
             proof -
               have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<cdot>\<^sub>B
                       (Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)
                          \<star>\<^sub>B Map \<tau> =
                     (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                       ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B Map \<tau>)"
               proof -
                 have "B.seq (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>))
                                ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<cdot>\<^sub>B B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
                   by (metis (no_types, lifting) B.arrI Map_hcomp arrE arr_hcomp
                       assms(1) assms(2) assms(4))
                 moreover have "B.seq (B.can (Cod \<tau>) (Cod \<tau>)) (Map \<tau>)"
                   using B.can_in_hom assms(3) by blast
                 moreover have "B.ide (B.can (Cod \<tau>) (Cod \<tau>))"
                   using B.can_Ide_self E.ide_eval_Ide arr_char assms(3) by presburger
                 ultimately show ?thesis
                   by (metis (no_types) B.comp_ide_arr B.interchange)
               qed
               also have
                 "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          ((Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                            (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                               B.can (Dom \<tau>) (Dom \<tau>))"
               proof -
                 have "B.seq (Map \<mu> \<star>\<^sub>B Map \<nu>) (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>))"
                   by (metis (no_types, lifting) B.arrI B.comp_null(2) B.ext Map_hcomp
                       arrE arr_hcomp assms(1) assms(2) assms(4))
                 moreover have "B.seq (Map \<tau>) (B.can (Dom \<tau>) (Dom \<tau>))"
                   using assms(3) by fastforce
                 ultimately show ?thesis
                   using B.interchange
                   by (metis (no_types, lifting) B.can_Ide_self B.comp_arr_ide E.ide_eval_Ide
                       arrE assms(3))
               qed
               also have
                 "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                            (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                              B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)) \<cdot>\<^sub>B
                            (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                               B.can (Dom \<tau>) (Dom \<tau>))"
               proof -
                 have "(Map \<mu> \<star>\<^sub>B Map \<nu>) \<star>\<^sub>B Map \<tau> =
                         B.\<a>' \<lbrace>Cod \<mu>\<rbrace> \<lbrace>Cod \<nu>\<rbrace> \<lbrace>Cod \<tau>\<rbrace> \<cdot>\<^sub>B
                           (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                              \<a>\<^sub>B \<lbrace>Dom \<mu>\<rbrace> \<lbrace>Dom \<nu>\<rbrace> \<lbrace>Dom \<tau>\<rbrace>"
                   using B.hcomp_reassoc(1)
                   by (metis (no_types, lifting) B.hcomp_in_vhomE B.in_homE \<mu>\<nu> \<nu>\<tau> arrE
                       assms(1) assms(2) assms(3))
                 also have "... = B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                                    (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                       B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                   using assms arr_char src_def trg_def arr_char B.canE_associator by simp
                finally show ?thesis by simp
               qed
               also have
                 "... = ((B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                          (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                        (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                           (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B
                              B.can (Dom \<tau>) (Dom \<tau>)))"
                 using B.comp_assoc by simp
               also have
                 "... = B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                          (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
               proof -
                 have "(B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) (Cod \<mu> \<^bold>\<star> Cod \<nu>) \<star>\<^sub>B B.can (Cod \<tau>) (Cod \<tau>)) \<cdot>\<^sub>B
                         (B.can ((Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) =
                       B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
                 proof -
                   have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
                         src_simps(1) trg_simps(1))
                   moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>)"
                     using E.Ide_HcompNml assms(1) assms(2) calculation by auto
                   moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>\<^bold>\<rfloor>"
                     using E.Nml_HcompNml(1) assms(1) assms(2) calculation(1) by fastforce
                   moreover have "E.Src (Cod \<mu> \<^bold>\<star> Cod \<nu>) = E.Trg (Cod \<tau>)"
                     by (metis (no_types, lifting) E.Src.simps(3) arrE assms(2-3,5)
                         src_simps(2) trg_simps(2))
                   moreover have "E.Src (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) = E.Trg (Cod \<tau>)"
                     using E.Src_HcompNml assms(1) assms(2) calculation(1) calculation(4)
                     by fastforce
                   moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<star> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
                     by (metis (no_types, lifting) E.Arr.simps(3) E.Nmlize_Hcomp_Hcomp
                         E.Nmlize_Hcomp_Hcomp' E.Ide_implies_Arr E.Src.simps(3) arrE assms(3)
                         calculation(1) calculation(4))
                   ultimately show ?thesis
                     using assms(3) B.hcomp_can B.vcomp_can by auto
                 qed
                 moreover have
                   "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                      (B.can (Dom \<mu> \<^bold>\<star> Dom \<nu>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<star>\<^sub>B B.can (Dom \<tau>) (Dom \<tau>)) =
                    B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                 proof -
                   have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>)"
                     by (metis (no_types, lifting) E.Ide_HcompNml arrE assms(1-2,4)
                         src_simps(2) trg_simps(2))
                   moreover have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) arrE assms(1-2,4)
                         src_simps(1) trg_simps(1))
                   moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu>\<^bold>\<rfloor>"
                     using E.Nml_HcompNml(1) assms(1-2) calculation(2) by fastforce
                   moreover have "E.Src (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) = E.Trg (Dom \<tau>)"
                     by (metis (no_types, lifting) E.Ide.simps(3) E.Src_HcompNml arrE
                         assms(1-3,5) calculation(2) src_simps(2) trg_simps(2))
                   moreover have "E.Src (Dom \<mu> \<^bold>\<star> Dom \<nu>) = E.Trg (Dom \<tau>)"
                     using E.Src_HcompNml assms(1-2) calculation(2) calculation(4)
                     by fastforce
                   moreover have "E.Ide ((Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                     using E.Ide.simps(3) assms(3) calculation(2) calculation(5) by blast
                   moreover have "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<star> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
                     using E.Nmlize_Hcomp_Hcomp calculation(6) by auto
                   ultimately show ?thesis
                     using assms(3) B.hcomp_can B.vcomp_can by auto
                 qed
                 ultimately show ?thesis by simp
               qed
               finally show ?thesis by simp
             qed
             thus ?thesis by simp
           qed
           also have
             "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                      B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                            B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using B.comp_assoc by simp
           also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                              (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have "B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                     B.can ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) =
                   B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
             proof -
               have "E.Ide (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>)"
                 using assms src_def trg_def by fastforce
               moreover have "E.Ide ((Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>)"
                 using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
                 by auto
               moreover have "E.Ide (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>)"
                 using assms arr_char src_def trg_def
                 by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
               moreover have "\<^bold>\<lfloor>Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
               moreover have "\<^bold>\<lfloor>(Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu>) \<^bold>\<star> Cod \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
                 by simp
               ultimately show ?thesis by simp
             qed
             moreover have
               "B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) \<cdot>\<^sub>B
                  B.can ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
                B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             proof -
               have "E.Ide (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>)"
                 using assms src_def trg_def by fastforce
               moreover have "E.Ide ((Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>)"
                 using assms arr_char src_def trg_def E.Ide_HcompNml E.Src_HcompNml
                 by auto
               moreover have "E.Ide (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
                 using assms arr_char src_def trg_def
                 by (simp add: E.Nml_HcompNml(1) E.Ide_HcompNml E.Trg_HcompNml)
               moreover have "\<^bold>\<lfloor>Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc by simp
               moreover have
                 "\<^bold>\<lfloor>(Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu>) \<^bold>\<star> Dom \<tau>\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>\<^bold>\<rfloor>"
                 using assms arr_char src_def trg_def E.Nml_HcompNml E.HcompNml_assoc
                 by simp
               ultimately show ?thesis by simp
             qed
             ultimately show ?thesis by simp
           qed
           finally show ?thesis by simp
         qed
         also have "... = Map (\<mu> \<star> \<nu> \<star> \<tau>)"
         proof -
           have 1: "Map (\<mu> \<star> \<nu> \<star> \<tau>) =
                    B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      (Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                                 (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                   B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
                         B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms Map_hcomp [of \<mu> "\<nu> \<star> \<tau>"] Map_hcomp [of \<nu> \<tau>] by simp
           also have
             "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      ((B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                             B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))) \<cdot>\<^sub>B
                      B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
           proof -
             have "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                             (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                               B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
                     (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                           B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               using assms B.interchange B.comp_cod_arr
               by (metis (no_types, lifting) B.can_Ide_self B.in_homE Map_hcomp arrE hseq_char)
             also have "... = (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B
                                  B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                                (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                  (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                                     B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               using assms B.interchange B.comp_arr_dom [of "Map \<mu>" "B.can (Dom \<mu>) (Dom \<mu>)"]
               by (metis (no_types, lifting) B.can_Ide_self B.comp_null(2) B.ext B.in_homE
                   Map_hcomp arrE hseq_char)
             finally have
               "Map \<mu> \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                  (Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                    B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) =
               (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>)) \<cdot>\<^sub>B
                 (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                   (B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
               by simp
             thus ?thesis by simp
           qed
           also have
             "... = (B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) \<cdot>\<^sub>B
                      (B.can (Cod \<mu>) (Cod \<mu>) \<star>\<^sub>B B.can (Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<nu> \<^bold>\<star> Cod \<tau>))) \<cdot>\<^sub>B
                        (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                          ((B.can (Dom \<mu>) (Dom \<mu>) \<star>\<^sub>B
                              B.can (Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)) \<cdot>\<^sub>B
                            B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>))"
             using B.comp_assoc by simp
           also have "... = B.can (Cod \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod \<tau>) (Cod \<mu> \<^bold>\<star> Cod \<nu> \<^bold>\<star> Cod \<tau>) \<cdot>\<^sub>B
                              (Map \<mu> \<star>\<^sub>B Map \<nu> \<star>\<^sub>B Map \<tau>) \<cdot>\<^sub>B
                                 B.can (Dom \<mu> \<^bold>\<star> Dom \<nu> \<^bold>\<star> Dom \<tau>) (Dom \<mu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<nu> \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom \<tau>)"
             using assms \<mu>\<nu> \<nu>\<tau> E.HcompNml_assoc src_def trg_def arr_char
                   E.Src_HcompNml E.Trg_HcompNml E.Nml_HcompNml E.Ide_HcompNml
             by simp
           finally show ?thesis by simp
         qed
         ultimately show ?thesis by metis
       qed
     qed
 
     lemma obj_char:
     shows "obj a \<longleftrightarrow> endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
     proof
       assume a: "obj a"
       show "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
       proof (intro conjI)
         show "endo a"
           using a ide_char by blast
         show "E.Obj (Dom a)"
           using a ide_char src_def
           by (metis (no_types, lifting) E.Ide_implies_Arr E.Obj_Trg arrE obj_def
               trg_simps(1) trg_src) 
         show "Map a = \<lbrace>Dom a\<rbrace>"
           using a ide_char src_def by blast
       qed
       next
       assume a: "endo a \<and> E.Obj (Dom a) \<and> Map a = \<lbrace>Dom a\<rbrace>"
       show "obj a"
       proof -
         have "arr a" using a by auto
         moreover have "src a = a"
           using a E.Obj_in_Hom(1) seq_char by (intro arr_eqI, auto)
         ultimately show ?thesis
           using obj_def by simp
       qed
     qed
 
     lemma hcomp_obj_self:
     assumes "obj a"
     shows "a \<star> a = a"
     proof (intro arr_eqI)
       show "hseq a a"
         using assms by auto
       show "arr a"
         using assms by auto
       show 1: "Dom (a \<star> a) = Dom a"
         unfolding hcomp_def
         using assms arr_char E.HcompNml_Trg_Nml
         apply simp
         by (metis (no_types, lifting) objE obj_def trg_simps(1))
       show 2: "Cod (a \<star> a) = Cod a"
         unfolding hcomp_def
         using assms 1 arr_char E.HcompNml_Trg_Nml
         apply simp
         by (metis (no_types, lifting) Dom_hcomp ideE objE)
       show "Map (a \<star> a) = Map a"
         using "1" Map_ide(1) assms by fastforce
     qed
 
     lemma hcomp_ide_src:
     assumes "ide f"
     shows "f \<star> src f = f"
     proof (intro arr_eqI)
       show "hseq f (src f)"
         using assms by simp
       show "arr f"
         using assms by simp
       show 1: "Dom (f \<star> src f) = Dom f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Nml_Src
         by (metis (no_types, lifting) ideD(1))
       show "Cod (f \<star> src f) = Cod f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Nml_Src
         by (metis (no_types, lifting) ideD(1))
       show "Map (f \<star> src f) = Map f"
         by (simp add: "1" Map_ide(1) assms)
     qed
 
     lemma hcomp_trg_ide:
     assumes "ide f"
     shows "trg f \<star> f = f"
     proof (intro arr_eqI)
       show "hseq (trg f) f"
         using assms by auto
       show "arr f"
         using assms by auto
       show 1: "Dom (trg f \<star> f) = Dom f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Trg_Nml
         by (metis (no_types, lifting) ideD(1))
       show "Cod (trg f \<star> f) = Cod f"
         unfolding hcomp_def
         using assms apply simp
         using assms ide_char arr_char E.HcompNml_Trg_Nml
         by (metis (no_types, lifting)  ideD(1))
       show "Map (trg f \<star> f) = Map f"
         by (simp add: "1" Map_ide(1) assms)
     qed
 
     interpretation L: full_functor vcomp vcomp L
     proof
       fix a a' g
       assume a: "ide a" and a': "ide a'"
       assume g: "in_hom g (L a') (L a)"
       have a_eq: "a = MkIde (Dom a)"
         using a dom_char [of a] by simp
       have a'_eq: "a' = MkIde (Dom a')"
         using a' dom_char [of a'] by simp
       have 1: "Cod g = Dom a"
       proof -
         have "Dom (L a) = Dom a"
           by (simp add: a hcomp_trg_ide)
         thus ?thesis
           using g cod_char [of g]
           by (metis (no_types, lifting) Dom_cod in_homE)
       qed
       have 2: "Dom g = Dom a'"
         using a' g hcomp_trg_ide in_hom_char by auto
       let ?f = "MkArr (Dom a') (Cod a) (Map g)"
       have f: "in_hom ?f a' a"
         by (metis (no_types, lifting) "1" "2" MkArr_Map a a' g ideE in_hom_char)
       moreover have "L ?f = g"
       proof -
         have "L ?f =
               trg (MkArr (Dom a') (Cod a) (Map g)) \<star> MkArr (Dom a') (Cod a) (Map g)"
           using f by auto
         also have "... = MkIde (E.Trg (Cod a)) \<star> MkArr (Dom a') (Cod a) (Map g)"
           using a a' f trg_def [of a] vconn_implies_hpar by auto
         also have "... = MkArr (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a)
                                (B.can (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
                                  (\<lbrace>E.Trg (Cod a)\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
                                  B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a'))"
           using hcomp_def
           apply simp
           by (metis (no_types, lifting) Cod.simps(1) arrE f in_homE src_trg trg.preserves_arr
               trg_def)
         also have "... = MkArr (Dom a') (Cod a)
                                (B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) \<cdot>\<^sub>B
                                  (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B
                                  B.can (E.Trg (Cod a) \<^bold>\<star> Dom a') (Dom a'))"
         proof -
           have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom a' = Dom a'"
             using a a' arr_char E.HcompNml_Trg_Nml
             by (metis (no_types, lifting) f ideE trg_simps(1) vconn_implies_hpar(4))
           moreover have "E.Trg (Cod a) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod a = Cod a"
             using a a' arr_char E.HcompNml_Trg_Nml by blast
           moreover have "\<lbrace>E.Trg (Cod a)\<rbrace> = trg\<^sub>B \<lbrace>Cod a\<rbrace>"
             using a a' arr_char E.eval_simps'(3) by fastforce
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom a') (Cod a)
                            (B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace>)"
         proof -
           have "E.Trg (Cod a) = E.Trg (Dom a')"
             using a a' a_eq g ide_char arr_char src_def trg_def trg_hcomp
                   \<open>Cod g = Dom a\<close> \<open>Dom g = Dom a'\<close>
             by (metis (no_types, lifting) Cod.simps(1) in_homE)
           moreover have "B.can (Cod a) (E.Trg (Cod a) \<^bold>\<star> Cod a) = B.lunit \<lbrace>Cod a\<rbrace>"
             using a ide_char arr_char B.canE_unitor(2) by blast
           moreover have "B.can (E.Trg (Dom a') \<^bold>\<star> Dom a') (Dom a') = B.lunit' \<lbrace>Dom a'\<rbrace>"
             using a' ide_char arr_char B.canE_unitor(4) by blast
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom g) (Cod g) (Map g)"
         proof -
           have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
             using a f g ide_char arr_char src_def B.comp_cod_arr
             by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
                 Cod.simps(1) Map.simps(1) in_homE)
           moreover have
             "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> = Map g"
           proof -
             have "B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B (Map g) \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom g\<rbrace> =
                   B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g ide_char arr_char B.lunit'_naturality
               by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
             also have "... = (B.lunit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.lunit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
               using B.comp_assoc by simp
             also have "... = \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g E.ide_eval_Ide B.comp_arr_inv' by fastforce
             also have "... = Map g"
               using g E.ide_eval_Ide B.comp_cod_arr by fastforce
             finally show ?thesis by simp
           qed
           ultimately have
             "B.lunit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (trg\<^sub>B \<lbrace>Cod a\<rbrace> \<star>\<^sub>B Map g) \<cdot>\<^sub>B B.lunit' \<lbrace>Dom a'\<rbrace> = Map g"
             using a a' 1 2 f g hcomp_def dom_char cod_char
             by (metis (no_types, lifting) B.comp_null(2) B.ext B.lunit_simps(2) B.lunit_simps(3)
                 B.src.preserves_reflects_arr B.trg_vcomp B.vseq_implies_hpar(1) ideE)
           thus ?thesis
             using a 1 2 by auto
         qed
         also have "... = g"
           using g MkArr_Map by blast
         finally show ?thesis by simp
       qed
       ultimately show "\<exists>f. in_hom f a' a \<and> L f = g"
         by blast
     qed
 
     interpretation R: full_functor vcomp vcomp R
     proof
       fix a a' g
       assume a: "ide a" and a': "ide a'"
       assume g: "in_hom g (R a') (R a)"
       have a_eq: "a = MkIde (Dom a)"
         using a dom_char [of a] by simp
       have a'_eq: "a' = MkIde (Dom a')"
         using a' dom_char [of a'] by simp
       have 1: "Cod g = Dom a"
         using a g hcomp_ide_src in_hom_char by force
       have 2: "Dom g = Dom a'"
         using a' g hcomp_ide_src by auto
       let ?f = "MkArr (Dom a') (Cod a) (Map g)"
       have f: "in_hom ?f a' a"
       proof (intro in_homI)
         show 3: "arr (MkArr (Dom a') (Cod a) (Map g))"
           by (metis (no_types, lifting) "1" "2" Cod.simps(1) MkArr_Map a_eq g in_homE)
         show "dom (MkArr (Dom a') (Cod a) (Map g)) = a'"
           using a a' 3 dom_char by auto
         show "cod (MkArr (Dom a') (Cod a) (Map g)) = a"
           using a a' 3 cod_char by auto
       qed
       moreover have "R ?f = g"
       proof -
         have "R ?f =
                MkArr (Dom a') (Cod a) (Map g) \<star> src (MkArr (Dom a') (Cod a) (Map g))"
           using f by auto
         also have "... = MkArr (Dom a') (Cod a) (Map g) \<star> MkIde (E.Src (Cod a))"
           using a a' f src_def [of a] vconn_implies_hpar by auto
         also have "... = MkArr (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a))
                                (B.can (Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B \<lbrace>E.Src (Cod a)\<rbrace>) \<cdot>\<^sub>B
                                  B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a)))"
           using hcomp_def
           apply simp
           by (metis (no_types, lifting) Cod_cod arrE f in_homE trg_src src.preserves_arr src_def)
         also have "... = MkArr (Dom a') (Cod a)
                                (B.can (Cod a) (Cod a \<^bold>\<star> E.Src (Cod a)) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B
                                  B.can (Dom a' \<^bold>\<star> E.Src (Cod a)) (Dom a'))"
         proof -
           have "Dom a' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Dom a'"
             using a a' arr_char E.HcompNml_Nml_Src
             by (metis (no_types, lifting) f ideE src_simps(1) vconn_implies_hpar(3))
           moreover have "Cod a \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Cod a) = Cod a"
             using a a' arr_char E.HcompNml_Nml_Src by blast
           moreover have "\<lbrace>E.Src (Cod a)\<rbrace> = src\<^sub>B \<lbrace>Cod a\<rbrace>"
             using a a' arr_char E.eval_simps'(2) by fastforce
           ultimately show ?thesis by simp
         qed
         also have "... = MkArr (Dom a') (Cod a)
                                (B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace>)"
           by (metis (no_types, lifting) B.canE_unitor(1) B.canE_unitor(3) a a' arrE f ideE
               src_simps(1) vconn_implies_hpar(3))
         also have "... = MkArr (Dom g) (Cod g) (Map g)"
         proof -
           have "src\<^sub>B \<lbrace>Cod a\<rbrace> = src\<^sub>B (Map g)"
             using a f g ide_char arr_char src_def B.comp_cod_arr
             by (metis (no_types, lifting) B.vconn_implies_hpar(1) B.vconn_implies_hpar(3)
                 Cod.simps(1) Map.simps(1) in_homE)
           moreover have
             "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> = Map g"
           proof -
             have "B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B (Map g)) \<cdot>\<^sub>B B.runit' \<lbrace>Dom g\<rbrace> =
                   B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit'\<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g ide_char arr_char B.runit'_naturality [of "Map g"]
               by (metis (no_types, lifting) partial_magma_axioms B.in_homE partial_magma.arrI)
             also have "... = (B.runit \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B B.runit' \<lbrace>Cod g\<rbrace>) \<cdot>\<^sub>B Map g"
               using B.comp_assoc by simp
             also have "... = \<lbrace>Cod g\<rbrace> \<cdot>\<^sub>B Map g"
               using g E.ide_eval_Ide B.comp_arr_inv' by fastforce
             also have "... = Map g"
               using g E.ide_eval_Ide B.comp_cod_arr by fastforce
             finally show ?thesis by simp
           qed
           ultimately have
             "B.runit \<lbrace>Cod a\<rbrace> \<cdot>\<^sub>B (Map g \<star>\<^sub>B src\<^sub>B \<lbrace>Cod a\<rbrace>) \<cdot>\<^sub>B B.runit' \<lbrace>Dom a'\<rbrace> = Map g"
             using a a' 1 2 f g hcomp_def dom_char cod_char
             by (metis (no_types, lifting) ideE)
           thus ?thesis
             using a 1 2 by auto
         qed
         also have "... = g"
            using g MkArr_Map by blast
         finally show ?thesis by simp
       qed
       ultimately show "\<exists>f. in_hom f a' a \<and> R f = g"
         by blast
     qed
 
     interpretation L: faithful_functor vcomp vcomp L
     proof
       fix f f'
       assume par: "par f f'" and eq: "L f = L f'"
       show "f = f'"
       proof (intro arr_eqI)
         have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
           using par dom_char cod_char by auto
         show "arr f"
           using par by simp
         show "arr f'"
           using par by simp
         show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
           using 1 by auto
         show "Map f = Map f'"
         proof -
           have "B.L (Map f) = trg\<^sub>B (Map f) \<star>\<^sub>B Map f"
             using par by auto
           also have "... = trg\<^sub>B (Map f') \<star>\<^sub>B Map f'"
           proof -
             have "\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f = \<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f'"
             proof -
               have A: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) :
                           \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def
                 by (metis (no_types, lifting) E.eval_simps(3) E.ide_eval_Ide E.Ide_implies_Arr
                     B.canE_unitor(4) B.lunit'_in_vhom)
               have B: "\<guillemotleft>B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) :
                           \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def
                 by (metis (no_types, lifting) E.Nmlize.simps(3) E.eval.simps(3) E.Ide.simps(3)
                     E.Ide_implies_Arr E.Src_Trg trg.preserves_arr trg_simps(2))
               have C: "\<guillemotleft>\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f :
                           \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B \<lbrace>Cod f\<rbrace>\<guillemotright>"
                 using par arr_char
                 by (metis (no_types, lifting) E.eval_simps'(1) E.eval_simps(3) E.ide_eval_Ide
                     E.Ide_implies_Arr E.Obj_Trg E.Obj_implies_Ide B.hcomp_in_vhom
                     B.ide_in_hom(2) B.src_trg)
               have 3: "(\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                           B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
                         (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                             B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
               proof -
                 have 2: "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) \<cdot>\<^sub>B
                           (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                             B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f) =
                          B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f') \<cdot>\<^sub>B
                            (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                              B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f')"
                   using par eq hcomp_def trg_def src_trg trg.preserves_arr Map_hcomp
                         trg_simps(1) trg_simps(2) trg_simps(3)
                   by auto
                 have "B.mono (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))"
                   using par arr_char B.inverse_arrows_can B.iso_is_section B.section_is_mono
                         src_def trg_def E.Nmlize_Nml E.HcompNml_Trg_Nml E.Ide_implies_Arr
                         trg.preserves_arr trg_simps(1)
                   by auto
                 moreover have
                   "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
                      ((\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f) \<cdot>\<^sub>B
                        B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using A B C by auto
                 moreover have
                   "B.seq (B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f))
                      ((\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f') \<cdot>\<^sub>B
                        B.can (E.Trg (Dom f') \<^bold>\<star> Dom f') (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f'))"
                   using par 1 2 arr_char calculation(2) by auto
                 moreover have "B.can (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f) (E.Trg (Dom f) \<^bold>\<star> Cod f) =
                                B.can (E.Trg (Dom f') \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod f') (E.Trg (Dom f') \<^bold>\<star> Cod f')"
                   using par 1 arr_char by simp
                 ultimately show ?thesis
                   using 2 B.monoE cod_char by auto
               qed
               show ?thesis
               proof -
                 have "B.epi (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using par arr_char B.inverse_arrows_can B.iso_is_retraction
                         B.retraction_is_epi E.Nmlize_Nml E.HcompNml_Trg_Nml src_def trg_def
                         E.Ide_implies_Arr
                   by (metis (no_types, lifting) E.Nmlize.simps(3) E.Ide.simps(3) E.Src_Trg
                       trg.preserves_arr trg_simps(1))
                 moreover have "B.seq (\<lbrace>E.Trg (Dom f)\<rbrace> \<star>\<^sub>B Map f)
                                      (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using A C by auto
                 moreover have "B.seq (\<lbrace>E.Trg (Dom f')\<rbrace> \<star>\<^sub>B Map f')
                                      (B.can (E.Trg (Dom f) \<^bold>\<star> Dom f) (E.Trg (Dom f) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom f))"
                   using 1 3 calculation(2) by auto
                 ultimately show ?thesis
                   using par 1 3 arr_char B.epiE by simp
               qed
             qed
             moreover have "trg\<^sub>B (Map f) = \<lbrace>E.Trg (Dom f)\<rbrace> \<and>
                            trg\<^sub>B (Map f') = \<lbrace>E.Trg (Dom f')\<rbrace>"
               using par arr_char trg_def E.Ide_implies_Arr B.comp_arr_dom
                     B.vseq_implies_hpar(2) E.eval_simps(3)
               by (metis (no_types, lifting) B.vconn_implies_hpar(2))
             ultimately show ?thesis by simp
           qed
           also have "... = B.L (Map f')"
             using par B.hseqE B.hseq_char' by auto
           finally have "B.L (Map f) = B.L (Map f')"
             by simp
           thus ?thesis
             using 2 3 par arr_char B.L.is_faithful
             by (metis (no_types, lifting) B.in_homE)
         qed
       qed
     qed
 
     interpretation R: faithful_functor vcomp vcomp R
     proof
       fix f f'
       assume par: "par f f'" and eq: "R f = R f'"
       show "f = f'"
       proof (intro arr_eqI)
         have 1: "Dom f = Dom f' \<and> Cod f = Cod f'"
           using par dom_char cod_char by auto
         show "arr f"
           using par by simp
         show "arr f'"
           using par by simp
         show 2: "Dom f = Dom f'" and 3: "Cod f = Cod f'"
           using 1 by auto
         show "Map f = Map f'"
         proof -
           have "B.R (Map f) = Map f \<star>\<^sub>B src\<^sub>B (Map f)"
             using par apply simp by (metis B.hseqE B.hseq_char')
           also have "... = Map f' \<star>\<^sub>B src\<^sub>B (Map f')"
           proof -
             have "Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> = Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>"
             proof -
               have 2: "E.Ide (Cod f \<^bold>\<star> E.Src (Dom f))"
                 using par arr_char src.preserves_arr by auto
               hence 3: "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f))"
                 using par arr_char E.Nml_Src E.Ide_HcompNml calculation by auto
               have 4: "\<^bold>\<lfloor>Cod f \<^bold>\<star> E.Src (Dom f)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<^bold>\<rfloor>"
                 using par arr_char by (simp add: E.Nml_HcompNml(1))
               have A: "\<guillemotleft>B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) :
                           \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using par arr_char B.can_in_hom E.Ide_HcompNml
                       E.Ide_Nmlize_Ide E.Nml_Src E.Nmlize_Nml E.HcompNml_Nml_Src
                       src_def trg_def
                 by (metis (no_types, lifting) E.eval_simps(2) E.ide_eval_Ide E.Ide_implies_Arr
                     B.canE_unitor(3) B.runit'_in_vhom)
               have B: "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) :
                           \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using 2 3 4 B.can_in_hom [of "Cod f \<^bold>\<star> E.Src (Dom f)" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)"]
                 by simp
               have C: "\<guillemotleft>Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> :
                          \<lbrace>Dom f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod f\<rbrace> \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>\<guillemotright>"
                 using par arr_char E.Ide_Nmlize_Ide E.Nml_Trg E.Nmlize_Nml E.HcompNml_Trg_Nml
                       src_def trg_def E.ide_eval_Ide E.Ide_implies_Arr E.Obj_implies_Ide
                 apply (intro B.hcomp_in_vhom)
                   apply (simp add: B.ide_in_hom(2))
                  apply simp
                 by (metis (no_types, lifting) A B.ideD(1) B.not_arr_null B.seq_if_composable
                     B.src.preserves_reflects_arr B.vconn_implies_hpar(3) E.HcompNml_Nml_Src)
               have 5: "(Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
                         (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                             B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
               proof -
                 have 6: "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) \<cdot>\<^sub>B
                            (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                              B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) =
                          B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f')) \<cdot>\<^sub>B
                            (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                              B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f'))"
                   using par eq hcomp_def src_def trg_src src.preserves_arr Map_hcomp
                         src_simps(1) src_simps(2) src_simps(3)
                   by auto
                 have "B.mono (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))"
                   using 2 3 4 B.inverse_arrows_can(1) B.iso_is_section B.section_is_mono
                   by simp
                 moreover have
                   "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
                      ((Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>) \<cdot>\<^sub>B
                        B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using A B C by auto
                 moreover have
                   "B.seq (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)))
                      ((Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>) \<cdot>\<^sub>B
                        B.can (Dom f' \<^bold>\<star> E.Src (Dom f')) (Dom f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')))"
                   using par 1 6 arr_char calculation(2) by auto
                 moreover have "B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)) (Cod f \<^bold>\<star> E.Src (Dom f)) =
                                B.can (Cod f' \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f')) (Cod f' \<^bold>\<star> E.Src (Dom f'))"
                   using par 1 arr_char by simp
                 ultimately show ?thesis
                   using 6 B.monoE cod_char by auto
               qed
               show ?thesis
               proof -
                 have "B.epi (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using 2 3 4 B.inverse_arrows_can(1) B.iso_is_retraction B.retraction_is_epi
                   by (metis (no_types, lifting) E.Nml_Src E.Nmlize.simps(3) E.Nmlize_Nml
                       E.HcompNml_Nml_Src E.Ide.simps(3) par arrE)
                 moreover have "B.seq (Map f \<star>\<^sub>B \<lbrace>E.Src (Dom f)\<rbrace>)
                                    (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using A C by auto
                 moreover have "B.seq (Map f' \<star>\<^sub>B \<lbrace>E.Src (Dom f')\<rbrace>)
                                    (B.can (Dom f \<^bold>\<star> E.Src (Dom f)) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> E.Src (Dom f)))"
                   using 1 5 calculation(2) by auto
                 ultimately show ?thesis
                   using par 1 5 arr_char B.epiE by simp
               qed
             qed
             moreover have "src\<^sub>B (Map f) = \<lbrace>E.Src (Dom f)\<rbrace> \<and>
                            src\<^sub>B (Map f') = \<lbrace>E.Src (Dom f')\<rbrace>"
               using par arr_char src_def
               by (metis (no_types, lifting) B.vconn_implies_hpar(1) E.Nml_implies_Arr
                   E.eval_simps(2))
             ultimately show ?thesis by simp
           qed
           also have "... = B.R (Map f')"
             using par B.hseqE B.hseq_char' by auto
           finally have "B.R (Map f) = B.R (Map f')"
             by simp
           thus ?thesis
             using 2 3 par arr_char B.R.is_faithful
             by (metis (no_types, lifting) B.in_homE)
         qed
       qed
     qed
 
     definition \<a>
     where "\<a> \<tau> \<mu> \<nu> \<equiv> if VVV.arr (\<tau>, \<mu>, \<nu>) then hcomp \<tau> (hcomp \<mu> \<nu>) else null"
 
     interpretation natural_isomorphism VVV.comp vcomp HoHV HoVH
                      \<open>\<lambda>\<tau>\<mu>\<nu>. \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))\<close>
     proof
       show "\<And>\<tau>\<mu>\<nu>. \<not> VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow> \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>)) = null"
         using \<a>_def by simp
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                   dom (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = HoHV (VVV.dom \<tau>\<mu>\<nu>)"
         using VVV.arr_char VV.arr_char \<a>_def hcomp_assoc HoHV_def VVV.dom_simp VV.dom_simp
         by force
       show 1: "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                      cod (\<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))) = HoVH (VVV.cod \<tau>\<mu>\<nu>)"
         using VVV.arr_char VV.arr_char \<a>_def HoVH_def VVV.cod_simp VV.cod_simp by force
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                   HoVH \<tau>\<mu>\<nu> \<cdot>
                     \<a> (fst (VVV.dom \<tau>\<mu>\<nu>)) (fst (snd (VVV.dom \<tau>\<mu>\<nu>)))
                       (snd (snd (VVV.dom \<tau>\<mu>\<nu>))) =
                   \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
         using \<a>_def HoVH.as_nat_trans.is_natural_1 HoVH_def by auto
       show "\<And>\<tau>\<mu>\<nu>. VVV.arr \<tau>\<mu>\<nu> \<Longrightarrow>
                    \<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>)))
                      (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot> HoHV \<tau>\<mu>\<nu> =
                    \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
       proof -
         fix \<tau>\<mu>\<nu>
         assume \<tau>\<mu>\<nu>: "VVV.arr \<tau>\<mu>\<nu>"
         have "HoHV \<tau>\<mu>\<nu> = \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
           unfolding \<a>_def HoHV_def
           using \<tau>\<mu>\<nu> HoHV.preserves_cod hcomp_assoc VVV.arr_char VV.arr_char
           by simp
         thus "\<a> (fst (VVV.cod \<tau>\<mu>\<nu>)) (fst (snd (VVV.cod \<tau>\<mu>\<nu>))) (snd (snd (VVV.cod \<tau>\<mu>\<nu>))) \<cdot>
                 HoHV \<tau>\<mu>\<nu> =
               \<a> (fst \<tau>\<mu>\<nu>) (fst (snd \<tau>\<mu>\<nu>)) (snd (snd \<tau>\<mu>\<nu>))"
           using 1 \<tau>\<mu>\<nu> comp_cod_arr \<a>_def
           by (metis (no_types, lifting) HoVH_def HoHV.preserves_arr prod.collapse)
       qed
       show "\<And>fgh. VVV.ide fgh \<Longrightarrow> iso (\<a> (fst fgh) (fst (snd fgh)) (snd (snd fgh)))"
         using \<a>_def HoVH.preserves_ide HoVH_def by auto
     qed
 
     definition \<i>
     where "\<i> \<equiv> \<lambda>a. a"
 
     sublocale bicategory vcomp hcomp \<a> \<i> src trg
       using hcomp_obj_self \<a>_def hcomp_assoc VVV.arr_char VV.arr_char
       apply unfold_locales
       by (auto simp add: \<i>_def ide_in_hom(2))
 
     lemma is_bicategory:
     shows "bicategory vcomp hcomp \<a> \<i> src trg"
       ..
 
     sublocale strict_bicategory vcomp hcomp \<a> \<i> src trg
     proof
       show "\<And>fgh. ide fgh \<Longrightarrow> lunit fgh = fgh"
       proof -
         fix fgh
         assume fgh: "ide fgh"
         have "fgh = lunit fgh"
         proof (intro lunit_eqI)
           show "ide fgh" using fgh by simp
           show "\<guillemotleft>fgh : trg fgh \<star> fgh \<Rightarrow> fgh\<guillemotright>"
             using fgh hcomp_def hcomp_trg_ide by auto
           show "trg fgh \<star> fgh = (\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
           proof -
             have "(\<i> (trg fgh) \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh =
                   (trg fgh \<star> fgh) \<cdot> \<a>' (trg fgh) (trg fgh) fgh"
               using fgh \<i>_def by metis
             also have "... = (trg fgh \<star> fgh) \<cdot> (trg fgh \<star> trg fgh \<star> fgh)"
               using fgh \<a>_def by fastforce
             also have "... = trg fgh \<star> fgh"
               using fgh hcomp_obj_self hcomp_assoc
               by (simp add: hcomp_trg_ide)
             finally show ?thesis by simp
           qed
         qed
         thus "lunit fgh = fgh" by simp
       qed
       show "\<And>fgh. ide fgh \<Longrightarrow> runit fgh = fgh"
       proof -
         fix fgh
         assume fgh: "ide fgh"
         have "fgh = runit fgh"
         proof (intro runit_eqI)
           show "ide fgh" using fgh by simp
           show "\<guillemotleft>fgh : fgh \<star> src fgh \<Rightarrow> fgh\<guillemotright>"
             using fgh hcomp_def hcomp_ide_src by auto
           show "fgh \<star> src fgh = (fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh)"
           proof -
             have "(fgh \<star> \<i> (src fgh)) \<cdot> \<a> fgh (src fgh) (src fgh) =
                   (fgh \<star> src fgh) \<cdot> \<a> fgh (src fgh) (src fgh)"
               using fgh \<i>_def by metis
             also have "... = (fgh \<star> src fgh) \<cdot> (fgh \<star> src fgh \<star> src fgh)"
               using fgh \<a>_def by fastforce
             also have "... = fgh \<star> src fgh"
               using fgh comp_arr_dom hcomp_obj_self by simp
             finally show ?thesis by simp
           qed
         qed
         thus "runit fgh = fgh" by simp
       qed
       show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow> ide (\<a> f g h)"
         using \<a>_def VV.arr_char VVV.arr_char by auto
     qed
 
     theorem is_strict_bicategory:
     shows "strict_bicategory vcomp hcomp \<a> \<i> src trg"
       ..
 
     lemma iso_char:
     shows "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
     and "iso \<mu> \<Longrightarrow> inv \<mu> = MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
     proof -
       have 1: "iso \<mu> \<Longrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
       proof -
         assume \<mu>: "iso \<mu>"
         obtain \<nu> where \<nu>: "inverse_arrows \<mu> \<nu>"
           using \<mu> by auto
         have "B.inverse_arrows (Map \<mu>) (Map \<nu>)"
         proof
           show "B.ide (Map \<mu> \<cdot>\<^sub>B Map \<nu>)"
           proof -
             have "Map \<mu> \<cdot>\<^sub>B Map \<nu> = Map (\<mu> \<cdot> \<nu>)"
               using \<mu> \<nu> inverse_arrows_def Map_comp arr_char seq_char
               by (metis (no_types, lifting) ide_compE)
             moreover have "B.ide ..."
               using \<nu> ide_char by blast
             ultimately show ?thesis by simp
           qed
           show "B.ide (Map \<nu> \<cdot>\<^sub>B Map \<mu>)"
           proof -
             have "Map \<nu> \<cdot>\<^sub>B Map \<mu> = Map (\<nu> \<cdot> \<mu>)"
               using \<mu> \<nu> inverse_arrows_def comp_char [of \<nu> \<mu>] by simp
             moreover have "B.ide ..."
               using \<nu> ide_char by blast
             ultimately show ?thesis by simp
           qed
         qed
         thus "arr \<mu> \<and> B.iso (Map \<mu>)"
           using \<mu> by auto
       qed
       let ?\<nu> = "MkArr (Cod \<mu>) (Dom \<mu>) (B.inv (Map \<mu>))"
       have 2: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu> \<and> inv \<mu> = ?\<nu>"
       proof
         assume \<mu>: "arr \<mu> \<and> B.iso (Map \<mu>)"
         have \<nu>: "\<guillemotleft>?\<nu> : cod \<mu> \<Rightarrow> dom \<mu>\<guillemotright>"
           using \<mu> arr_char dom_char cod_char by auto
         have 4: "inverse_arrows \<mu> ?\<nu>"
         proof
           show "ide (?\<nu> \<cdot> \<mu>)"
           proof -
             have "?\<nu> \<cdot> \<mu> = dom \<mu>"
               using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_inv_arr' dom_char by auto
             thus ?thesis
               using \<mu> by simp
           qed
           show "ide (\<mu> \<cdot> ?\<nu>)"
           proof -
             have "\<mu> \<cdot> ?\<nu> = cod \<mu>"
               using \<mu> \<nu> MkArr_Map comp_char seq_char B.comp_arr_inv' cod_char by auto
             thus ?thesis
               using \<mu> by simp
           qed
         qed
         thus "iso \<mu>" by auto
         show "inv \<mu> = ?\<nu>"
           using 4 inverse_unique by simp
       qed
       have 3: "arr \<mu> \<and> B.iso (Map \<mu>) \<Longrightarrow> iso \<mu>"
         using 2 by simp
       show "iso \<mu> \<longleftrightarrow> arr \<mu> \<and> B.iso (Map \<mu>)"
         using 1 3 by blast
       show "iso \<mu> \<Longrightarrow> inv \<mu> = ?\<nu>"
         using 1 2 by blast
     qed
 
     subsection "The Strictness Theorem"
 
     text \<open>
       The Strictness Theorem asserts: ``Every bicategory is biequivalent to a strict bicategory.''
       This amounts to an equivalent (and perhaps more desirable) formulation of the
       Coherence Theorem.
       In this section we prove the Strictness Theorem by constructing an equivalence pseudofunctor
       from a bicategory to its strictification.
     \<close>
 
     text \<open>
       We define a map \<open>UP\<close> from the given bicategory \<open>B\<close> to its strictification,
       and show that it is an equivalence pseudofunctor.
       The following auxiliary definition is not logically necessary, but it provides some
       terms that can be the targets of simplification rules and thereby enables some proofs
       to be done by simplification that otherwise could not be.  Trying to eliminate it
       breaks some short proofs below, so I have kept it.
     \<close>
 
     definition UP\<^sub>0
     where "UP\<^sub>0 a \<equiv> if B.obj a then MkIde \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 else null"
 
     lemma obj_UP\<^sub>0 [simp]:
     assumes "B.obj a"
     shows "obj (UP\<^sub>0 a)"
       unfolding obj_def
       using assms UP\<^sub>0_def ide_MkIde [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] src_def by simp
 
     lemma UP\<^sub>0_in_hom [intro]:
     assumes "B.obj a"
     shows "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<rightarrow> UP\<^sub>0 a\<guillemotright>"
     and "\<guillemotleft>UP\<^sub>0 a : UP\<^sub>0 a \<Rightarrow> UP\<^sub>0 a\<guillemotright>"
       using assms obj_UP\<^sub>0 by blast+
 
     lemma UP\<^sub>0_simps [simp]:
     assumes "B.obj a"
     shows "ide (UP\<^sub>0 a)" "arr (UP\<^sub>0 a)"
     and "src (UP\<^sub>0 a) = UP\<^sub>0 a" and "trg (UP\<^sub>0 a) = UP\<^sub>0 a"
     and "dom (UP\<^sub>0 a) = UP\<^sub>0 a" and "cod (UP\<^sub>0 a) = UP\<^sub>0 a"
       using assms obj_UP\<^sub>0
            apply blast
       using assms obj_UP\<^sub>0 obj_simps
       by simp_all
 
     definition UP
     where "UP \<mu> \<equiv> if B.arr \<mu> then MkArr \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle> \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle> \<mu> else null"
 
     lemma Dom_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Dom (UP \<mu>) = \<^bold>\<langle>B.dom \<mu>\<^bold>\<rangle>"
       using assms UP_def by fastforce
 
     lemma Cod_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Cod (UP \<mu>) = \<^bold>\<langle>B.cod \<mu>\<^bold>\<rangle>"
       using assms UP_def by fastforce
 
     lemma Map_UP [simp]:
     assumes "B.arr \<mu>"
     shows "Map (UP \<mu>) = \<mu>"
       using assms UP_def by fastforce
 
     lemma arr_UP:
     assumes "B.arr \<mu>"
     shows "arr (UP \<mu>)"
       using assms UP_def
       by (intro arrI, fastforce+)
 
     lemma UP_in_hom [intro]:
     assumes "B.arr \<mu>"
     shows "\<guillemotleft>UP \<mu> : UP\<^sub>0 (src\<^sub>B \<mu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B \<mu>)\<guillemotright>"
     and "\<guillemotleft>UP \<mu> : UP (B.dom \<mu>) \<Rightarrow> UP (B.cod \<mu>)\<guillemotright>"
       using assms arr_UP UP_def UP\<^sub>0_def dom_char cod_char src_def trg_def by auto
 
     lemma UP_simps [simp]:
     assumes "B.arr \<mu>"
     shows "arr (UP \<mu>)"
     and "src (UP \<mu>) = UP\<^sub>0 (src\<^sub>B \<mu>)" and "trg (UP \<mu>) = UP\<^sub>0 (trg\<^sub>B \<mu>)"
     and "dom (UP \<mu>) = UP (B.dom \<mu>)" and "cod (UP \<mu>) = UP (B.cod \<mu>)"
       using assms arr_UP UP_in_hom by auto
 
     interpretation UP: "functor" V\<^sub>B vcomp UP
       using UP_def arr_UP UP_simps(4-5) arr_UP UP_def comp_char seq_char
       by unfold_locales auto
 
     interpretation UP: weak_arrow_of_homs V\<^sub>B src\<^sub>B trg\<^sub>B vcomp src trg UP
     proof
       fix \<mu>
       assume \<mu>: "B.arr \<mu>"
       show "isomorphic (UP (src\<^sub>B \<mu>)) (src (UP \<mu>))"
       proof -
         let ?\<phi> = "MkArr \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>src\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (src\<^sub>B \<mu>)"
         have \<phi>: "\<guillemotleft>?\<phi> : UP (src\<^sub>B \<mu>) \<Rightarrow> src (UP \<mu>)\<guillemotright>"
         proof
           show 1: "arr ?\<phi>"
             using \<mu> by (intro arrI, auto)
           show "dom ?\<phi> = UP (src\<^sub>B \<mu>)"
             using \<mu> 1 dom_char UP_def by simp
           show "cod ?\<phi> = src (UP \<mu>)"
             using \<mu> 1 cod_char src_def by auto
         qed
         have "iso ?\<phi>"
           using \<mu> \<phi> iso_char src_def by auto
         thus ?thesis
           using \<phi> isomorphic_def by auto
       qed
       show "isomorphic (UP (trg\<^sub>B \<mu>)) (trg (UP \<mu>))"
       proof -
         let ?\<phi> = "MkArr \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle> \<^bold>\<langle>trg\<^sub>B \<mu>\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B \<mu>)"
         have \<phi>: "\<guillemotleft>?\<phi> : UP (trg\<^sub>B \<mu>) \<Rightarrow> trg (UP \<mu>)\<guillemotright>"
         proof
           show 1: "arr ?\<phi>"
             using \<mu> by (intro arrI, auto)
           show "dom ?\<phi> = UP (trg\<^sub>B \<mu>)"
             using \<mu> 1 dom_char UP_def by simp
           show "cod ?\<phi> = trg (UP \<mu>)"
             using \<mu> 1 cod_char trg_def by auto
         qed
         have "iso ?\<phi>"
           using \<mu> \<phi> iso_char trg_def by auto
         thus ?thesis
           using \<phi> isomorphic_def by auto
       qed
     qed
 
     interpretation HoUP_UP: composite_functor B.VV.comp VV.comp vcomp
                               UP.FF \<open>\<lambda>\<mu>\<nu>. hcomp (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
     interpretation UPoH: composite_functor B.VV.comp V\<^sub>B vcomp
                            \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>\<close> UP ..
 
     abbreviation \<Phi>\<^sub>o
     where "\<Phi>\<^sub>o fg \<equiv> MkArr (\<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>) \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle> (fst fg \<star>\<^sub>B snd fg)"
 
     interpretation \<Phi>: transformation_by_components
                         B.VV.comp vcomp HoUP_UP.map UPoH.map \<Phi>\<^sub>o
     proof
       fix fg
       assume fg: "B.VV.ide fg"
       show "\<guillemotleft>\<Phi>\<^sub>o fg : HoUP_UP.map fg \<Rightarrow> UPoH.map fg\<guillemotright>"
       proof (intro in_homI)
         show 1: "arr (\<Phi>\<^sub>o fg)"
           using fg arr_char B.VV.ide_char B.VV.arr_char by auto
         show "dom (\<Phi>\<^sub>o fg) = HoUP_UP.map fg"
           using 1 fg UP.FF_def B.VV.arr_char B.VV.ide_char dom_char hcomp_def B.can_Ide_self
           by simp
         show "cod (\<Phi>\<^sub>o fg) = UPoH.map fg"
           using fg arr_char cod_char B.VV.ide_char B.VV.arr_char UP_def by auto
       qed
       next
       fix \<mu>\<nu>
       assume \<mu>\<nu>: "B.VV.arr \<mu>\<nu>"
       show "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
       proof -
         have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
               MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                     (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                     (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
         proof -
           have "\<Phi>\<^sub>o (B.VV.cod \<mu>\<nu>) \<cdot> HoUP_UP.map \<mu>\<nu> =
                 MkArr (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>) (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.cod (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def B.VV.cod_simp
                   src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
             by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  ((B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>))"
             using \<mu>\<nu> B.VV.arr_char
             by (intro comp_MkArr arr_MkArr, auto)
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char B.comp_cod_arr by auto
           finally show ?thesis by simp
         qed
         also have "... = UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>)"
         proof -
           have "UPoH.map \<mu>\<nu> \<cdot> \<Phi>\<^sub>o (B.VV.dom \<mu>\<nu>) =
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>
                 MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (\<^bold>\<langle>B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                       (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>))"
             using \<mu>\<nu> B.VV.arr_char arr_char UP.FF_def hcomp_def UP_def B.VV.dom_simp
                   src_def trg_def B.can_in_hom B.can_Ide_self B.comp_arr_dom B.comp_cod_arr
             by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  ((fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>) \<cdot>\<^sub>B (B.dom (fst \<mu>\<nu>) \<star>\<^sub>B B.dom (snd \<mu>\<nu>)))"
             using \<mu>\<nu> B.VV.arr_char arr_MkArr
             apply (intro comp_MkArr arr_MkArr) by auto
           also have "... = MkArr (\<^bold>\<langle>B.dom (fst \<mu>\<nu>)\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>B.dom (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (\<^bold>\<langle>B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>)\<^bold>\<rangle>)
                                  (fst \<mu>\<nu> \<star>\<^sub>B snd \<mu>\<nu>)"
             using \<mu>\<nu> B.VV.arr_char B.comp_arr_dom by auto
          finally show ?thesis by simp
         qed
         finally show ?thesis by simp
       qed
     qed
 
     abbreviation cmp\<^sub>U\<^sub>P
     where "cmp\<^sub>U\<^sub>P \<equiv> \<Phi>.map"
 
     lemma cmp\<^sub>U\<^sub>P_in_hom [intro]:
     assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
     shows "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>)) \<rightarrow> UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))\<guillemotright>"
     and "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))
                     \<Rightarrow> UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))\<guillemotright>"
     proof -
       let ?\<mu> = "fst \<mu>\<nu>" and ?\<nu> = "snd \<mu>\<nu>"
       show 1: "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> :
                   UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>) \<Rightarrow> UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)\<guillemotright>"
       proof
         show "arr (cmp\<^sub>U\<^sub>P \<mu>\<nu>)"
           using assms by auto
         show "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
         proof -
           have "B.VV.in_hom (?\<mu>, ?\<nu>) (B.dom ?\<mu>, B.dom ?\<nu>) (B.cod ?\<mu>, B.cod ?\<nu>)"
             using assms B.VV.in_hom_char B.VV.arr_char by auto
           hence "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = HoUP_UP.map (B.dom ?\<mu>, B.dom ?\<nu>)"
             by auto
           also have "... = UP (B.dom ?\<mu>) \<star> UP (B.dom ?\<nu>)"
             using assms UP.FF_def by fastforce
           finally show ?thesis by simp
         qed
         show "cod (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.cod ?\<mu> \<star>\<^sub>B B.cod ?\<nu>)"
           using assms B.VV.in_hom_char B.VV.arr_char B.VV.cod_simp by auto
       qed
       show "\<guillemotleft>cmp\<^sub>U\<^sub>P \<mu>\<nu> : UP\<^sub>0 (src\<^sub>B ?\<nu>) \<rightarrow> UP\<^sub>0 (trg\<^sub>B ?\<mu>)\<guillemotright>"
         using assms 1 src_dom [of "cmp\<^sub>U\<^sub>P \<mu>\<nu>"] trg_dom [of "cmp\<^sub>U\<^sub>P \<mu>\<nu>"] by fastforce
     qed
 
     lemma cmp\<^sub>U\<^sub>P_simps [simp]:
     assumes "B.arr (fst \<mu>\<nu>)" and "B.arr (snd \<mu>\<nu>)" and "src\<^sub>B (fst \<mu>\<nu>) = trg\<^sub>B (snd \<mu>\<nu>)"
     shows "arr (cmp\<^sub>U\<^sub>P \<mu>\<nu>)"
     and "src (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP\<^sub>0 (src\<^sub>B (snd \<mu>\<nu>))" and "trg (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP\<^sub>0 (trg\<^sub>B (fst \<mu>\<nu>))"
     and "dom (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.dom (fst \<mu>\<nu>)) \<star> UP (B.dom (snd \<mu>\<nu>))"
     and "cod (cmp\<^sub>U\<^sub>P \<mu>\<nu>) = UP (B.cod (fst \<mu>\<nu>) \<star>\<^sub>B B.cod (snd \<mu>\<nu>))"
       using assms cmp\<^sub>U\<^sub>P_in_hom [of \<mu>\<nu>] by auto
 
     lemma cmp\<^sub>U\<^sub>P_ide_simps [simp]:
     assumes "B.ide (fst fg)" and "B.ide (snd fg)" and "src\<^sub>B (fst fg) = trg\<^sub>B (snd fg)"
     shows "Dom (cmp\<^sub>U\<^sub>P fg) = \<^bold>\<langle>fst fg\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>snd fg\<^bold>\<rangle>"
     and "Cod (cmp\<^sub>U\<^sub>P fg) = \<^bold>\<langle>fst fg \<star>\<^sub>B snd fg\<^bold>\<rangle>"
     and "Map (cmp\<^sub>U\<^sub>P fg) = fst fg \<star>\<^sub>B snd fg"
       using assms B.VV.ide_char B.VV.arr_char by auto
 
     interpretation \<Phi>: natural_isomorphism
                         B.VV.comp vcomp HoUP_UP.map UPoH.map cmp\<^sub>U\<^sub>P
     proof
       fix fg
       assume fg: "B.VV.ide fg"
       have "arr (cmp\<^sub>U\<^sub>P fg)"
         using fg \<Phi>.preserves_reflects_arr [of fg] by simp
       thus "iso (cmp\<^sub>U\<^sub>P fg)"
         using fg iso_char by simp
     qed
 
     lemma cmp\<^sub>U\<^sub>P_ide_simp:
     assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
     shows "cmp\<^sub>U\<^sub>P (f, g) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
       using assms B.VV.ide_char B.VV.arr_char by simp
 
     lemma cmp\<^sub>U\<^sub>P'_ide_simp:
     assumes "B.ide f" and "B.ide g" and "src\<^sub>B f = trg\<^sub>B g"
     shows "inv (cmp\<^sub>U\<^sub>P (f, g)) = MkArr \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
       using assms cmp\<^sub>U\<^sub>P_ide_simp iso_char \<Phi>.components_are_iso [of "(f, g)"]
             B.VV.ide_char B.VV.arr_char
       by simp
 
     interpretation UP: pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
     proof
       fix f g h
       assume f: "B.ide f" and g: "B.ide g" and h: "B.ide h"
       and fg: "src\<^sub>B f = trg\<^sub>B g" and gh: "src\<^sub>B g = trg\<^sub>B h"
       show "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
             cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
       proof -
         have "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
               MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
         proof -
           have 1: "UP.hseq\<^sub>D (MkIde \<^bold>\<langle>f\<^bold>\<rangle>) (MkIde \<^bold>\<langle>g\<^bold>\<rangle>)"
             using f g fg hseq_char src_def trg_def arr_char by auto
           have 2: "UP.hseq\<^sub>D (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>))
                             (MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
           proof -
             have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
             proof -
               have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkIde (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) =
                     MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot> MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
                 using f g fg by simp
               also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<cdot>\<^sub>B (f \<star>\<^sub>B g))"
                 using f g fg by (intro comp_MkArr arr_MkArr, auto)
               also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
                 using f g fg by simp
               finally show ?thesis by blast
             qed
             thus ?thesis
               using f g h fg gh arr_char src_def trg_def by auto
           qed
           have "UP \<a>\<^sub>B[f, g, h] = MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h]"
             using f g h fg gh UP_def B.HoHV_def B.HoVH_def B.VVV.arr_char B.VV.arr_char
                   B.VVV.dom_char B.VVV.cod_char
             by simp
           moreover have
             "cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) = MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                   MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)"
             using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def B.VV.arr_char UP.FF_def B.VV.cod_simp
                   hcomp_def B.can_Ide_self
             by simp
           moreover have "cmp\<^sub>U\<^sub>P (f, g) \<star> UP h =
                          MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
           proof -
             have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)
                         (B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<cdot>\<^sub>B (f \<star>\<^sub>B g) \<cdot>\<^sub>B B.can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)) =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g)"
               using f g fg B.can_Ide_self B.comp_arr_dom B.comp_cod_arr by simp
             moreover have "MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g) \<cdot>
                              MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) (f \<star>\<^sub>B g) =
                            MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> (f \<star>\<^sub>B g)"
               by (metis (no_types, lifting) 2 B.ideD(1) E.eval.simps(2-3) cod_MkArr
                   comp_arr_ide f g ide_char' seq_char)
             moreover have "B.can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = B.inv \<a>\<^sub>B[f, g, h]"
               using f g h fg gh B.canI_associator_0 B.inverse_arrows_can by simp
             ultimately show ?thesis
               using 1 2 f g h fg gh \<Phi>.map_def UP_def hcomp_def UP.FF_def
                     B.VV.arr_char B.can_Ide_self B.comp_cod_arr B.VV.cod_simp
               by simp
           qed
           ultimately have "UP \<a>\<^sub>B[f, g, h] \<cdot> cmp\<^sub>U\<^sub>P (f \<star>\<^sub>B g, h) \<cdot> (cmp\<^sub>U\<^sub>P (f, g) \<star> UP h) =
                            MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h] \<cdot>
                              MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>
                                  MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])"
             using comp_assoc by presburger
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle>
                                  (\<a>\<^sub>B[f, g, h] \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B
                                    B.inv \<a>\<^sub>B[f, g, h])"
           proof -
             have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
                      Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)
                                 (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr (\<^bold>\<langle>f \<star>\<^sub>B g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> ((f \<star>\<^sub>B g) \<star>\<^sub>B h)) \<and>
                      Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle>
                           (((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B ((f \<star>\<^sub>B g) \<star>\<^sub>B h) \<cdot>\<^sub>B B.inv \<a>\<^sub>B[f, g, h])) \<and>
                      Arr (MkArr \<^bold>\<langle>(f \<star>\<^sub>B g) \<star>\<^sub>B h\<^bold>\<rangle> \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> \<a>\<^sub>B[f, g, h])"
               using f g h fg gh B.\<alpha>.preserves_hom B.HoHV_def B.HoVH_def by auto
             thus ?thesis
               using f g h fg gh comp_def B.comp_arr_dom B.comp_cod_arr by simp
           qed
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
             using B.comp_cod_arr B.comp_arr_inv'
             by (auto simp add: f fg g gh h)
           finally show ?thesis by simp
         qed
         also have "... = cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h)"
         proof -
           have "cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (UP f \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot> \<a> (UP f) (UP g) (UP h) =
                 cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) \<cdot> (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> cmp\<^sub>U\<^sub>P (g, h)) \<cdot>
                 (MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle>)"
             using f g h fg gh VVV.arr_char VV.arr_char arr_char src_def trg_def UP_def \<a>_def
             by auto
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                             MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                              MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                               MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
           proof -
             have "cmp\<^sub>U\<^sub>P (f, g \<star>\<^sub>B h) = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h) \<cdot>
                                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
               using f g h fg gh \<Phi>.map_simp_ide \<Phi>.map_def UP.FF_def UP_def hcomp_def
                     B.VV.arr_char B.can_Ide_self B.comp_arr_dom B.comp_cod_arr src_def trg_def
                     arr_char B.VV.cod_simp
               by auto
             moreover
             have "cmp\<^sub>U\<^sub>P (g, h) = MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h)"
               using g h gh cmp\<^sub>U\<^sub>P_ide_simp by blast
             moreover have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkArr (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle> (g \<star>\<^sub>B h) =
                            MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
               using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
                     B.comp_arr_dom B.comp_cod_arr
               by auto
             moreover
             have "MkIde \<^bold>\<langle>f\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>g\<^bold>\<rangle> \<star> MkIde \<^bold>\<langle>h\<^bold>\<rangle> =
                   MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)"
             proof -
               have "\<guillemotleft>f : f \<Rightarrow>\<^sub>B f\<guillemotright> \<and> \<guillemotleft>g : g \<Rightarrow>\<^sub>B g\<guillemotright> \<and> \<guillemotleft>h : h \<Rightarrow>\<^sub>B h\<guillemotright>"
                 using f g h by auto
               thus ?thesis
                 using f g h fg gh hcomp_def arr_char src_def trg_def B.can_Ide_self
                       B.comp_arr_dom B.comp_cod_arr
                 by auto
             qed
             ultimately show ?thesis
               using comp_assoc by auto
           qed
           also have "... = MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h)"
           proof -
             have "Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) (f \<star>\<^sub>B g \<star>\<^sub>B h)) \<and>
                   Arr (MkArr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g \<star>\<^sub>B h\<^bold>\<rangle>) \<^bold>\<langle>f \<star>\<^sub>B g \<star>\<^sub>B h\<^bold>\<rangle> (f \<star>\<^sub>B g \<star>\<^sub>B h))"
               using f g h fg gh by auto
             thus ?thesis
               using f g h fg gh comp_def by auto
           qed
           finally show ?thesis by simp
         qed
         finally show ?thesis by blast
       qed
     qed
 
     lemma UP_is_pseudofunctor:
     shows "pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P" ..
 
     lemma UP_map\<^sub>0_obj [simp]:
     assumes "B.obj a"
     shows "UP.map\<^sub>0 a = UP\<^sub>0 a"
       using assms UP.map\<^sub>0_def by auto
 
     interpretation UP: full_functor V\<^sub>B vcomp UP
     proof
       fix \<mu> f g
       assume f: "B.ide f" and g: "B.ide g"
       assume \<mu>: "\<guillemotleft>\<mu> : UP f \<Rightarrow> UP g\<guillemotright>"
       show "\<exists>\<nu>. \<guillemotleft>\<nu> : f \<Rightarrow>\<^sub>B g\<guillemotright> \<and> UP \<nu> = \<mu>"
       proof -
         have 1: "\<guillemotleft>Map \<mu> : f \<Rightarrow>\<^sub>B g\<guillemotright>"
           using f g \<mu> UP_def arr_char in_hom_char by auto
         moreover have "UP (Map \<mu>) = \<mu>"
         proof -
           have "\<mu> = MkArr (Dom \<mu>) (Cod \<mu>) (Map \<mu>)"
             using \<mu> MkArr_Map by auto
           also have "... = UP (Map \<mu>)"
             using "1" B.arrI UP.as_nat_trans.preserves_hom UP_def \<mu> in_hom_char by force
           finally show ?thesis by auto
         qed
         ultimately show ?thesis by blast
       qed
     qed
 
     interpretation UP: faithful_functor V\<^sub>B vcomp UP
       using arr_char UP_def
       by (unfold_locales, simp_all)
 
     interpretation UP: fully_faithful_functor V\<^sub>B vcomp UP ..
 
     lemma UP_is_fully_faithful_functor:
     shows "fully_faithful_functor V\<^sub>B vcomp UP"
       ..
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")   (* Inherited from functor, I think. *)
 
     lemma Map_reflects_hhom:
     assumes "B.obj a" and "B.obj b" and "ide g"
     and "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
     shows "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
     proof
       have 1: "B.ide (Map g)"
         using assms ide_char by blast
       show "B.arr (Map g)"
         using 1 by simp
       show "src\<^sub>B (Map g) = a"
       proof -
         have "src\<^sub>B (Map g) = Map (src g)"
           using assms src_def apply simp
           by (metis (no_types, lifting) E.eval_simps(2) E.Ide_implies_Arr arr_char ideE)
         also have "... = Map (UP.map\<^sub>0 a)"
           using assms by (metis (no_types, lifting) in_hhomE)
         also have "... = a"
           using assms UP.map\<^sub>0_def UP_def [of a] src_def by auto
         finally show ?thesis by simp
       qed
       show "trg\<^sub>B (Map g) = b"
       proof -
         have "trg\<^sub>B (Map g) = Map (trg g)"
           using assms trg_def apply simp
           by (metis (no_types, lifting) E.eval_simps(3) E.Ide_implies_Arr arr_char ideE)
         also have "... = Map (UP.map\<^sub>0 b)"
           using assms by (metis (no_types, lifting) in_hhomE)
         also have "... = b"
           using assms UP.map\<^sub>0_def UP_def [of b] src_def by auto
         finally show ?thesis by simp
       qed
     qed
 
     lemma eval_Dom_ide [simp]:
     assumes "ide g"
     shows "\<lbrace>Dom g\<rbrace> = Map g"
       using assms dom_char ideD by auto
 
     lemma Cod_ide:
     assumes "ide f"
     shows "Cod f = Dom f"
       using assms dom_char by auto
 
     lemma Map_preserves_objects:
     assumes "obj a"
     shows "B.obj (Map a)"
     proof -
       have "src\<^sub>B (Map a) = Map (src a)"
         using assms src_def apply simp
         using E.eval_simps(2) E.Ide_implies_Arr arr_char ideE
         by (metis (no_types, lifting) objE)
       also have 1: "... = \<lbrace>E.Src (Dom a)\<rbrace>"
         using assms src_def by auto
       also have "... = \<lbrace>\<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0\<rbrace>"
         using assms B.src.is_extensional 1 obj_simps(2) by force
       also have "... = Map a"
         using assms by auto
       finally have "src\<^sub>B (Map a) = Map a" by simp
       moreover have "B.arr (Map a)"
         using assms B.ideD arr_char by auto
       ultimately show ?thesis
         using B.obj_def by simp
     qed
 
     interpretation UP: equivalence_pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
     proof
       (* UP is full, hence locally full. *)
       show "\<And>f f' \<nu>. \<lbrakk> B.ide f; B.ide f'; src\<^sub>B f = src\<^sub>B f'; trg\<^sub>B f = trg\<^sub>B f';
                        \<guillemotleft>\<nu> : UP f \<Rightarrow> UP f'\<guillemotright> \<rbrakk> \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow>\<^sub>B f'\<guillemotright> \<and> UP \<mu> = \<nu>"
         using UP.is_full by simp
       (* UP is biessentially surjective on objects. *)
       show "\<And>b. obj b \<Longrightarrow> \<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
       proof -
         fix b
         assume b: "obj b"
         have 1: "B.obj (Map b)"
           using b Map_preserves_objects by simp
         have 3: "UP.map\<^sub>0 (Map b) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
           using b 1 UP.map\<^sub>0_def [of "Map b"] UP_def src_def arr_char by auto
         have 4: "b = MkArr (Dom b) (Dom b) (Map b)"
           using b objE eval_Dom_ide
           by (metis (no_types, lifting) dom_char ideD(2) obj_def)
         let ?\<phi> = "MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Dom b) (Map b)"
         have \<phi>: "arr ?\<phi>"
         proof -
           have 2: "E.Obj (Dom b)"
             using b obj_char by blast
           have "E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0"
             using 1 by auto
           moreover have "E.Nml (Dom b) \<and> E.Ide (Dom b)"
             using b arr_char [of b] by auto
           moreover have "E.Src \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Src (Dom b)"
             using b 1 2
             apply (cases "Dom b")
                      apply simp_all
             by fastforce
           moreover have "E.Trg \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 = E.Trg (Dom b)"
             using b 1 2
             apply (cases "Dom b")
                      apply simp_all
             by fastforce
           moreover have "\<guillemotleft>Map b : \<lbrace>\<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom b\<rbrace>\<guillemotright>"
             using b 1 by (elim objE, auto)
           ultimately show ?thesis
             using arr_char \<open>E.Nml \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<and> E.Ide \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0\<close> by auto
         qed
         hence "iso ?\<phi>"
           using 1 iso_char by auto
         moreover have "dom ?\<phi> = UP.map\<^sub>0 (Map b)"
           using \<phi> dom_char b 1 3 B.objE UP.map\<^sub>0_def UP_def src_def by auto
         moreover have "cod ?\<phi> = b"
           using \<phi> cod_char b 4 1 by auto
         ultimately have "isomorphic (UP.map\<^sub>0 (Map b)) b"
           using \<phi> 3 4 isomorphic_def by blast
         moreover have 5: "obj (UP.map\<^sub>0 (Map b))"
           using 1 UP.map\<^sub>0_simps(2) by simp
         ultimately have 6: "UP.map\<^sub>0 (Map b) = b"
           using b isomorphic_objects_are_equal by simp
         have "equivalent_objects (UP.map\<^sub>0 (Map b)) b"
           using b 6 equivalent_objects_reflexive [of b] by simp
         thus "\<exists>a. B.obj a \<and> equivalent_objects (UP.map\<^sub>0 a) b"
           using 1 6 by auto
       qed
       (* UP is locally essentially surjective. *)
       show "\<And>a b g. \<lbrakk> B.obj a; B.obj b; \<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>; ide g \<rbrakk> \<Longrightarrow>
                         \<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
       proof -
         fix a b g
         assume a: "B.obj a" and b: "B.obj b"
         assume g_in_hhom: "\<guillemotleft>g : UP.map\<^sub>0 a \<rightarrow> UP.map\<^sub>0 b\<guillemotright>"
         assume ide_g: "ide g"
         have 1: "B.ide (Map g)"
           using ide_g ide_char by blast
         have "arr (UP a)"
           using a by auto
         have "arr (UP b)"
           using b by auto
         have Map_g_eq: "Map g = \<lbrace>Dom g\<rbrace>"
           using ide_g by simp
         have Map_g_in_hhom: "\<guillemotleft>Map g : a \<rightarrow>\<^sub>B b\<guillemotright>"
           using a b ide_g g_in_hhom Map_reflects_hhom by simp
 
         let ?\<phi> = "MkArr \<^bold>\<langle>Map g\<^bold>\<rangle> (Dom g) (Map g)"
         have \<phi>: "arr ?\<phi>"
         proof -
           have "\<guillemotleft>Map ?\<phi> : \<lbrace>Dom ?\<phi>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<phi>\<rbrace>\<guillemotright>"
             using 1 Map_g_eq by auto
           moreover have "E.Ide \<^bold>\<langle>Map g\<^bold>\<rangle> \<and> E.Nml \<^bold>\<langle>Map g\<^bold>\<rangle>"
             using 1 by simp
           moreover have "E.Ide (Dom g) \<and> E.Nml (Dom g)"
             using ide_g arr_char ide_char by blast
           moreover have "E.Src \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Src (Dom g)"
             using ide_g g_in_hhom src_def Map_g_in_hhom
             by (metis (no_types, lifting) B.ideD(2) B.in_hhom_def B.objE B.obj_def'
                 Dom.simps(1) E.Src.simps(2) UP.map\<^sub>0_def \<open>arr (UP a)\<close> a in_hhomE UP_def)
           moreover have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = E.Trg (Dom g)"
           proof -
             have "E.Trg \<^bold>\<langle>Map g\<^bold>\<rangle> = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
               using Map_g_in_hhom by auto
             also have "... = E.Trg (Dom g)"
             proof -
               have "E.Trg (Dom g) = Dom (trg g)"
                 using ide_g trg_def by simp
               also have "... = Dom (UP.map\<^sub>0 b)"
                 using g_in_hhom by auto
               also have "... = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
                 using b \<open>arr (UP b)\<close> UP.map\<^sub>0_def src_def UP_def B.objE by auto
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
           ultimately show ?thesis
             using arr_char by simp
         qed
         have "\<guillemotleft>?\<phi> : UP (Map g) \<Rightarrow> g\<guillemotright>"
           by (simp add: "1" \<phi> ide_g in_hom_char)
         moreover have "iso ?\<phi>"
           using \<phi> 1 iso_char by simp
         ultimately have "isomorphic (UP (Map g)) g"
           using isomorphic_def by auto
         thus "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>B b\<guillemotright> \<and> B.ide f \<and> isomorphic (UP f) g"
           using 1 Map_g_in_hhom by auto
       qed
     qed
 
     theorem UP_is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg
              UP cmp\<^sub>U\<^sub>P"
       ..
 
     text \<open>
       Next, we work out the details of the equivalence pseudofunctor \<open>DN\<close> in the
       converse direction.
     \<close>
 
     definition DN
     where "DN \<mu> \<equiv> if arr \<mu> then Map \<mu> else B.null"
 
     lemma DN_in_hom [intro]:
     assumes "arr \<mu>"
     shows "\<guillemotleft>DN \<mu> : DN (src \<mu>) \<rightarrow>\<^sub>B DN (trg \<mu>)\<guillemotright>"
     and "\<guillemotleft>DN \<mu> : DN (dom \<mu>) \<Rightarrow>\<^sub>B DN (cod \<mu>)\<guillemotright>"
       using assms DN_def arr_char [of \<mu>] B.vconn_implies_hpar(1-2) E.eval_in_hom(1)
             B.in_hhom_def
       by auto
 
     lemma DN_simps [simp]:
     assumes "arr \<mu>"
     shows "B.arr (DN \<mu>)"
     and "src\<^sub>B (DN \<mu>) = DN (src \<mu>)" and "trg\<^sub>B (DN \<mu>) = DN (trg \<mu>)"
     and "B.dom (DN \<mu>) = DN (dom \<mu>)" and "B.cod (DN \<mu>) = DN (cod \<mu>)"
       using assms DN_in_hom by auto
 
     interpretation "functor" vcomp V\<^sub>B DN
       using DN_def seqE Map_comp seq_char
       by unfold_locales auto
 
     interpretation DN: weak_arrow_of_homs vcomp src trg V\<^sub>B src\<^sub>B trg\<^sub>B DN
     proof
       fix \<mu>
       assume \<mu>: "arr \<mu>"
       show "B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))"
       proof -
         have "DN (src \<mu>) = src\<^sub>B (DN \<mu>)"
           using B.src.is_extensional DN_def DN_simps(2) by auto
         moreover have "B.ide (DN (src \<mu>))"
           using \<mu> by simp
         ultimately show ?thesis
           using \<mu> B.isomorphic_reflexive by auto
       qed
       show "B.isomorphic (DN (trg \<mu>)) (trg\<^sub>B (DN \<mu>))"
       proof -
         have "DN (trg \<mu>) = trg\<^sub>B (DN \<mu>)"
           using \<open>B.isomorphic (DN (src \<mu>)) (src\<^sub>B (DN \<mu>))\<close> by fastforce
         moreover have "B.ide (DN (trg \<mu>))"
           using \<mu> by simp
         ultimately show ?thesis
           using B.isomorphic_reflexive by auto
       qed
     qed
 
     interpretation "functor" VV.comp B.VV.comp DN.FF
       using DN.functor_FF by auto
     interpretation HoDN_DN: composite_functor VV.comp B.VV.comp V\<^sub>B
                       DN.FF \<open>\<lambda>\<mu>\<nu>. H\<^sub>B (fst \<mu>\<nu>) (snd \<mu>\<nu>)\<close> ..
     interpretation DNoH: composite_functor VV.comp vcomp V\<^sub>B
                       \<open>\<lambda>\<mu>\<nu>. fst \<mu>\<nu> \<star> snd \<mu>\<nu>\<close> DN ..
 
     abbreviation \<Psi>\<^sub>o
     where "\<Psi>\<^sub>o fg \<equiv> B.can (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
 
     abbreviation \<Psi>\<^sub>o'
     where "\<Psi>\<^sub>o' fg \<equiv> B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
 
     lemma \<Psi>\<^sub>o_in_hom:
     assumes "VV.ide fg"
     shows "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
     and "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
     and "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
     proof -
       have 1: "E.Ide (Dom (fst fg) \<^bold>\<star> Dom (snd fg))"
         unfolding E.Ide.simps(3)
         apply (intro conjI)
         using assms VV.ide_char VV.arr_char arr_char
           apply simp
         using VV.arr_char VV.ideD(1) assms
          apply blast
         by (metis (no_types, lifting) VV.arrE VV.ideD(1) assms src_simps(1) trg_simps(1))
       have 2: "E.Ide (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
         using 1
         by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char assms)
       have 3: "\<^bold>\<lfloor>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<^bold>\<rfloor>"
         by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
             E.Nmlize_Nml VV.arr_char VV.ideD(1) arr_char assms 1)
       have 4: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
         using assms VV.ide_char VV.arr_char arr_char by simp
       show "\<guillemotleft>\<Psi>\<^sub>o fg : Map (fst fg) \<star>\<^sub>B Map (snd fg) \<Rightarrow>\<^sub>B \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>\<guillemotright>"
         using 1 2 3 4 by auto
       show "\<guillemotleft>\<Psi>\<^sub>o' fg : \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace> \<Rightarrow>\<^sub>B Map (fst fg) \<star>\<^sub>B Map (snd fg)\<guillemotright>"
         using 1 2 3 4 by auto
       show "B.inverse_arrows (\<Psi>\<^sub>o fg) (\<Psi>\<^sub>o' fg)"
         using 1 2 3 B.inverse_arrows_can by blast
     qed
 
     interpretation \<Psi>: transformation_by_components
                          VV.comp V\<^sub>B HoDN_DN.map DNoH.map \<Psi>\<^sub>o
     proof
       fix fg
       assume fg: "VV.ide fg"
       have 1: "\<lbrace>Dom (fst fg) \<^bold>\<star> Dom (snd fg)\<rbrace> = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
         using fg VV.ide_char VV.arr_char arr_char by simp
       show "\<guillemotleft>\<Psi>\<^sub>o fg : HoDN_DN.map fg \<Rightarrow>\<^sub>B DNoH.map fg\<guillemotright>"
       proof
         show "B.arr (\<Psi>\<^sub>o fg)"
           using fg \<Psi>\<^sub>o_in_hom by blast
         show "B.dom (\<Psi>\<^sub>o fg) = HoDN_DN.map fg"
         proof -
           have "B.dom (\<Psi>\<^sub>o fg) = Map (fst fg) \<star>\<^sub>B Map (snd fg)"
             using fg \<Psi>\<^sub>o_in_hom by blast
           also have "... = HoDN_DN.map fg"
             using fg DN.FF_def DN_def VV.arr_char src_def trg_def VV.ide_char by auto
           finally show ?thesis by simp
         qed
         show "B.cod (\<Psi>\<^sub>o fg) = DNoH.map fg"
         proof -
           have "B.cod (\<Psi>\<^sub>o fg) = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
             using fg \<Psi>\<^sub>o_in_hom by blast
           also have "... = DNoH.map fg"
           proof -
             have "DNoH.map fg = 
                   B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
                     (Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
                       B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
               using fg DN_def Map_hcomp VV.arr_char
               apply simp
               using VV.ideD(1) by blast
             also have "... =
                        B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) \<cdot>\<^sub>B
                          B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
             proof -
               have "(Map (fst fg) \<star>\<^sub>B Map (snd fg)) \<cdot>\<^sub>B
                       B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)) =
                     B.can (Dom (fst fg) \<^bold>\<star> Dom (snd fg)) (Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg))"
                 using fg 1 \<Psi>\<^sub>o_in_hom B.comp_cod_arr by blast
               thus ?thesis by simp
             qed
             also have "... = \<lbrace>Dom (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd fg)\<rbrace>"
             proof -
               have "B.can (Cod (fst fg) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd fg)) (Cod (fst fg) \<^bold>\<star> Cod (snd fg)) = \<Psi>\<^sub>o fg"
                 using fg VV.ide_char Cod_ide by simp
               thus ?thesis
                 using fg 1 \<Psi>\<^sub>o_in_hom [of fg] B.comp_arr_inv' by fastforce
             qed
             finally show ?thesis by simp
           qed
           finally show ?thesis by blast
         qed
       qed
       next
       show "\<And>f. VV.arr f \<Longrightarrow>
                    \<Psi>\<^sub>o (VV.cod f) \<cdot>\<^sub>B HoDN_DN.map f = DNoH.map f \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom f)"
       proof -
         fix \<mu>\<nu>
         assume \<mu>\<nu>: "VV.arr \<mu>\<nu>"
         show "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
         proof -
           have 1: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>))"
             unfolding E.Ide.simps(3)
-            apply (intro conjI)
-            using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
-              apply simp
-            using VV.arr_char VV.ideD(1) \<mu>\<nu>
-             apply blast
-            by (metis (no_types, lifting) VV.arrE \<mu>\<nu> src_simps(1) trg_simps(1))
+            by (metis (no_types, lifting) VV.arrE \<mu>\<nu> arrE src_simps(2) trg_simps(2))
           have 2: "E.Ide (Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>))"
             using 1
             by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
           have 3: "\<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<^bold>\<rfloor>"
             by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
           have 4: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>))"
             unfolding E.Ide.simps(3)
-            apply (intro conjI)
-            using \<mu>\<nu> VV.ide_char VV.arr_char arr_char
-              apply simp
-            using VV.arr_char VV.ideD(1) \<mu>\<nu>
-             apply blast
-            by (metis (no_types, lifting) "1" E.Ide.simps(3) VV.arrE \<mu>\<nu> arrE)
+            by (metis (no_types, lifting) "1" E.Ide.simps(3) VV.arrE \<mu>\<nu> arr_char)
           have 5: "E.Ide (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))"
             using 4
             by (meson E.Ide.simps(3) E.Ide_HcompNml VV.arr_char VV.ideD(1) arr_char \<mu>\<nu>)
           have 6: "\<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<^bold>\<rfloor>"
             by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                E.Nmlize_Nml VV.arr_char arr_char \<mu>\<nu> 1)
           have A: "\<guillemotleft>\<Psi>\<^sub>o' \<mu>\<nu> : \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom (snd \<mu>\<nu>)\<rbrace>
                                  \<Rightarrow>\<^sub>B \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using 1 2 3 by auto
           have B: "\<guillemotleft>Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>) :
                      \<lbrace>Dom (fst \<mu>\<nu>) \<^bold>\<star> Dom (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using \<mu>\<nu> VV.arr_char arr_char src_def trg_def E.Nml_implies_Arr E.eval_simps'(2-3)
             by auto
           have C: "\<guillemotleft>B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) :
                      \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)\<rbrace>\<guillemotright>"
             using 4 5 6 by auto
           have "\<Psi>\<^sub>o (VV.cod \<mu>\<nu>) \<cdot>\<^sub>B HoDN_DN.map \<mu>\<nu> =
                 B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                   (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>))"
             using \<mu>\<nu> VV.arr_char VV.cod_char arr_char src_def trg_def cod_char DN.FF_def DN_def
             by auto
           also have "... = B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>))
                                  (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                              (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o \<mu>\<nu>"
             using B \<mu>\<nu> VV.arr_char arr_char src_def trg_def
                   E.Ide_HcompNml E.Nml_HcompNml(1) B.can_Ide_self B.comp_arr_dom
             by auto
           also have "... = DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
           proof -
             have "DNoH.map \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>) =
                   B.can (Cod (fst \<mu>\<nu>) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod (snd \<mu>\<nu>)) (Cod (fst \<mu>\<nu>) \<^bold>\<star> Cod (snd \<mu>\<nu>)) \<cdot>\<^sub>B
                     (Map (fst \<mu>\<nu>) \<star>\<^sub>B Map (snd \<mu>\<nu>)) \<cdot>\<^sub>B \<Psi>\<^sub>o' \<mu>\<nu> \<cdot>\<^sub>B \<Psi>\<^sub>o (VV.dom \<mu>\<nu>)"
               using \<mu>\<nu> DN_def VV.arr_char B.comp_assoc by simp
             moreover have "\<Psi>\<^sub>o (VV.dom \<mu>\<nu>) = \<Psi>\<^sub>o \<mu>\<nu>"
               using \<mu>\<nu> VV.dom_char VV.arr_char by auto
             ultimately show ?thesis
               using B.comp_assoc by simp
           qed
           finally show ?thesis by blast
         qed
       qed
     qed
 
     abbreviation cmp\<^sub>D\<^sub>N
     where "cmp\<^sub>D\<^sub>N \<equiv> \<Psi>.map"
 
     interpretation \<Psi>: natural_isomorphism VV.comp V\<^sub>B HoDN_DN.map DNoH.map cmp\<^sub>D\<^sub>N
       using \<Psi>\<^sub>o_in_hom B.iso_def \<Psi>.map_simp_ide
       apply unfold_locales
         apply auto
       by blast
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     lemma cmp\<^sub>D\<^sub>N_in_hom [intro]:
     assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
     shows "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
     and "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                     \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
     proof -
       have 1: "VV.arr \<mu>\<nu>"
         using assms VV.arr_char by simp
       show 2: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                           \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
       proof -
         have "HoDN_DN.map (VV.dom \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
           using assms 1 DN.FF_def VV.dom_simp by auto
         moreover have "DNoH.map (VV.cod \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
           using assms 1 VV.cod_simp by simp
         ultimately show ?thesis
           using assms 1 \<Psi>.preserves_hom by auto
       qed
       show "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
         using assms 2 B.src_dom [of "cmp\<^sub>D\<^sub>N \<mu>\<nu>"] B.trg_dom [of "cmp\<^sub>D\<^sub>N \<mu>\<nu>"]
         by (elim B.in_homE, intro B.in_hhomI) auto
     qed
 
     lemma cmp\<^sub>D\<^sub>N_simps [simp]:
     assumes "arr (fst \<mu>\<nu>)" and "arr (snd \<mu>\<nu>)" and "src (fst \<mu>\<nu>) = trg (snd \<mu>\<nu>)"
     shows "B.arr (cmp\<^sub>D\<^sub>N \<mu>\<nu>)"
     and "src\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))" and "trg\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
     and "B.dom (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
     and "B.cod (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
     proof
       show "VV.arr \<mu>\<nu>"
         using assms by blast
       have 1: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (src (snd \<mu>\<nu>)) \<rightarrow>\<^sub>B DN (trg (fst \<mu>\<nu>))\<guillemotright>"
         using assms by blast
       show "src\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (src (snd \<mu>\<nu>))"
         using 1 by fast
       show "trg\<^sub>B (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (trg (fst \<mu>\<nu>))"
         using 1 by fast
       have 2: "\<guillemotleft>cmp\<^sub>D\<^sub>N \<mu>\<nu> : DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))
                           \<Rightarrow>\<^sub>B DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))\<guillemotright>"
         using assms by blast
       show "B.dom (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (dom (fst \<mu>\<nu>)) \<star>\<^sub>B DN (dom (snd \<mu>\<nu>))"
         using 2 by fast
       show "B.cod (cmp\<^sub>D\<^sub>N \<mu>\<nu>) = DN (cod (fst \<mu>\<nu>) \<star> cod (snd \<mu>\<nu>))"
         using 2 by fast
     qed
 
     interpretation DN: pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
                          DN cmp\<^sub>D\<^sub>N
     proof
       show "\<And>f g h. \<lbrakk> ide f; ide g; ide h; src f = trg g; src g = trg h \<rbrakk> \<Longrightarrow>
                        DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                        cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
       proof -
         fix f g h
         assume f: "ide f" and g: "ide g" and h: "ide h"
         and fg: "src f = trg g" and gh: "src g = trg h"
         show "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
               cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
         proof -
           have 1: "E.Trg (Dom g) = E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<and>
                    \<lbrace>E.Trg (Dom g)\<rbrace> = \<lbrace>E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<rbrace>"
             using f g h fg gh arr_char src_def trg_def E.Trg_HcompNml
             by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
           have 2: "arr (MkArr (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
                        (B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
                           (Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                           (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
           proof -
             have "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<cdot>\<^sub>B
                      (Map f \<star>\<^sub>B
                         B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                           (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)) \<cdot>\<^sub>B
                           B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                      EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
                        \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
             proof (intro B.comp_in_homI)
               show 2: "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                           EVAL (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B
                             EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)\<guillemotright>"
                 using f g h fg gh 1
                 apply (intro B.can_in_hom)
                   apply (metis (no_types, lifting) E.Ide_HcompNml E.Nml_HcompNml(1)
                     arr_char ideD(1) src_simps(1) trg_simps(1))
                  apply (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml ideD(1)
                     arr_char src_simps(1) trg_simps(1))
                 by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                     E.Nmlize_Nml ideD(1) arr_char src_simps(1) trg_simps(1))
               show "\<guillemotleft>B.can (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) :
                        EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<Rightarrow>\<^sub>B
                          EVAL (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
               proof -
                 have "E.Ide (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh 1 Cod_ide E.Ide_HcompNml arr_char
                   apply simp
                   by (metis (no_types, lifting) ideD(1) src_simps(1) trg_simps(1))
                 moreover have "E.Ide (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
                       arr_char calculation ideD(1) src_simps(1) trg_simps(1))
                 moreover have "E.Nmlize (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) =
                                E.Nmlize (Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                   using f g h fg gh
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                       E.Nmlize_Nml arr_char calculation(1) ideD(1) src_simps(1) trg_simps(1))
                 ultimately show ?thesis
                   using B.can_in_hom [of "Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h" "Cod f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h"]
                   by blast
               qed
               show "\<guillemotleft>Map f \<star>\<^sub>B B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                      (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                        EVAL (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod f \<^bold>\<star> Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
                 using f g h fg gh B.can_in_hom
                 apply simp
               proof (intro B.hcomp_in_vhom B.comp_in_homI)
                 show 1: "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                             EVAL (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<Rightarrow>\<^sub>B EVAL (Dom g \<^bold>\<star> Dom h)\<guillemotright>"
                   using g h gh B.can_in_hom
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Nml_HcompNml(1)
                       E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1) src_simps(1) trg_simps(1))
                 show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
                          EVAL (Cod g \<^bold>\<star> Cod h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)\<guillemotright>"
                   using g h gh B.can_in_hom
                   by (metis (no_types, lifting) Cod_ide E.Ide.simps(3) E.Ide_HcompNml
                       E.Nml_HcompNml(1) E.Nmlize.simps(3) E.Nmlize_Nml arr_char ideD(1)
                       src_simps(2) trg_simps(2))
                 show "\<guillemotleft>Map g \<star>\<^sub>B Map h : EVAL (Dom g \<^bold>\<star> Dom h) \<Rightarrow>\<^sub>B EVAL (Cod g \<^bold>\<star> Cod h)\<guillemotright>"
                 proof
                   show 2: "B.hseq (Map g) (Map h)"
                     using g h gh
                     by (metis (no_types, lifting) B.comp_null(1-2) B.hseq_char'
                         B.ideD(1) Map_hcomp ideE ide_hcomp)
                   show "B.dom (Map g \<star>\<^sub>B Map h) = EVAL (Dom g \<^bold>\<star> Dom h)"
                     using g h gh 2 by fastforce
                   show "B.cod (Map g \<star>\<^sub>B Map h) = EVAL (Cod g \<^bold>\<star> Cod h)"
                     using g h gh 2 by fastforce
                 qed
                 show "\<guillemotleft>Map f : Map f \<Rightarrow>\<^sub>B EVAL (Cod f)\<guillemotright>"
                   using f arr_char Cod_ide by auto
                 show "src\<^sub>B (Map f) = trg\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   using f g h fg gh 1 2 src_def trg_def B.arrI B.hseqE B.not_arr_null
                         B.trg.is_extensional B.trg.preserves_hom B.vconn_implies_hpar(2)
                         B.vconn_implies_hpar(4) E.eval.simps(3)
                   by (metis (no_types, lifting) Map_ide(1))
               qed
             qed
             thus ?thesis
               using f g h fg gh arr_char src_def trg_def E.Nml_HcompNml E.Ide_HcompNml
                     ideD(1)
               apply (intro arr_MkArr) by auto
           qed
           have 3: "E.Ide (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using g h gh ide_char arr_char src_def trg_def E.Ide_HcompNml Cod_ide
             by (metis (no_types, lifting) ideD(1) src_simps(2) trg_simps(2))
           have 4: "E.Ide (Dom g \<^bold>\<star> Dom h)"
             by (metis (no_types, lifting) E.Ide.simps(3) arrE g gh h ideE src_simps(1) trg_simps(1))
           have 5: "E.Nmlize (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Nmlize (Dom g \<^bold>\<star> Dom h)"
             using g h gh ide_char arr_char src_def trg_def E.Nml_HcompNml
             by (metis (no_types, lifting) 4 E.Ide.simps(3) E.Nmlize.simps(3) E.Nmlize_Nml
                 ideD(1))
           have 6: "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
             by (metis (no_types, lifting) 1 E.Nml_HcompNml(1) E.Ide_HcompNml ideD(1)
                 src_simps(2) trg_simps(2))
           have 7: "E.Ide (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
             by (metis (no_types, lifting) 1 3 E.Ide.simps(3) ideD(1) src_simps(2) trg_simps(2))
           have 8: "E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                    E.Nmlize (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
             using f g h fg gh arr_char src_def trg_def
                   7 E.Nml_HcompNml(1) ideD(1)
             by auto
           have "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                 B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
           proof -
             have 9: "VVV.arr (f, g, h)"
               using f g h fg gh VVV.arr_char VV.arr_char arr_char ideD by simp
             have 10: "VV.ide (f, g)"
               using f g fg VV.ide_char by auto
             have 11: "VV.ide (hcomp f g, h)"
               using f g h fg gh VV.ide_char VV.arr_char by simp
             have 12: "arr (MkArr (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)
                                 (B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                                   (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
                                   B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)))"
             proof (intro arr_MkArr)
               show "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE"
                 using g h gh
                 by (metis (no_types, lifting) 3 E.Nml_HcompNml(1) arr_char ideD(1)
                     mem_Collect_eq src_simps(2) trg_simps(2))
               show "Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h \<in> IDE"
                 using g h gh Cod_ide \<open>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h \<in> IDE\<close> by auto
               show "B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                       (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B
                       B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)
                     \<in> HOM (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
               proof
                 show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
                       E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) \<and>
                       \<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                          (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                          \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                 proof (intro conjI)
                   show "E.Src (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Src (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                     using g h gh Cod_ide by simp
                   show "E.Trg (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) = E.Trg (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h)"
                     using g h gh Cod_ide by simp
                   show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) \<cdot>\<^sub>B
                            (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                            \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                   proof (intro B.comp_in_homI)
                     show "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                              \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace>\<guillemotright>"
                       using 3 4 5 by blast
                     show "\<guillemotleft>Map g \<star>\<^sub>B Map h : \<lbrace>Dom g \<^bold>\<star> Dom h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace>\<guillemotright>"
                       using g h gh
                       by (metis (no_types, lifting) 4 B.ide_in_hom(2) Cod_ide E.eval.simps(3)
                           E.ide_eval_Ide Map_ide(2))
                     show "\<guillemotleft>B.can (Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h) (Cod g \<^bold>\<star> Cod h) :
                             \<lbrace>Cod g \<^bold>\<star> Cod h\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Cod h\<rbrace>\<guillemotright>"
                       using 3 4 5 Cod_ide g h by auto
                   qed
                 qed
               qed
             qed
             have "DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
             proof -
               have "DN (\<a> f g h) =
                     (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                       ((Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                          (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))) \<cdot>\<^sub>B
                       B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h))"
                 using f g h fg gh 1 2 9 12 DN_def \<a>_def Cod_ide by simp
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          (Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
                            B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
               proof -
                 have "\<guillemotleft>B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                                     \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map g \<star>\<^sub>B Map h\<guillemotright>"
                   using g h 3 4 5 B.can_in_hom [of "Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom g \<^bold>\<star> Dom h"]
                   by simp
                 hence "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                        Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using B.comp_cod_arr by auto
                 also have "... = Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   using f g h fg gh 3 4 5 B.can_Ide_self by auto
                 finally have "Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                                  (Map g \<star>\<^sub>B Map h) \<cdot>\<^sub>B B.can (Dom g \<^bold>\<star> Dom h) (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                               Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                   by simp
                 thus ?thesis by simp
               qed
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
               proof -
                 have "\<guillemotleft>B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) :
                                \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace> \<Rightarrow>\<^sub>B Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<guillemotright>"
                   using f g h 6 7 8
                         B.can_in_hom [of "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h" "Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h"]
                   by simp
                 hence "(Map f \<star>\<^sub>B \<lbrace>Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                        B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using B.comp_cod_arr by auto
                 thus ?thesis by simp
               qed
               also have
                 "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h fg gh 6 7 8 by auto
               also have "... = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>"
                 using f g h fg gh 6 B.can_Ide_self by blast
               finally show ?thesis by simp
             qed
             have "DN (\<a> f g h) \<cdot>\<^sub>B cmp\<^sub>D\<^sub>N (f \<star> g, h) \<cdot>\<^sub>B (cmp\<^sub>D\<^sub>N (f, g) \<star>\<^sub>B DN h) =
                   B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                   B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                     (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
             proof -
               have "DN (\<a> f g h) =
                     B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h fg gh DN_def 1 4 6 7 B.can_Ide_self E.HcompNml_assoc
                       E.Ide.simps(3) \<open>DN (\<a> f g h) = \<lbrace>Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h\<rbrace>\<close> ide_char
                 by (metis (no_types, lifting) arr_char ideD(1))
               thus ?thesis
                 using f g h fg gh 10 11 DN_def \<Psi>.map_simp_ide by simp
             qed
             also have
               "... = (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                        B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)) \<cdot>\<^sub>B
                         (B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h)"
               using B.comp_assoc by simp
             also have
               "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                        B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
                     B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
               proof -
                 have "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B Map h =
                       B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) (Dom f \<^bold>\<star> Dom g) \<star>\<^sub>B B.can (Dom h) (Dom h)"
                   using h B.can_Ide_self by fastforce
                 also have "... = B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                   using f g h 1 4 7 arr_char E.Nml_HcompNml(1) E.Src_HcompNml
                         B.hcomp_can [of "Dom f \<^bold>\<star> Dom g" "Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g" "Dom h" "Dom h"]
                   by (metis (no_types, lifting) E.Nmlize.simps(3) E.Nmlize_Nml
                       E.Ide.simps(3) E.Ide_HcompNml E.Src.simps(3) arrE ideD(1))
                 finally show ?thesis by simp
               qed
               moreover have
                 "B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                    B.can ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                      B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
               proof -
                 have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                   using f g h 1 4 7
                   by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
                       arrE ideD(1))
                 moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 7 E.Ide_HcompNml E.Nml_HcompNml(1) arr_char calculation
                         ideD(1)
                   by auto
                 moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 6 by blast
                 moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                                E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 7
                   by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                       E.Nmlize_Nml E.Ide.simps(3) arrE calculation(1) ideD(1))
                 moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) =
                                E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                   using f g h 1 4 7 E.HcompNml_assoc by fastforce
                 ultimately show ?thesis
                   using B.vcomp_can by simp
               qed
               ultimately show ?thesis by simp
             qed
             also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "E.Ide ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                 using 1 4 7 by simp
               moreover have "E.Ide ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                 using f g 1 4 7
                 by (metis (no_types, lifting) E.Ide.simps(3) E.Ide_HcompNml E.Src_HcompNml
                     arrE ideD(1))
               moreover have "E.Ide (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h 6 by blast
               moreover have "E.Nmlize ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h) =
                              E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h)"
                 using f g h 1 7 E.Nml_HcompNml(1) by fastforce
               moreover have "E.Nmlize ((Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g) \<^bold>\<star> Dom h) =
                              E.Nmlize (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h)"
                 using f g h 1 4 7
                 by (metis (no_types, lifting) E.Nml_HcompNml(1) E.Nmlize.simps(3)
                     E.Nmlize_Nml E.HcompNml_assoc E.Ide.simps(3) arrE ideD(1))
               ultimately show ?thesis
                 using B.vcomp_can by simp
             qed
             finally show ?thesis by simp
           qed
           also have "... = cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B
                            \<a>\<^sub>B[DN f, DN g, DN h]"
           proof -
             have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h] =
                   (cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h))) \<cdot>\<^sub>B \<a>\<^sub>B[DN f, DN g, DN h]"
               using B.comp_assoc by simp
             also have
               "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) \<cdot>\<^sub>B
                        B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
             proof -
               have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) =
                     B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
               proof -
                 have "cmp\<^sub>D\<^sub>N (f, g \<star> h) \<cdot>\<^sub>B (DN f \<star>\<^sub>B cmp\<^sub>D\<^sub>N (g, h)) =
                       B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                             (Map f \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
                   using f g h fg gh VV.ide_char VV.arr_char DN_def by simp
                 also have
                   "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                            (B.can (Dom f) (Dom f) \<star>\<^sub>B B.can (Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom g \<^bold>\<star> Dom h))"
                 proof -
                   have "Map f = B.can (Dom f) (Dom f)"
                     using f arr_char B.can_Ide_self [of "Dom f"] Map_ide
                     by (metis (no_types, lifting) ide_char')
                   thus ?thesis by simp
                 qed
                 also have
                   "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) \<cdot>\<^sub>B
                          B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
                   using 1 4 5 7 B.hcomp_can by auto
                 also have "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h)"
                   using 1 4 5 6 7 8 B.vcomp_can by auto
                 finally show ?thesis by simp
               qed
               moreover have "\<a>\<^sub>B[DN f, DN g, DN h] =
                              B.can (Dom f \<^bold>\<star> Dom g \<^bold>\<star> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
                 using f g h 1 4 7 DN_def B.canE_associator(1) by auto
               ultimately show ?thesis by simp
             qed
             also have  "... = B.can (Dom f \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom g \<^bold>\<lfloor>\<^bold>\<star>\<^bold>\<rfloor> Dom h) ((Dom f \<^bold>\<star> Dom g) \<^bold>\<star> Dom h)"
               using 1 4 5 6 7 8 E.Nmlize_Hcomp_Hcomp B.vcomp_can by simp
             finally show ?thesis by simp
           qed
           finally show ?thesis by blast
         qed
       qed
     qed
 
     lemma DN_is_pseudofunctor:
     shows "pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN cmp\<^sub>D\<^sub>N"
       ..
 
     interpretation faithful_functor vcomp V\<^sub>B DN
       using arr_char dom_char cod_char DN_def
       apply unfold_locales
       by (metis (no_types, lifting) Cod_dom Dom_cod MkArr_Map)
 
     no_notation B.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")
 
     lemma DN_UP:
     assumes "B.arr \<mu>"
     shows "DN (UP \<mu>) = \<mu>"
       using assms UP_def DN_def arr_UP by auto
 
     interpretation DN: equivalence_pseudofunctor
                          vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B DN cmp\<^sub>D\<^sub>N
     proof
       (* DN is locally (but not globally) full. *)
       show "\<And>f f' \<nu>. \<lbrakk> ide f; ide f'; src f = src f'; trg f = trg f'; \<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright> \<rbrakk>
                          \<Longrightarrow> \<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
       proof -
         fix f f' \<nu>
         assume f: "ide f" and f': "ide f'"
         and eq_src: "src f = src f'" and eq_trg: "trg f = trg f'"
         and \<nu>: "\<guillemotleft>\<nu> : DN f \<Rightarrow>\<^sub>B DN f'\<guillemotright>"
         show "\<exists>\<mu>. \<guillemotleft>\<mu> : f \<Rightarrow> f'\<guillemotright> \<and> DN \<mu> = \<nu>"
         proof -
           let ?\<mu> = "MkArr (Dom f) (Dom f') \<nu>"
           have \<mu>: "\<guillemotleft>?\<mu> : f \<Rightarrow> f'\<guillemotright>"
           proof
             have "Map f = \<lbrace>Dom f\<rbrace>"
               using f by simp
             have "Map f' = \<lbrace>Dom f'\<rbrace>"
               using f' by simp
             have "Dom f' = Cod f'"
               using f' Cod_ide by simp
             show \<mu>: "arr ?\<mu>"
             proof -
               have "E.Nml (Dom ?\<mu>) \<and> E.Ide (Dom ?\<mu>)"
               proof -
                 have "E.Nml (Dom f) \<and> E.Ide (Dom f)"
                   using f ide_char arr_char by blast
                 thus ?thesis
                   using f by simp
               qed
               moreover have "E.Nml (Cod ?\<mu>) \<and> E.Ide (Cod ?\<mu>)"
               proof -
                 have "E.Nml (Dom f') \<and> E.Ide (Dom f')"
                   using f' ide_char arr_char by blast
                 thus ?thesis
                   using f' by simp
               qed
               moreover have "E.Src (Dom ?\<mu>) = E.Src (Cod ?\<mu>)"
                 using f f' \<nu> arr_char src_def eq_src ideD(1) by auto
               moreover have "E.Trg (Dom ?\<mu>) = E.Trg (Cod ?\<mu>)"
                 using f f' \<nu> arr_char trg_def eq_trg ideD(1) by auto
               moreover have "\<guillemotleft>Map ?\<mu> : \<lbrace>Dom ?\<mu>\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Cod ?\<mu>\<rbrace>\<guillemotright>"
               proof -
                 have "\<guillemotleft>\<nu> : \<lbrace>Dom f\<rbrace> \<Rightarrow>\<^sub>B \<lbrace>Dom f'\<rbrace>\<guillemotright>"
                   using f f' \<nu> ide_char arr_char DN_def Cod_ide Map_ide
                   by (metis (no_types, lifting) ideD(1))
                 thus ?thesis by simp
               qed
               ultimately show ?thesis
                 using f f' \<nu> ide_char arr_char by blast
             qed
             show "dom ?\<mu> = f"
               using f \<mu> dom_char MkArr_Map MkIde_Dom' by simp
             show "cod ?\<mu> = f'"
             proof -
               have "cod ?\<mu> = MkIde (Dom f')"
                 using \<mu> cod_char by simp
               also have "... = MkArr (Dom f') (Cod f') (Map f')"
                 using f' by auto
               also have "... = f'"
                 using f' MkArr_Map by simp
               finally show ?thesis by simp
             qed
           qed
           moreover have "DN ?\<mu> = \<nu>"
             using \<mu> DN_def by auto
           ultimately show ?thesis by blast
         qed
       qed
       (* DN is biessentially surjective on objects. *)
       show "\<And>a'. B.obj a' \<Longrightarrow> \<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
       proof -
         fix a'
         assume a': "B.obj a'"
         have "obj (UP.map\<^sub>0 a')"
           using a' UP.map\<^sub>0_simps(1) by simp
         moreover have "B.equivalent_objects (DN.map\<^sub>0 (UP.map\<^sub>0 a')) a'"
         proof -
           have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle> \<^bold>\<langle>a'\<^bold>\<rangle> a')"
             using a' UP_def [of a'] UP.preserves_reflects_arr [of a'] by auto
           moreover have "arr (MkArr \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a'\<^bold>\<rangle>\<^sub>0 a')"
             using a' arr_char obj_simps by auto
           ultimately have "DN.map\<^sub>0 (UP.map\<^sub>0 a') = a'"
             using a' UP.map\<^sub>0_def DN.map\<^sub>0_def DN_def src_def by auto
           thus ?thesis
             using a' B.equivalent_objects_reflexive by simp
         qed
         ultimately show "\<exists>a. obj a \<and> B.equivalent_objects (DN.map\<^sub>0 a) a'"
           by blast
       qed
       (* DN is locally essentially surjective. *)
       show "\<And>a b g. \<lbrakk> obj a; obj b; \<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>; B.ide g \<rbrakk> \<Longrightarrow>
                        \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
       proof -
         fix a b g
         assume a: "obj a" and b: "obj b"
         and g: "\<guillemotleft>g : DN.map\<^sub>0 a \<rightarrow>\<^sub>B DN.map\<^sub>0 b\<guillemotright>" and ide_g: "B.ide g"
         have "ide (UP g)"
           using ide_g UP.preserves_ide by simp
         moreover have "B.isomorphic (DN (UP g)) g"
           using ide_g DN_UP B.isomorphic_reflexive by simp
         moreover have "\<guillemotleft>UP g : a \<rightarrow> b\<guillemotright>"
         proof
           show "arr (UP g)"
             using g UP.preserves_reflects_arr by auto
           show "src (UP g) = a"
           proof -
             have "src (UP g) = MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g)"
               using ide_g src_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
             also have "... = a"
             proof -
               have "src\<^sub>B g = src\<^sub>B (DN.map\<^sub>0 a)"
                 using a g B.in_hhom_def by simp
               also have "... = Map a"
                 using a Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src B.obj_simps
                 by auto
               finally have "src\<^sub>B g = Map a" by simp
               hence "MkArr \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>src\<^sub>B g\<^bold>\<rangle>\<^sub>0 (src\<^sub>B g) = MkArr \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map a\<^bold>\<rangle>\<^sub>0 (Map a)"
                 by simp
               also have "... = a"
                 using a obj_char [of a] MkIde_Dom [of a]
                 apply (cases "Dom a")
                          apply force
                 by simp_all
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
           show "trg (UP g) = b"
           proof -
             have "trg (UP g) = MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g)"
               using ide_g trg_def UP_def UP.preserves_reflects_arr [of g] B.ideD(1) by simp
             also have "... = b"
             proof -
               have "trg\<^sub>B g = trg\<^sub>B (DN.map\<^sub>0 b)"
                 using b g B.in_hhom_def by simp
               also have "... = Map b"
                 using b Map_preserves_objects DN.map\<^sub>0_def DN_def B.src_src B.obj_simps
                 by auto
               finally have "trg\<^sub>B g = Map b" by simp
               hence "MkArr \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>trg\<^sub>B g\<^bold>\<rangle>\<^sub>0 (trg\<^sub>B g) = MkArr \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>Map b\<^bold>\<rangle>\<^sub>0 (Map b)"
                 by simp
               also have "... = b"
                 using b obj_char [of b] MkIde_Dom [of b]
                 apply (cases "Dom b")
                          apply force
                 by simp_all
               finally show ?thesis by simp
             qed
             finally show ?thesis by simp
           qed
         qed
         ultimately show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> ide f \<and> B.isomorphic (DN f) g"
           by blast
       qed
     qed
 
     theorem DN_is_equivalence_pseudofunctor:
     shows "equivalence_pseudofunctor vcomp hcomp \<a> \<i> src trg V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B
              DN cmp\<^sub>D\<^sub>N"
       ..
 
     text \<open>
       The following gives an explicit formula for a component of the unit isomorphism of
       the pseudofunctor \<open>UP\<close> from a bicategory to its strictification.
       It is not currently being used -- I originally proved it in order to establish something
       that I later proved in a more abstract setting -- but it might be useful at some point.
     \<close>
     interpretation UP: equivalence_pseudofunctor
                          V\<^sub>B H\<^sub>B \<a>\<^sub>B \<i>\<^sub>B src\<^sub>B trg\<^sub>B vcomp hcomp \<a> \<i> src trg UP cmp\<^sub>U\<^sub>P
       using UP_is_equivalence_pseudofunctor by auto
 
     lemma UP_unit_char:
     assumes "B.obj a"
     shows "UP.unit a = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
     proof -
       have " MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a = UP.unit a"
       proof (intro UP.unit_eqI)
         show "B.obj a"
           using assms by simp
         have 0: "\<guillemotleft>a : a \<Rightarrow>\<^sub>B a\<guillemotright>"
           using assms by auto
         have 1: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         have 2: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         have 3: "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 a)"
           apply (unfold arr_char, intro conjI)
           using assms by auto
         show "\<guillemotleft>MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a : UP.map\<^sub>0 a \<Rightarrow> UP a\<guillemotright>"
         proof
           show "arr (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)" by fact
           show "dom (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP.map\<^sub>0 a"
             using assms 1 2 dom_char UP.map\<^sub>0_def UP_def src_def by auto
           show "cod (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) = UP a"
             using assms 1 2 cod_char UP.map\<^sub>0_def UP_def src_def by auto
         qed
         show "iso (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           using assms 1 iso_char by auto
         show "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) =
               (UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
         proof -
           have "MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<cdot> \<i> (UP.map\<^sub>0 a) = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
             unfolding \<i>_def UP.map\<^sub>0_def UP_def
             using assms 0 1 2 src_def by auto
           also have "... = (UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
           proof -
             have "(UP \<i>\<^sub>B[a] \<cdot> cmp\<^sub>U\<^sub>P (a, a)) \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a) =
                   (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
                      \<cdot> (MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a \<star> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a)"
               using assms UP_def cmp\<^sub>U\<^sub>P_ide_simp by auto
             also have "... = (MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a))
                                \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a)"
               using assms 0 1 2 3 hcomp_def B.comp_cod_arr src_def trg_def
                     B.can_Ide_self B.canE_unitor [of "\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"] B.comp_cod_arr
               by auto
             also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
             proof -
               have "MkArr \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> \<^bold>\<langle>a\<^bold>\<rangle> \<i>\<^sub>B[a] \<cdot> MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a \<star>\<^sub>B a\<^bold>\<rangle> (a \<star>\<^sub>B a) =
                     MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))"
                 using assms
                 by (intro comp_MkArr arr_MkArr) auto
               moreover have "MkArr (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) \<^bold>\<langle>a\<^bold>\<rangle> (\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a))
                                \<cdot> MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>) (B.runit' a) =
                              MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> ((\<i>\<^sub>B[a] \<cdot>\<^sub>B (a \<star>\<^sub>B a)) \<cdot>\<^sub>B B.runit' a)"
                 using assms 0 B.comp_arr_dom
                 by (intro comp_MkArr arr_MkArr, auto)
               ultimately show ?thesis by argo
             qed
             also have "... = MkArr \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle> a"
               using assms B.comp_arr_dom B.comp_arr_inv' B.iso_unit B.unitor_coincidence(2)
               by simp
             finally show ?thesis by argo
           qed
           finally show ?thesis by simp
         qed
       qed
       thus ?thesis by simp
     qed
 
   end
 
   subsection "Pseudofunctors into a Strict Bicategory"
 
   text \<open>
     In the special case of a pseudofunctor into a strict bicategory, we can obtain
     explicit formulas for the images of the units and associativities under the pseudofunctor,
     which only involve the structure maps of the pseudofunctor, since the units and associativities
     in the target bicategory are all identities.  This is useful in applying strictification.
   \<close>
 
   locale pseudofunctor_into_strict_bicategory =
     pseudofunctor +
     D: strict_bicategory V\<^sub>D H\<^sub>D \<a>\<^sub>D \<i>\<^sub>D src\<^sub>D trg\<^sub>D
   begin
 
     lemma image_of_unitor:
     assumes "C.ide g"
     shows "F \<l>\<^sub>C[g] = (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
     and "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
     and "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
     and "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
     proof -
       show A: "F \<l>\<^sub>C[g] = (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
       proof -
         have 1: "\<guillemotleft>(D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) :
                      F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
         proof
           show "\<guillemotleft>D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g : F (trg\<^sub>C g) \<star>\<^sub>D F g \<Rightarrow>\<^sub>D F g\<guillemotright>"
             using assms unit_char by (auto simp add: D.hcomp_obj_arr)
           show "\<guillemotleft>D.inv (\<Phi> (trg\<^sub>C g, g)) : F (trg\<^sub>C g \<star>\<^sub>C g) \<Rightarrow>\<^sub>D F (trg\<^sub>C g) \<star>\<^sub>D F g\<guillemotright>"
             using assms cmp_in_hom(2) D.inv_is_inverse by simp
         qed
         have "(D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) =
               F g \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
           using 1 D.comp_cod_arr by auto
         also have "... = (F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
                            (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g))"
           using assms lunit_coherence [of g] D.strict_lunit by simp
         also have "... = F \<l>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D
                                     ((unit (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g)) \<cdot>\<^sub>D
                                    D.inv (\<Phi> (trg\<^sub>C g, g))"
           using D.comp_assoc by simp
         also have "... = F \<l>\<^sub>C[g]"
         proof -
           have "(unit (trg\<^sub>C g) \<star>\<^sub>D F g) \<cdot>\<^sub>D (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) = F (trg\<^sub>C g) \<star>\<^sub>D F g"
             using assms unit_char D.whisker_right
             by (metis C.ideD(1) C.obj_trg C.trg.preserves_reflects_arr D.comp_arr_inv'
                 unit_simps(5) preserves_arr preserves_ide)
           moreover have "\<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)) = F (trg\<^sub>C g \<star>\<^sub>C g)"
             using assms D.comp_arr_inv D.inv_is_inverse by simp
           ultimately show ?thesis
             using assms D.comp_arr_dom D.comp_cod_arr unit_char by auto
         qed
         finally show ?thesis by simp
       qed
       show B: "F \<r>\<^sub>C[g] = (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
       proof -
         have 1: "\<guillemotleft>(F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) :
                     F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
         proof
           show "\<guillemotleft>F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g)) : F g \<star>\<^sub>D F (src\<^sub>C g) \<Rightarrow>\<^sub>D F g\<guillemotright>"
             using assms unit_char by (auto simp add: D.hcomp_arr_obj)
           show "\<guillemotleft>D.inv (\<Phi> (g, src\<^sub>C g)) : F (g \<star>\<^sub>C src\<^sub>C g) \<Rightarrow>\<^sub>D F g \<star>\<^sub>D F (src\<^sub>C g)\<guillemotright>"
             using assms cmp_in_hom(2) by simp
         qed
         have "(F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) =
               F g \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
           using 1 D.comp_cod_arr by auto
         also have "... = (F \<r>\<^sub>C[g] \<cdot>\<^sub>D \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))) \<cdot>\<^sub>D
                            (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
            using assms runit_coherence [of g] D.strict_runit by simp
         also have "... = F \<r>\<^sub>C[g] \<cdot>\<^sub>D (\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D ((F g \<star>\<^sub>D unit (src\<^sub>C g)) \<cdot>\<^sub>D
                            (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g))"
            using D.comp_assoc by simp
         also have "... = F \<r>\<^sub>C[g]"
         proof -
           have "(F g \<star>\<^sub>D unit (src\<^sub>C g)) \<cdot>\<^sub>D (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) = F g \<star>\<^sub>D F (src\<^sub>C g)"
             using assms D.whisker_left unit_char
             by (metis C.ideD(1) C.obj_src C.src.preserves_ide D.comp_arr_inv' D.ideD(1)
                 unit_simps(5) preserves_ide)
           moreover have "\<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)) = F (g \<star>\<^sub>C src\<^sub>C g)"
             using assms D.comp_arr_inv D.inv_is_inverse by simp
           ultimately show ?thesis
             using assms D.comp_arr_dom D.comp_cod_arr unit_char cmp_in_hom(2) [of g "src\<^sub>C g"]
             by auto
         qed
         finally show ?thesis by simp
       qed
       show "F (C.lunit' g) = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
       proof -
         have "F (C.lunit' g) = D.inv (F \<l>\<^sub>C[g])"
           using assms C.iso_lunit preserves_inv by simp
         also have "... = D.inv ((D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<cdot>\<^sub>D D.inv (\<Phi> (trg\<^sub>C g, g)))"
           using A by simp
         also have "... = \<Phi> (trg\<^sub>C g, g) \<cdot>\<^sub>D (unit (trg\<^sub>C g) \<star>\<^sub>D F g)"
         proof -
           have "D.iso (D.inv (\<Phi> (trg\<^sub>C g, g))) \<and> D.inv (D.inv (\<Phi> (trg\<^sub>C g, g))) = \<Phi> (trg\<^sub>C g, g)"
             using assms by simp
           moreover have "D.iso (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) \<and>
                          D.inv (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) = unit (trg\<^sub>C g) \<star>\<^sub>D F g"
             using assms unit_char by simp
           moreover have "D.seq (D.inv (unit (trg\<^sub>C g)) \<star>\<^sub>D F g) (D.inv (\<Phi> (trg\<^sub>C g, g)))"
             using assms unit_char by (metis A C.lunit_simps(1) preserves_arr)
           ultimately show ?thesis
             using D.inv_comp by simp
         qed
         finally show ?thesis by simp
       qed
       show "F (C.runit' g) = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
       proof -
         have "F (C.runit' g) = D.inv (F \<r>\<^sub>C[g])"
           using assms C.iso_runit preserves_inv by simp
         also have "... = D.inv ((F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<cdot>\<^sub>D D.inv (\<Phi> (g, src\<^sub>C g)))"
           using B by simp
         also have "... = \<Phi> (g, src\<^sub>C g) \<cdot>\<^sub>D (F g \<star>\<^sub>D unit (src\<^sub>C g))"
         proof -
           have "D.iso (D.inv (\<Phi> (g, src\<^sub>C g))) \<and> D.inv (D.inv (\<Phi> (g, src\<^sub>C g))) = \<Phi> (g, src\<^sub>C g)"
             using assms by simp
           moreover have "D.iso (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) \<and>
                          D.inv (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) = F g \<star>\<^sub>D unit (src\<^sub>C g)"
             using assms unit_char by simp
           moreover have "D.seq (F g \<star>\<^sub>D D.inv (unit (src\<^sub>C g))) (D.inv (\<Phi> (g, src\<^sub>C g)))"
             using assms unit_char by (metis B C.runit_simps(1) preserves_arr)
           ultimately show ?thesis
             using D.inv_comp by simp
         qed
         finally show ?thesis by simp
       qed
     qed
 
     lemma image_of_associator:
     assumes "C.ide f" and "C.ide g" and "C.ide h" and "src\<^sub>C f = trg\<^sub>C g" and "src\<^sub>C g = trg\<^sub>C h"
     shows "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                              (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
     and "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                 (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
     proof -
       show 1: "F \<a>\<^sub>C[f, g, h] = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                                  (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
       proof -
         have 2: "D.seq (\<Phi> (f, g \<star>\<^sub>C h)) ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])"
           using assms D.assoc_in_hom(2) [of "F f" "F g" "F h"] cmp_simps(1,4) C.VV.cod_simp
           by (intro D.seqI) auto
         moreover have 3: "F \<a>\<^sub>C[f, g, h] \<cdot>\<^sub>D \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) =
                           \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
           using assms assoc_coherence [of f g h] by blast
         moreover have "D.iso (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
           using assms 2 3 C.VV.arr_char C.VV.dom_char C.VV.cod_char FF_def D.isos_compose
           by auto
         ultimately have "F \<a>\<^sub>C[f, g, h] =
                          (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D ((F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h])) \<cdot>\<^sub>D
                            D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h))"
           using D.invert_side_of_triangle(2)
                   [of "\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h]"
                       "F \<a>\<^sub>C[f, g, h]" "\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)"]
           by presburger
         also have "... = \<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                             (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
         proof -
           have "D.inv (\<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h)) =
                 (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h))"
           proof -
             have "D.seq (\<Phi> (f \<star>\<^sub>C g, h)) (\<Phi> (f, g) \<star>\<^sub>D F h)"
               using assms by fastforce
             thus ?thesis
               using assms D.inv_comp by simp
           qed
           moreover have "(F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D \<a>\<^sub>D[F f, F g, F h] = (F f \<star>\<^sub>D \<Phi> (g, h))"
             using assms D.comp_arr_dom D.assoc_in_hom [of "F f" "F g" "F h"] cmp_in_hom
             by (metis "2" "3" D.comp_arr_ide D.hseq_char D.seqE D.strict_assoc
                 cmp_simps(2) cmp_simps(3) preserves_ide)
           ultimately show ?thesis
             using D.comp_assoc by simp
         qed
         finally show ?thesis
           by simp
       qed
       show "F (C.\<a>' f g h) = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
       proof -
         have "F (C.\<a>' f g h) = D.inv (F \<a>\<^sub>C[f, g, h])"
           using assms preserves_inv by simp
         also have "... = D.inv (\<Phi> (f, g \<star>\<^sub>C h) \<cdot>\<^sub>D (F f \<star>\<^sub>D \<Phi> (g, h)) \<cdot>\<^sub>D
                                   (D.inv (\<Phi> (f, g)) \<star>\<^sub>D F h) \<cdot>\<^sub>D D.inv (\<Phi> (f \<star>\<^sub>C g, h)))"
           using 1 by simp
         also have "... = \<Phi> (f \<star>\<^sub>C g, h) \<cdot>\<^sub>D (\<Phi> (f, g) \<star>\<^sub>D F h) \<cdot>\<^sub>D
                                    (F f \<star>\<^sub>D D.inv (\<Phi> (g, h))) \<cdot>\<^sub>D D.inv (\<Phi> (f, g \<star>\<^sub>C h))"
           using assms C.VV.arr_char FF_def D.hcomp_assoc D.comp_assoc
                 C.VV.dom_simp C.VV.cod_simp
           (* OK, this is pretty cool, but not as cool as if I didn't have to direct it. *)
           by (simp add: D.inv_comp D.isos_compose)
         finally show ?thesis by simp
       qed
     qed
 
   end
 
   subsection "Internal Equivalences in a Strict Bicategory"
 
   text \<open>
     In this section we prove a useful fact about internal equivalences in a strict bicategory:
     namely, that if the ``right'' triangle identity holds for such an equivalence then the
     ``left'' does, as well.  Later we will dualize this property, and use strictification to
     extend it to arbitrary bicategories.
   \<close>
 
   locale equivalence_in_strict_bicategory =
     strict_bicategory +
     equivalence_in_bicategory
   begin
 
     lemma triangle_right_implies_left:
     shows "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g \<Longrightarrow> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f"
     proof -
       text \<open>
         The formal proof here was constructed following the string diagram sketch below,
         which appears in \cite{nlab-zigzag-diagram}
         (see it also in context in \cite{nlab-adjoint-equivalence}).
         The diagram is reproduced here by permission of its author, Mike Shulman,
         who says (private communication):
         ``Just don't give the impression that the proof itself is due to me, because it's not.
         I don't know who first gave that proof; it's probably folklore.''
         \begin{figure}[h]
           \includegraphics[width=6.5in]{triangle_right_implies_left.png}
         \end{figure}
       \<close>
       assume 1: "(g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
       have 2: "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = g"
       proof -
         have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) = inv ((g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g))"
           using antipar inv_comp hcomp_assoc by simp
         also have "... = g"
           using 1 by simp
         finally show ?thesis by blast
       qed
       have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) = f \<star> \<eta>"
           using 2 ide_left ide_right antipar whisker_left
           by (metis comp_cod_arr unit_simps(1) unit_simps(3))
         thus ?thesis by simp
       qed
       also have "... = (\<epsilon> \<star> f) \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot> (f \<star> \<eta>) \<star> (inv \<eta> \<cdot> \<eta>)"
       proof -
         have "inv \<eta> \<cdot> \<eta> = src f"
           by (simp add: comp_inv_arr')
         thus ?thesis
           by (metis antipar(1) antipar(2) arrI calculation
               comp_ide_arr hcomp_arr_obj ideD(1) ide_left ide_right obj_src seqE
               strict_assoc' triangle_in_hom(1) vconn_implies_hpar(1))
       qed
       also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> ((f \<star> inv \<eta>) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
         using ide_left ide_right antipar unit_is_iso
         by (metis "2" arr_inv calculation comp_arr_dom comp_inv_arr' counit_simps(1)
             counit_simps(2) dom_inv hcomp_arr_obj ideD(1) unit_simps(1) unit_simps(2)
             unit_simps(5) obj_trg seqI whisker_left)
       also have "... = (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star>
                          ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>))) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (f \<star> g) \<star> f"
           using whisker_right [of f "inv \<epsilon>" \<epsilon>] counit_in_hom
           by (simp add: antipar(1) comp_inv_arr')
         thus ?thesis
           using hcomp_assoc comp_arr_dom
           by (metis comp_cod_arr ide_left local.unit_simps(1) local.unit_simps(3)
               whisker_left)
       qed
       also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<cdot> (f \<star> g)) \<star>
                          (((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
                            (f \<star> \<eta>)"
         using ide_left ide_right antipar comp_assoc whisker_right comp_cod_arr
         by (metis "2" comp_arr_dom counit_simps(1-2))
       also have "... = (((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
                          ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))) \<cdot>
                            (f \<star> \<eta>)"
       proof -
         have 3: "seq (\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) (f \<star> g)"
           using 2 antipar by auto
         moreover have 4: "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) ((\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>))"
           using antipar hcomp_assoc by auto
         ultimately show ?thesis
           using interchange by simp
       qed
       also have "... = ((\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f))) \<cdot>
                         ((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>)"
         using comp_assoc by presburger
       also have "... = ((\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)) \<cdot>
                            (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(\<epsilon> \<cdot> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))) \<star> ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) =
               (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)) \<star> f)"
         proof -
           have "seq \<epsilon> (f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>))"
             using 2 antipar by simp
           moreover have "seq ((f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) f"
             using antipar hcomp_assoc hcomp_obj_arr by auto
           ultimately show ?thesis
             using comp_assoc comp_arr_dom hcomp_obj_arr
                   interchange [of \<epsilon> "f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>)" "(f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)" f]
             by simp
         qed
         moreover have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
                        (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
         proof -
           have "((f \<star> g) \<star> (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)) \<cdot> (f \<star> \<eta>) =
                 (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> (g \<star> f) \<star> \<eta>) \<cdot> (f \<star> \<eta> \<star> src f)"
             using antipar comp_assoc hcomp_assoc whisker_left hcomp_arr_obj by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> ((g \<star> f) \<star> \<eta>) \<cdot> (\<eta> \<cdot> src f))"
             using antipar comp_arr_dom whisker_left hcomp_arr_obj by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> \<eta>)"
             using antipar comp_arr_dom comp_cod_arr hcomp_arr_obj
                   interchange [of "g \<star> f" \<eta> \<eta> "src f"]
             by simp
           also have "... = (f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f) \<cdot> (f \<star> src f \<star> \<eta>)"
             using antipar comp_arr_dom comp_cod_arr whisker_left
                   interchange [of \<eta> "src f" "g \<star> f" \<eta>]
             by simp
           also have "... = ((f \<star> g \<star> \<epsilon> \<star> f) \<cdot> (f \<star> \<eta> \<star> g \<star> f)) \<cdot> (f \<star> \<eta>)"
             using antipar comp_assoc by (simp add: hcomp_obj_arr)
           also have "... = (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f) \<cdot> (f \<star> \<eta>)"
             using antipar comp_assoc whisker_left whisker_right hcomp_assoc by simp
           finally show ?thesis by blast
         qed
         ultimately show ?thesis by simp
       qed
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<star> f) \<cdot>
                            (f \<star> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot> (f \<star> \<eta>)"
         using comp_assoc hcomp_assoc antipar(1) antipar(2) by auto
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot>
                          ((f \<star> (inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) \<star> f)) \<cdot>
                            (f \<star> \<eta>)"
         using ide_left ide_right antipar comp_cod_arr comp_assoc whisker_left
         by (metis "1" "2" comp_ide_self unit_simps(1) unit_simps(3))
       also have "... = (\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(inv \<eta> \<star> g) \<cdot> (g \<star> inv \<epsilon>) \<cdot> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
           using ide_left ide_right antipar comp_arr_dom comp_assoc
           by (metis "1" "2" comp_ide_self)
         thus ?thesis
           using antipar comp_cod_arr by simp
       qed
       also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
       proof -
         have "(\<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
               (trg f \<cdot> \<epsilon> \<star> (f \<star> inv \<eta>) \<cdot> (inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
           using hcomp_obj_arr comp_cod_arr by simp
         also have "... = ((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
           using antipar hcomp_arr_obj hcomp_assoc interchange by auto
         also have "... = (f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>)"
         proof -
           have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = (trg f \<star> inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> trg f \<star> f)"
             using hseqI' by (simp add: hcomp_obj_arr)
           also have "... = \<epsilon> \<star> inv \<epsilon> \<star> f"
             using antipar comp_arr_dom comp_cod_arr
                   interchange [of "trg f" \<epsilon> "inv \<epsilon> \<star> f" "trg f \<star> f"]
             by force
           finally have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = \<epsilon> \<star> inv \<epsilon> \<star> f" by simp
           moreover have "trg f \<star> f \<star> inv \<eta> = f \<star> inv \<eta>"
             using hcomp_obj_arr [of "trg f" "f \<star> inv \<eta>"] by fastforce
           ultimately have "((trg f \<star> f \<star> inv \<eta>) \<cdot> (\<epsilon> \<star> inv \<epsilon> \<star> f)) \<cdot> (f \<star> \<eta>) =
                            ((f \<star> inv \<eta>) \<cdot> ((inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f))) \<cdot> (f \<star> \<eta>)"
             by simp
           thus ?thesis
             using comp_assoc by simp
         qed
         finally show ?thesis by simp
       qed
       also have "... = f \<star> inv \<eta> \<cdot> \<eta>"
       proof -
         have "(inv \<epsilon> \<star> f) \<cdot> (\<epsilon> \<star> f) = f \<star> g \<star> f"
           using ide_left ide_right antipar counit_is_iso whisker_right hcomp_assoc
           by (metis comp_arr_dom comp_inv_arr' counit_simps(1) counit_simps(2) seqE)
         thus ?thesis
           using ide_left ide_right antipar unit_is_iso comp_cod_arr
           by (metis arr_inv dom_inv unit_simps(1) unit_simps(3) seqI whisker_left)
       qed
       also have "... = f \<star> src f"
         using antipar by (simp add: comp_inv_arr')
       also have "... = f"
         using hcomp_arr_obj by simp
       finally show ?thesis by simp
     qed
 
   end
 
   text \<open>
     Now we use strictification to generalize the preceding result to arbitrary bicategories.
     I originally attempted to generalize this proof directly from the strict case, by filling
     in the necessary canonical isomorphisms, but it turned out to be too daunting.
     The proof using strictification is still fairly tedious, but it is manageable.
   \<close>
 
   context equivalence_in_bicategory
   begin
 
     interpretation S: strictified_bicategory V H \<a> \<i> src trg ..
 
     notation S.vcomp  (infixr "\<cdot>\<^sub>S" 55)
     notation S.hcomp  (infixr "\<star>\<^sub>S" 53)
     notation S.in_hom  ("\<guillemotleft>_ : _ \<Rightarrow>\<^sub>S _\<guillemotright>")
     notation S.in_hhom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
 
     interpretation UP: equivalence_pseudofunctor V H \<a> \<i> src trg
                           S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.cmp\<^sub>U\<^sub>P
       using S.UP_is_equivalence_pseudofunctor by auto
     interpretation UP: pseudofunctor_into_strict_bicategory V H \<a> \<i> src trg
                           S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg S.UP S.cmp\<^sub>U\<^sub>P
       ..
     interpretation E: equivalence_in_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
                         \<open>S.UP f\<close> \<open>S.UP g\<close>
                         \<open>S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f)\<close>
                         \<open>S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)\<close>
       using equivalence_in_bicategory_axioms UP.preserves_equivalence [of f g \<eta> \<epsilon>] by auto
     interpretation E: equivalence_in_strict_bicategory S.vcomp S.hcomp S.\<a> S.\<i> S.src S.trg
                         \<open>S.UP f\<close> \<open>S.UP g\<close>
                         \<open>S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f)\<close>
                         \<open>S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)\<close>
       ..
 
     lemma UP_triangle:
     shows "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
             S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
               (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
     and "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
             (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
     and "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     and "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
             (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     and "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                  (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
                (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                  (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
     proof -
       show T1: "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
                 S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                   (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
       proof -
         have "S.UP ((g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g)) =
                 S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.UP \<a>[g, f, g] \<cdot>\<^sub>S S.UP (\<eta> \<star> g)"
           using antipar by simp
         also have "... =
                    (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S
                    ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S
                      (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                    (((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)))) \<cdot>\<^sub>S
                    S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         proof -
           have "S.UP \<a>[g, f, g] =
                 S.cmp\<^sub>U\<^sub>P (g, f \<star> g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                 (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g))"
             using ide_left ide_right antipar UP.image_of_associator [of g f g] by simp
           moreover have
             "S.UP (g \<star> \<epsilon>) =
              S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g))"
           proof -
             have "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g)) (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
               using antipar UP.FF_def UP.cmp_in_hom [of g "src g"]
               apply (intro S.seqI) by auto
             moreover have
               "S.UP (g \<star> \<epsilon>) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g) = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)"
               using antipar UP.\<Phi>.naturality [of "(g, \<epsilon>)"] UP.FF_def VV.arr_char
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.iso (S.cmp\<^sub>U\<^sub>P (g, f \<star> g))"
               using antipar by simp
             ultimately show ?thesis
-              using antipar S.comp_assoc
-                    S.invert_side_of_triangle(2)
+              using S.invert_side_of_triangle(2)
                       [of "S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon>)" "S.UP (g \<star> \<epsilon>)"
-                          "S.cmp\<^sub>U\<^sub>P (g, f \<star> g)"]
-              by simp
+                          "S.cmp\<^sub>U\<^sub>P (g, f \<star> g)"] S.comp_assoc
+              by presburger
           qed
           moreover have "S.UP (\<eta> \<star> g) =
                          (S.cmp\<^sub>U\<^sub>P (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
           proof -
             have "S.UP (\<eta> \<star> g) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (trg g, g) =
                   S.cmp\<^sub>U\<^sub>P (g \<star> f, g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)"
               using antipar UP.\<Phi>.naturality [of "(\<eta>, g)"] UP.FF_def VV.arr_char
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.seq (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) (S.UP \<eta> \<star>\<^sub>S S.UP g)"
               using antipar UP.cmp_in_hom(2) by (intro S.seqI, auto)
             ultimately show ?thesis
               using antipar S.invert_side_of_triangle(2) by simp
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S
                            ((S.UP g \<star>\<^sub>S S.UP \<epsilon>) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                            ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         proof -
           have "(S.inv (S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g \<star> f, g)) \<cdot>\<^sub>S (S.UP \<eta> \<star>\<^sub>S S.UP g) =
                 (S.UP \<eta> \<star>\<^sub>S S.UP g)"
             using antipar S.comp_inv_arr' S.comp_cod_arr by auto
           moreover have "(S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                            = (S.UP g \<star>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))"
           proof -
             have "S.inv (S.cmp\<^sub>U\<^sub>P (g, f \<star> g)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (g, f \<star> g) = S.UP g \<star>\<^sub>S S.UP (f \<star> g)"
               using antipar S.comp_inv_arr' UP.cmp_in_hom by auto
             thus ?thesis
               using antipar VV.arr_char S.comp_cod_arr by simp
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                            (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
             using antipar VV.arr_char S.whisker_left S.whisker_right by auto
         finally show ?thesis by simp
       qed
       show T2: "S.UP (\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]) =
                 (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                    (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
         using UP.image_of_unitor by simp
       show "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
             S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
       proof -
         have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) =
                  S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.UP \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot>\<^sub>S S.UP (f \<star> \<eta>)"
           using antipar by simp
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                           (S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f) \<cdot>\<^sub>S
                            (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                          (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S
                          S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "S.UP \<a>\<^sup>-\<^sup>1[f, g, f] =
                 S.cmp\<^sub>U\<^sub>P (f \<star> g, f) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S
                    S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f))"
             using ide_left ide_right antipar UP.image_of_associator by simp
           moreover have "S.UP (\<epsilon> \<star> f) =
                          S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f))"
           proof -
             have "S.seq (S.cmp\<^sub>U\<^sub>P (trg f, f)) (S.UP \<epsilon> \<star>\<^sub>S S.UP f)"
               using antipar UP.FF_def VV.ide_char VV.arr_char UP.cmp_in_hom [of "trg f" f]
               apply (intro S.seqI) by auto
             moreover have
               "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f) = S.UP (\<epsilon> \<star> f) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f)"
               using antipar UP.\<Phi>.naturality [of "(\<epsilon>, f)"] UP.FF_def VV.arr_char
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.iso (S.cmp\<^sub>U\<^sub>P (f \<star> g, f))"
               using antipar by simp
             ultimately show ?thesis
               using antipar S.comp_assoc
                     S.invert_side_of_triangle(2)
                       [of "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<star>\<^sub>S S.UP f)" "S.UP (\<epsilon> \<star> f)"
                           "S.cmp\<^sub>U\<^sub>P (f \<star> g, f)"]
               by metis
           qed
           moreover have "S.UP (f \<star> \<eta>) =
                         (S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
           proof -
             have "S.cmp\<^sub>U\<^sub>P (f, g \<star> f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>) =
                   S.UP (f \<star> \<eta>) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, src f)"
               using antipar UP.\<Phi>.naturality [of "(f, \<eta>)"] UP.FF_def VV.arr_char
                     VV.dom_simp VV.cod_simp
               by simp
             moreover have "S.seq (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) (S.UP f \<star>\<^sub>S S.UP \<eta>)"
               using antipar by (intro S.seqI, auto)
             ultimately show ?thesis
               using antipar S.invert_side_of_triangle(2) by auto
           qed
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S
                            ((S.UP \<epsilon> \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                            ((S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f))) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                            S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "(S.inv (S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f \<star> g, f)) \<cdot>\<^sub>S (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) =
                 (S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)"
             using antipar S.comp_cod_arr VV.arr_char S.comp_inv_arr' by auto
           moreover have "(S.inv (S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g \<star> f)) \<cdot>\<^sub>S
                          (S.UP f \<star>\<^sub>S S.UP \<eta>)
                          = (S.UP f \<star>\<^sub>S S.UP \<eta>)"
             using antipar S.comp_inv_arr' S.comp_cod_arr by auto
           ultimately show ?thesis
             using S.comp_assoc by simp
         qed
         also have "... = S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                            (S.UP f \<star>\<^sub>S
                               S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
             using antipar VV.arr_char S.whisker_left S.whisker_right by auto
         finally show ?thesis by simp
       qed
       show "S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]) =
             (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
               (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         using UP.image_of_unitor by simp
       show "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] \<Longrightarrow>
               S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                   (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
               (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                   (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
       proof -
         assume A: "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         have B: "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                    (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
         proof -
           show "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                 (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g) = S.UP g"
           proof -
             have 2: "S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                        (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                        S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))
                      = (S.cmp\<^sub>U\<^sub>P (g, src g) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S UP.unit (src g))) \<cdot>\<^sub>S
                          (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
               using A T1 T2 by simp
             show ?thesis
             proof -
               have 8: "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g))
                              ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                                S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                 using antipar VV.arr_char S.hcomp_assoc
                 by (metis (no_types, lifting) S.arr_UP T1 arrI triangle_in_hom(2))
               have 7: "S.seq (S.cmp\<^sub>U\<^sub>P (g, src g))
                              ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S
                                S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                 using antipar 2 8 S.comp_assoc by auto
               have 5: "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                          (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
                        (S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)"
               proof -
                 have "((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S
                         S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)) =
                       ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                         S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g))"
                 proof -
                   have "S.mono (S.cmp\<^sub>U\<^sub>P (g, src g))"
                     using antipar S.iso_is_section S.section_is_mono by simp
                   thus ?thesis
                     using 2 8 7 S.monoE S.comp_assoc by presburger
                 qed
                 moreover have "S.epi (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using antipar S.iso_is_retraction S.retraction_is_epi by simp
                 moreover have "S.seq ((S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                       (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S
                                       S.UP \<eta> \<star>\<^sub>S S.UP g))
                                      (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using S.comp_assoc S.seq_char 8 by presburger
                 moreover have
                   "S.seq ((S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g))
                          (S.inv (S.cmp\<^sub>U\<^sub>P (trg g, g)))"
                   using antipar calculation(1,3) by presburger
                 ultimately show ?thesis
                   using 2 S.epiE by blast
               qed
               have 6: "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                              (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                 using antipar VV.arr_char S.hcomp_assoc by auto
               have 3: "(S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                        (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g) =
                        (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g)"
               proof -
                 have "S.seq (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))
                             (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                   using 6 by simp
                 moreover have "(S.UP g \<star>\<^sub>S UP.unit (src g)) \<cdot>\<^sub>S (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) =
                                (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                  (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                   using 5 by argo
                 moreover have "S.iso (S.UP g \<star>\<^sub>S UP.unit (src g))"
                   using antipar UP.unit_char S.UP_map\<^sub>0_obj by simp
                 moreover have "S.inv (S.UP g \<star>\<^sub>S UP.unit (src g)) =
                                S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))"
                   using antipar UP.unit_char S.UP_map\<^sub>0_obj by simp
                 ultimately show ?thesis
                   using S.invert_side_of_triangle(1)
                           [of "(S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g)) \<cdot>\<^sub>S
                                  (S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)"
                               "S.UP g \<star>\<^sub>S UP.unit (src g)" "S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g"]
                   by presburger
               qed
               have 4: "((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)
                        = S.UP g"
               proof -
                 have "(((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g)) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)) =
                       (((S.UP g \<star>\<^sub>S S.inv (UP.unit (src g))) \<cdot>\<^sub>S
                          (S.UP g \<star>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g))) \<cdot>\<^sub>S
                          ((S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<star>\<^sub>S S.UP g))) \<cdot>\<^sub>S
                          (UP.unit (trg g) \<star>\<^sub>S S.UP g)"
                   using S.comp_assoc by simp
                 also have "... =
                            (S.inv (UP.unit (trg g)) \<star>\<^sub>S S.UP g) \<cdot>\<^sub>S (UP.unit (trg g) \<star>\<^sub>S S.UP g)"
                   using 3 S.comp_assoc by auto
                 also have "... = S.inv (UP.unit (trg g)) \<cdot>\<^sub>S UP.unit (trg g) \<star>\<^sub>S S.UP g"
                   using UP.unit_char(2) S.whisker_right by auto
                 also have "... = UP.map\<^sub>0 (trg g) \<star>\<^sub>S S.UP g"
                   using UP.unit_char [of "trg g"] S.comp_inv_arr S.inv_is_inverse by simp
                 also have "... = S.UP g"
                   using S.UP_map\<^sub>0_obj by (simp add: S.hcomp_obj_arr)
                 finally show ?thesis by blast
               qed
               thus ?thesis
                 using antipar S.whisker_left S.whisker_right UP.unit_char S.comp_assoc by simp
             qed
           qed
         qed
         show "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                 (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
               (S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S (UP.unit (trg f) \<star>\<^sub>S S.UP f)) \<cdot>\<^sub>S
                 (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
         proof -
           have "(S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) =
                    (UP.unit (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f)))"
           proof -
             have 2: "(S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                           (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S UP.unit (src f)) =
                      S.UP f"
             proof -
               have "S.UP f = (S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S 
                                S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f))"
                 using B antipar E.triangle_right_implies_left by argo
               also have "... = (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                  ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                     (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                                  (S.UP f \<star>\<^sub>S UP.unit (src f))"
               proof -
                 have "S.inv (UP.unit (trg f)) \<cdot>\<^sub>S S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f =
                         (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         (S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f)"
                   using UP.unit_char S.whisker_right by simp
                 moreover have "S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta> \<cdot>\<^sub>S UP.unit (src f) =
                                  (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>) \<cdot>\<^sub>S
                                    (S.UP f \<star>\<^sub>S UP.unit (src f))"
                   using antipar UP.unit_char S.whisker_left S.comp_assoc by simp
                 ultimately show ?thesis
                   using S.comp_assoc by presburger
               qed
               finally show ?thesis by argo
             qed
             show ?thesis
             proof -
               have "((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                         (S.UP f \<star>\<^sub>S UP.unit (src f)) =
                      (UP.unit (trg f) \<star>\<^sub>S S.UP f)"
               proof -
                 have "S.inv (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S S.UP f =
                       UP.unit (trg f) \<star>\<^sub>S S.UP f"
                   using UP.unit_char S.comp_arr_dom S.UP_map\<^sub>0_obj
                   by (simp add: S.hcomp_obj_arr)
                 moreover have "S.arr (S.UP f)"
                   by simp
                 moreover have "S.iso (S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f)"
                   using S.UP_map\<^sub>0_obj by (simp add: UP.unit_char(2))
                 ultimately show ?thesis
                   using 2 S.invert_side_of_triangle(1)
                             [of "S.UP f" "S.inv (UP.unit (trg f)) \<star>\<^sub>S S.UP f"
                                 "((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                    (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S
                                  (S.UP f \<star>\<^sub>S UP.unit (src f))"]
                   by presburger
               qed
               moreover have "S.hseq (UP.unit (trg f)) (S.UP f) \<and>
                              S.iso (S.UP f \<star>\<^sub>S UP.unit (src f)) \<and>
                              S.inv (S.UP f \<star>\<^sub>S UP.unit (src f)) = S.UP f \<star>\<^sub>S S.inv (UP.unit (src f))"
                 using UP.unit_char S.UP_map\<^sub>0_obj by simp
               ultimately show ?thesis
                 using S.invert_side_of_triangle(2)
                         [of "UP.unit (trg f) \<star>\<^sub>S S.UP f"
                             "(S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                                (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)"
                             "S.UP f \<star>\<^sub>S UP.unit (src f)"]
                 by presburger
             qed
           qed
           hence "S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S ((S.UP \<epsilon> \<cdot>\<^sub>S S.cmp\<^sub>U\<^sub>P (f, g) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                    (S.UP f \<star>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (g, f)) \<cdot>\<^sub>S S.UP \<eta>)) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f)) =
                  S.cmp\<^sub>U\<^sub>P (trg f, f) \<cdot>\<^sub>S ((UP.unit (trg f) \<star>\<^sub>S S.UP f) \<cdot>\<^sub>S
                    (S.UP f \<star>\<^sub>S S.inv (UP.unit (src f)))) \<cdot>\<^sub>S S.inv (S.cmp\<^sub>U\<^sub>P (f, src f))"
             by simp
           thus ?thesis
             using S.comp_assoc by simp
         qed
       qed
     qed
 
     lemma triangle_right_implies_left:
     assumes "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
     shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
     proof -
       have "par ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
         using antipar by simp
       moreover have "S.UP ((\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>)) = S.UP (\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f])"
         using assms UP_triangle(3-5) by simp
       ultimately show "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
         using UP.is_faithful by blast
     qed
 
     text \<open>
       We \emph{really} don't want to go through the ordeal of proving a dual version of
       \<open>UP_triangle(5)\<close>, do we?  So let's be smart and dualize via the opposite bicategory.
     \<close>
 
     lemma triangle_left_implies_right:
     assumes "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
     shows "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
     proof -
       interpret Cop: op_bicategory V H \<a> \<i> src trg ..
       interpret Eop: equivalence_in_bicategory V Cop.H Cop.\<a> \<i> Cop.src Cop.trg g f \<eta> \<epsilon>
         using antipar unit_in_hom counit_in_hom
         by (unfold_locales) simp_all
       have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<Longrightarrow>
             (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         using antipar Cop.lunit_ide_simp Cop.runit_ide_simp Cop.assoc_ide_simp
               VVV.ide_char VVV.arr_char VV.arr_char Eop.triangle_right_implies_left
         by simp
       thus ?thesis
         using assms by simp
     qed
 
     lemma triangle_left_iff_right:
     shows "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] \<longleftrightarrow>
            (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
       using triangle_left_implies_right triangle_right_implies_left by auto
 
   end
 
   text \<open>
     We might as well specialize the dual result back to the strict case while we are at it.
   \<close>
 
   context equivalence_in_strict_bicategory
   begin
 
     lemma triangle_left_iff_right:
     shows "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
     proof -
       have "(\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>) = f \<longleftrightarrow> (\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = \<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f]"
       proof -
         have "\<l>\<^sup>-\<^sup>1[f] \<cdot> \<r>[f] = f"
           using strict_lunit strict_runit by simp
         moreover have "(\<epsilon> \<star> f) \<cdot> \<a>\<^sup>-\<^sup>1[f, g, f] \<cdot> (f \<star> \<eta>) = (\<epsilon> \<star> f) \<cdot> (f \<star> \<eta>)"
           using antipar strict_assoc assoc'_in_hom(2) [of f g f] comp_cod_arr
           by auto
         ultimately show ?thesis by simp
       qed
       also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = \<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g]"
         using triangle_left_iff_right by blast
       also have "... \<longleftrightarrow> (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g) = g"
       proof -
         have "\<r>\<^sup>-\<^sup>1[g] \<cdot> \<l>[g] = g"
           using strict_lunit strict_runit by simp
         moreover have "(g \<star> \<epsilon>) \<cdot> \<a>[g, f, g] \<cdot> (\<eta> \<star> g) = (g \<star> \<epsilon>) \<cdot> (\<eta> \<star> g)"
           using antipar strict_assoc assoc_in_hom(2) [of g f g] comp_cod_arr
           by auto
         ultimately show ?thesis by simp
       qed
       finally show ?thesis by simp
     qed
 
   end
 
 end
diff --git a/thys/Bicategory/Subbicategory.thy b/thys/Bicategory/Subbicategory.thy
--- a/thys/Bicategory/Subbicategory.thy
+++ b/thys/Bicategory/Subbicategory.thy
@@ -1,1494 +1,1492 @@
 (*  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>)) "
+                           ((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
         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)
           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
-            using f f' \<nu> in_hom_char [of ?\<mu> f f'] arr_char comp_closed ide_char
-                  runit'_closed runit_closed
-            apply auto
-            by fastforce
+            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
          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/EquivalenceOfCategories.thy b/thys/Category3/EquivalenceOfCategories.thy
--- a/thys/Category3/EquivalenceOfCategories.thy
+++ b/thys/Category3/EquivalenceOfCategories.thy
@@ -1,915 +1,913 @@
 (*  Title:       EquivalenceOfCategories
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Equivalence of Categories"
 
 text \<open>
   In this chapter we define the notions of equivalence and adjoint equivalence of categories
   and establish some properties of functors that are part of an equivalence.
 \<close>
 
 theory EquivalenceOfCategories
 imports Adjunction
 begin
 
   locale equivalence_of_categories =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G +
     \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
     \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and F :: "'d \<Rightarrow> 'c"
   and G :: "'c \<Rightarrow> 'd"
   and \<eta> :: "'d \<Rightarrow> 'd"
   and \<epsilon> :: "'c \<Rightarrow> 'c"
   begin
 
     notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     lemma C_arr_expansion:
     assumes "C.arr f"
     shows "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f"
     and "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
     proof -
       have \<epsilon>_dom: "C.inverse_arrows (\<epsilon> (C.dom f)) (C.inv (\<epsilon> (C.dom f)))"
         using assms C.inv_is_inverse by auto
       have \<epsilon>_cod: "C.inverse_arrows (\<epsilon> (C.cod f)) (C.inv (\<epsilon> (C.cod f)))"
         using assms C.inv_is_inverse by auto
       have "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) =
             (\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
         using C.comp_assoc by force
       also have 1: "... = (f \<cdot>\<^sub>C \<epsilon> (C.dom f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
         using assms \<epsilon>.naturality by simp
       also have 2: "... = f"
         using assms \<epsilon>_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
       finally show "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f" by blast
       show "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
         using assms 1 2 \<epsilon>_dom \<epsilon>_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
         by metis
     qed
 
     lemma G_is_faithful:
     shows "faithful_functor C D G"
     proof
       fix f f'
       assume par: "C.par f f'" and eq: "G f = G f'"
       show "f = f'"
       proof -
         have "C.inv (\<epsilon> (C.cod f)) \<in> C.hom (C.cod f) (F (G (C.cod f))) \<and>
               C.iso (C.inv (\<epsilon> (C.cod f)))"
           using par by auto
         moreover have 1: "\<epsilon> (C.dom f) \<in> C.hom (F (G (C.dom f))) (C.dom f) \<and>
                           C.iso (\<epsilon> (C.dom f))"
           using par by auto
         ultimately have 2: "f \<cdot>\<^sub>C \<epsilon> (C.dom f) = f' \<cdot>\<^sub>C \<epsilon> (C.dom f)"
           using par C_arr_expansion eq C.iso_is_section C.section_is_mono
           by (metis C_arr_expansion(1) eq)
         show ?thesis
         proof -
           have "C.epi (\<epsilon> (C.dom f))"
             using 1 par C.iso_is_retraction C.retraction_is_epi by blast
           thus ?thesis using 2 par by auto
         qed
       qed
     qed
 
     lemma G_is_essentially_surjective:
     shows "essentially_surjective_functor C D G"
     proof
       fix b
       assume b: "D.ide b"
       have "C.ide (F b) \<and> D.isomorphic (G (F b)) b"
       proof
         show "C.ide (F b)" using b by simp
         show "D.isomorphic (G (F b)) b"
         proof (unfold D.isomorphic_def)
           have "\<guillemotleft>D.inv (\<eta> b) : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso (D.inv (\<eta> b))"
             using b by auto
           thus "\<exists>f. \<guillemotleft>f : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso f" by blast
         qed
       qed
       thus "\<exists>a. C.ide a \<and> D.isomorphic (G a) b"
         by blast
     qed
 
     interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
     interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
     interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
 
     lemma F_is_faithful:
     shows "faithful_functor D C F"
       using GF.G_is_faithful by simp
 
     lemma F_is_essentially_surjective:
     shows "essentially_surjective_functor D C F"
       using GF.G_is_essentially_surjective by simp
 
     lemma G_is_full:
     shows "full_functor C D G"
     proof
       fix a a' g
       assume a: "C.ide a" and a': "C.ide a'"
       assume g: "\<guillemotleft>g : G a \<rightarrow>\<^sub>D G a'\<guillemotright>"
       show "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G f = g"
       proof
         have \<epsilon>a: "C.inverse_arrows (\<epsilon> a) (C.inv (\<epsilon> a))"
           using a C.inv_is_inverse by auto
         have \<epsilon>a': "C.inverse_arrows (\<epsilon> a') (C.inv (\<epsilon> a'))"
           using a' C.inv_is_inverse by auto
         let ?f = "\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a)"
         have f: "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright>"
           using a a' g \<epsilon>a \<epsilon>a' \<epsilon>.preserves_hom [of a' a' a'] \<epsilon>_inv.preserves_hom [of a a a]
           by fastforce
         moreover have "G ?f = g"
         proof -
           interpret F: faithful_functor D C F
             using F_is_faithful by auto
           have "F (G ?f) = F g"
           proof -
             have "F (G ?f) = C.inv (\<epsilon> a') \<cdot>\<^sub>C ?f \<cdot>\<^sub>C \<epsilon> a"
               using f C_arr_expansion(2) [of "?f"] by auto
             also have "... = (C.inv (\<epsilon> a') \<cdot>\<^sub>C \<epsilon> a') \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a) \<cdot>\<^sub>C \<epsilon> a"
               using a a' f g C.comp_assoc by fastforce
             also have "... = F g"
               using a a' g \<epsilon>a \<epsilon>a' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
             finally show ?thesis by blast
           qed
           moreover have "D.par (G (\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a))) g"
             using f g by fastforce
           ultimately show ?thesis using f g F.is_faithful by blast
         qed
         ultimately show "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G ?f = g" by blast
       qed
     qed
 
   end
 
   (* I'm not sure why I had to close and re-open the context here in order to
    * get the G_is_full fact in the interpretation GF. *)
 
   context equivalence_of_categories
   begin
 
     interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
     interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
     interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
 
     lemma F_is_full:
     shows "full_functor D C F"
       using GF.G_is_full by simp
 
   end
 
   text \<open>
     Traditionally the term "equivalence of categories" is also used for a functor
     that is part of an equivalence of categories.  However, it seems best to use
     that term for a situation in which all of the structure of an equivalence is
     explicitly given, and to have a different term for one of the functors involved.
 \<close>
 
   locale equivalence_functor =
     C: category C +
     D: category D +
     "functor" C D G
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and G :: "'c \<Rightarrow> 'd" +
   assumes induces_equivalence: "\<exists>F \<eta> \<epsilon>. equivalence_of_categories C D F G \<eta> \<epsilon>"
   begin
 
     notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   sublocale equivalence_of_categories \<subseteq> equivalence_functor C D G
     using equivalence_of_categories_axioms by (unfold_locales, blast)
 
   text \<open>
     An equivalence functor is fully faithful and essentially surjective.
 \<close>
 
   sublocale equivalence_functor \<subseteq> fully_faithful_functor C D G
   proof -
     obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
       using induces_equivalence by blast
     interpret equivalence_of_categories C D F G \<eta> \<epsilon>
       using 1 by auto
     show "fully_faithful_functor C D G"
       using G_is_full G_is_faithful fully_faithful_functor.intro by auto
   qed
 
   sublocale equivalence_functor \<subseteq> essentially_surjective_functor C D G
   proof -
     obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
       using induces_equivalence by blast
     interpret equivalence_of_categories C D F G \<eta> \<epsilon>
       using 1 by auto
     show "essentially_surjective_functor C D G"
       using G_is_essentially_surjective by auto
   qed
 
   lemma (in inverse_functors) induce_equivalence:
   shows "equivalence_of_categories A B F G B.map A.map"
     using inv inv' A.is_extensional B.is_extensional B.comp_arr_dom B.comp_cod_arr
           A.comp_arr_dom A.comp_cod_arr
     by unfold_locales auto
 
   lemma (in invertible_functor) is_equivalence:
   shows "equivalence_functor A B G"
     using equivalence_functor_axioms.intro equivalence_functor_def equivalence_of_categories_def
           induce_equivalence
     by blast
 
   lemma (in identity_functor) is_equivalence:
   shows "equivalence_functor C C map"
   proof -
     interpret inverse_functors C C map map
       using map_def by unfold_locales auto
     interpret invertible_functor C C map
       using inverse_functors_axioms
       by unfold_locales blast
     show ?thesis
       using is_equivalence by blast
   qed
 
   text \<open>
     A special case of an equivalence functor is an endofunctor \<open>F\<close> equipped with
     a natural isomorphism from \<open>F\<close> to the identity functor.
 \<close>
 
   context endofunctor
   begin
 
     lemma isomorphic_to_identity_is_equivalence:
     assumes "natural_isomorphism A A F A.map \<phi>"
     shows "equivalence_functor A A F"
     proof -
       interpret \<phi>: natural_isomorphism A A F A.map \<phi>
          using assms by auto
       interpret \<phi>': inverse_transformation A A F A.map \<phi> ..
       interpret F\<phi>': natural_isomorphism A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
       proof -
         interpret F\<phi>': natural_transformation A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
           using \<phi>'.natural_transformation_axioms functor_axioms
                 horizontal_composite [of A A A.map F \<phi>'.map A F F F]
           by simp
         show "natural_isomorphism A A F (F o F) (F o \<phi>'.map)"
           apply unfold_locales
           using \<phi>'.components_are_iso by fastforce
       qed
       interpret F\<phi>'o\<phi>': vertical_composite A A A.map F \<open>F o F\<close> \<phi>'.map \<open>F o \<phi>'.map\<close> ..
       interpret F\<phi>'o\<phi>': natural_isomorphism A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map
         using \<phi>'.natural_isomorphism_axioms F\<phi>'.natural_isomorphism_axioms
               natural_isomorphisms_compose
         by fast
       interpret inv_F\<phi>'o\<phi>': inverse_transformation A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map ..
       interpret F: equivalence_of_categories A A F F F\<phi>'o\<phi>'.map inv_F\<phi>'o\<phi>'.map ..
       show ?thesis ..
     qed
 
   end
 
   text \<open>
     An adjoint equivalence is an equivalence of categories that is also an adjunction.
 \<close>
 
   locale adjoint_equivalence =
     unit_counit_adjunction C D F G \<eta> \<epsilon> +
     \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
     \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and F :: "'d \<Rightarrow> 'c"
   and G :: "'c \<Rightarrow> 'd"
   and \<eta> :: "'d \<Rightarrow> 'd"
   and \<epsilon> :: "'c \<Rightarrow> 'c"
 
   text \<open>
     An adjoint equivalence is clearly an equivalence of categories.
 \<close>
 
   sublocale adjoint_equivalence \<subseteq> equivalence_of_categories ..
 
   context adjoint_equivalence
   begin
 
     text \<open>
       The triangle identities for an adjunction reduce to inverse relations when
       \<open>\<eta>\<close> and \<open>\<epsilon>\<close> are natural isomorphisms.
 \<close>
 
     lemma triangle_G':
     assumes "C.ide a"
     shows "D.inverse_arrows (\<eta> (G a)) (G (\<epsilon> a))"
     proof
       show "D.ide (G (\<epsilon> a) \<cdot>\<^sub>D \<eta> (G a))"
         using assms triangle_G G\<epsilon>o\<eta>G.map_simp_ide by fastforce
       thus "D.ide (\<eta> (G a) \<cdot>\<^sub>D G (\<epsilon> a))"
         using assms D.section_retraction_of_iso [of "G (\<epsilon> a)" "\<eta> (G a)"] by auto
     qed
 
     lemma triangle_F':
     assumes "D.ide b"
     shows "C.inverse_arrows (F (\<eta> b)) (\<epsilon> (F b))"
     proof
      show "C.ide (\<epsilon> (F b) \<cdot>\<^sub>C F (\<eta> b))"
         using assms triangle_F \<epsilon>FoF\<eta>.map_simp_ide by auto
       thus "C.ide (F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b))"
         using assms C.section_retraction_of_iso [of "\<epsilon> (F b)" "F (\<eta> b)"] by auto
     qed
 
     text \<open>
       An adjoint equivalence can be dualized by interchanging the two functors and inverting
       the natural isomorphisms.  This is somewhat awkward to prove, but probably useful to have
       done it once and for all.
 \<close>
 
     lemma dual_equivalence:
     assumes "adjoint_equivalence C D F G \<eta> \<epsilon>"
     shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) \<epsilon>)
                                        (inverse_transformation.map D D (G o F) \<eta>)"
     proof -
       interpret adjoint_equivalence C D F G \<eta> \<epsilon> using assms by auto
       interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
       interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
       interpret G\<epsilon>': natural_transformation C D G \<open>G o F o G\<close> \<open>G o \<epsilon>'.map\<close>
       proof -
         have "natural_transformation C D G (G o (F o G)) (G o \<epsilon>'.map)"
           using G.as_nat_trans.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
                 horizontal_composite
           by fastforce
         thus "natural_transformation C D G (G o F o G) (G o \<epsilon>'.map)"
           using o_assoc by metis
       qed
       interpret \<eta>'G: natural_transformation C D \<open>G o F o G\<close> G \<open>\<eta>'.map o G\<close>
         using \<eta>'.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret \<epsilon>'F: natural_transformation D C F \<open>F o G o F\<close> \<open>\<epsilon>'.map o F\<close>
         using \<epsilon>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret F\<eta>': natural_transformation D C \<open>F o G o F\<close> F \<open>F o \<eta>'.map\<close>
       proof -
         have "natural_transformation D C (F o (G o F)) F (F o \<eta>'.map)"
           using \<eta>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
                 horizontal_composite
           by fastforce
         thus "natural_transformation D C (F o G o F) F (F o \<eta>'.map)"
           using o_assoc by metis
       qed
       interpret F\<eta>'o\<epsilon>'F: vertical_composite D C F \<open>(F o G) o F\<close> F \<open>\<epsilon>'.map o F\<close> \<open>F o \<eta>'.map\<close> ..
       interpret \<eta>'GoG\<epsilon>': vertical_composite C D G \<open>G o F o G\<close> G \<open>G o \<epsilon>'.map\<close> \<open>\<eta>'.map o G\<close> ..
       show ?thesis
       proof
         show "\<eta>'GoG\<epsilon>'.map = G"
         proof (intro NaturalTransformation.eqI)
           show "natural_transformation C D G G G"
             using G.as_nat_trans.natural_transformation_axioms by auto
           show "natural_transformation C D G G \<eta>'GoG\<epsilon>'.map"
             using \<eta>'GoG\<epsilon>'.natural_transformation_axioms by auto
           show "\<And>a. C.ide a \<Longrightarrow> \<eta>'GoG\<epsilon>'.map a = G a"
           proof -
             fix a
             assume a: "C.ide a"
             show "\<eta>'GoG\<epsilon>'.map a = G a"
-              using a \<eta>'GoG\<epsilon>'.map_simp_ide triangle_G'
-                    \<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
+              using a \<eta>'GoG\<epsilon>'.map_simp_ide triangle_G' G.preserves_ide
                     \<eta>'.inverts_components \<epsilon>'.inverts_components
                     D.inverse_unique G.preserves_inverse_arrows G\<epsilon>o\<eta>G.map_simp_ide
                     D.inverse_arrows_sym triangle_G
               by (metis o_apply)
           qed
         qed
         show "F\<eta>'o\<epsilon>'F.map = F"
         proof (intro NaturalTransformation.eqI)
           show "natural_transformation D C F F F"
             using F.as_nat_trans.natural_transformation_axioms by auto
           show "natural_transformation D C F F F\<eta>'o\<epsilon>'F.map"
             using F\<eta>'o\<epsilon>'F.natural_transformation_axioms by auto
           show "\<And>b. D.ide b \<Longrightarrow> F\<eta>'o\<epsilon>'F.map b = F b"
           proof -
             fix b
             assume b: "D.ide b"
             show "F\<eta>'o\<epsilon>'F.map b = F b"
               using b F\<eta>'o\<epsilon>'F.map_simp_ide \<epsilon>FoF\<eta>.map_simp_ide triangle_F triangle_F'
-                    \<eta>.components_are_iso \<epsilon>.components_are_iso G.preserves_ide
                     \<eta>'.inverts_components \<epsilon>'.inverts_components F.preserves_ide
                     C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
               by (metis o_apply)
           qed
         qed
       qed
     qed
 
   end
 
   text \<open>
     Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
     To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
     we first show that a fully faithful and essentially surjective functor is a left adjoint
     functor, and then we show that if the left adjoint in a unit-counit adjunction is
     fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
     hence the adjunction is in fact an adjoint equivalence.
 \<close>
 
   locale fully_faithful_and_essentially_surjective_functor =
     C: category C +
     D: category D +
     fully_faithful_functor C D F +
     essentially_surjective_functor C D F
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'c \<Rightarrow> 'd"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     lemma is_left_adjoint_functor:
     shows "left_adjoint_functor C D F"
     proof
       fix y
       assume y: "D.ide y"
       let ?x = "SOME x. C.ide x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>D y\<guillemotright>)"
       let ?e = "SOME e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"
       have "\<exists>x e. D.iso e \<and> terminal_arrow_from_functor C D F x y e"
       proof -
         have "\<exists>x. D.iso ?e \<and> terminal_arrow_from_functor C D F x y ?e"
         proof -
           have x: "C.ide ?x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>)"
             using y essentially_surjective
                   someI_ex [of "\<lambda>x. C.ide x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>D y\<guillemotright>)"]
             by blast
           hence e: "D.iso ?e \<and> \<guillemotleft>?e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"
             using someI_ex [of "\<lambda>e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"] by blast
           interpret arrow_from_functor C D F ?x y ?e
             using x e by (unfold_locales, simp)
           interpret terminal_arrow_from_functor C D F ?x y ?e
           proof
             fix x' f
             assume 1: "arrow_from_functor C D F x' y f"
             interpret f: arrow_from_functor C D F x' y f
               using 1 by simp
             have f: "\<guillemotleft>f: F x' \<rightarrow>\<^sub>D y\<guillemotright>"
               by (meson f.arrow)
             show "\<exists>!g. is_coext x' f g"
             proof
               let ?g = "SOME g. \<guillemotleft>g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F g = D.inv ?e \<cdot>\<^sub>D f"
               have g: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F ?g = D.inv ?e \<cdot>\<^sub>D f"
                 using f e x f.arrow is_full D.comp_in_homI D.inv_in_hom
                       someI_ex [of "\<lambda>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F g = D.inv ?e \<cdot>\<^sub>D f"]
                 by auto
               show 1: "is_coext x' f ?g"
               proof -
                 have "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright>"
                   using g by simp
                 moreover have "?e \<cdot>\<^sub>D F ?g = f"
                 proof -
                   have "?e \<cdot>\<^sub>D F ?g = ?e \<cdot>\<^sub>D D.inv ?e \<cdot>\<^sub>D f"
                     using g by simp
                   also have "... = (?e \<cdot>\<^sub>D D.inv ?e) \<cdot>\<^sub>D f"
                     using e f D.inv_in_hom by (metis D.comp_assoc)
                   also have "... = f"
                   proof -
                     have "?e \<cdot>\<^sub>D D.inv ?e = y"
                       using e D.comp_arr_inv D.inv_is_inverse by auto
                     thus ?thesis
                       using f D.comp_cod_arr by auto
                   qed
                   finally show ?thesis by blast
                 qed
                 ultimately show ?thesis
                   unfolding is_coext_def by simp
               qed
               show "\<And>g'. is_coext x' f g' \<Longrightarrow> g' = ?g"
               proof -
                 fix g'
                 assume g': "is_coext x' f g'"
                 have 2: "\<guillemotleft>g' : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>D F g' = f" using g' is_coext_def by simp
                 have 3: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>D F ?g = f" using 1 is_coext_def by simp
                 have "F g' = F ?g"
                   using e f 2 3 D.iso_is_section D.section_is_mono D.monoE D.arrI
                   by (metis (no_types, lifting) D.arrI)
                 moreover have "C.par g' ?g"
                   using 2 3 by fastforce
                 ultimately show "g' = ?g"
                   using is_faithful [of g' ?g] by simp
               qed
             qed
           qed
           show ?thesis
             using e terminal_arrow_from_functor_axioms by auto
         qed
         thus ?thesis by auto
       qed
       thus "\<exists>x e. terminal_arrow_from_functor C D F x y e" by blast
     qed
 
     lemma extends_to_adjoint_equivalence:
     shows "\<exists>G \<eta> \<epsilon>. adjoint_equivalence C D G F \<eta> \<epsilon>"
     proof -
       interpret left_adjoint_functor C D F
         using is_left_adjoint_functor by blast
       interpret Adj: meta_adjunction D C F G \<phi> \<psi>
         using induces_meta_adjunction by simp
       interpret Adj: adjunction D C replete_setcat.comp
                        Adj.\<phi>C Adj.\<phi>D F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
         using induces_adjunction by simp
       interpret equivalence_of_categories D C F G Adj.\<eta> Adj.\<epsilon>
       proof
         show 1: "\<And>a. D.ide a \<Longrightarrow> D.iso (Adj.\<epsilon> a)"
         proof -
           fix a
           assume a: "D.ide a"
           interpret \<epsilon>a: terminal_arrow_from_functor C D F \<open>G a\<close> a \<open>Adj.\<epsilon> a\<close>
             using a Adj.has_terminal_arrows_from_functor [of a] by blast
           have "D.retraction (Adj.\<epsilon> a)"
           proof -
             obtain b \<phi> where \<phi>: "C.ide b \<and> D.iso \<phi> \<and> \<guillemotleft>\<phi>: F b \<rightarrow>\<^sub>D a\<guillemotright>"
               using a essentially_surjective by blast
             interpret \<phi>: arrow_from_functor C D F b a \<phi>
               using \<phi> by (unfold_locales, simp)
             let ?g = "\<epsilon>a.the_coext b \<phi>"
             have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>C G a\<guillemotright> \<and> Adj.\<epsilon> a \<cdot>\<^sub>D F ?g = \<phi>"
               using \<phi>.arrow_from_functor_axioms \<epsilon>a.the_coext_prop [of b \<phi>] by simp
             have "a = (Adj.\<epsilon> a \<cdot>\<^sub>D F ?g) \<cdot>\<^sub>D D.inv \<phi>"
               using a 1 \<phi> D.comp_cod_arr Adj.\<epsilon>.preserves_hom D.invert_side_of_triangle(2)
                by auto
             also have "... = Adj.\<epsilon> a \<cdot>\<^sub>D F ?g \<cdot>\<^sub>D D.inv \<phi>"
               using a 1 \<phi> D.inv_in_hom Adj.\<epsilon>.preserves_hom [of a a a] D.comp_assoc
               by blast
             finally have "\<exists>f. D.ide (Adj.\<epsilon> a \<cdot>\<^sub>D f)"
               using a by metis
             thus ?thesis
               unfolding D.retraction_def by blast
           qed
           moreover have "D.mono (Adj.\<epsilon> a)"
           proof
             show "D.arr (Adj.\<epsilon> a)"
               using a by simp
             show "\<And>f f'. D.seq (Adj.\<epsilon> a) f \<and> D.seq (Adj.\<epsilon> a) f' \<and> Adj.\<epsilon> a \<cdot>\<^sub>D f = Adj.\<epsilon> a \<cdot>\<^sub>D f'
                             \<Longrightarrow> f = f'"
             proof -
               fix f f'
               assume ff': "D.seq (Adj.\<epsilon> a) f \<and> D.seq (Adj.\<epsilon> a) f' \<and> Adj.\<epsilon> a \<cdot>\<^sub>D f = Adj.\<epsilon> a \<cdot>\<^sub>D f'"
               have f: "\<guillemotleft>f : D.dom f \<rightarrow>\<^sub>D F (G a)\<guillemotright>"
                 using a ff' Adj.\<epsilon>.preserves_hom [of a a a] by fastforce
               have f': "\<guillemotleft>f' : D.dom f' \<rightarrow>\<^sub>D F (G a)\<guillemotright>"
                 using a ff' Adj.\<epsilon>.preserves_hom [of a a a] by fastforce
               have par: "D.par f f'"
                 using f f' ff' D.dom_comp [of "Adj.\<epsilon> a" f] by force
               obtain b' \<phi> where \<phi>: "C.ide b' \<and> D.iso \<phi> \<and> \<guillemotleft>\<phi>: F b' \<rightarrow>\<^sub>D D.dom f\<guillemotright>"
                 using par essentially_surjective D.ide_dom [of f] by blast
               have 1: "Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi> = Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>"
                 using ff' \<phi> par D.comp_assoc by metis
               obtain g where g: "\<guillemotleft>g : b' \<rightarrow>\<^sub>C G a\<guillemotright> \<and> F g = f \<cdot>\<^sub>D \<phi>"
                 using a f \<phi> is_full [of "G a" b' "f \<cdot>\<^sub>D \<phi>"] by auto
               obtain g' where g': "\<guillemotleft>g' : b' \<rightarrow>\<^sub>C G a\<guillemotright> \<and> F g' = f' \<cdot>\<^sub>D \<phi>"
                 using a f' par \<phi> is_full [of "G a" b' "f' \<cdot>\<^sub>D \<phi>"] by auto
               interpret f\<phi>: arrow_from_functor C D F b' a \<open>Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi>\<close>
                 using a \<phi> f Adj.\<epsilon>.preserves_hom
                 by (unfold_locales, fastforce)
               interpret f'\<phi>: arrow_from_functor C D F b' a \<open>Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>\<close>
                 using a \<phi> f' par Adj.\<epsilon>.preserves_hom
                 by (unfold_locales, fastforce)
               have "\<epsilon>a.is_coext b' (Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi>) g"
                 unfolding \<epsilon>a.is_coext_def using g 1 by auto
               moreover have "\<epsilon>a.is_coext b' (Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>) g'"
                 unfolding \<epsilon>a.is_coext_def using g' 1 by auto
               ultimately have "g = g'"
                 using 1 f\<phi>.arrow_from_functor_axioms f'\<phi>.arrow_from_functor_axioms
                       \<epsilon>a.the_coext_unique \<epsilon>a.the_coext_unique [of b' "Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>" g']
                 by auto
               hence "f \<cdot>\<^sub>D \<phi> = f' \<cdot>\<^sub>D \<phi>"
                 using g g' is_faithful by argo
               thus "f = f'"
                 using \<phi> f f' par D.iso_is_retraction D.retraction_is_epi D.epiE [of \<phi> f f']
                 by auto
             qed
           qed
           ultimately show "D.iso (Adj.\<epsilon> a)"
             using D.iso_iff_mono_and_retraction by simp
         qed
         interpret \<epsilon>: natural_isomorphism D D \<open>F o G\<close> D.map Adj.\<epsilon>
           using 1 by (unfold_locales, auto)
         interpret \<epsilon>F: natural_isomorphism C D \<open>F o G o F\<close> F \<open>Adj.\<epsilon> o F\<close>
           using \<epsilon>.components_are_iso by (unfold_locales, simp)
         show "\<And>a. C.ide a \<Longrightarrow> C.iso (Adj.\<eta> a)"
         proof -
           fix a
           assume a: "C.ide a"
           have "D.inverse_arrows ((Adj.\<epsilon> o F) a) ((F o Adj.\<eta>) a)"
             using a \<epsilon>.components_are_iso Adj.\<eta>\<epsilon>.triangle_F Adj.\<epsilon>FoF\<eta>.map_simp_ide
                   D.section_retraction_of_iso
             by simp
           hence "D.iso ((F o Adj.\<eta>) a)"
             by blast
           thus "C.iso (Adj.\<eta> a)"
             using a reflects_iso [of "Adj.\<eta> a"] by fastforce
         qed
       qed
       (*
        * Uggh, I should have started with "right_adjoint_functor D C G" so that the
        * following would come out right.  Instead, another step is needed to dualize.
        * TODO: Maybe re-work this later.
        *)
       interpret adjoint_equivalence D C F G Adj.\<eta> Adj.\<epsilon> ..
       interpret \<epsilon>': inverse_transformation D D \<open>F o G\<close> D.map Adj.\<epsilon> ..
       interpret \<eta>': inverse_transformation C C C.map \<open>G o F\<close> Adj.\<eta> ..
       interpret E: adjoint_equivalence C D G F \<epsilon>'.map \<eta>'.map
         using adjoint_equivalence_axioms dual_equivalence by blast
       show ?thesis
         using E.adjoint_equivalence_axioms by auto
     qed
 
     lemma is_right_adjoint_functor:
     shows "right_adjoint_functor C D F"
     proof -
       obtain G \<eta> \<epsilon> where E: "adjoint_equivalence C D G F \<eta> \<epsilon>"
         using extends_to_adjoint_equivalence by auto
       interpret E: adjoint_equivalence C D G F \<eta> \<epsilon>
         using E by simp
       interpret Adj: meta_adjunction C D G F E.\<phi> E.\<psi>
         using E.induces_meta_adjunction by simp
       show ?thesis
         using Adj.has_right_adjoint_functor by simp
     qed
 
     lemma is_equivalence_functor:
     shows "equivalence_functor C D F"
     proof
       obtain G \<eta> \<epsilon> where E: "adjoint_equivalence C D G F \<eta> \<epsilon>"
         using extends_to_adjoint_equivalence by auto
       interpret E: adjoint_equivalence C D G F \<eta> \<epsilon>
         using E by simp
       have "equivalence_of_categories C D G F \<eta> \<epsilon>" ..
       thus "\<exists>G \<eta> \<epsilon>. equivalence_of_categories C D G F \<eta> \<epsilon>" by blast
     qed
 
     sublocale equivalence_functor C D F
       using is_equivalence_functor by blast
 
   end
 
   context equivalence_of_categories
   begin
 
     text \<open>
       The following development shows that an equivalence of categories can
       be refined to an adjoint equivalence by replacing just the counit.
     \<close>
 
     abbreviation \<epsilon>'
     where "\<epsilon>' a \<equiv> \<epsilon> a \<cdot>\<^sub>C F (D.inv (\<eta> (G a))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G a)))"
 
     interpretation \<epsilon>': transformation_by_components C C \<open>F \<circ> G\<close> C.map \<epsilon>'
     proof
       show "\<And>a. C.ide a \<Longrightarrow> \<guillemotleft>\<epsilon>' a : (F \<circ> G) a \<rightarrow>\<^sub>C C.map a\<guillemotright>"
         using \<eta>.components_are_iso \<epsilon>.components_are_iso by simp
       fix f
       assume f: "C.arr f"
       show "\<epsilon>' (C.cod f) \<cdot>\<^sub>C (F \<circ> G) f = C.map f \<cdot>\<^sub>C \<epsilon>' (C.dom f)"
       proof -
         have "\<epsilon>' (C.cod f) \<cdot>\<^sub>C (F \<circ> G) f =
               \<epsilon> (C.cod f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (C.cod f)))) \<cdot>\<^sub>C F (G f)"
           using f C.comp_assoc by simp
         also have "... = \<epsilon> (C.cod f) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C
                            F (G (F (G f)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (C.dom f))))"
           using f \<epsilon>.inv_naturality [of "F (G f)"] C.comp_assoc by simp
         also have "... = (\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f)))) \<cdot>\<^sub>C
                            C.inv (\<epsilon> (F (G (C.dom f))))"
         proof -
           have "F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C F (G (F (G f))) =
                 F (G f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f))))"
           proof -
             have "F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C F (G (F (G f))) =
                   F (D.inv (\<eta> (G (C.cod f))) \<cdot>\<^sub>D G (F (G f)))"
               using f by simp
             also have "... = F (G f \<cdot>\<^sub>D D.inv (\<eta> (G (C.dom f))))"
               using f \<eta>.inv_naturality [of "G f"] by simp
             also have "... = F (G f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f))))"
               using f by simp
             finally show ?thesis by blast
           qed
           thus ?thesis
             using C.comp_assoc by simp
         qed
         also have "... = C.map f \<cdot>\<^sub>C \<epsilon> (C.dom f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f)))) \<cdot>\<^sub>C
                            C.inv (\<epsilon> (F (G (C.dom f))))"
           using f \<epsilon>.naturality C.comp_assoc by simp
         finally show ?thesis by blast
       qed
     qed
 
     interpretation \<epsilon>': natural_isomorphism C C \<open>F \<circ> G\<close> C.map \<epsilon>'.map
     proof
       show "\<And>a. C.ide a \<Longrightarrow> C.iso (\<epsilon>'.map a)"
         unfolding \<epsilon>'.map_def
         using \<eta>.components_are_iso \<epsilon>.components_are_iso
         apply simp
         by (intro C.isos_compose) auto
     qed
 
     lemma F\<eta>_inverse:
     assumes "D.ide b"
     shows "F (\<eta> (G (F b))) = F (G (F (\<eta> b)))"
     and "F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b) = \<epsilon> (F (G (F b))) \<cdot>\<^sub>C F (\<eta> (G (F b)))"
     and "C.inverse_arrows (F (\<eta> b)) (\<epsilon>' (F b))"
     and "F (\<eta> b) = C.inv (\<epsilon>' (F b))"
     and "C.inv (F (\<eta> b)) = \<epsilon>' (F b)"
     proof -
       let ?\<epsilon>' = "\<lambda>a. \<epsilon> a \<cdot>\<^sub>C F (D.inv (\<eta> (G a))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G a)))"
       show 1: "F (\<eta> (G (F b))) = F (G (F (\<eta> b)))"
       proof -
         have "F (\<eta> (G (F b))) \<cdot>\<^sub>C F (\<eta> b) = F (G (F (\<eta> b))) \<cdot>\<^sub>C F (\<eta> b)"
         proof -
           have "F (\<eta> (G (F b))) \<cdot>\<^sub>C F (\<eta> b) = F (\<eta> (G (F b)) \<cdot>\<^sub>D \<eta> b)"
             using assms by simp
           also have "... = F (G (F (\<eta> b)) \<cdot>\<^sub>D \<eta> b)"
             using assms \<eta>.naturality [of "\<eta> b"] by simp
           also have "... = F (G (F (\<eta> b))) \<cdot>\<^sub>C F (\<eta> b)"
             using assms by simp
           finally show ?thesis by blast
         qed
         thus ?thesis
           using assms \<eta>.components_are_iso C.iso_cancel_right by simp
       qed
       show "F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b) = \<epsilon> (F (G (F b))) \<cdot>\<^sub>C F (\<eta> (G (F b)))"
         using assms 1 \<epsilon>.naturality [of "F (\<eta> b)"] by simp
       show 2: "C.inverse_arrows (F (\<eta> b)) (?\<epsilon>' (F b))"
       proof
         show 3: "C.ide (?\<epsilon>' (F b) \<cdot>\<^sub>C F (\<eta> b))"
         proof -
           have "?\<epsilon>' (F b) \<cdot>\<^sub>C F (\<eta> b) =
                 \<epsilon> (F b) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"
             using C.comp_assoc by simp
           also have "... = \<epsilon> (F b) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C F (G (F (\<eta> b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F b))"
             using assms \<epsilon>.naturality [of "F (\<eta> b)"] \<epsilon>.components_are_iso C.comp_assoc
                   C.invert_opposite_sides_of_square
                     [of "\<epsilon> (F (G (F b)))" "F (G (F (\<eta> b)))" "F (\<eta> b)" "\<epsilon> (F b)"]
             by simp
           also have "... = \<epsilon> (F b) \<cdot>\<^sub>C C.inv (\<epsilon> (F b))"
           proof -
             have "F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C F (G (F (\<eta> b))) = F (G (F b))"
               using assms 1 D.comp_inv_arr' \<eta>.components_are_iso
               by (metis D.ideD(1) D.ideD(2) F.preserves_comp
                   F.preserves_ide G.preserves_ide \<eta>.preserves_dom D.map_simp)
             moreover have "F (G (F b)) \<cdot>\<^sub>C C.inv (\<epsilon> (F b)) = C.inv (\<epsilon> (F b))"
               using assms D.comp_cod_arr \<epsilon>.components_are_iso C.inv_in_hom [of "\<epsilon> (F b)"]
               by (metis C.comp_ide_arr C_arr_expansion(1) D.ide_char F.preserves_arr
                   F.preserves_dom F.preserves_ide G.preserves_ide C.seqE)
             ultimately show ?thesis by simp
           qed
           also have "... = F b"
             using assms \<epsilon>.components_are_iso C.comp_arr_inv' by simp
           finally have "(\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b) = F b"
             by blast
           thus ?thesis
             using assms by simp
         qed
         show "C.ide (F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b))"
         proof -
           have "(F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b)) \<cdot>\<^sub>C F (\<eta> b) = F (G (F b)) \<cdot>\<^sub>C F (\<eta> b)"
           proof -
             have "(F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b)) \<cdot>\<^sub>C F (\<eta> b) =
                   F (\<eta> b) \<cdot>\<^sub>C (\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"
               using C.comp_assoc by simp
             also have "... = F (\<eta> b)"
               using assms 3
                     C.comp_arr_dom
                       [of "F (\<eta> b)" "(\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C
                                        C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"]
               by auto
             also have "... = F (G (F b)) \<cdot>\<^sub>C F (\<eta> b)"
               using assms C.comp_cod_arr by simp
             finally show ?thesis by blast
           qed
           hence "F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b) = F (G (F b))"
             using assms C.iso_cancel_right by simp
           thus ?thesis
             using assms by simp
         qed
       qed
       show "C.inv (F (\<eta> b)) = ?\<epsilon>' (F b)"
         using assms 2 C.inverse_unique by simp
       show "F (\<eta> b) = C.inv (?\<epsilon>' (F b))"
       proof -
         have "C.inverse_arrows (?\<epsilon>' (F b)) (F (\<eta> b))"
           using assms 2 by auto
         thus ?thesis
           using assms C.inverse_unique by simp
       qed
     qed
 
     interpretation FoGoF: composite_functor D C C F \<open>F o G\<close> ..
     interpretation GoFoG: composite_functor C D D G \<open>G o F\<close> ..
 
     interpretation natural_transformation D C F FoGoF.map \<open>F \<circ> \<eta>\<close>
     proof -
       have "F \<circ> D.map = F"
         using hcomp_ide_dom F.as_nat_trans.natural_transformation_axioms by blast
       moreover have "F o (G o F) = FoGoF.map"
         by auto
       ultimately show "natural_transformation D C F FoGoF.map (F \<circ> \<eta>)"
         using \<eta>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite [of D D D.map "G o F" \<eta> C F F F]
         by simp
     qed
 
     interpretation natural_transformation C D G GoFoG.map \<open>\<eta> \<circ> G\<close>
       using \<eta>.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
             horizontal_composite [of C D G G G ]
       by fastforce
 
     interpretation natural_transformation D C FoGoF.map F \<open>\<epsilon>'.map \<circ> F\<close>
       using \<epsilon>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
             horizontal_composite [of D C F F F]
       by fastforce
 
     interpretation natural_transformation C D GoFoG.map G \<open>G \<circ> \<epsilon>'.map\<close>
     proof -
       have "G o C.map = G"
         using hcomp_ide_dom G.as_nat_trans.natural_transformation_axioms by blast
       moreover have "G o (F o G) = GoFoG.map"
         by auto
       ultimately show "natural_transformation C D GoFoG.map G (G \<circ> \<epsilon>'.map)"
         using G.as_nat_trans.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
               horizontal_composite [of C C "F o G" C.map \<epsilon>'.map D G G G]
         by simp
     qed
 
     interpretation \<epsilon>'F_F\<eta>: vertical_composite D C F FoGoF.map F \<open>F \<circ> \<eta>\<close> \<open>\<epsilon>'.map \<circ> F\<close> ..
     interpretation G\<epsilon>'_\<eta>G: vertical_composite C D G GoFoG.map G \<open>\<eta> o G\<close> \<open>G o \<epsilon>'.map\<close> ..
 
     interpretation \<eta>\<epsilon>': unit_counit_adjunction C D F G \<eta> \<epsilon>'.map
     proof
       show 1: "\<epsilon>'F_F\<eta>.map = F"
       proof
         fix g
         show "\<epsilon>'F_F\<eta>.map g = F g"
         proof (cases "D.arr g")
           show "\<not> D.arr g \<Longrightarrow> \<epsilon>'F_F\<eta>.map g = F g"
             using \<epsilon>'F_F\<eta>.is_extensional F.is_extensional by simp
           assume g: "D.arr g"
           have "\<epsilon>'F_F\<eta>.map g = \<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> g)"
             using g \<epsilon>'F_F\<eta>.map_def by simp
           also have "... = \<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> (D.cod g) \<cdot>\<^sub>D g)"
             using g \<eta>.is_natural_2 by simp
           also have "... = (\<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> (D.cod g))) \<cdot>\<^sub>C F g"
             using g C.comp_assoc by simp
           also have "... = F (D.cod g) \<cdot>\<^sub>C F g"
             using g F\<eta>_inverse(3) [of "D.cod g"] by fastforce
           also have "... = F g"
             using g C.comp_cod_arr by simp
           finally show "\<epsilon>'F_F\<eta>.map g = F g" by blast
         qed
       qed
       show "G\<epsilon>'_\<eta>G.map = G"
       proof
         fix f
         show "G\<epsilon>'_\<eta>G.map f = G f"
         proof (cases "C.arr f")
           show "\<not> C.arr f \<Longrightarrow> G\<epsilon>'_\<eta>G.map f = G f"
             using G\<epsilon>'_\<eta>G.is_extensional G.is_extensional by simp
           assume f: "C.arr f"
           have "F (G\<epsilon>'_\<eta>G.map f) = F (G (\<epsilon>' (C.cod f)) \<cdot>\<^sub>D \<eta> (G f))"
             using f G\<epsilon>'_\<eta>G.map_def D.comp_assoc by simp
           also have "... = F (G (\<epsilon>' (C.cod f)) \<cdot>\<^sub>D \<eta> (G (C.cod f)) \<cdot>\<^sub>D G f)"
             using f \<eta>.is_natural_2 [of "G f"] by simp
           also have "... = F (G (\<epsilon>' (C.cod f))) \<cdot>\<^sub>C F (\<eta> (G (C.cod f))) \<cdot>\<^sub>C F (G f)"
             using f by simp
           also have "... = (F (G (\<epsilon>' (C.cod f))) \<cdot>\<^sub>C C.inv (\<epsilon>' (F (G (C.cod f))))) \<cdot>\<^sub>C F (G f)"
             using f F\<eta>_inverse(4) C.comp_assoc by simp
           also have "... = (C.inv (\<epsilon>' (C.cod f)) \<cdot>\<^sub>C \<epsilon>' (C.cod f)) \<cdot>\<^sub>C F (G f)"
             using f \<epsilon>'.inv_naturality [of "\<epsilon>' (C.cod f)"] by simp
           also have "... = F (G (C.cod f)) \<cdot>\<^sub>C F (G f)"
             using f C.comp_inv_arr' [of "\<epsilon>' (C.cod f)"] \<epsilon>'.components_are_iso by simp
           also have "... = F (G f)"
             using f C.comp_cod_arr by simp
           finally have "F (G\<epsilon>'_\<eta>G.map f) = F (G f)" by blast
           moreover have "D.par (G\<epsilon>'_\<eta>G.map f) (G f)"
             using f by simp
           ultimately show "G\<epsilon>'_\<eta>G.map f = G f"
             using f F_is_faithful
             by (simp add: faithful_functor_axioms_def faithful_functor_def)
         qed
       qed
     qed
 
     interpretation \<eta>\<epsilon>': adjoint_equivalence C D F G \<eta> \<epsilon>'.map ..
 
     lemma refines_to_adjoint_equivalence:
     shows "adjoint_equivalence C D F G \<eta> \<epsilon>'.map"
       ..
 
   end
 
 end
diff --git a/thys/Category3/SetCat.thy b/thys/Category3/SetCat.thy
--- a/thys/Category3/SetCat.thy
+++ b/thys/Category3/SetCat.thy
@@ -1,875 +1,874 @@
 (*  Title:       SetCat
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter SetCat
 
 theory SetCat
 imports SetCategory ConcreteCategory
 begin
 
   text\<open>
     This theory proves the consistency of the \<open>set_category\<close> locale by giving
     a particular concrete construction of an interpretation for it.
     Applying the general construction given by @{locale concrete_category},
     we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
     and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
 \<close>
 
   text\<open>
     This locale uses an extra dummy parameter just to fix the element type for sets.
     Without this, a type is used for each interpretation, which makes it impossible to
     construct set categories whose element types are related to the context.
   \<close>
 
   locale setcat =
   fixes dummy :: 'e
   and \<AA> :: "'a rel"
   assumes cardinal: "Card_order \<AA> \<and> infinite (Field \<AA>)"
   begin
 
     lemma finite_imp_card_less:
     assumes "finite A"
     shows "|A| <o \<AA>"
     proof -
       have "finite (Field |A| )"
         using assms by simp
       thus ?thesis
         using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
         by blast
     qed
 
     type_synonym 'b arr = "('b set, 'b \<Rightarrow> 'b) concrete_category.arr"
 
     interpretation concrete_category \<open>{A :: 'e set. |A| <o \<AA>}\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
                      \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
       using compose_Id Id_compose
       apply unfold_locales
           apply auto[3]
        apply blast
       by (metis IntD2 compose_assoc)
 
     abbreviation comp :: "'e setcat.arr comp"     (infixr "\<cdot>" 55)
     where "comp \<equiv> COMP"
     notation in_hom                               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma MkArr_expansion:
     assumes "arr f"
     shows "f = MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x)"
     proof (intro arr_eqI)
       show "arr f" by fact
       show "arr (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
         using assms arr_char
         by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
       show "Dom f = Dom (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
         by simp
       show "Cod f = Cod (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
         by simp
       show "Map f = Map (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
         using assms arr_char
         by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
     qed
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> f \<noteq> Null \<and> |Dom f| <o \<AA> \<and> |Cod f| <o \<AA> \<and>
                      Map f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
       using arr_char by auto
 
     lemma terminal_char:
     shows "terminal a \<longleftrightarrow> (\<exists>x. a = MkIde {x})"
     proof
       show "\<exists>x. a = MkIde {x} \<Longrightarrow> terminal a"
       proof -
         assume a: "\<exists>x. a = MkIde {x}"
         from this obtain x where x: "a = MkIde {x}" by blast
         have "terminal (MkIde {x})"
         proof
           show 1: "ide (MkIde {x})"
             using finite_imp_card_less ide_MkIde by auto
           show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
           proof
             fix a :: "'e setcat.arr"
             assume a: "ide a"
             show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> MkIde {x}\<guillemotright>"
             proof
               show 2: "arr (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x))"
                 using a 1 arr_MkArr [of "Dom a" "{x}"] ide_char by force
               show "dom (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)) = a"
                 using a 2 dom_MkArr by force
               show "cod (MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x)) = MkIde {x}"
                 using 2 cod_MkArr by blast
             qed
             fix f :: "'e setcat.arr"
             assume f: "\<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
             show "f = MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)"
             proof -
               have 1: "Dom f = Dom a \<and> Cod f = {x}"
                 using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
               moreover have "Map f = (\<lambda>_ \<in> Dom a. x)"
               proof
                 fix z
                 have "z \<notin> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                   using f 1 MkArr_expansion
                   by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
                 moreover have "z \<in> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                   using f 1 arr_char [of f] by fastforce
                 ultimately show "Map f z = (\<lambda>_ \<in> Dom a. x) z" by auto
               qed
               ultimately show ?thesis
                using f MkArr_expansion [of f] by fastforce
             qed
           qed
         qed
         thus "terminal a" using x by simp
       qed
       show "terminal a \<Longrightarrow> \<exists>x. a = MkIde {x}"
       proof -
         assume a: "terminal a"
         hence ide_a: "ide a" using terminal_def by auto
         have 1: "\<exists>!x. x \<in> Dom a"
         proof -
           have "Dom a = {} \<Longrightarrow> \<not>terminal a"
           proof -
             assume "Dom a = {}"
             hence 1: "a = MkIde {}"
               using MkIde_Dom' \<open>ide a\<close> by fastforce
             have "\<And>f. f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))
                          \<Longrightarrow> Map f \<in> {undefined} \<rightarrow> {}"
             proof -
               fix f
               assume f: "f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))"
               show "Map f \<in> {undefined} \<rightarrow> {}"
                 using f MkArr_expansion arr_char [of f] in_hom_char by auto
             qed
             hence "hom (MkIde {undefined}) a = {}" using 1 by auto
             moreover have "ide (MkIde {undefined})"
               using finite_imp_card_less
               by (metis (mono_tags, lifting) finite.intros(1-2) ide_MkIde mem_Collect_eq)
             ultimately show "\<not>terminal a" by blast
           qed
           moreover have "\<And>x x'. x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>terminal a"
           proof -
             fix x x'
             assume 1: "x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x'"
             let ?f = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x)"
             let ?f' = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x')"
             have "\<guillemotleft>?f : MkIde {undefined} \<rightarrow> a\<guillemotright>"
             proof
               show 2: "arr ?f"
               proof (intro arr_MkArr)
                 show "{undefined} \<in> {A. |A| <o \<AA>}"
                   by (simp add: finite_imp_card_less)
                 show "Dom a \<in> {A. |A| <o \<AA>}"
                   using ide_a ide_char by blast
                 show "(\<lambda>_ \<in> {undefined}. x) \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
                   using 1 by blast
               qed
               show "dom ?f = MkIde {undefined}"
                 using 2 dom_MkArr by auto
               show "cod ?f = a"
                 using 2 cod_MkArr ide_a by force
             qed
             moreover have "\<guillemotleft>?f' : MkIde {undefined} \<rightarrow> a\<guillemotright>"
             proof
               show 2: "arr ?f'"
                 using 1 ide_a ide_char arr_MkArr [of "{undefined}" "Dom a"]
                       finite_imp_card_less
               proof (intro arr_MkArr)
                 show "{undefined} \<in> {A. |A| <o \<AA>}"
                   by (simp add: finite_imp_card_less)
                 show "Dom a \<in> {A. |A| <o \<AA>}"
                   using ide_a ide_char by blast
                 show "(\<lambda>_ \<in> {undefined}. x') \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
                   using 1 by blast
               qed
               show "dom ?f' = MkIde {undefined}"
                 using 2 dom_MkArr by auto
               show "cod ?f' = a"
                 using 2 cod_MkArr ide_a by force
             qed
             moreover have "?f \<noteq> ?f'"
               using 1 by (metis arr.inject restrict_apply' singletonI)
             ultimately show "\<not>terminal a"
               using terminal_arr_unique
               by (metis (mono_tags, lifting) in_homE)
           qed
           ultimately show ?thesis
             using a by auto
         qed
         hence "Dom a = {THE x. x \<in> Dom a}"
           using theI [of "\<lambda>x. x \<in> Dom a"] by auto
         hence "a = MkIde {THE x. x \<in> Dom a}"
           using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
         thus "\<exists>x. a = MkIde {x}"
           by auto
       qed
     qed
 
     definition IMG :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
     where "IMG f = MkIde (Map f ` Dom f)"
   
     interpretation set_category_data comp IMG ..
 
     lemma terminal_unity:
     shows "terminal unity"
       using terminal_char unity_def someI_ex [of terminal]
       by (metis (mono_tags, lifting))
   
     text\<open>
       The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
       the inhabitants of type @{typ 'a} and the corresponding terminal objects.
       These are exported so that a client of the theory can relate the concrete
       element type @{typ 'a} to the otherwise abstract arrow type.
 \<close>
 
     definition UP :: "'e \<Rightarrow> 'e setcat.arr"
     where "UP x \<equiv> MkIde {x}"
   
     definition DOWN :: "'e setcat.arr \<Rightarrow> 'e"
     where "DOWN t \<equiv> the_elem (Dom t)"
 
     abbreviation U
     where "U \<equiv> DOWN unity"
   
     lemma UP_mapsto:
     shows "UP \<in> UNIV \<rightarrow> Univ"
       using terminal_char UP_def by fast
     
     lemma DOWN_mapsto:
     shows "DOWN \<in> Univ \<rightarrow> UNIV"
       by auto
     
     lemma DOWN_UP [simp]:
     shows "DOWN (UP x) = x"
       by (simp add: DOWN_def UP_def)
     
     lemma UP_DOWN [simp]:
     assumes "t \<in> Univ"
     shows "UP (DOWN t) = t"
       using assms terminal_char UP_def DOWN_def
       by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)
   
     lemma inj_UP:
     shows "inj UP"
       by (metis DOWN_UP injI)
   
     lemma bij_UP:
     shows "bij_betw UP UNIV Univ"
     proof (intro bij_betwI)
       interpret category comp using is_category by auto
       show DOWN_UP: "\<And>x :: 'e. DOWN (UP x) = x" by simp
       show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by simp
       show "UP \<in> UNIV \<rightarrow> Univ" using UP_mapsto by auto
       show "DOWN \<in> Collect terminal \<rightarrow> UNIV" by auto
     qed
   
     lemma Dom_terminal:
     assumes "terminal t"
     shows "Dom t = {DOWN t}"
       using assms UP_def
       by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)
 
     text\<open>
       The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
       by the formula @{term "(UP o Fun p o DOWN) unity"}.
 \<close>
 
     lemma IMG_point:
     assumes "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright>"
     shows "IMG \<in> hom unity a \<rightarrow> Univ"
     and "IMG p = (UP o Map p o DOWN) unity"
     proof -
       show "IMG \<in> hom unity a \<rightarrow> Univ"
       proof
         fix f
         assume f: "f \<in> hom unity a"
         have "terminal (MkIde (Map f ` Dom unity))"
         proof -
           obtain u :: 'e where u: "unity = MkIde {u}"
             using terminal_unity terminal_char
             by (metis (mono_tags, lifting))
           have "Map f ` Dom unity = {Map f u}"
             using u by simp
           thus ?thesis
             using terminal_char by auto
         qed
         hence "MkIde (Map f ` Dom unity) \<in> Univ" by simp
         moreover have "MkIde (Map f ` Dom unity) = IMG f"
           using f IMG_def in_hom_char
           by (metis (mono_tags, lifting) mem_Collect_eq)
         ultimately show "IMG f \<in> Univ" by auto
       qed
       have "IMG p = MkIde (Map p ` Dom p)" using IMG_def by blast
       also have "... = MkIde (Map p ` {U})"
         using assms in_hom_char terminal_unity Dom_terminal
         by (metis (mono_tags, lifting))
       also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
       finally show "IMG p = (UP o Map p o DOWN) unity" using assms by auto
     qed
   
     text\<open>
       The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
       a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
       constant-@{term t} function.
 \<close>
 
     abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
     where "MkElem t a \<equiv> MkArr {U} (Dom a) (\<lambda>_ \<in> {U}. DOWN t)"
 
     lemma MkElem_in_hom:
     assumes "arr f" and "x \<in> Dom f"
     shows "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
     proof -
       have "(\<lambda>_ \<in> {U}. DOWN (UP x)) \<in> {U} \<rightarrow> Dom (dom f)"
         using assms dom_char [of f] by simp
       moreover have "MkIde {U} = unity"
         using terminal_char terminal_unity
         by (metis (mono_tags, lifting) DOWN_UP UP_def)
       moreover have "MkIde (Dom (dom f)) = dom f"
         using assms dom_char MkIde_Dom' ide_dom by blast
       ultimately show ?thesis
         using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "\<lambda>_ \<in> {U}. DOWN (UP x)"]
         by (metis (no_types, lifting) Dom.simps(1) Dom_in_Obj IntI arr_dom ideD(1)
             restrict_extensional terminal_def terminal_unity)
     qed
 
     lemma MkElem_IMG:
     assumes "p \<in> hom unity a"
     shows "MkElem (IMG p) a = p"
     proof -
       have 0: "IMG p = UP (Map p U)"
         using assms IMG_point(2) by auto
       have 1: "Dom p = {U}"
         using assms terminal_unity Dom_terminal
         by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
       moreover have "Cod p = Dom a"
         using assms
         by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
       moreover have "Map p = (\<lambda>_ \<in> {U}. DOWN (IMG p))"
       proof
         fix e
         show "Map p e = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
         proof -
           have "Map p e = (\<lambda>x \<in> Dom p. Map p x) e"
             using assms MkArr_expansion [of p]
             by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
           also have "... = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
             using assms 0 1 by simp
           finally show ?thesis by blast
         qed
       qed
       ultimately show "MkElem (IMG p) a = p"
         using assms MkArr_Map CollectD
         by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
     qed
 
     lemma inj_IMG:
     assumes "ide a"
     shows "inj_on IMG (hom unity a)"
     proof (intro inj_onI)
       fix x y
       assume x: "x \<in> hom unity a"
       assume y: "y \<in> hom unity a"
       assume eq: "IMG x = IMG y"
       show "x = y"
       proof (intro arr_eqI)
         show "arr x" using x by blast
         show "arr y" using y by blast
         show "Dom x = Dom y"
           using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
         show "Cod x = Cod y"
           using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
         show "Map x = Map y"
         proof -
           have "\<And>a. y \<in> hom unity a \<Longrightarrow> MkArr {U} (Dom a) (\<lambda>e\<in>{U}. DOWN (IMG x)) = y"
             using MkElem_IMG eq by presburger
           hence "y = x"
             using MkElem_IMG x y by blast
           thus ?thesis by meson
         qed
       qed
     qed
 
     lemma set_char:
     assumes "ide a"
     shows "set a = UP ` Dom a"
     proof
       show "set a \<subseteq> UP ` Dom a"
       proof
         fix t
         assume "t \<in> set a"
         from this obtain p where p: "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright> \<and> t = IMG p"
           using set_def by blast
         have "t = (UP o Map p o DOWN) unity"
           using p IMG_point(2) by blast
         moreover have "(Map p o DOWN) unity \<in> Dom a"
           using p arr_char in_hom_char Dom_terminal terminal_unity
           by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
         ultimately show "t \<in> UP ` Dom a" by simp
       qed
       show "UP ` Dom a \<subseteq> set a"
       proof
         fix t
         assume "t \<in> UP ` Dom a"
         from this obtain x where x: "x \<in> Dom a \<and> t = UP x" by blast
         let ?p = "MkElem (UP x) a"
         have p: "?p \<in> hom unity a"
           using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
         moreover have "IMG ?p = t"
           using p x DOWN_UP IMG_def UP_def
           by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
               image_insert image_restrict_eq)
         ultimately show "t \<in> set a" using set_def by blast
       qed
     qed
   
     lemma Map_via_comp:
     assumes "arr f"
     shows "Map f = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U)"
     proof
       fix x
       have "x \<notin> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
         using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
       moreover have
            "x \<in> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
       proof -
         assume x: "x \<in> Dom f"
         let ?X = "MkElem (UP x) (dom f)"
         have "\<guillemotleft>?X : unity \<rightarrow> dom f\<guillemotright>"
           using assms x MkElem_in_hom by auto
         moreover have "Dom ?X = {U} \<and> Map ?X = (\<lambda>_ \<in> {U}. x)"
           using x by simp
         ultimately have
           "Map (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Map f) (\<lambda>_ \<in> {U}. x)"
           using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
           by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
         thus ?thesis
           using x by (simp add: compose_eq restrict_apply' singletonI)
       qed
       ultimately show "Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
         by auto
     qed
 
     lemma arr_eqI':
     assumes "par f f'" and "\<And>t. \<guillemotleft>t : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> t = f' \<cdot> t"
     shows "f = f'"
     proof (intro arr_eqI)
       show "arr f" using assms by simp
       show "arr f'" using assms by simp
       show "Dom f = Dom f'"
         using assms by (metis (mono_tags, lifting) Dom_dom)
       show "Cod f = Cod f'"
         using assms by (metis (mono_tags, lifting) Cod_cod)
       show "Map f = Map f'"
       proof
         have 1: "\<And>x. x \<in> Dom f \<Longrightarrow> \<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
           using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
         fix x
         show "Map f x = Map f' x"
           using assms 1 \<open>Dom f = Dom f'\<close> by (simp add: Map_via_comp)
       qed
     qed
 
     text \<open>
       We need to show that the cardinality constraint on the sets that determine objects
       implies a corresponding constraint on the sets of global elements of those objects.
     \<close>
     
     lemma card_points_less:
     assumes "ide a"
     shows "|hom unity a| <o \<AA>"
     proof -
       have "bij_betw (\<lambda>f. Map f U) (hom unity a) (Dom a)"
       proof (intro bij_betwI')
         show "\<And>x. x \<in> hom unity a \<Longrightarrow> Map x (DOWN unity) \<in> Dom a"
           using arr_char Dom_terminal terminal_unity in_hom_char by auto
         show "\<And>x y. \<lbrakk>x \<in> hom unity a; y \<in> hom unity a\<rbrakk> \<Longrightarrow> Map x U = Map y U \<longleftrightarrow> x = y"
         proof -
           fix x y
           assume x: "x \<in> hom unity a" and y: "y \<in> hom unity a"
           have 1: "Map x \<in> extensional {U} \<and> Map y \<in> extensional {U}"
             using x y in_hom_char Dom_terminal terminal_unity
             by (metis (mono_tags, lifting) Map_via_comp mem_Collect_eq restrict_extensional)
           show "Map x U = Map y U \<longleftrightarrow> x = y"
           proof
             show "x = y \<Longrightarrow> Map x U = Map y U"
               by simp
             show "Map x U = Map y U \<Longrightarrow> x = y"
             proof -
               assume 2: "Map x U = Map y U"
               have "Map x = Map y"
               proof
                 fix z
                 show "Map x z = Map y z"
                   using 1 2 extensional_arb [of "Map x"] extensional_arb [of "Map y"]
                   by (cases "z = U") auto
               qed
               thus "x = y"
                 using x y 1 in_hom_char
                 by (intro arr_eqI) auto
             qed
           qed
         qed
         show "\<And>y. y \<in> Dom a \<Longrightarrow> \<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
         proof -
           fix y
           assume y: "y \<in> Dom a"
           let ?x = "MkArr {DOWN unity} (Dom a) (\<lambda>_ \<in> {U}. y)"
           have "arr ?x"
           proof (intro arr_MkArr)
             show "{U} \<in> {A. |A| <o \<AA>}"
               by (metis (mono_tags, lifting) Dom_terminal ide_char terminal_def terminal_unity)
             show "Dom a \<in> {A. |A| <o \<AA>}"
               using assms ide_char by blast
             show "(\<lambda>_ \<in> {U}. y) \<in> extensional {U} \<inter> ({U} \<rightarrow> Dom a)"
               using assms y by blast
           qed
           hence "?x \<in> hom unity a"
             using UP_DOWN UP_def assms cod_MkArr dom_char in_homI terminal_unity by simp
           moreover have "y = Map ?x (DOWN unity)"
             by simp
           ultimately show "\<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
             by auto
         qed
       qed
       hence "|hom unity a| =o |Dom a|"
         using card_of_ordIsoI by auto
       moreover have "|Dom a| <o \<AA>"
         using assms ide_char by auto
       ultimately show "|hom unity a| <o \<AA>"
         using ordIso_ordLess_trans by auto
     qed
 
     text\<open>
       The main result, which establishes the consistency of the \<open>set_category\<close> locale
       and provides us with a way of obtaining ``set categories'' at arbitrary types.
 \<close>
 
     theorem is_set_category:
     shows "set_category comp \<AA>"
     proof
       show "\<exists>img :: 'e setcat.arr \<Rightarrow> 'e setcat.arr. set_category_given_img comp img \<AA>"
       proof
         show "set_category_given_img (comp :: 'e setcat.arr comp) IMG \<AA>"
         proof
           show "Card_order \<AA> \<and> infinite (Field \<AA> )"
             using cardinal by simp
           show "Univ \<noteq> {}" using terminal_char by blast
           fix a :: "'e setcat.arr"
           assume a: "ide a"
           show "IMG \<in> hom unity a \<rightarrow> Univ" using IMG_point terminal_unity by blast
           show "|hom unity a| <o \<AA>" using a card_points_less by simp
           show "inj_on IMG (hom unity a)" using a inj_IMG terminal_unity by blast
           next
           fix t :: "'e setcat.arr"
           assume t: "terminal t"
           show "t \<in> IMG ` hom unity t"
           proof -
             have "t \<in> set t"
               using t set_char [of t]
               by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
                   terminal_char terminal_def)
             thus ?thesis
               using t set_def [of t] by simp
           qed
           next
           fix A :: "'e setcat.arr set"
           assume A: "A \<subseteq> Univ" and 0: "|A| <o \<AA>"
           show "\<exists>a. ide a \<and> set a = A"
           proof
             let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x \<in> (DOWN ` A). x)"
             show "ide ?a \<and> set ?a = A"
             proof
               have "|DOWN ` A| <o \<AA>"
                 using 0 card_of_image ordLeq_ordLess_trans by blast
               thus 1: "ide ?a"
                 using ide_char [of ?a] by simp
               show "set ?a = A"
               proof -
                 have 2: "\<And>x. x \<in> A \<Longrightarrow> x = UP (DOWN x)"
                   using A UP_DOWN by force
                 hence "UP ` DOWN ` A = A"
                   using A UP_DOWN by auto
                 thus ?thesis
                   using 1 A set_char [of ?a] by simp
               qed
             qed
           qed
           next
           fix a b :: "'e setcat.arr"
           assume a: "ide a" and b: "ide b" and ab: "set a = set b"
           show "a = b"
             using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
             by (metis (mono_tags, lifting))
           next
           fix f f' :: "'e setcat.arr"
           assume par: "par f f'" and ff': "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
           show "f = f'" using par ff' arr_eqI' by blast
           next
           fix a b :: "'e setcat.arr" and F :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
           assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
           show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
           proof
             let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)"
             have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
             proof -
               have "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)
                       \<in> extensional (Dom a) \<inter> (Dom a \<rightarrow> Dom b)"
               proof
                 show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> extensional (Dom a)"
                   using a F by simp
                 show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
                 proof
                   fix x
                   assume x: "x \<in> Dom a"
                   have "MkElem (UP x) a \<in> hom unity a"
                     using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
                   hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
                     using F by auto
                   moreover have "Dom (F (MkElem (UP x) a)) = {U}"
                     using 1 MkElem_IMG
                     by (metis (mono_tags, lifting) Dom.simps(1))
                   moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
                     using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
                   ultimately have "Map (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
                     using arr_char [of "F (MkElem (UP x) a)"] by blast
                   thus "Map (F (MkElem (UP x) a)) U \<in> Dom b" by blast
                 qed
               qed
               hence "\<guillemotleft>?f : MkIde (Dom a) \<rightarrow> MkIde (Dom b)\<guillemotright>"
                 using a b MkArr_in_hom ide_char by blast
               thus ?thesis
                 using a b by simp
             qed
             moreover have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
             proof -
               fix x
               assume x: "\<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright>"
               have 2: "x = MkElem (IMG x) a"
                 using a x 1 MkElem_IMG [of x a]
                 by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
               moreover have 5: "Dom x = {U} \<and> Cod x = Dom a \<and>
                                 Map x = (\<lambda>_ \<in> {U}. DOWN (IMG x))"
                 using x 2
                 by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
               moreover have "Cod ?f = Dom b" using 1 by simp
               ultimately have
                    3: "?f \<cdot> x =
                        MkArr {U} (Dom b) (compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)))"
-                using 1 x comp_char [of ?f "MkElem (IMG x) a"]
-                by (metis (mono_tags, lifting) in_homE seqI)
+                by (metis (no_types, lifting) "1" Map.simps(1) comp_MkArr in_homE x)
               have 4: "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) = Map (F x)"
               proof
                 fix y
                 have "y \<notin> {U} \<Longrightarrow>
                         compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                 proof -
                   assume y: "y \<notin> {U}"
                   have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = undefined"
                     using y compose_def extensional_arb by simp
                   also have "... = Map (F x) y"
                   proof -
                     have 5: "F x \<in> hom unity b" using x F 1 by fastforce
                     hence "Dom (F x) = {U}"
                       by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
                     thus ?thesis
                       using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
                       by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
                   qed
                   ultimately show ?thesis by auto
                 qed
                 moreover have
                     "y \<in> {U} \<Longrightarrow>
                        compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                 proof -
                   assume y: "y \<in> {U}"
                   have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y =
                         Map ?f (DOWN (IMG x))"
                     using y by (simp add: compose_eq restrict_apply')
                   also have "... = (\<lambda>x. Map (F (MkElem (UP x) a)) U) (DOWN (IMG x))"
                   proof -
                     have "DOWN (IMG x) \<in> Dom a"
                       using x y a 5 arr_char in_homE restrict_apply by force
                     thus ?thesis
                       using restrict_apply by simp
                   qed
                   also have "... = Map (F x) y"
                     using x y 1 2 MkElem_IMG [of x a] by simp
                   finally show
                       "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                     by auto
                 qed
                 ultimately show
                     "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                   by auto
               qed
               show "?f \<cdot> x = F x"
               proof (intro arr_eqI)
                 have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by blast
                 have 6: "F x \<in> hom unity b"
                   using x F 1
                   by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
                 show "arr (comp ?f x)" using 5 by blast
                 show "arr (F x)" using 6 by blast
                 show "Dom (comp ?f x) = Dom (F x)"
                   using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                 show "Cod (comp ?f x) = Cod (F x)"
                   using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                 show "Map (comp ?f x) = Map (F x)"
                   using 3 4 by simp
               qed
             qed
             thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
               using 1 by blast
           qed
         qed
       qed
     qed
 
     text\<open>
       \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
       @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
       of \<open>SetCat\<close>.
 \<close>
 
     corollary is_concrete_set_category:
     shows "concrete_set_category comp \<AA> UNIV UP"
     proof -
       interpret S: set_category comp \<AA> using is_set_category by auto
       show ?thesis
       proof
         show 1: "UP \<in> UNIV \<rightarrow> S.Univ"
           using UP_def terminal_char by force
         show "inj_on UP UNIV"
           using inj_UP by blast
       qed
     qed
 
     text\<open>
       As a consequence of the categoricity of the \<open>set_category\<close> axioms,
       if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
       the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
       to the category \<open>setcat\<close> of @{typ 'a} sets and functions between them constructed here.
 \<close>
 
     corollary set_category_iso_SetCat:
     fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'e"
     assumes "set_category S \<AA>"
     and "bij_betw \<phi> (Collect (category.terminal S)) UNIV"
     shows "\<exists>\<Phi>. invertible_functor S (comp :: 'e setcat.arr comp) \<Phi>
                  \<and> (\<forall>m. set_category.incl S \<AA> m \<longrightarrow> set_category.incl comp \<AA> (\<Phi> m))"
     proof -
       interpret S: set_category S using assms by auto
       let ?\<psi> = "inv_into S.Univ \<phi>"
       have "bij_betw (UP o \<phi>) S.Univ (Collect terminal)"
       proof (intro bij_betwI)
         show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect terminal"
           using assms(2) UP_mapsto by auto
         show "?\<psi> o DOWN \<in> Collect terminal \<rightarrow> S.Univ"
         proof
           fix x :: "'e setcat.arr"
           assume x: "x \<in> Univ"
           show "(inv_into S.Univ \<phi> \<circ> DOWN) x \<in> S.Univ"
             using x assms(2) bij_betw_def comp_apply inv_into_into
             by (metis UNIV_I)
         qed
         fix t
         assume "t \<in> S.Univ"
         thus "(?\<psi> o DOWN) ((UP o \<phi>) t) = t"
           using assms(2) bij_betw_inv_into_left
           by (metis comp_apply DOWN_UP)
         next
         fix t' :: "'e setcat.arr"
         assume "t' \<in> Collect terminal"
         thus "(UP o \<phi>) ((?\<psi> o DOWN) t') = t'"
           using assms(2) by (simp add: bij_betw_def f_inv_into_f)
       qed
       thus ?thesis
         using assms(1) set_category_is_categorical [of S \<AA> comp "UP o \<phi>"] is_set_category
         by auto
     qed
 
   end
 
   sublocale setcat \<subseteq> set_category comp \<AA>
     using is_set_category by simp
   sublocale setcat \<subseteq> concrete_set_category comp \<AA> UNIV UP
     using is_concrete_set_category by simp
 
   text\<open>
     By using a large enough cardinal, we can effectively eliminate the cardinality constraint
     on the sets that determine objects and thereby obtain a set category that is replete.
     This is the normal use case, which we want to streamline as much as possible,
     so it is useful to introduce a special locale for this purpose.
   \<close>
 
   locale replete_setcat =
   fixes dummy :: 'e
   begin
 
     interpretation SC: setcat dummy
                          \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
     proof
       show "Card_order (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)) \<and>
             infinite (Field (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)))"
       by (metis Card_order_cmax Field_natLeq cardSuc_Card_order cardSuc_finite
           card_of_Card_order finite_cmax infinite_UNIV_char_0 natLeq_Card_order)
     qed
 
     text\<open>
       We don't want to expose the concrete details of the construction used to obtain
       the interpretation \<open>SC\<close>; instead, we want any facts proved about it to be derived
       solely from the assumptions of the @{locale set_category} locales.
       So we create another level of definitions here.
     \<close>
 
     definition comp
     where "comp \<equiv> SC.comp"
 
     definition UP
     where "UP \<equiv> SC.UP"
 
     definition DOWN
     where "DOWN \<equiv> SC.DOWN"
 
     sublocale set_category comp \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
       using SC.is_set_category comp_def by simp
 
     sublocale concrete_set_category comp
                 \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close> UNIV UP
       using SC.is_concrete_set_category comp_def UP_def by simp
 
     sublocale replete_set_category comp ..
 
     lemma UP_mapsto:
     shows "UP \<in> UNIV \<rightarrow> Univ"
       using SC.UP_mapsto
       by (simp add: UP_def comp_def)
 
     lemma DOWN_mapsto:
     shows "DOWN \<in> Univ \<rightarrow> UNIV"
       by auto
 
     lemma DOWN_UP [simp]:
     shows "DOWN (UP x) = x"
       by (simp add: DOWN_def UP_def)
 
     lemma UP_DOWN [simp]:
     assumes "t \<in> Univ"
     shows "UP (DOWN t) = t"
       using assms DOWN_def UP_def
       by (simp add: DOWN_def UP_def comp_def)
 
     lemma inj_UP:
     shows "inj UP"
       by (metis DOWN_UP injI)
 
     lemma bij_UP:
     shows "bij_betw UP UNIV Univ"
       by (metis SC.bij_UP UP_def comp_def)
 
   end
 
 end
 
diff --git a/thys/Category3/Yoneda.thy b/thys/Category3/Yoneda.thy
--- a/thys/Category3/Yoneda.thy
+++ b/thys/Category3/Yoneda.thy
@@ -1,1090 +1,1088 @@
 (*  Title:       Yoneda
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter Yoneda
 
 theory Yoneda
 imports DualCategory SetCat FunctorCategory
 begin
 
   text\<open>
     This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
     In traditional developments of category theory based on set theories such as ZFC,
     hom-functors are normally defined to be functors into the large category \textbf{Set}
     whose objects are of \emph{all} sets and whose arrows are functions between sets.
     However, in HOL there does not exist a single ``type of all sets'', so the notion of
     the category of \emph{all} sets and functions does not make sense.  To work around this,
     we consider a more general setting consisting of a category @{term C} together with
     a set category @{term S} and a function @{term "\<phi> :: 'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"} such that
     whenever @{term b} and @{term a} are objects of C then @{term "\<phi> (b, a)"} maps
     \<open>C.hom b a\<close> injectively to \<open>S.Univ\<close>.  We show that these data induce
     a binary functor \<open>Hom\<close> from \<open>Cop\<times>C\<close> to @{term S} in such a way that @{term \<phi>}
     is rendered natural in @{term "(b, a)"}.  The Yoneda lemma is then proved for the
     Yoneda functor determined by \<open>Hom\<close>.
 \<close>
 
   section "Hom-Functors"
 
   text\<open>
     A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
     as objects of a category @{term S} of sets and functions.  Any description of a
     hom-functor for @{term C} must therefore specify the category @{term S} and provide
     some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
     If we are to think of each hom-set \<open>C.hom b a\<close> of \<open>C\<close> as corresponding
     to an object \<open>Hom (b, a)\<close> of @{term S} then at a minimum it ought to be the
     case that the correspondence between arrows and elements is bijective between
     \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.  The \<open>hom_functor\<close> locale defined
     below captures this idea by assuming a set category @{term S} and a function @{term \<phi>}
     taking arrows of @{term C} to elements of \<open>S.Univ\<close>, such that @{term \<phi>} is injective
     on each set \<open>C.hom b a\<close>.  We show that these data induce a functor \<open>Hom\<close>
     from \<open>Cop\<times>C\<close> to \<open>S\<close> in such a way that @{term \<phi>} becomes a natural
     bijection between \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.
 \<close>
 
   locale hom_functor =
     C: category C +
     Cop: dual_category C +
     CopxC: product_category Cop.comp C +
     S: replete_set_category S
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's" +
   assumes maps_arr_to_Univ: "C.arr f \<Longrightarrow> \<phi> (C.dom f, C.cod f) f \<in> S.Univ"
   and local_inj: "\<lbrakk> C.ide b; C.ide a \<rbrakk> \<Longrightarrow> inj_on (\<phi> (b, a)) (C.hom b a)"
   begin
 
     notation S.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
     notation CopxC.comp   (infixr "\<odot>" 55)
     notation CopxC.in_hom ("\<guillemotleft>_ : _ \<rightleftharpoons> _\<guillemotright>")
 
     definition set
     where "set ba \<equiv> \<phi> (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"
 
     lemma set_subset_Univ:
     assumes "C.ide b" and "C.ide a"
     shows "set (b, a) \<subseteq> S.Univ"
       using assms set_def maps_arr_to_Univ CopxC.ide_char by auto
 
     definition \<psi> :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
     where "\<psi> ba = inv_into (C.hom (fst ba) (snd ba)) (\<phi> ba)"
 
     lemma \<phi>_mapsto:
     assumes "C.ide b" and "C.ide a"
     shows "\<phi> (b, a) \<in> C.hom b a \<rightarrow> set (b, a)"
       using assms set_def maps_arr_to_Univ by auto
 
     lemma \<psi>_mapsto:
     assumes "C.ide b" and "C.ide a"
     shows "\<psi> (b, a) \<in> set (b, a) \<rightarrow> C.hom b a"
       using assms set_def \<psi>_def local_inj by auto
 
     lemma \<psi>_\<phi> [simp]:
     assumes "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
     shows "\<psi> (b, a) (\<phi> (b, a) f) = f"
       using assms local_inj [of b a] \<psi>_def by fastforce
 
     lemma \<phi>_\<psi> [simp]:
     assumes "C.ide b" and "C.ide a"
     and "x \<in> set (b, a)"
     shows "\<phi> (b, a) (\<psi> (b, a) x) = x"
       using assms set_def local_inj \<psi>_def by auto
 
     lemma \<psi>_img_set:
     assumes "C.ide b" and "C.ide a"
     shows "\<psi> (b, a) ` set (b, a) = C.hom b a"
       using assms \<psi>_def set_def local_inj by auto
 
     text\<open>
       A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
       to the arrow of the set category @{term[source=true] S} corresponding to the function
       that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
       obtained by precomposing with @{term g} and postcomposing with @{term f}.
 \<close>
 
     definition map
     where "map gf =
              (if CopxC.arr gf then
                 S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
                         (\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf))
               else S.null)"
 
     lemma arr_map:
     assumes "CopxC.arr gf"
     shows "S.arr (map gf)"
     proof -
       have "\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf)
               \<in> set (CopxC.dom gf) \<rightarrow> set (CopxC.cod gf)"
         using assms \<phi>_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
               \<psi>_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
         by fastforce
       thus ?thesis
         using assms map_def S.arr_mkArr set_subset_Univ S.card_of_leq by simp
     qed
 
     lemma map_ide [simp]:
     assumes "C.ide b" and "C.ide a"
     shows "map (b, a) = S.mkIde (set (b, a))"
     proof -
       have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
                                  (\<phi> (b, a) o (\<lambda>h. a \<cdot> h \<cdot> b) o \<psi> (b, a))"
         using assms map_def by auto
       also have "... = S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h)"
       proof -
         have "S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h) = ..."
           using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
                 S.card_of_leq S.arr_mkIde
           by (intro S.mkArr_eqI', simp, fastforce)
         thus ?thesis by auto
       qed
       also have "... = S.mkIde (set (b, a))"
         using assms S.mkIde_as_mkArr set_subset_Univ by simp
       finally show ?thesis by auto
     qed
 
     lemma set_map:
     assumes "C.ide a" and "C.ide b"
     shows "S.set (map (b, a)) = set (b, a)"
       using assms map_ide S.set_mkIde set_subset_Univ by simp
 
     text\<open>
       The definition does in fact yield a functor.
 \<close>
 
     interpretation "functor" CopxC.comp S map
     proof
       fix gf
       assume "\<not>CopxC.arr gf"
       thus "map gf = S.null" using map_def by auto
       next
       fix gf
       assume gf: "CopxC.arr gf"
       thus arr: "S.arr (map gf)" using gf arr_map by blast
       show "S.dom (map gf) = map (CopxC.dom gf)"
-        using gf set_subset_Univ \<psi>_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
-              arr map_ide
-        by auto
+        using arr gf local.map_def map_ide by auto
       show "S.cod (map gf) = map (CopxC.cod gf)"
         using gf set_subset_Univ \<psi>_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
               arr map_ide
         by auto
       next
       fix gf gf'
       assume gf': "CopxC.seq gf' gf"
       hence seq: "C.arr (fst gf) \<and> C.arr (snd gf) \<and> C.dom (snd gf') = C.cod (snd gf) \<and>
                   C.arr (fst gf') \<and> C.arr (snd gf') \<and> C.dom (fst gf) = C.cod (fst gf')"
         by (elim CopxC.seqE C.seqE, auto)
       have 0: "S.arr (map (CopxC.comp gf' gf))"
         using gf' arr_map by blast
       have 1: "map (gf' \<odot> gf) =
                     S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                             (\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                                o \<psi> (CopxC.dom gf))"
         using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
       also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                                (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf')
                                 \<circ>
                                (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                              (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                                 \<circ> \<psi> (CopxC.dom gf)))"
           using 0 1 by simp
         show "\<And>x. x \<in> set (CopxC.dom gf) \<Longrightarrow>
                      (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                       \<psi> (CopxC.dom gf)) x =
                      (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                       (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
         proof -
           fix x
           assume "x \<in> set (CopxC.dom gf)"
           hence x: "x \<in> set (C.cod (fst gf), C.dom (snd gf))"
-            using gf' CopxC.seqE by (elim CopxC.seqE, fastforce)
+            by (simp add: seq)
           show "(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                  \<psi> (CopxC.dom gf)) x =
                 (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                  (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
           proof -
             have "(\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                      o \<psi> (CopxC.dom gf)) x =
                   \<phi> (CopxC.cod gf') (snd (gf' \<odot> gf) \<cdot> \<psi> (CopxC.dom gf) x \<cdot> fst (gf' \<odot> gf))"
               by simp
             also have "... = \<phi> (CopxC.cod gf')
                                (((\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                                  (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf)))
                                 (\<psi> (CopxC.dom gf) x))"
             proof -
               have "C.ide (C.cod (fst gf)) \<and> C.ide (C.dom (snd gf))"
                 using gf' by (elim CopxC.seqE, auto)
               hence "\<guillemotleft>\<psi> (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf) \<rightarrow> C.dom (snd gf)\<guillemotright>"
                 using x \<psi>_mapsto by auto
               hence "\<guillemotleft>snd gf \<cdot> \<psi> (C.cod (fst gf), C.dom (snd gf)) x \<cdot> fst gf :
                         C.cod (fst gf') \<rightarrow> C.dom (snd gf')\<guillemotright>"
                 using x seq by auto
               thus ?thesis
                 using seq \<psi>_\<phi> C.comp_assoc by auto
             qed
             also have "... = (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                               (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))
                               x"
               by auto
             finally show ?thesis using seq by simp
           qed
         qed
       qed
       also have "... = map gf' \<cdot>\<^sub>S map gf"
         using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
       finally show "map (gf' \<odot> gf) = map gf' \<cdot>\<^sub>S map gf"
         using seq gf' by auto
     qed
 
     interpretation binary_functor Cop.comp C S map ..
 
     lemma is_binary_functor:
     shows "binary_functor Cop.comp C S map" ..
 
   end
 
   sublocale hom_functor \<subseteq> binary_functor Cop.comp C S map
     using is_binary_functor by auto
 
   context hom_functor
   begin
 
     text\<open>
       The map @{term \<phi>} determines a bijection between @{term "C.hom b a"} and
       @{term "set (b, a)"} which is natural in @{term "(b, a)"}.
 \<close>
 
     lemma \<phi>_local_bij:
     assumes "C.ide b" and "C.ide a"
     shows "bij_betw (\<phi> (b, a)) (C.hom b a) (set (b, a))"
       using assms local_inj inj_on_imp_bij_betw set_def by auto
 
     lemma \<phi>_natural:
     assumes "C.arr g" and "C.arr f" and "h \<in> C.hom (C.cod g) (C.dom f)"
     shows "\<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g) = S.Fun (map (g, f)) (\<phi> (C.cod g, C.dom f) h)"
     proof -
       let ?\<phi>h = "\<phi> (C.cod g, C.dom f) h"
       have \<phi>h: "?\<phi>h \<in> set (C.cod g, C.dom f)"
         using assms \<phi>_mapsto set_def by simp
       have gf: "CopxC.arr (g, f)" using assms by simp
       have "map (g, f) =
                S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
                        (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))"
         using assms map_def by simp
       moreover have "S.arr (map (g, f))" using gf by simp
       ultimately have
           "S.Fun (map (g, f)) =
                restrict (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))
                         (set (C.cod g, C.dom f))"
         using S.Fun_mkArr by simp
       hence "S.Fun (map (g, f)) ?\<phi>h =
                 (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f)) ?\<phi>h"
         using \<phi>h by simp
       also have "... = \<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g)"
         using assms(3) by simp
       finally show ?thesis by auto
     qed
 
     lemma Dom_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
       using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
 
     lemma Cod_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Cod (map (g, f)) = set (C.dom g, C.cod f)"
       using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
 
     lemma Fun_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Fun (map (g, f)) =
              restrict (\<phi> (C.dom g, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> g) o \<psi> (C.cod g, C.dom f))
                       (set (C.cod g, C.dom f))"
       using assms map_def preserves_arr by force
 
     lemma map_simp_1:
     assumes "C.arr g" and "C.ide a"
     shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                 (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
     proof -
       have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                     (\<phi> (C.dom g, a) o (\<lambda>h. a \<cdot> h \<cdot> g) o \<psi> (C.cod g, a))"
         using assms map_def by force
       also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
         using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
         by (intro S.mkArr_eqI) auto
      finally show ?thesis by blast
     qed
 
     lemma map_simp_2:
     assumes "C.ide b" and "C.arr f"
     shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                 (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
     proof -
       have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                     (\<phi> (b, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> b) o \<psi> (b, C.dom f))"
         using assms map_def by force
       also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
         using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
         by (intro S.mkArr_eqI) auto
       finally show ?thesis by blast
     qed
 
   end
 
   text\<open>
     Every category @{term C} has a hom-functor: take @{term S} to be the replete set category
     generated by the arrow type \<open>'a\<close> of @{term C} and take @{term "\<phi> (b, a)"} to be the map
     \<open>S.UP :: 'a \<Rightarrow> 'a SC.arr\<close>.
 \<close>
 
   context category
   begin
 
     interpretation Cop: dual_category C ..
     interpretation CopxC: product_category Cop.comp C ..
     interpretation S: replete_setcat \<open>undefined :: 'a\<close> .
 
     lemma has_hom_functor:
     shows "hom_functor C (S.comp :: 'a setcat.arr comp) (\<lambda>_. S.UP)"
     proof
       show "\<And>f. arr f \<Longrightarrow> S.UP f \<in> S.Univ"
         using S.UP_mapsto by auto
       show "\<And>b a. \<lbrakk>ide b; ide a\<rbrakk> \<Longrightarrow> inj_on S.UP (hom b a)"
         by (meson S.inj_UP injD inj_onI)
     qed
 
   end
 
   text\<open>
     The locales \<open>set_valued_functor\<close> and \<open>set_valued_transformation\<close> provide some
     abbreviations that are convenient when working with functors and natural transformations
     into a set category.
 \<close>
 
   locale set_valued_functor =
     C: category C +
     S: replete_set_category S +
     "functor" C S F
     for C :: "'c comp"
     and S :: "'s comp"
     and F :: "'c \<Rightarrow> 's"
   begin
 
     abbreviation SET :: "'c \<Rightarrow> 's set"
     where "SET a \<equiv> S.set (F a)"
     
     abbreviation DOM :: "'c \<Rightarrow> 's set"
     where "DOM f \<equiv> S.Dom (F f)"
     
     abbreviation COD :: "'c \<Rightarrow> 's set"
     where "COD f \<equiv> S.Cod (F f)"
 
     abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
     where "FUN f \<equiv> S.Fun (F f)"
 
   end
 
   locale set_valued_transformation =
     C: category C +
     S: replete_set_category S +
     F: set_valued_functor C S F +
     G: set_valued_functor C S G +
     natural_transformation C S F G \<tau>
   for C :: "'c comp"
   and S :: "'s comp"
   and F :: "'c \<Rightarrow> 's"
   and G :: "'c \<Rightarrow> 's"
   and \<tau> :: "'c \<Rightarrow> 's"
   begin
   
     abbreviation DOM :: "'c \<Rightarrow> 's set"
     where "DOM f \<equiv> S.Dom (\<tau> f)"
     
     abbreviation COD :: "'c \<Rightarrow> 's set"
     where "COD f \<equiv> S.Cod (\<tau> f)"
 
     abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
     where "FUN f \<equiv> S.Fun (\<tau> f)"
 
   end
 
   section "Yoneda Functors"
     
   text\<open>
     A Yoneda functor is the functor from @{term C} to \<open>[Cop, S]\<close> obtained by ``currying''
     a hom-functor in its first argument.
 \<close>
 
   locale yoneda_functor =
     C: category C +
     Cop: dual_category C +
     CopxC: product_category Cop.comp C +
     S: replete_set_category S +
     Hom: hom_functor C S \<phi> +
     Cop_S: functor_category Cop.comp S +
     curried_functor' Cop.comp C S Hom.map
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   begin
 
     notation Cop_S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] _\<guillemotright>")
 
     abbreviation \<psi>
     where "\<psi> \<equiv> Hom.\<psi>"
 
     text\<open>
       An arrow of the functor category \<open>[Cop, S]\<close> consists of a natural transformation
       bundled together with its domain and codomain functors.  However, when considering
       a Yoneda functor from @{term[source=true] C} to \<open>[Cop, S]\<close> we generally are only
       interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
       to the corresponding natural transformation @{term "Y f"}.  The domain and codomain functors
       are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
 \<close>
 
     definition Y
     where "Y f \<equiv> Cop_S.Map (map f)"
 
     lemma Y_simp [simp]:
     assumes "C.arr f"
     shows "Y f = (\<lambda>g. Hom.map (g, f))"
       using assms preserves_arr Y_def by simp
 
     lemma Y_ide_is_functor:
     assumes "C.ide a"
     shows "functor Cop.comp S (Y a)"
       using assms Y_def Hom.fixing_ide_gives_functor_2 by force
 
     lemma Y_arr_is_transformation:
     assumes "C.arr f"
     shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
       using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
             preserves_dom preserves_cod by fastforce
 
     lemma Y_ide_arr [simp]:
     assumes a: "C.ide a" and "\<guillemotleft>g : b' \<rightarrow> b\<guillemotright>"
     shows "\<guillemotleft>Y a g : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b', a)\<guillemotright>"
     and "Y a g =
          S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (\<phi> (b', a) o Cop.comp g o \<psi> (b, a))"
       using assms Hom.map_simp_1 by (fastforce, auto)
 
     lemma Y_arr_ide [simp]:
     assumes "C.ide b" and "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>"
     shows "\<guillemotleft>Y f b : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b, a')\<guillemotright>"
     and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (\<phi> (b, a') o C f o \<psi> (b, a))"
       using assms apply fastforce
       using assms Hom.map_simp_2 by auto
 
   end
 
   locale yoneda_functor_fixed_object =
     yoneda_functor C S \<phi>
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and a :: 'c +
   assumes ide_a: "C.ide a"
   
   sublocale yoneda_functor_fixed_object \<subseteq> "functor" Cop.comp S "(Y a)"
     using ide_a Y_ide_is_functor by auto
   sublocale yoneda_functor_fixed_object \<subseteq> set_valued_functor Cop.comp S "(Y a)" ..
 
   text\<open>
     The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
     from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
     the set of natural transformations from the contravariant functor @{term "Y a"}
     to @{term F} is in bijective correspondence with the set \<open>F.SET a\<close>
     of elements of @{term "F a"}.
 
     Explicitly, if @{term e} is an arbitrary element of the set \<open>F.SET a\<close>,
     then the functions \<open>\<lambda>x. F.FUN (\<psi> (b, a) x) e\<close> are the components of a
     natural transformation from @{term "Y a"} to @{term F}.
     Conversely, if @{term \<tau>} is a natural transformation from @{term "Y a"} to @{term F},
     then the component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
     is completely determined by the single arrow \<open>\<tau>.FUN a (\<phi> (a, a) a)))\<close>,
     which is the the element of \<open>F.SET a\<close> that corresponds to the image of the
     identity @{term a} under the function \<open>\<tau>.FUN a\<close>.
     Then @{term "\<tau> b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
     to the function \<open>\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a)))\<close>
     from \<open>S.set (Y a b)\<close> to \<open>F.SET b\<close>.
    
     The above expressions look somewhat more complicated than the usual versions due to the
     need to account for the coercions @{term \<phi>} and @{term \<psi>}.
 \<close>
 
   locale yoneda_lemma =
     C: category C +
     Cop: dual_category C +
     S: replete_set_category S +
     F: set_valued_functor Cop.comp S F +
     yoneda_functor_fixed_object C S \<phi> a
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   begin
 
     text\<open>
       The mapping that evaluates the component @{term "\<tau> a"} at @{term a} of a
       natural transformation @{term \<tau>} from @{term Y} to @{term F} on the element
       @{term "\<phi> (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
 \<close>
 
     definition \<E> :: "('c \<Rightarrow> 's) \<Rightarrow> 's"
     where "\<E> \<tau> = S.Fun (\<tau> a) (\<phi> (a, a) a)"
 
     text\<open>
       The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
       a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
       @{term[source=true] S} corresponding to the function
       @{term "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"}.
 \<close>
 
     definition \<T>o :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
     where "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
 
     lemma \<T>o_e_ide:
     assumes e: "e \<in> S.set (F a)" and b: "C.ide b"
     shows "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
     and "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
     proof -
       show "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
         using \<T>o_def by auto
       moreover have "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"
       proof
         fix x
         assume x: "x \<in> Hom.set (b, a)"
         thus "F.FUN (\<psi> (b, a) x) e \<in> F.SET b"
           using assms e ide_a Hom.\<psi>_mapsto S.Fun_mapsto [of "F (\<psi> (b, a) x)"] by force
       qed
       ultimately show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
         using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
               S.mkIde_set
         by force
     qed
 
     text\<open>
       For each @{term "e \<in> F.SET a"}, the mapping @{term "\<T>o e"} gives the components
       of a natural transformation @{term \<T>} from @{term "Y a"} to @{term F}.
 \<close>
 
     lemma \<T>o_e_induces_transformation:
     assumes e: "e \<in> S.set (F a)"
     shows "transformation_by_components Cop.comp S (Y a) F (\<T>o e)"
     proof
       fix b :: 'c
       assume b: "Cop.ide b"
       show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
         using ide_a b e \<T>o_e_ide by simp
       next
       fix g :: 'c
       assume g: "Cop.arr g"
       let ?b = "Cop.dom g"
       let ?b' = "Cop.cod g"
       show "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
       proof -
         have 1: "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g
                    = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                              ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                 o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)))"
         proof -
           have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) \<and>
                 S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = Y a (Cop.cod g) \<and>
                 S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = F (Cop.cod g)"
             using Cop.cod_char \<T>o_e_ide [of e ?b'] \<T>o_e_ide [of e ?b'] e g
             by (metis Cop.ide_char Cop.ide_cod S.in_homE)
           moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
                                          (\<phi> (Cop.cod g, a) \<circ> Cop.comp g \<circ> \<psi> (Cop.dom g, a))"
             using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
           ultimately show ?thesis
             using ide_a e g Y_ide_arr Cop.cod_char \<T>o_e_ide
                   S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
                                    "\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)"
                                    "F.SET ?b'" "\<lambda>x. F.FUN (\<psi> (?b', a) x) e"]
             by (metis C.ide_dom Cop.arr_char preserves_arr)
         qed
         also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                  (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e))"
         proof (intro S.mkArr_eqI')
           have "(\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                    o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)) \<in> Hom.set (?b, a) \<rightarrow> F.SET ?b'"
           proof -
             have "S.arr (S (\<T>o e ?b') (Y a g))"
               using ide_a e g \<T>o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
                     Cop.ide_char Cop.ide_cod
               by blast
             thus ?thesis using 1 S.arr_mkArr by simp
           qed
           thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                   o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))))"
             using ide_a e g Hom.set_subset_Univ S.arr_mkArr by force
           show "\<And>x. x \<in> Hom.set (?b, a) \<Longrightarrow>
                         ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e) o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                         = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
           proof -
             fix x
             assume x: "x \<in> Hom.set (?b, a)"
             have "((\<lambda>x. (F.FUN o \<psi> (?b', a)) x e)
                        o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                     = F.FUN (\<psi> (?b', a) (\<phi> (?b', a) (C (\<psi> (?b, a) x) g))) e"
               by simp
             also have "... = (F.FUN g o (F.FUN o \<psi> (?b, a)) x) e"
             proof -
               have 1: "\<guillemotleft>\<psi> (Cop.dom g, a) x : Cop.dom g \<rightarrow> a\<guillemotright>"
                 using ide_a x g Hom.\<psi>_mapsto [of ?b a] by auto
               moreover have "S.seq (F g) (F (\<psi> (C.cod g, a) x))"
                 using 1 g by (intro S.seqI', auto)
               moreover have "\<psi> (C.dom g, a) (\<phi> (C.dom g, a) (C (\<psi> (C.cod g, a) x) g)) =
                              C (\<psi> (C.cod g, a) x) g"
                 using g 1 Hom.\<psi>_\<phi> [of "C (\<psi> (?b, a) x) g" ?b' a] by fastforce
               ultimately show ?thesis
                 using assms F.preserves_comp by fastforce
             qed
             also have "... = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x" by fastforce
             finally show "((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                              o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                             = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
               by simp
           qed
         qed
         also have "... = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
         proof -
           have "S.arr (F g) \<and> F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
             using g S.mkArr_Fun [of "F g"] by simp
           moreover have
               "S.arr (\<T>o e ?b) \<and>
                \<T>o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)"
             using e g \<T>o_e_ide
             by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
           ultimately show ?thesis
             using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "\<lambda>x. F.FUN (\<psi> (?b, a) x) e"
                                    "F.SET ?b'" "F.FUN g"]
             by metis
         qed
         finally show ?thesis by blast
       qed
     qed
 
     abbreviation \<T> :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
     where "\<T> e \<equiv> transformation_by_components.map Cop.comp S (Y a) (\<T>o e)"
 
   end
 
   locale yoneda_lemma_fixed_e =
     yoneda_lemma C S \<phi> F a
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   and e :: 's +
   assumes E: "e \<in> F.SET a"
   begin
 
     interpretation \<T>e: transformation_by_components Cop.comp S \<open>Y a\<close> F \<open>\<T>o e\<close>
       using E \<T>o_e_induces_transformation by auto
 
     lemma natural_transformation_\<T>e:
     shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
 
     lemma \<T>e_ide:
     assumes "Cop.ide b"
     shows "S.arr (\<T> e b)"
     and "\<T> e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
       using assms apply fastforce
       using assms \<T>o_def by auto
 
   end
 
   locale yoneda_lemma_fixed_\<tau> =
     yoneda_lemma C S \<phi> F a +
     \<tau>: set_valued_transformation Cop.comp S "Y a" F \<tau>
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   and \<tau> :: "'c \<Rightarrow> 's"
   begin
 
     text\<open>
       The key lemma: The component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
       is completely determined by the single element @{term "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"}.
 \<close>
 
     lemma \<tau>_ide:
     assumes b: "Cop.ide b"
     shows "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b)
                          (\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a))))"
     proof -
       let ?\<phi>a = "\<phi> (a, a) a"
       have \<phi>a: "\<phi> (a, a) a \<in> Hom.set (a, a)" using ide_a Hom.\<phi>_mapsto [of a a] by fastforce
       have 1: "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b)"
         using ide_a b S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
       also have
           "... = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a)))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b))"
           using ide_a b 1 S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
         show "\<And>x. x \<in> Hom.set (b, a) \<Longrightarrow> \<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
         proof -
           fix x
           assume x: "x \<in> Hom.set (b, a)"
           let ?\<psi>x = "\<psi> (b, a) x"
           have \<psi>x: "\<guillemotleft>?\<psi>x : b \<rightarrow> a\<guillemotright>"
             using ide_a b x Hom.\<psi>_mapsto [of b a] by auto
           show "\<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
           proof -
             have "\<tau>.FUN b x = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
             proof -
               have "\<tau>.FUN b x = \<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)"
                 using ide_a b x \<psi>x Hom.\<phi>_\<psi>
                by (metis C.comp_cod_arr C.in_homE C.ide_dom Cop.comp_def comp_apply)
               also have "\<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)
                            = (\<tau>.FUN b o (\<phi> (b, a) o Cop.comp ?\<psi>x o \<psi> (a, a))) ?\<phi>a"
                 using ide_a b C.ide_in_hom by simp
               also have "... = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
               proof -
                 have "S.arr (Y a ?\<psi>x)"
                   using ide_a \<psi>x preserves_arr by (elim C.in_homE, auto)
                 moreover have "Y a ?\<psi>x = S.mkArr (Hom.set (a, a)) (SET b)
                                                  (\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a))"
                   using ide_a b \<psi>x preserves_hom Y_ide_arr Hom.set_map C.arrI by auto
                 moreover have "S.arr (\<tau> b) \<and> \<tau> b = S.mkArr (SET b) (F.SET b) (\<tau>.FUN b)"
                   using ide_a b S.mkArr_Fun [of "\<tau> b"] by simp
                 ultimately have
                      "S.seq (\<tau> b) (Y a ?\<psi>x) \<and>
                       \<tau> b \<cdot>\<^sub>S Y a ?\<psi>x =
                          S.mkArr (Hom.set (a, a)) (F.SET b)
                                  (\<tau>.FUN b o (\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a)))"
                   using 1 S.comp_mkArr S.seqI
                   by (metis S.cod_mkArr S.dom_mkArr)
                 thus ?thesis
                   using ide_a b x Hom.\<phi>_mapsto S.Fun_mkArr by force
               qed
               finally show ?thesis by auto
             qed
             also have "... = S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) ?\<phi>a"
               using ide_a b \<psi>x \<tau>.naturality [of ?\<psi>x] by force
             also have "... = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
             proof -
               have "restrict (S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)) (Hom.set (a, a))
                                = restrict (F.FUN (\<psi> (b, a) x) o \<tau>.FUN a) (Hom.set (a, a))"
               proof -
                 have
                   "S.arr (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) \<and>
                    F ?\<psi>x \<cdot>\<^sub>S \<tau> a = S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
                 proof
                   show 1: "S.seq (F ?\<psi>x) (\<tau> a)"
                     using \<psi>x ide_a \<tau>.preserves_cod F.preserves_dom by (elim C.in_homE, auto)
                   have "\<tau> a = S.mkArr (Hom.set (a, a)) (F.SET a) (\<tau>.FUN a)"
                     using ide_a 1 S.mkArr_Fun [of "\<tau> a"] Hom.set_map by auto
                   moreover have "F ?\<psi>x = S.mkArr (F.SET a) (F.SET b) (F.FUN ?\<psi>x)"
                     using x \<psi>x 1 S.mkArr_Fun [of "F ?\<psi>x"] by fastforce
                   ultimately show "F ?\<psi>x \<cdot>\<^sub>S \<tau> a =
                                    S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
                     using 1 S.comp_mkArr [of "Hom.set (a, a)" "F.SET a" "\<tau>.FUN a"
                                              "F.SET b" "F.FUN ?\<psi>x"]
                     by (elim S.seqE, auto)
                 qed
                 thus ?thesis by force
               qed
               thus "S.Fun (F (\<psi> (b, a) x) \<cdot>\<^sub>S \<tau> a) ?\<phi>a = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
                  using ide_a \<phi>a restr_eqE [of "S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)"
                                            "Hom.set (a, a)" "F.FUN ?\<psi>x o \<tau>.FUN a"]
                  by simp
             qed
             finally show ?thesis by simp
           qed
         qed
       qed
       finally show ?thesis by auto
     qed
 
     text\<open>
       Consequently, if @{term \<tau>'} is any natural transformation from @{term "Y a"} to @{term F}
       that agrees with @{term \<tau>} at @{term a}, then @{term "\<tau>' = \<tau>"}.
 \<close>
 
     lemma eqI:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>'" and "\<tau>' a = \<tau> a"
     shows "\<tau>' = \<tau>"
     proof (intro NaturalTransformation.eqI)
       interpret \<tau>': natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>' using assms by auto
       interpret T': yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau>' ..
       show "natural_transformation Cop.comp S (Y a) F \<tau>" ..
       show "natural_transformation Cop.comp S (Y a) F \<tau>'" ..
       show "\<And>b. Cop.ide b \<Longrightarrow> \<tau>' b = \<tau> b"
         using assms(2) \<tau>_ide T'.\<tau>_ide by simp
     qed
 
   end
 
   context yoneda_lemma
   begin
 
     text\<open>
       One half of the Yoneda lemma:
       The mapping @{term \<T>} is an injection, with left inverse @{term \<E>},
       from the set @{term "F.SET a"} to the set of natural transformations from
       @{term "Y a"} to @{term F}.
 \<close>
 
     lemma \<T>_is_injection:
     assumes "e \<in> F.SET a"
     shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" and "\<E> (\<T> e) = e"
     proof -
       interpret yoneda_lemma_fixed_e C S \<phi> F a e
         using assms by (unfold_locales, auto)
       interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> e\<close>
         using natural_transformation_\<T>e by auto
       show "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
       show "\<E> (\<T> e) = e"
         unfolding \<E>_def
         using assms \<T>e_ide S.Fun_mkArr Hom.\<phi>_mapsto Hom.\<psi>_\<phi> ide_a
               F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
         by (auto simp add: Pi_iff)
     qed
 
     lemma \<E>\<tau>_in_Fa:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
     shows "\<E> \<tau> \<in> F.SET a"
     proof -
       interpret \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
       interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
       show ?thesis
       proof (unfold \<E>_def)
         have "S.arr (\<tau> a) \<and> S.Dom (\<tau> a) = Hom.set (a, a) \<and> S.Cod (\<tau> a) = F.SET a"
           using ide_a Hom.set_map by auto
         hence "\<tau>.FUN a \<in> Hom.set (a, a) \<rightarrow> F.SET a"
           using S.Fun_mapsto by blast
         thus "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"
           using ide_a Hom.\<phi>_mapsto by fastforce
       qed
     qed
 
     text\<open>
       The other half of the Yoneda lemma:
       The mapping @{term \<T>} is a surjection, with right inverse @{term \<E>},
       taking natural transformations from @{term "Y a"} to @{term F}
       to elements of @{term "F.SET a"}.
 \<close>
 
     lemma \<T>_is_surjection:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
     shows "\<E> \<tau> \<in> F.SET a" and "\<T> (\<E> \<tau>) = \<tau>"
     proof -
       interpret natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
       interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
       show 1: "\<E> \<tau> \<in> F.SET a" using assms \<E>\<tau>_in_Fa by auto
       interpret yoneda_lemma_fixed_e C S \<phi> F a \<open>\<E> \<tau>\<close>
         using 1 by (unfold_locales, auto)
       interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> (\<E> \<tau>)\<close>
         using natural_transformation_\<T>e by auto
       show "\<T> (\<E> \<tau>) = \<tau>"
       proof (intro eqI)
         show "natural_transformation Cop.comp S (Y a) F (\<T> (\<E> \<tau>))" ..
         show "\<T> (\<E> \<tau>) a = \<tau> a"
           using ide_a \<tau>_ide [of a] \<T>e_ide \<E>_def by simp
       qed
     qed
      
     text\<open>
       The main result.
 \<close>
 
     theorem yoneda_lemma:
     shows "bij_betw \<T> (F.SET a) {\<tau>. natural_transformation Cop.comp S (Y a) F \<tau>}"
       using \<T>_is_injection \<T>_is_surjection by (intro bij_betwI, auto)
 
   end
 
   text\<open>
     We now consider the special case in which @{term F} is the contravariant
     functor @{term "Y a'"}.  Then for any @{term e} in \<open>Hom.set (a, a')\<close>
     we have @{term "\<T> e = Y (\<psi> (a, a') e)"}, and @{term \<T>} is a bijection from
     \<open>Hom.set (a, a')\<close> to the set of natural transformations from @{term "Y a"}
     to @{term "Y a'"}.  It then follows that that the Yoneda functor @{term Y}
     is a fully faithful functor from @{term C} to the functor category \<open>[Cop, S]\<close>.
 \<close>
 
   locale yoneda_lemma_for_hom =
     C: category C +
     Cop: dual_category C +
     S: replete_set_category S +
     yoneda_functor_fixed_object C S \<phi> a +
     Ya': yoneda_functor_fixed_object C S \<phi> a' +
     yoneda_lemma C S \<phi> "Y a'" a
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   and a' :: 'c +
   assumes ide_a': "C.ide a'"
   begin
 
     text\<open>
       In case @{term F} is the functor @{term "Y a'"}, for any @{term "e \<in> Hom.set (a, a')"}
       the induced natural transformation @{term "\<T> e"} from @{term "Y a"} to @{term "Y a'"}
       is just @{term "Y (\<psi> (a, a') e)"}.
 \<close>
 
     lemma \<T>_equals_Yo\<psi>:
     assumes e: "e \<in> Hom.set (a, a')"
     shows "\<T> e = Y (\<psi> (a, a') e)"
     proof -
       let ?\<psi>e = "\<psi> (a, a') e"
       have \<psi>e: "\<guillemotleft>?\<psi>e : a \<rightarrow> a'\<guillemotright>" using ide_a ide_a' e Hom.\<psi>_mapsto [of a a'] by auto
       interpret Ye: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>Y ?\<psi>e\<close>
         using Y_arr_is_transformation [of ?\<psi>e] \<psi>e by (elim C.in_homE, auto)
       interpret yoneda_lemma_fixed_e C S \<phi> \<open>Y a'\<close> a e
         using ide_a ide_a' e S.set_mkIde Hom.set_map
         by (unfold_locales, simp_all)
       interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>\<T> e\<close>
         using natural_transformation_\<T>e by auto
       interpret yoneda_lemma_fixed_\<tau> C S \<phi> \<open>Y a'\<close> a \<open>\<T> e\<close> ..
       have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?\<psi>e)" ..
       moreover have "natural_transformation Cop.comp S (Y a) (Y a') (\<T> e)" ..
       moreover have "\<T> e a = Y ?\<psi>e a"
       proof -
         have 1: "S.arr (\<T> e a)"
           using ide_a e \<T>e.preserves_reflects_arr by simp
         have 2: "\<T> e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e)"
           using ide_a \<T>o_def \<T>e_ide by simp
         also have
             "... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a))"
         proof (intro S.mkArr_eqI)
           show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e))"
             using ide_a e 1 2 by simp
           show "Hom.set (a, a) = Hom.set (a, a)" ..
           show 3: "Ya'.SET a = Hom.set (a, a')"
             using ide_a ide_a' Y_simp Hom.set_map by simp
           show "\<And>x. x \<in> Hom.set (a, a) \<Longrightarrow>
                       Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x"
           proof -
             fix x
             assume x: "x \<in> Hom.set (a, a)"
             have \<psi>x: "\<guillemotleft>\<psi> (a, a) x : a \<rightarrow> a\<guillemotright>" using ide_a x Hom.\<psi>_mapsto [of a a] by auto
             have "S.arr (Y a' (\<psi> (a, a) x)) \<and>
                   Y a' (\<psi> (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
                                               (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a'))"
               using Y_ide_arr ide_a ide_a' \<psi>x by blast
             hence "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a')) e"
               using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of "\<psi> (a, a) x"] by simp
             also have "... = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by simp
             finally show "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by auto
           qed
         qed
         also have "... = Y ?\<psi>e a"
           using ide_a ide_a' Y_arr_ide \<psi>e by simp
         finally show "\<T> e a = Y ?\<psi>e a" by auto
       qed
       ultimately show ?thesis using eqI by auto
     qed
 
     lemma Y_injective_on_homs:
     assumes "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>" and "\<guillemotleft>f' : a \<rightarrow> a'\<guillemotright>" and "map f = map f'"
     shows "f = f'"
     proof -
       have "f = \<psi> (a, a') (\<phi> (a, a') f)"
         using assms ide_a Hom.\<psi>_\<phi> by simp
       also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f)))"
         using ide_a ide_a' assms(1) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
         by (elim C.in_homE, simp add: Pi_iff)
       also have "... = \<psi> (a, a') (\<E> (Y (\<psi> (a, a') (\<phi> (a, a') f))))"
         using assms Hom.\<phi>_mapsto [of a a'] \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f"] by force
       also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f')))"
         using assms Hom.\<phi>_mapsto [of a a'] ide_a Hom.\<psi>_\<phi> Y_def
               \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f'"]
         by fastforce
       also have "... = \<psi> (a, a') (\<phi> (a, a') f')"
         using ide_a ide_a' assms(2) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
         by (elim C.in_homE, simp add: Pi_iff)
       also have "... = f'"
         using assms ide_a Hom.\<psi>_\<phi> by simp
       finally show "f = f'" by auto
     qed
 
     lemma Y_surjective_on_homs:
     assumes \<tau>: "natural_transformation Cop.comp S (Y a) (Y a') \<tau>"
     shows "Y (\<psi> (a, a') (\<E> \<tau>)) = \<tau>"
       using ide_a ide_a' \<tau> \<T>_is_surjection \<T>_equals_Yo\<psi> \<E>\<tau>_in_Fa Hom.set_map by simp
 
   end
 
   context yoneda_functor
   begin
 
     lemma is_faithful_functor:
     shows "faithful_functor C Cop_S.comp map"
     proof
       fix f :: 'c and f' :: 'c
       assume par: "C.par f f'" and ff': "map f = map f'"
       show "f = f'"
       proof -
         interpret Ya': yoneda_functor_fixed_object C S \<phi> \<open>C.cod f\<close>
           using par by (unfold_locales, auto)
         interpret yoneda_lemma_for_hom C S \<phi> \<open>Y (C.cod f)\<close> \<open>C.dom f\<close> \<open>C.cod f\<close>
           using par by (unfold_locales, auto)
         show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
       qed
     qed
 
     lemma is_full_functor:
     shows "full_functor C Cop_S.comp map"
     proof
       fix a :: 'c and a' :: 'c and t
       assume a: "C.ide a" and a': "C.ide a'"
       assume t: "\<guillemotleft>t : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
       show "\<exists>e. \<guillemotleft>e : a \<rightarrow> a'\<guillemotright> \<and> map e = t"
       proof
         interpret Ya': yoneda_functor_fixed_object C S \<phi> a'
           using a' by (unfold_locales, auto)
         interpret yoneda_lemma_for_hom C S \<phi> \<open>Y a'\<close> a a'
           using a a' by (unfold_locales, auto)
         have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
           using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
                 Cop_S.in_homE Cop_S.arrE
           by metis
         hence 1: "\<E> (Cop_S.Map t) \<in> Hom.set (a, a')"
           using \<E>\<tau>_in_Fa ide_a ide_a' Hom.set_map by simp
         moreover have "map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
         proof (intro Cop_S.arr_eqI)
           have 2: "\<guillemotleft>map (\<psi> (a, a') (\<E> (Cop_S.Map t))) : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
             using 1 ide_a ide_a' Hom.\<psi>_mapsto [of a a'] by blast
           show "Cop_S.arr t" using t by blast
           show "Cop_S.arr (map (\<psi> (a, a') (\<E> (Cop_S.Map t))))" using 2 by blast
           show 3: "Cop_S.Map (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Map t"
             using NT Y_surjective_on_homs Y_def by simp
           show 4: "Cop_S.Dom (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Dom t"
             using t 2 functor_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
           show "Cop_S.Cod (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Cod t"
             using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
         qed
         ultimately show "\<guillemotleft>\<psi> (a, a') (\<E> (Cop_S.Map t)) : a \<rightarrow> a'\<guillemotright> \<and>
                          map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
           using ide_a ide_a' Hom.\<psi>_mapsto by auto
       qed
     qed
 
   end
 
   sublocale yoneda_functor \<subseteq> faithful_functor C Cop_S.comp map
     using is_faithful_functor by auto
   sublocale yoneda_functor \<subseteq> full_functor C Cop_S.comp map using is_full_functor by auto
   sublocale yoneda_functor \<subseteq> fully_faithful_functor C Cop_S.comp map ..
 
 end
 
diff --git a/thys/MonoidalCategory/MonoidalCategory.thy b/thys/MonoidalCategory/MonoidalCategory.thy
--- a/thys/MonoidalCategory/MonoidalCategory.thy
+++ b/thys/MonoidalCategory/MonoidalCategory.thy
@@ -1,4467 +1,4462 @@
 (*  Title:       MonoidalCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Monoidal Category"
 
 text_raw\<open>
 \label{monoidal-category-chap}
 \<close>
 
 text \<open>
   In this theory, we define the notion ``monoidal category,'' and develop consequences of
   the definition.  The main result is a proof of MacLane's coherence theorem.
 \<close>
     
 theory MonoidalCategory
 imports Category3.EquivalenceOfCategories
 begin
 
   section "Monoidal Category"
 
   text \<open>
     A typical textbook presentation defines a monoidal category to be a category @{term C}
     equipped with (among other things) a binary ``tensor product'' functor \<open>\<otimes>: C \<times> C \<rightarrow> C\<close>
     and an ``associativity'' natural isomorphism \<open>\<alpha>\<close>, whose components are isomorphisms
     \<open>\<alpha> (a, b, c): (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> (b \<otimes> c)\<close> for objects \<open>a\<close>, \<open>b\<close>,
     and \<open>c\<close> of \<open>C\<close>.  This way of saying things avoids an explicit definition of
     the functors that are the domain and codomain of \<open>\<alpha>\<close> and, in particular, what category
     serves as the domain of these functors.  The domain category is in fact the product
     category \<open>C \<times> C \<times> C\<close> and the domain and codomain of \<open>\<alpha>\<close> are the functors
     \<open>T o (T \<times> C): C \<times> C \<times> C \<rightarrow> C\<close> and \<open>T o (C \<times> T): C \<times> C \<times> C \<rightarrow> C\<close>.
     In a formal development, though, we can't gloss over the fact that
     \<open>C \<times> C \<times> C\<close> has to mean either \<open>C \<times> (C \<times> C)\<close> or \<open>(C \<times> C) \<times> C\<close>,
     which are not formally identical, and that associativities are somehow involved in the
     definitions of the functors \<open>T o (T \<times> C)\<close> and \<open>T o (C \<times> T)\<close>.
     Here we define the \<open>binary_endofunctor\<close> locale to codify our choices about what
     \<open>C \<times> C \<times> C\<close>, \<open>T o (T \<times> C)\<close>, and \<open>T o (C \<times> T)\<close> actually mean.
     In particular, we choose \<open>C \<times> C \<times> C\<close> to be \<open>C \<times> (C \<times> C)\<close> and define the
     functors \<open>T o (T \<times> C)\<close>, and \<open>T o (C \<times> T)\<close> accordingly.
 \<close>
 
   locale binary_endofunctor =
     C: category C +
     CC: product_category C C +
     CCC: product_category C CC.comp +
     binary_functor C C C T
   for C :: "'a comp"      (infixr "\<cdot>" 55)
   and T :: "'a * 'a \<Rightarrow> 'a"
   begin
 
     definition ToTC
     where "ToTC f \<equiv> if CCC.arr f then T (T (fst f, fst (snd f)), snd (snd f)) else C.null"
 
     lemma functor_ToTC:
     shows "functor CCC.comp C ToTC"
       using ToTC_def apply unfold_locales
           apply auto[4]
     proof -
       fix f g
       assume gf: "CCC.seq g f"
       show "ToTC (CCC.comp g f) = ToTC g \<cdot> ToTC f"
-        using gf unfolding CCC.seq_char CC.seq_char ToTC_def apply auto
-        apply (elim C.seqE, auto)
-        by (metis C.seqI CC.comp_simp CC.seqI fst_conv preserves_comp preserves_seq snd_conv)
+        using gf unfolding CCC.seq_char CC.seq_char ToTC_def
+        apply auto
+        by (metis CC.comp_simp CC.seqI fst_conv preserves_comp preserves_seq snd_conv)
     qed
 
     lemma ToTC_simp [simp]:
     assumes "C.arr f" and "C.arr g" and "C.arr h"
     shows "ToTC (f, g, h) = T (T (f, g), h)"
       using assms ToTC_def CCC.arr_char by simp
 
     definition ToCT
     where "ToCT f \<equiv> if CCC.arr f then T (fst f, T (fst (snd f), snd (snd f))) else C.null"
 
     lemma functor_ToCT:
     shows "functor CCC.comp C ToCT"
       using ToCT_def apply unfold_locales
         apply auto[4]
     proof -
       fix f g
       assume gf: "CCC.seq g f"
       show "ToCT (CCC.comp g f) = ToCT g \<cdot> ToCT f"
-        using gf unfolding CCC.seq_char CC.seq_char ToCT_def apply auto
-        apply (elim C.seqE, auto)
-      by (metis C.seqI CC.comp_simp CC.seqI fst_conv preserves_comp preserves_seq snd_conv)
+        using gf unfolding CCC.seq_char CC.seq_char ToCT_def
+        apply auto
+        by (metis CC.comp_simp CC.seq_char as_nat_trans.preserves_comp_2 fst_conv
+                  preserves_reflects_arr snd_conv)
     qed
 
     lemma ToCT_simp [simp]:
     assumes "C.arr f" and "C.arr g" and "C.arr h"
     shows "ToCT (f, g, h) = T (f, T (g, h))"
       using assms ToCT_def CCC.arr_char by simp
 
   end
 
   text \<open>
     Our primary definition for ``monoidal category'' follows the somewhat non-traditional
     development in \cite{Etingof15}.  There a monoidal category is defined to be a category
     \<open>C\<close> equipped with a binary \emph{tensor product} functor \<open>T: C \<times> C \<rightarrow> C\<close>,
     an \emph{associativity isomorphism}, which is a natural isomorphism
     \<open>\<alpha>: T o (T \<times> C) \<rightarrow> T o (C \<times> T)\<close>, a \emph{unit object} \<open>\<I>\<close> of \<open>C\<close>,
     and an isomorphism \<open>\<iota>: T (\<I>, \<I>) \<rightarrow> \<I>\<close>, subject to two axioms:
     the \emph{pentagon axiom}, which expresses the commutativity of certain pentagonal diagrams
     involving components of \<open>\<alpha>\<close>, and the left and right \emph{unit axioms}, which state
     that the endofunctors \<open>T (\<I>, -)\<close> and \<open>T (-, \<I>)\<close> are equivalences of categories.
     This definition is formalized in the \<open>monoidal_category\<close> locale.
 
     In more traditional developments, the definition of monoidal category involves additional
     left and right \emph{unitor} isomorphisms \<open>\<lambda>\<close> and \<open>\<rho>\<close> and associated axioms
     involving their components.
     However, as is shown in \cite{Etingof15} and formalized here, the unitors are uniquely
     determined by \<open>\<alpha>\<close> and their values \<open>\<lambda>(\<I>)\<close> and \<open>\<rho>(\<I>)\<close> at \<open>\<I>\<close>,
     which coincide.  Treating \<open>\<lambda>\<close> and \<open>\<rho>\<close> as defined notions results in a more
     economical basic definition of monoidal category that requires less data to be given,
     and has a similar effect on the definition of ``monoidal functor.''
     Moreover, in the context of the formalization of categories that we use here,
     the unit object \<open>\<I>\<close> also need not be given separately, as it can be obtained as the
     codomain of the isomorphism \<open>\<iota>\<close>.
 \<close>
 
   locale monoidal_category =
     category C +
     CC: product_category C C +
     CCC: product_category C CC.comp +
     T: binary_endofunctor C T +
     \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha> +
     L: equivalence_functor C C "\<lambda>f. T (cod \<iota>, f)" +
     R: equivalence_functor C C "\<lambda>f. T (f, cod \<iota>)"
   for C :: "'a comp"       (infixr "\<cdot>" 55)
   and T :: "'a * 'a \<Rightarrow> 'a"
   and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
   and \<iota> :: 'a +
   assumes \<iota>_in_hom': "\<guillemotleft>\<iota> : T (cod \<iota>, cod \<iota>) \<rightarrow> cod \<iota>\<guillemotright>"
   and \<iota>_is_iso: "iso \<iota>"
   and pentagon: "\<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
                  T (a, \<alpha> (b, c, d)) \<cdot> \<alpha> (a, T (b, c), d) \<cdot> T (\<alpha> (a, b, c), d) =
                  \<alpha> (a, b, T (c, d)) \<cdot> \<alpha> (T (a, b), c, d)"
   begin
 
     text\<open>
       We now define helpful notation and abbreviations to improve readability.
       We did not define and use the notation \<open>\<otimes>\<close> for the tensor product
       in the definition of the locale because to define \<open>\<otimes>\<close> as a binary
       operator requires that it be in curried form, whereas for \<open>T\<close>
       to be a binary functor requires that it take a pair as its argument.
 \<close>
 
     definition unity :: 'a ("\<I>")
     where "unity \<equiv> cod \<iota>"
 
     abbreviation L :: "'a \<Rightarrow> 'a"
     where "L f \<equiv> T (\<I>, f)"
 
     abbreviation R :: "'a \<Rightarrow> 'a"
     where "R f \<equiv> T (f, \<I>)"
 
     abbreviation tensor      (infixr "\<otimes>" 53)
     where "f \<otimes> g \<equiv> T (f, g)"
 
     abbreviation assoc       ("\<a>[_, _, _]")
     where "\<a>[a, b, c] \<equiv> \<alpha> (a, b, c)"
 
     text\<open>
       In HOL we can just give the definitions of the left and right unitors ``up front''
       without any preliminary work.  Later we will have to show that these definitions
       have the right properties.  The next two definitions define the values of the
       unitors when applied to identities; that is, their components as natural transformations.
 \<close>
 
     definition lunit ("\<l>[_]")
     where "lunit a \<equiv> THE f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
 
     definition runit ("\<r>[_]")
     where "runit a \<equiv> THE f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
 
     text\<open>
       The next two definitions extend the unitors to all arrows, not just identities.
       Unfortunately, the traditional symbol \<open>\<lambda>\<close> for the left unitor is already
       reserved for a higher purpose, so we have to make do with a poor substitute.
 \<close>
 
     abbreviation \<ll>
     where "\<ll> f \<equiv> if arr f then f \<cdot> \<l>[dom f] else null"
 
     abbreviation \<rho>
     where "\<rho> f \<equiv> if arr f then f \<cdot> \<r>[dom f] else null"
 
     text\<open>
       We now embark upon a development of the consequences of the monoidal category axioms.
       One of our objectives is to be able to show that an interpretation of the
       \<open>monoidal_category\<close> locale induces an interpretation of a locale corresponding
       to a more traditional definition of monoidal category.
       Another is to obtain the facts we need to prove the coherence theorem.
 \<close>
 
     lemma \<iota>_in_hom [intro]:
     shows "\<guillemotleft>\<iota> : \<I> \<otimes> \<I> \<rightarrow> \<I>\<guillemotright>"
       using unity_def \<iota>_in_hom' by force
 
     lemma ide_unity [simp]:
     shows "ide \<I>"
       using \<iota>_in_hom unity_def by auto
 
     lemma tensor_in_hom [simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
     shows "\<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
       using assms T.preserves_hom CC.arr_char by simp
 
     lemma arr_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "arr (f \<otimes> g)"
       using assms by simp
 
     lemma dom_tensor [simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
     shows "dom (f \<otimes> g) = a \<otimes> c"
       using assms by fastforce
 
     lemma cod_tensor [simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
     shows "cod (f \<otimes> g) = b \<otimes> d"
       using assms by fastforce
 
     lemma tensor_preserves_ide [simp]:
     assumes "ide a" and "ide b"
     shows "ide (a \<otimes> b)"
       using assms T.preserves_ide CC.ide_char by simp
 
     lemma tensor_preserves_iso [simp]:
     assumes "iso f" and "iso g"
     shows "iso (f \<otimes> g)"
       using assms by simp
 
     lemma inv_tensor [simp]:
     assumes "iso f" and "iso g"
     shows "inv (f \<otimes> g) = inv f \<otimes> inv g"
       using assms T.preserves_inv by auto
 
     lemma interchange:
     assumes "seq h g" and "seq h' g'"
     shows "(h \<otimes> h') \<cdot> (g \<otimes> g') = h \<cdot> g \<otimes> h' \<cdot> g'"
       using assms T.preserves_comp [of "(h, h')" "(g, g')"] by simp
 
     lemma \<alpha>_simp:
     assumes "arr f" and "arr g" and "arr h"
     shows "\<alpha> (f, g, h) = (f \<otimes> g \<otimes> h) \<cdot> \<a>[dom f, dom g, dom h]"
       using assms \<alpha>.is_natural_1 [of "(f, g, h)"] by simp
 
     lemma assoc_in_hom [intro]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
       using assms CCC.in_homE by auto
 
     lemma arr_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>[a, b, c]"
       using assms assoc_in_hom by simp
 
     lemma dom_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms assoc_in_hom by simp
 
     lemma cod_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
       using assms assoc_in_hom by simp
 
     lemma assoc_naturality:
     assumes "arr f0" and "arr f1" and "arr f2"
     shows "\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2) =
            (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
       using assms \<alpha>.naturality by auto
 
     lemma iso_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "iso \<a>[a, b, c]"
       using assms \<alpha>.preserves_iso by simp
 
     text\<open>
       The next result uses the fact that the functor \<open>L\<close> is an equivalence
       (and hence faithful) to show the existence of a unique solution to the characteristic
       equation used in the definition of a component @{term "\<l>[a]"} of the left unitor.
       It follows that @{term "\<l>[a]"}, as given by our definition using definite description,
       satisfies this characteristic equation and is therefore uniquely determined by
       by \<open>\<otimes>\<close>, @{term \<alpha>}, and \<open>\<iota>\<close>.
 \<close>
 
     lemma lunit_char:
     assumes "ide a"
     shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" and "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
     and "\<exists>!f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
     proof -
       obtain F \<eta> \<epsilon> where L: "equivalence_of_categories C C F (\<lambda>f. \<I> \<otimes> f) \<eta> \<epsilon>"
         using L.induces_equivalence unity_def by auto
       interpret L: equivalence_of_categories C C F \<open>\<lambda>f. \<I> \<otimes> f\<close> \<eta> \<epsilon>
         using L by auto
       let ?P = "\<lambda>f. \<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright> \<and> \<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
       have "\<guillemotleft>(\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a] : \<I> \<otimes> \<I> \<otimes> a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
       proof
         show "\<guillemotleft>\<iota> \<otimes> a : (\<I> \<otimes> \<I>) \<otimes> a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
           using assms ide_in_hom by (intro tensor_in_hom, auto)
         show "\<guillemotleft>inv \<a>[\<I>, \<I>, a] : \<I> \<otimes> \<I> \<otimes> a \<rightarrow> (\<I> \<otimes> \<I>) \<otimes> a\<guillemotright>"
           using assms by auto
       qed
       moreover have "ide (\<I> \<otimes> a)" using assms by simp
       ultimately have "\<exists>f. ?P f"
         using assms L.is_full by blast
       moreover have "\<And>f f'. ?P f \<Longrightarrow> ?P f' \<Longrightarrow> f = f'"
       proof -
         fix f f'
         assume f: "?P f" and f': "?P f'"
         have "par f f'" using f f' by force
         show "f = f'" using f f' L.is_faithful [of f f'] by force
       qed
       ultimately show "\<exists>!f. ?P f" by blast
       hence 1: "?P \<l>[a]"
         unfolding lunit_def using theI' [of ?P] by auto
       show "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" using 1 by fast
       show "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]" using 1 by fast
     qed
 
     lemma \<ll>_ide_simp:
     assumes "ide a"
     shows "\<ll> a = \<l>[a]"
       using assms lunit_char comp_cod_arr ide_in_hom by (metis in_homE)
 
     lemma lunit_in_hom [intro]:
     assumes "ide a"
     shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
       using assms lunit_char(1) by blast
 
     lemma arr_lunit [simp]:
     assumes "ide a"
     shows "arr \<l>[a]"
       using assms lunit_in_hom by auto
 
     lemma dom_lunit [simp]:
     assumes "ide a"
     shows "dom \<l>[a] = \<I> \<otimes> a"
       using assms lunit_in_hom by auto
 
     lemma cod_lunit [simp]:
     assumes "ide a"
     shows "cod \<l>[a] = a"
       using assms lunit_in_hom by auto
 
     text\<open>
       As the right-hand side of the characteristic equation for @{term "\<I> \<otimes> \<l>[a]"}
       is an isomorphism, and the equivalence functor \<open>L\<close> reflects isomorphisms,
       it follows that @{term "\<l>[a]"} is an isomorphism.
 \<close>
 
     lemma iso_lunit [simp]:
     assumes "ide a"
     shows "iso \<l>[a]"
       using assms lunit_char(2) \<iota>_is_iso ide_unity isos_compose iso_assoc iso_inv_iso
             \<iota>_in_hom L.reflects_iso arr_lunit arr_tensor ideD(1) ide_is_iso lunit_in_hom
             tensor_preserves_iso unity_def
       by metis
 
     text\<open>
       To prove that an arrow @{term f} is equal to @{term "\<l>[a]"} we need only show
       that it is parallel to @{term "\<l>[a]"} and that @{term "\<I> \<otimes> f"} satisfies the same
       characteristic equation as @{term "\<I> \<otimes> \<l>[a]"} does.
 \<close>
 
     lemma lunit_eqI:
     assumes "\<guillemotleft>f : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" and "\<I> \<otimes> f = (\<iota> \<otimes> a) \<cdot> inv \<a>[\<I>, \<I>, a]"
     shows "f = \<l>[a]"
     proof -
       have "ide a" using assms(1) by auto
       thus ?thesis
         using assms lunit_char the1_equality by blast
     qed
 
     text\<open>
       The next facts establish the corresponding results for the components of the
       right unitor.
 \<close>
 
     lemma runit_char:
     assumes "ide a"
     shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" and "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
     and "\<exists>!f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
     proof -
       obtain F \<eta> \<epsilon> where R: "equivalence_of_categories C C F (\<lambda>f. f \<otimes> \<I>) \<eta> \<epsilon>"
         using R.induces_equivalence \<iota>_in_hom by auto
       interpret R: equivalence_of_categories C C F \<open>\<lambda>f. f \<otimes> \<I>\<close> \<eta> \<epsilon>
         using R by auto
       let ?P = "\<lambda>f. \<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright> \<and> f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
       have "\<guillemotleft>(a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>] : (a \<otimes> \<I>) \<otimes> \<I> \<rightarrow> a \<otimes> \<I>\<guillemotright>"
         using assms by fastforce
       moreover have "ide (a \<otimes> \<I>)" using assms by simp
       ultimately have "\<exists>f. ?P f"
         using assms R.is_full [of a "a \<otimes> \<I>" "(a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"] by blast
       moreover have "\<And>f f'. ?P f \<Longrightarrow> ?P f' \<Longrightarrow> f = f'"
       proof -
         fix f f'
         assume f: "?P f" and f': "?P f'"
         have "par f f'" using f f' by force
         show "f = f'" using f f' R.is_faithful [of f f'] by force
       qed
       ultimately show "\<exists>!f. ?P f" by blast
       hence 1: "?P \<r>[a]" unfolding runit_def using theI' [of ?P] by fast
       show "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" using 1 by fast
       show "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]" using 1 by fast
     qed
 
     lemma \<rho>_ide_simp:
     assumes "ide a"
     shows "\<rho> a = \<r>[a]"
       using assms runit_char [of a] comp_cod_arr by auto
 
     lemma runit_in_hom [intro]:
     assumes "ide a"
     shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
       using assms runit_char(1) by blast
 
     lemma arr_runit [simp]:
     assumes "ide a"
     shows "arr \<r>[a]"
       using assms runit_in_hom by blast
 
     lemma dom_runit [simp]:
     assumes "ide a"
     shows "dom \<r>[a] = a \<otimes> \<I>"
       using assms runit_in_hom by blast
 
     lemma cod_runit [simp]:
     assumes "ide a"
     shows "cod \<r>[a] = a"
       using assms runit_in_hom by blast
 
     lemma runit_eqI:
     assumes "\<guillemotleft>f : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" and "f \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
     shows "f = \<r>[a]"
     proof -
       have "ide a" using assms(1) by auto
       thus ?thesis
         using assms runit_char the1_equality by blast
     qed
 
     lemma iso_runit [simp]:
     assumes "ide a"
     shows "iso \<r>[a]"
       using assms \<iota>_is_iso iso_inv_iso isos_compose ide_is_iso R.preserves_reflects_arr
             arrI ide_unity iso_assoc runit_char tensor_preserves_iso R.reflects_iso
             unity_def
       by metis
 
     text\<open>
       We can now show that the components of the left and right unitors have the
       naturality properties required of a natural transformation.
 \<close>
 
     lemma lunit_naturality:
     assumes "arr f"
     shows "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
     proof -
       interpret \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
       have par: "par (\<l>[cod f] \<cdot> (\<I> \<otimes> f)) (f \<cdot> \<l>[dom f])"
         using assms by simp
       moreover have "\<I> \<otimes> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = \<I> \<otimes> f \<cdot> \<l>[dom f]"
       proof -
         have "\<I> \<otimes> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = ((\<iota> \<otimes> cod f) \<cdot> ((\<I> \<otimes> \<I>) \<otimes> f)) \<cdot> inv \<a>[\<I>, \<I>, dom f]"
           using assms interchange [of \<I> \<I> "\<I> \<otimes> f" "\<l>[cod f]"] lunit_char(2) \<iota>_in_hom unity_def
                 \<alpha>'.naturality [of "(\<I>, \<I>, f)"] comp_assoc
           by auto
         also have "... = ((\<I> \<otimes> f) \<cdot> (\<iota> \<otimes> dom f)) \<cdot> inv \<a>[\<I>, \<I>, dom f]"
           using assms interchange comp_arr_dom comp_cod_arr \<iota>_in_hom by auto
         also have "... = (\<I> \<otimes> f) \<cdot> (\<I> \<otimes> \<l>[dom f])"
           using assms \<iota>_in_hom lunit_char(2) comp_assoc by auto
         also have "... = \<I> \<otimes> f \<cdot> \<l>[dom f]"
           using assms interchange by simp
         finally show ?thesis by blast
       qed
       ultimately show "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
         using L.is_faithful unity_def by metis
     qed
 
     lemma runit_naturality:
     assumes "arr f"
     shows "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
     proof -
       have "par (\<r>[cod f] \<cdot> (f \<otimes> \<I>)) (f \<cdot> \<r>[dom f])"
         using assms by force
       moreover have "\<r>[cod f] \<cdot> (f \<otimes> \<I>) \<otimes> \<I> = f \<cdot> \<r>[dom f] \<otimes> \<I>"
       proof -
         have "\<r>[cod f] \<cdot> (f \<otimes> \<I>) \<otimes> \<I> = (cod f \<otimes> \<iota>) \<cdot> \<a>[cod f, \<I>, \<I>] \<cdot> ((f \<otimes> \<I>) \<otimes> \<I>)"
           using assms interchange [of \<I> \<I> "\<I> \<otimes> f" "\<r>[cod f]"] runit_char(2) \<iota>_in_hom unity_def
                 comp_assoc
           by auto
         also have "... = (cod f \<otimes> \<iota>) \<cdot> (f \<otimes> \<I> \<otimes> \<I>) \<cdot>  \<a>[dom f, \<I>, \<I>]"
           using assms \<alpha>.naturality [of "(f, \<I>, \<I>)"] by auto
         also have "... = ((cod f \<otimes> \<iota>) \<cdot> (f \<otimes> \<I> \<otimes> \<I>)) \<cdot> \<a>[dom f, \<I>, \<I>]"
           using comp_assoc by simp
         also have "... = ((f \<otimes> \<I>) \<cdot> (dom f \<otimes> \<iota>)) \<cdot> \<a>[dom f, \<I>, \<I>]"
           using assms \<iota>_in_hom interchange comp_arr_dom comp_cod_arr by auto
         also have "... = (f \<otimes> \<I>) \<cdot> (\<r>[dom f] \<otimes> \<I>)"
           using assms runit_char comp_assoc by auto
         also have "... = f \<cdot> \<r>[dom f] \<otimes> \<I>"
           using assms interchange by simp
         finally show ?thesis by blast
       qed
       ultimately show "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
         using R.is_faithful unity_def by metis
     qed
 
   end
 
   text\<open>
     The following locale is an extension of @{locale monoidal_category} that has the
     unitors and their inverses, as well as the inverse to the associator,
     conveniently pre-interpreted.
 \<close>
 
   locale extended_monoidal_category =
     monoidal_category +
     \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> +
     \<ll>: natural_isomorphism C C L map \<ll> +
     \<ll>': inverse_transformation C C L map \<ll> +
     \<rho>: natural_isomorphism C C R map \<rho> +
     \<rho>': inverse_transformation C C R map \<rho>
 
   text\<open>
     Next we show that an interpretation of @{locale monoidal_category} extends to an
     interpretation of @{locale extended_monoidal_category} and we arrange for the former
     locale to inherit from the latter.
 \<close>
 
   context monoidal_category
   begin
 
     interpretation \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
 
     interpretation \<ll>: natural_transformation C C L map \<ll>
     proof -
       interpret \<ll>: transformation_by_components C C L map \<open>\<lambda>a. \<l>[a]\<close>
         using lunit_in_hom lunit_naturality unity_def \<iota>_in_hom' L.is_extensional
         by (unfold_locales, auto)
       have "\<ll>.map = \<ll>"
         using \<ll>.is_natural_1 \<ll>.is_extensional by auto
       thus "natural_transformation C C L map \<ll>"
         using \<ll>.natural_transformation_axioms by auto
     qed
 
     interpretation \<ll>: natural_isomorphism C C L map \<ll>
       apply unfold_locales
       using iso_lunit \<ll>_ide_simp by simp
 
     interpretation \<rho>: natural_transformation C C R map \<rho>
     proof -
       interpret \<rho>: transformation_by_components C C R map \<open>\<lambda>a. \<r>[a]\<close>
         using runit_naturality unity_def \<iota>_in_hom' R.is_extensional
         by (unfold_locales, auto)
       have "\<rho>.map = \<rho>"
         using \<rho>.is_natural_1 \<rho>.is_extensional by auto
       thus "natural_transformation C C R map \<rho>"
         using \<rho>.natural_transformation_axioms by auto
     qed
 
     interpretation \<rho>: natural_isomorphism C C R map \<rho>
       apply unfold_locales
       using \<rho>_ide_simp by simp
 
     lemma induces_extended_monoidal_category:
     shows "extended_monoidal_category C T \<alpha> \<iota>" ..
 
   end
 
   sublocale monoidal_category \<subseteq> extended_monoidal_category
     using induces_extended_monoidal_category by auto
 
   context monoidal_category
   begin
 
     abbreviation \<alpha>'
     where "\<alpha>' \<equiv> \<alpha>'.map"
 
     lemma natural_isomorphism_\<alpha>':
     shows "natural_isomorphism CCC.comp C T.ToCT T.ToTC \<alpha>'" ..
 
     abbreviation assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
     where "\<a>\<^sup>-\<^sup>1[a, b, c] \<equiv> inv \<a>[a, b, c]"
 
     lemma \<alpha>'_ide_simp:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<alpha>' (a, b, c) = \<a>\<^sup>-\<^sup>1[a, b, c]"
       using assms \<alpha>'.inverts_components inverse_unique by force
 
     lemma \<alpha>'_simp:
     assumes "arr f" and "arr g" and "arr h"
     shows "\<alpha>' (f, g, h) = ((f \<otimes> g) \<otimes> h) \<cdot> \<a>\<^sup>-\<^sup>1[dom f, dom g, dom h]"
       using assms T.ToTC_simp \<alpha>'.is_natural_1 \<alpha>'_ide_simp by force
 
     lemma assoc_inv:
     assumes "ide a" and "ide b" and "ide c"
     shows "inverse_arrows \<a>[a, b, c] \<a>\<^sup>-\<^sup>1[a, b, c]"
       using assms inv_is_inverse by simp
 
     lemma assoc'_in_hom [intro]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>\<^sup>-\<^sup>1[a, b, c] : a \<otimes> b \<otimes> c \<rightarrow> (a \<otimes> b) \<otimes> c\<guillemotright>"
       using assms by auto
 
     lemma arr_assoc' [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>\<^sup>-\<^sup>1[a, b, c]"
       using assms by simp
 
     lemma dom_assoc' [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "dom \<a>\<^sup>-\<^sup>1[a, b, c] = a \<otimes> b \<otimes> c"
       using assms by simp
 
     lemma cod_assoc' [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "cod \<a>\<^sup>-\<^sup>1[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms by simp
 
     lemma comp_assoc_assoc' [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<a>[a, b, c] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c] = a \<otimes> (b \<otimes> c)"
     and "\<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms assoc_inv comp_arr_inv comp_inv_arr by auto
 
     lemma assoc'_naturality:
     assumes "arr f0" and "arr f1" and "arr f2"
     shows "((f0 \<otimes> f1) \<otimes> f2) \<cdot> \<a>\<^sup>-\<^sup>1[dom f0, dom f1, dom f2] =
            \<a>\<^sup>-\<^sup>1[cod f0, cod f1, cod f2] \<cdot> (f0 \<otimes> f1 \<otimes> f2)"
       using assms \<alpha>'.naturality by auto
 
     abbreviation \<ll>'
     where "\<ll>' \<equiv> \<ll>'.map"
 
     abbreviation lunit'                ("\<l>\<^sup>-\<^sup>1[_]")
     where "\<l>\<^sup>-\<^sup>1[a] \<equiv> inv \<l>[a]"
 
     lemma \<ll>'_ide_simp:
     assumes "ide a"
     shows "\<ll>'.map a = \<l>\<^sup>-\<^sup>1[a]"
       using assms \<ll>'.inverts_components \<ll>_ide_simp inverse_unique by force
 
     lemma lunit_inv:
     assumes "ide a"
     shows "inverse_arrows \<l>[a] \<l>\<^sup>-\<^sup>1[a]"
       using assms inv_is_inverse by simp
 
     lemma lunit'_in_hom [intro]:
     assumes "ide a"
     shows "\<guillemotleft>\<l>\<^sup>-\<^sup>1[a] : a \<rightarrow> \<I> \<otimes> a\<guillemotright>"
       using assms by auto
 
     lemma comp_lunit_lunit' [simp]:
     assumes "ide a"
     shows "\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a] = a"
     and "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<I> \<otimes> a"
     proof -
       show "\<l>[a] \<cdot> \<l>\<^sup>-\<^sup>1[a] = a"
         using assms comp_arr_inv lunit_inv by fastforce
       show "\<l>\<^sup>-\<^sup>1[a] \<cdot> \<l>[a] = \<I> \<otimes> a"
         using assms comp_arr_inv lunit_inv by fastforce
     qed
 
     lemma lunit'_naturality:
     assumes "arr f"
     shows "(\<I> \<otimes> f) \<cdot> \<l>\<^sup>-\<^sup>1[dom f] = \<l>\<^sup>-\<^sup>1[cod f] \<cdot> f"
       using assms \<ll>'.naturality \<ll>'_ide_simp by simp
 
     abbreviation \<rho>'
     where "\<rho>' \<equiv> \<rho>'.map"
 
     abbreviation runit' ("\<r>\<^sup>-\<^sup>1[_]")
     where "\<r>\<^sup>-\<^sup>1[a] \<equiv> inv \<r>[a]"
 
     lemma \<rho>'_ide_simp:
     assumes "ide a"
     shows "\<rho>'.map a = \<r>\<^sup>-\<^sup>1[a]"
       using assms \<rho>'.inverts_components \<rho>_ide_simp inverse_unique by auto
 
     lemma runit_inv:
     assumes "ide a"
     shows "inverse_arrows \<r>[a] \<r>\<^sup>-\<^sup>1[a]"
       using assms inv_is_inverse by simp
 
     lemma runit'_in_hom [intro]:
     assumes "ide a"
     shows "\<guillemotleft>\<r>\<^sup>-\<^sup>1[a] : a \<rightarrow> a \<otimes> \<I>\<guillemotright>"
       using assms by auto
 
     lemma comp_runit_runit' [simp]:
     assumes "ide a"
     shows "\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a] = a"
     and "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = a \<otimes> \<I>"
     proof -
       show "\<r>[a] \<cdot> \<r>\<^sup>-\<^sup>1[a] = a"
         using assms runit_inv by fastforce
       show "\<r>\<^sup>-\<^sup>1[a] \<cdot> \<r>[a] = a \<otimes> \<I>"
         using assms runit_inv by fastforce
     qed
 
     lemma runit'_naturality:
     assumes "arr f"
     shows "(f \<otimes> \<I>) \<cdot> \<r>\<^sup>-\<^sup>1[dom f] = \<r>\<^sup>-\<^sup>1[cod f] \<cdot> f"
       using assms \<rho>'.naturality \<rho>'_ide_simp by simp
 
     lemma lunit_commutes_with_L:
     assumes "ide a"
     shows "\<l>[\<I> \<otimes> a] = \<I> \<otimes> \<l>[a]"
       using assms lunit_naturality lunit_in_hom iso_lunit iso_is_section
             section_is_mono monoE L.preserves_ide arrI cod_lunit dom_lunit seqI
             unity_def
       by metis
 
     lemma runit_commutes_with_R:
     assumes "ide a"
     shows "\<r>[a \<otimes> \<I>] = \<r>[a] \<otimes> \<I>"
       using assms runit_naturality runit_in_hom iso_runit iso_is_section
             section_is_mono monoE R.preserves_ide arrI cod_runit dom_runit seqI
             unity_def
       by metis
 
     text\<open>
       The components of the left and right unitors are related via a ``triangle''
       diagram that also involves the associator.
       The proof follows \cite{Etingof15}, Proposition 2.2.3.
 \<close>
 
     lemma triangle:
     assumes "ide a" and "ide b"
     shows "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
     proof -
       text\<open>
         We show that the lower left triangle in the following diagram commutes.
 \<close>
       text\<open>
 $$\xymatrix{
   {@{term "((a \<otimes> \<I>) \<otimes> \<I>) \<otimes> b"}}
      \ar[rrrr]^{\scriptsize @{term "\<a>[a, \<I>, \<I>] \<otimes> b"}}
      \ar[ddd]_{\scriptsize @{term "\<a>[a \<otimes> \<I>, \<I>, b]"}}
      \ar[drr]_{\scriptsize @{term "(\<r>[a] \<otimes> \<I>) \<otimes> b"}}
   && &&
   {@{term "(a \<otimes> (\<I> \<otimes> \<I>)) \<otimes> b"}}
      \ar[dll]^{\scriptsize @{term "(a \<otimes> \<iota>) \<otimes> b"}}
      \ar[ddd]^{\scriptsize @{term "\<a>[a, \<I> \<otimes> \<I>, b]"}} \\
   && {@{term "(a \<otimes> \<I>) \<otimes> b"}}
       \ar[d]^{\scriptsize @{term "\<a>[a, \<I>, b]"}} \\
   && {@{term "a \<otimes> \<I> \<otimes> b"}}  \\
   {@{term "(a \<otimes> \<I>) \<otimes> \<I> \<otimes> b"}}
       \ar[urr]^{\scriptsize @{term "\<r>[a] \<otimes> \<I> \<otimes> b"}}
       \ar[drr]_{\scriptsize @{term "\<a>[a, \<I>, \<I> \<otimes> b]"}}
   && &&
   {@{term "a \<otimes> (\<I> \<otimes> \<I>) \<otimes> b"}}
       \ar[ull]_{\scriptsize @{term "a \<otimes> \<iota> \<otimes> b"}}
       \ar[dll]^{\scriptsize @{term "a \<otimes> \<a>[\<I>, \<I>, b]"}}  \\
   && {@{term "a \<otimes> \<I> \<otimes> \<I> \<otimes> b"}}
       \ar[uu]^{\scriptsize @{term "a \<otimes> \<l>[\<I> \<otimes> b]"}}
 }$$
 \<close>
       have *: "(a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] = \<r>[a] \<otimes> \<I> \<otimes> b"
       proof -
         have 1: "((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]
                     = (\<r>[a] \<otimes> \<I> \<otimes> b) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]"
         proof -
           have "((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b] =
                 ((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<a>[\<I>, \<I>, b])) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b] \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
             using assms pentagon comp_assoc by auto
           also have "... = (a \<otimes> ((\<I> \<otimes> \<l>[b]) \<cdot> \<a>[\<I>, \<I>, b])) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b] \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
             using assms interchange lunit_commutes_with_L by simp
           also have "... = ((a \<otimes> (\<iota> \<otimes> b)) \<cdot> \<a>[a, \<I> \<otimes> \<I>, b]) \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
             using assms lunit_char \<iota>_in_hom comp_arr_dom comp_assoc by auto
           also have "... = (\<a>[a, \<I>, b] \<cdot> ((a \<otimes> \<iota>) \<otimes> b)) \<cdot> (\<a>[a, \<I>, \<I>] \<otimes> b)"
             using assms \<iota>_in_hom assoc_naturality [of a \<iota> b] by fastforce
           also have "... = \<a>[a, \<I>, b] \<cdot> ((\<r>[a] \<otimes> \<I>) \<otimes> b)"
             using assms \<iota>_in_hom interchange runit_char(2) comp_assoc by auto
           also have "... = (\<r>[a] \<otimes> \<I> \<otimes> b) \<cdot> \<a>[a \<otimes> \<I>, \<I>, b]"
             using assms assoc_naturality [of "\<r>[a]" \<I> b] by simp
           finally show ?thesis by blast
         qed
         show ?thesis
         proof -
           have "epi \<a>[a \<otimes> \<I>, \<I>, b]"
             using assms iso_assoc iso_is_retraction retraction_is_epi by simp
           thus ?thesis
             using 1 assms epiE [of "\<a>[a \<otimes> \<I>, \<I>, b]" "(a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]"]
             by fastforce
         qed
       qed
       text\<open>
          In \cite{Etingof15} it merely states that the preceding result suffices
          ``because any object of \<open>C\<close> is isomorphic to one of the form @{term "\<I> \<otimes> b"}.''
          However, it seems a little bit more involved than that to formally transport the
          equation \<open>(*)\<close> along the isomorphism @{term "\<l>[b]"} from @{term "\<I> \<otimes> b"}
          to @{term b}.
 \<close>
       have "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = ((a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])) \<cdot>
                                      (a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
       proof -
         have "\<a>[a, \<I>, b] = (a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
         proof -
           have "(a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])
                   = ((a \<otimes> \<I> \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])) \<cdot> \<a>[a, \<I>, b]"
             using assms assoc_naturality [of a \<I> "\<l>\<^sup>-\<^sup>1[b]"] comp_assoc by simp
           also have "... = \<a>[a, \<I>, b]"
             using assms inv_is_inverse interchange comp_cod_arr by simp
           finally show ?thesis by auto
         qed
         moreover have "a \<otimes> \<l>[b] = (a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b])"
           using assms lunit_commutes_with_L comp_arr_dom interchange by auto
         ultimately show ?thesis by argo
       qed
       also have "... = (a \<otimes> \<l>[b]) \<cdot> (a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> ((a \<otimes> \<I> \<otimes> \<l>\<^sup>-\<^sup>1[b]) \<cdot> (a \<otimes> \<I> \<otimes> \<l>[b])) \<cdot>
                        \<a>[a, \<I>, \<I> \<otimes> b] \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
         using assms comp_assoc by auto
       also have "... = (a \<otimes> \<l>[b]) \<cdot> ((a \<otimes> \<l>[\<I> \<otimes> b]) \<cdot> \<a>[a, \<I>, \<I> \<otimes> b]) \<cdot> ((a \<otimes> \<I>) \<otimes> \<l>\<^sup>-\<^sup>1[b])"
         using assms interchange comp_cod_arr comp_assoc by auto
       also have "... = \<r>[a] \<otimes> b"
         using assms * interchange runit_char(1) comp_arr_dom comp_cod_arr by auto
       finally show ?thesis by blast
     qed
 
     lemma lunit_tensor_gen:
     assumes "ide a" and "ide b" and "ide c"
     shows "(a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c]) = a \<otimes> \<l>[b] \<otimes> c"
     proof -
       text\<open>
         We show that the lower right triangle in the following diagram commutes.
 \<close>
       text\<open>
 $$\xymatrix{
   {@{term "((a \<otimes> \<I>) \<otimes> b) \<otimes> c"}}
      \ar[rrrr]^{\scriptsize @{term "\<a>[a, \<I>, b] \<otimes> c"}}
      \ar[ddd]_{\scriptsize @{term "\<a>[a \<otimes> \<I>, b, c]"}}
      \ar[drr]_{\scriptsize @{term "\<r>[a] \<otimes> b \<otimes> c"}}
   && &&
   {@{term "(a \<otimes> (\<I> \<otimes> b)) \<otimes> c"}}
      \ar[dll]^{\scriptsize @{term "(a \<otimes> \<l>[b]) \<otimes> c"}}
      \ar[ddd]^{\scriptsize @{term "\<a>[a, \<I> \<otimes> b, c]"}} \\
   && {@{term "(a \<otimes> b) \<otimes> c"}}
       \ar[d]^{\scriptsize @{term "\<a>[a, b, c]"}}    \\
   && {@{term "a \<otimes> b \<otimes> c"}}        \\
   {@{term "(a \<otimes> \<I>) \<otimes> b \<otimes> c"}}
       \ar[urr]^{\scriptsize @{term "\<r>[a] \<otimes> b \<otimes> c"}}
       \ar[drr]_{\scriptsize @{term "\<a>[a, \<I>, b \<otimes> c]"}}
   && &&
   {@{term "a \<otimes> (\<I> \<otimes> b) \<otimes> c"}}
       \ar[ull]_{\scriptsize @{term "a \<otimes> \<l>[b] \<otimes> c"}}
       \ar[dll]^{\scriptsize @{term "a \<otimes> \<a>[\<I>, b, c]"}}  \\
   && {@{term "a \<otimes> \<I> \<otimes> b \<otimes> c"}}
       \ar[uu]^{\scriptsize @{term "a \<otimes> \<l>[b \<otimes> c]"}}
 }$$
 \<close>
       have "((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) \<cdot> (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)) =
             ((a \<otimes> \<l>[b \<otimes> c]) \<cdot> \<a>[a, \<I>, b \<otimes> c]) \<cdot> \<a>[a \<otimes> \<I>, b, c]"
         using assms pentagon comp_assoc by simp
       also have "... = (\<r>[a] \<otimes> (b \<otimes> c)) \<cdot> \<a>[a \<otimes> \<I>, b, c]"
         using assms triangle by auto
       also have "... = \<a>[a, b, c] \<cdot> ((\<r>[a] \<otimes> b) \<otimes> c)"
         using assms assoc_naturality [of "\<r>[a]" b c] by auto
       also have "... = (\<a>[a, b, c] \<cdot> ((a \<otimes> \<l>[b]) \<otimes> c)) \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
         using assms triangle interchange comp_assoc by auto
       also have "... = (a \<otimes> (\<l>[b] \<otimes> c)) \<cdot> (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
         using assms assoc_naturality [of a "\<l>[b]" c] comp_assoc by auto
       finally have 1: "((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) \<cdot> \<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)
                         = (a \<otimes> (\<l>[b] \<otimes> c)) \<cdot> \<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
         by blast
       text\<open>
         The result follows by cancelling the isomorphism
         @{term "\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"}
 \<close>
       have 2: "iso (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
         using assms isos_compose by simp
       moreover have
           "seq ((a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])) (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
         using assms by auto
       moreover have "seq (a \<otimes> (\<l>[b] \<otimes> c)) (\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c))"
         using assms by auto
       ultimately show ?thesis
         using 1 2 assms iso_is_retraction retraction_is_epi
               epiE [of "\<a>[a, \<I> \<otimes> b, c] \<cdot> (\<a>[a, \<I>, b] \<otimes> c)"
                        "(a \<otimes> \<l>[b \<otimes> c]) \<cdot> (a \<otimes> \<a>[\<I>, b, c])" "a \<otimes> \<l>[b] \<otimes> c"]
         by auto
     qed
 
     text\<open>
       The following result is quoted without proof as Theorem 7 of \cite{Kelly64} where it is
       attributed to MacLane \cite{MacLane63}.  It also appears as \cite{MacLane71},
       Exercise 1, page 161.  I did not succeed within a few hours to construct a proof following
       MacLane's hint.  The proof below is based on \cite{Etingof15}, Proposition 2.2.4.
 \<close>
 
     lemma lunit_tensor':
     assumes "ide a" and "ide b"
     shows "\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b] = \<l>[a] \<otimes> b"
     proof -
       have "\<I> \<otimes> (\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]) = \<I> \<otimes> (\<l>[a] \<otimes> b)"
         using assms interchange [of \<I> \<I>] lunit_tensor_gen by simp
       moreover have "par (\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]) (\<l>[a] \<otimes> b)"
         using assms by simp
       ultimately show ?thesis
         using assms L.is_faithful [of "\<l>[a \<otimes> b] \<cdot> \<a>[\<I>, a, b]" "\<l>[a] \<otimes> b"] unity_def by simp
     qed
 
     lemma lunit_tensor:
     assumes "ide a" and "ide b"
     shows "\<l>[a \<otimes> b] = (\<l>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, a, b]"
       using assms lunit_tensor' invert_side_of_triangle by simp
 
     text\<open>
       We next show the corresponding result for the right unitor.
 \<close>
       
     lemma runit_tensor_gen:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<r>[a \<otimes> b] \<otimes> c = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"
     proof -
       text\<open>
         We show that the upper right triangle in the following diagram commutes.
 \<close>
       text\<open>
 $$\xymatrix{
   && {@{term "((a \<otimes> b) \<otimes> \<I>) \<otimes> c"}}
      \ar[dll]_{\scriptsize @{term "\<a>[a \<otimes> b, \<I>, c]"}}
      \ar[dd]^{\scriptsize @{term "\<r>[a \<otimes> b] \<otimes> c"}}
      \ar[drr]^{\scriptsize @{term "\<a>[a, b, \<I>] \<otimes> c"}} \\
   {@{term "(a \<otimes> b) \<otimes> \<I> \<otimes> c"}}
      \ar[ddd]_{\scriptsize @{term "\<a>[a, b, \<I> \<otimes> c]"}}
      \ar[drr]_{\scriptsize @{term "(a \<otimes> b) \<otimes> \<l>[c]"}}
   && &&
   {@{term "(a \<otimes> b \<otimes> \<I>) \<otimes> c"}}
      \ar[dll]^{\scriptsize @{term "(a \<otimes> \<r>[b]) \<otimes> c"}}
      \ar[ddd]^{\scriptsize @{term "\<a>[a, b \<otimes> \<I>, c]"}} \\
   && {@{term "(a \<otimes> b) \<otimes> c"}}
      \ar[d]^{\scriptsize @{term "\<a>[a, b, c]"}}     \\
   && {@{term "a \<otimes> b \<otimes> c"}}        \\
   {@{term "a \<otimes> b \<otimes> \<I> \<otimes> c"}}
      \ar[urr]^{\scriptsize @{term "a \<otimes> b \<otimes> \<l>[c]"}}
   && &&
   {@{term "a \<otimes> (b \<otimes> \<I>) \<otimes> c"}}
      \ar[llll]^{\scriptsize @{term "a \<otimes> \<a>[b, \<I>, c]"}}
      \ar[ull]_{\scriptsize @{term "a \<otimes> \<r>[b] \<otimes> c"}}
 }$$
 \<close>
       have "\<r>[a \<otimes> b] \<otimes> c = ((a \<otimes> b) \<otimes> \<l>[c]) \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using assms triangle by simp
       also have "... = (\<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> (a \<otimes> b \<otimes> \<l>[c]) \<cdot> \<a>[a, b, \<I> \<otimes> c]) \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using assms assoc_naturality [of a b "\<l>[c]"] comp_arr_dom comp_cod_arr
               invert_side_of_triangle(1)
         by force
       also have "... = \<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> (a \<otimes> b \<otimes> \<l>[c]) \<cdot> \<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using comp_assoc by force
       also have "... = \<a>\<^sup>-\<^sup>1[a, b, c] \<cdot> ((a \<otimes> (\<r>[b] \<otimes> c)) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c])) \<cdot>
                        \<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using assms triangle [of b c] interchange invert_side_of_triangle(2) by force
       also have "... = (((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> \<I>, c]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c]) \<cdot>
                        \<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using assms assoc'_naturality [of a "\<r>[b]" c] comp_assoc by force
       also have "... = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> \<I>, c] \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, \<I>, c]) \<cdot>
                        \<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]"
         using comp_assoc by simp
       also have "... = ((a \<otimes> \<r>[b]) \<otimes> c) \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"
         using assms pentagon invert_side_of_triangle(1)
               invert_side_of_triangle(1)
                 [of "\<a>[a, b, \<I> \<otimes> c] \<cdot> \<a>[a \<otimes> b, \<I>, c]" "a \<otimes> \<a>[b, \<I>, c]"
                     "\<a>[a, b \<otimes> \<I>, c] \<cdot> (\<a>[a, b, \<I>] \<otimes> c)"]
         by force
       finally show ?thesis by blast
     qed
 
     lemma runit_tensor:
     assumes "ide a" and "ide b"
     shows "\<r>[a \<otimes> b] = (a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]"
     proof -
       have "((a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]) \<otimes> \<I> = \<r>[a \<otimes> b] \<otimes> \<I>"
         using assms interchange [of \<I> \<I>] runit_tensor_gen by simp
       moreover have "par ((a \<otimes> \<r>[b]) \<cdot> \<a>[a, b, \<I>]) \<r>[a \<otimes> b]"
         using assms by simp
       ultimately show ?thesis
         using assms R.is_faithful [of "(a \<otimes> \<r>[b]) \<cdot> (\<a>[a, b, \<I>])" "\<r>[a \<otimes> b]"] unity_def
         by argo
     qed
 
     lemma runit_tensor':
     assumes "ide a" and "ide b"
     shows "\<r>[a \<otimes> b] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, \<I>] = a \<otimes> \<r>[b]"
       using assms runit_tensor invert_side_of_triangle by force
 
     text \<open>
       Sometimes inverted forms of the triangle and pentagon axioms are useful.
 \<close>
 
     lemma triangle':
     assumes "ide a" and "ide b"
     shows "(a \<otimes> \<l>[b]) = (\<r>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b]"
     proof -
       have "(\<r>[a] \<otimes> b) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b] = ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b]) \<cdot> \<a>\<^sup>-\<^sup>1[a, \<I>, b]"
           using assms triangle by auto
       also have "... = (a \<otimes> \<l>[b])"
         using assms comp_arr_dom comp_assoc by auto
       finally show ?thesis by auto
     qed
 
     lemma pentagon':
     assumes "ide a" and "ide b" and "ide c" and "ide d"
     shows "((\<a>\<^sup>-\<^sup>1[a, b, c] \<otimes> d) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> c, d]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, c, d])
               = \<a>\<^sup>-\<^sup>1[a \<otimes> b, c, d] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c \<otimes> d]"
     proof -
       have "((\<a>\<^sup>-\<^sup>1[a, b, c] \<otimes> d) \<cdot> \<a>\<^sup>-\<^sup>1[a, b \<otimes> c, d]) \<cdot> (a \<otimes> \<a>\<^sup>-\<^sup>1[b, c, d])
               = inv ((a \<otimes> \<a>[b, c, d]) \<cdot> (\<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)))"
         using assms isos_compose inv_comp by simp
       also have "... = inv (\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d])"
         using assms pentagon by auto
       also have "... = \<a>\<^sup>-\<^sup>1[a \<otimes> b, c, d] \<cdot> \<a>\<^sup>-\<^sup>1[a, b, c \<otimes> d]"
         using assms inv_comp by simp
       finally show ?thesis by auto
     qed
 
     text\<open>
       The following non-obvious fact is Corollary 2.2.5 from \cite{Etingof15}.
       The statement that @{term "\<l>[\<I>] = \<r>[\<I>]"} is Theorem 6 from \cite{Kelly64}.
       MacLane \cite{MacLane71} does not show this, but assumes it as an axiom.
 \<close>
 
     lemma unitor_coincidence:
     shows "\<l>[\<I>] = \<iota>" and "\<r>[\<I>] = \<iota>"
     proof -
       have "\<l>[\<I>] \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
         using lunit_tensor' [of \<I> \<I>] lunit_commutes_with_L [of \<I>] by simp
       moreover have "\<r>[\<I>] \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
         using triangle [of \<I> \<I>] by simp
       moreover have "\<iota> \<otimes> \<I> = (\<I> \<otimes> \<l>[\<I>]) \<cdot> \<a>[\<I>, \<I>, \<I>]"
         using lunit_char comp_arr_dom \<iota>_in_hom comp_assoc by auto
       ultimately have "\<l>[\<I>] \<otimes> \<I> = \<iota> \<otimes> \<I> \<and> \<r>[\<I>] \<otimes> \<I> = \<iota> \<otimes> \<I>"
         by argo
       moreover have "par \<l>[\<I>] \<iota> \<and> par \<r>[\<I>] \<iota>"
         using \<iota>_in_hom by force
       ultimately have 1: "\<l>[\<I>] = \<iota> \<and> \<r>[\<I>] = \<iota>"
         using R.is_faithful unity_def by metis
       show "\<l>[\<I>] = \<iota>" using 1 by auto
       show "\<r>[\<I>] = \<iota>" using 1 by auto
     qed
 
     lemma \<iota>_triangle:
     shows "\<iota> \<otimes> \<I> = (\<I> \<otimes> \<iota>) \<cdot> \<a>[\<I>, \<I>, \<I>]"
     and "(\<iota> \<otimes> \<I>) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>] = \<I> \<otimes> \<iota>"
       using triangle [of \<I> \<I>] triangle' [of \<I> \<I>] unitor_coincidence by auto
 
     text\<open>
       The only isomorphism that commutes with @{term \<iota>} is @{term \<I>}.
 \<close>
 
     lemma iso_commuting_with_\<iota>_equals_\<I>:
     assumes "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<guillemotright>" and "iso f" and "f \<cdot> \<iota> = \<iota> \<cdot> (f \<otimes> f)"
     shows "f = \<I>"
     proof -
       have 1: "f \<otimes> f = f \<otimes> \<I>"
       proof -
         have "f \<otimes> f = (inv \<iota> \<cdot> \<iota>) \<cdot> (f \<otimes> f)"
           using assms \<iota>_in_hom \<iota>_is_iso inv_is_inverse comp_inv_arr comp_cod_arr [of "f \<otimes> f"]
           by force
         also have "... = (inv \<iota> \<cdot> f) \<cdot> \<iota>"
           using assms \<iota>_is_iso inv_is_inverse comp_assoc by force
         also have "... = ((f \<otimes> \<I>) \<cdot> inv \<iota>) \<cdot> \<iota>"
           using assms unitor_coincidence runit'_naturality [of f] by auto
         also have "... = (f \<otimes> \<I>) \<cdot> (inv \<iota> \<cdot> \<iota>)"
           using comp_assoc by force
         also have "... = f \<otimes> \<I>"
           using assms \<iota>_in_hom \<iota>_is_iso inv_is_inverse comp_inv_arr
                 comp_arr_dom [of "f \<otimes> \<I>" "\<I> \<otimes> \<I>"]
           by force
         finally show ?thesis by blast
       qed
       moreover have "(f \<otimes> f) \<cdot> (inv f \<otimes> \<I>) = \<I> \<otimes> f \<and> (f \<otimes> \<I>) \<cdot> (inv f \<otimes> \<I>) = \<I> \<otimes> \<I>"
         using assms interchange comp_arr_inv inv_is_inverse comp_arr_dom by auto
       ultimately have "\<I> \<otimes> f = \<I> \<otimes> \<I>" by metis
       moreover have "par f \<I>"
         using assms by auto
       ultimately have "f = \<I>"
         using L.is_faithful unity_def by metis
       thus ?thesis using 1 by blast
     qed
 
   end
 
   text\<open>
     We now show that the unit \<open>\<iota>\<close> of a monoidal category is unique up to a unique
     isomorphism (Proposition 2.2.6 of \cite{Etingof15}).
 \<close>
 
   locale monoidal_category_with_alternate_unit =
     monoidal_category C T \<alpha> \<iota> +
     C\<^sub>1: monoidal_category C T \<alpha> \<iota>\<^sub>1
   for C :: "'a comp"      (infixr "\<cdot>" 55)
   and T :: "'a * 'a \<Rightarrow> 'a"
   and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
   and \<iota> :: 'a
   and \<iota>\<^sub>1 :: 'a
   begin
 
     no_notation C\<^sub>1.tensor (infixr "\<otimes>" 53)
     no_notation C\<^sub>1.unity  ("\<I>")
     no_notation C\<^sub>1.lunit  ("\<l>[_]")
     no_notation C\<^sub>1.runit  ("\<r>[_]")
     no_notation C\<^sub>1.assoc  ("\<a>[_, _, _]")
     no_notation C\<^sub>1.assoc' ("\<a>\<^sup>-\<^sup>1[_, _, _]")
 
     notation C\<^sub>1.tensor    (infixr "\<otimes>\<^sub>1" 53)
     notation C\<^sub>1.unity     ("\<I>\<^sub>1")
     notation C\<^sub>1.lunit     ("\<l>\<^sub>1[_]")
     notation C\<^sub>1.runit     ("\<r>\<^sub>1[_]")
     notation C\<^sub>1.assoc     ("\<a>\<^sub>1[_, _, _]")
     notation C\<^sub>1.assoc'    ("\<a>\<^sub>1\<^sup>-\<^sup>1[_, _, _]")
 
     definition i
     where "i \<equiv> \<l>[\<I>\<^sub>1] \<cdot> inv \<r>\<^sub>1[\<I>]"
 
     lemma iso_i:
     shows "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>" and "iso i"
     proof -
       show "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>"
         using C\<^sub>1.iso_runit inv_in_hom i_def by auto
       show "iso i"
         using iso_lunit C\<^sub>1.iso_runit isos_compose i_def by simp
     qed
 
     text\<open>
       The following is Exercise 2.2.7 of \cite{Etingof15}.
 \<close>
 
     lemma i_maps_\<iota>_to_\<iota>\<^sub>1:
     shows "i \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
     proof -
       have 1: "inv \<r>\<^sub>1[\<I>] \<cdot> \<iota> = (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
       proof -
         have "\<iota> \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) = \<r>\<^sub>1[\<I>] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
         proof -
           text \<open>
 $$\xymatrix{
   && {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
      \ar[dddll]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]"}}
      \ar[dd]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
      \ar[dddrr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
   \\
   \\
   && {@{term[source=true] "\<I> \<otimes> \<I> \<otimes> \<I>\<^sub>1"}}
      \ar[dll]^{\scriptsize @{term[source=true] "\<I> \<otimes> \<r>\<^sub>1[\<I>]"}}
      \ar[drr]_{\scriptsize @{term[source=true] "\<I> \<otimes> \<l>[\<I>\<^sub>1]"}}
      \ar[dd]^{\scriptsize @{term[source=true] "\<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]"}}
   \\
   {@{term[source=true] "\<I> \<otimes> \<I>"}}
      \ar[dddrr]_{\scriptsize @{term[source=true] "\<iota>"}}
   &&
   &&
   {@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
      \ar[dddll]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>]"}}
   \\
   && {@{ term[source=true] "(\<I> \<otimes> \<I>) \<otimes> \<I>\<^sub>1"}}
      \ar[ull]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I> \<otimes> \<I>]"}}
      \ar[urr]^{\scriptsize @{term[source=true] "\<iota> \<otimes> \<I>"}}
   \\
   \\
   && {@{term[source=true] "\<I>"}}
 }$$
 \<close>
           have "\<iota> \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) = \<iota> \<cdot> (\<I> \<otimes> \<r>\<^sub>1[\<I>]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using interchange comp_cod_arr comp_arr_dom by simp
           also have "... = \<iota> \<cdot> (\<r>\<^sub>1[\<I> \<otimes> \<I>] \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using C\<^sub>1.runit_tensor' by auto
           also have "... = (\<iota> \<cdot> \<r>\<^sub>1[\<I> \<otimes> \<I>]) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using comp_assoc by auto
           also have "... = (\<r>\<^sub>1[\<I>] \<cdot> (\<iota> \<otimes> \<I>\<^sub>1)) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using C\<^sub>1.runit_naturality [of \<iota>] \<iota>_in_hom by fastforce
           also have "... = \<r>\<^sub>1[\<I>] \<cdot> ((\<iota> \<otimes> \<I>\<^sub>1) \<cdot> \<a>\<^sup>-\<^sup>1[\<I>, \<I>, \<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using comp_assoc by auto
           also have "... = \<r>\<^sub>1[\<I>] \<cdot> (\<I> \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I> \<otimes> \<I>\<^sub>1)"
             using lunit_tensor lunit_commutes_with_L unitor_coincidence by simp
           also have "... = \<r>\<^sub>1[\<I>] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
             using interchange comp_arr_dom comp_cod_arr by simp
           finally show ?thesis by blast
         qed
         moreover have "seq \<iota> (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]) \<and> seq \<r>\<^sub>1[\<I>] (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])"
           using \<iota>_in_hom by fastforce
         moreover have "iso \<r>\<^sub>1[\<I>] \<and> iso (\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>])"
           using C\<^sub>1.iso_runit tensor_preserves_iso by force
         ultimately show ?thesis
           using invert_opposite_sides_of_square inv_tensor by metis
       qed
       have 2: "\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1])"
       proof -
         text \<open>
 $$\xymatrix{
   && {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> (\<I> \<otimes> \<I>\<^sub>1)"}}
      \ar[dddll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]"}}
      \ar[dd]^{\scriptsize @{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1]"}}
      \ar[dddrr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
   \\
   \\
   && {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<I>\<^sub>1"}}
      \ar[dll]^{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<I>\<^sub>1"}}
      \ar[drr]_{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<I>\<^sub>1"}}
      \ar[dd]^{\scriptsize @{term[source=true] "\<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]"}}
   \\
   {@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
      \ar[dddrr]_{\scriptsize @{term[source=true] "\<iota>\<^sub>1"}}
   &&
   &&
   {@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
      \ar[dddll]^{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1]"}}
   \\
   && {@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
      \ar[ull]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1]"}}
      \ar[urr]^{\scriptsize @{term[source=true] "\<I> \<otimes> \<iota>\<^sub>1"}}
   \\
   \\
   && {@{term[source=true] "\<I>\<^sub>1"}}
 }$$
 \<close>
         have "\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]) = \<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<I>\<^sub>1) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using interchange comp_arr_dom comp_cod_arr by force
         also have "... = \<l>[\<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<iota>\<^sub>1) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using C\<^sub>1.runit_tensor C\<^sub>1.unitor_coincidence C\<^sub>1.runit_commutes_with_R by simp
         also have "... = (\<l>[\<I>\<^sub>1] \<cdot> (\<I> \<otimes> \<iota>\<^sub>1)) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using comp_assoc by fastforce
         also have "... = (\<iota>\<^sub>1 \<cdot> \<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1]) \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1] \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using lunit_naturality [of \<iota>\<^sub>1] C\<^sub>1.\<iota>_in_hom lunit_commutes_with_L by fastforce
         also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1 \<otimes> \<I>\<^sub>1] \<cdot> \<a>[\<I>, \<I>\<^sub>1, \<I>\<^sub>1]) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using comp_assoc by force
         also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<I>\<^sub>1) \<cdot> ((\<I> \<otimes> \<I>\<^sub>1) \<otimes> \<l>[\<I>\<^sub>1])"
           using lunit_tensor' by auto
         also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1])"
           using interchange comp_arr_dom comp_cod_arr by simp
         finally show ?thesis by blast
       qed
       show ?thesis
       proof -
         text \<open>
 $$\xymatrix{
   {@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
      \ar[dd]_{\scriptsize @{term "\<iota>\<^sub>1"}}
   &&
   {@{term[source=true] "(\<I> \<otimes> \<I>\<^sub>1) \<otimes> (\<I> \<otimes> \<I>\<^sub>1)"}}
      \ar[ll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]"}}
      \ar[dd]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1]"}}
      \ar[rr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>] \<otimes> \<r>\<^sub>1[\<I>]"}}
   &&
   {@{term[source=true] "\<I>\<^sub>1 \<otimes> \<I>\<^sub>1"}}
      \ar[dd]^{\scriptsize @{term[source=true] "\<iota>"}}
   \\
   \\
   {@{term[source=true] "\<I>\<^sub>1"}}
   &&
   {@{term[source=true] "\<I> \<otimes> \<I>\<^sub>1"}}
      \ar[ll]_{\scriptsize @{term[source=true] "\<l>[\<I>\<^sub>1]"}}
      \ar[rr]^{\scriptsize @{term[source=true] "\<r>\<^sub>1[\<I>]"}}
   &&
   {@{term[source=true] "\<I>"}}
 }$$
 \<close>
         have "i \<cdot> \<iota> = \<l>[\<I>\<^sub>1] \<cdot> inv \<r>\<^sub>1[\<I>] \<cdot> \<iota>"
           using i_def comp_assoc by auto
         also have "... = (\<l>[\<I>\<^sub>1] \<cdot> (\<r>\<^sub>1[\<I>] \<otimes> \<l>[\<I>\<^sub>1])) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
           using 1 comp_assoc by simp
         also have "... = \<iota>\<^sub>1 \<cdot> (\<l>[\<I>\<^sub>1] \<otimes> \<l>[\<I>\<^sub>1]) \<cdot> (inv \<r>\<^sub>1[\<I>] \<otimes> inv \<r>\<^sub>1[\<I>])"
           using 2 comp_assoc by fastforce
         also have "... = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
           using interchange i_def by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma inv_i_iso_\<iota>:
     assumes "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright>" and "iso f" and "f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
     shows "\<guillemotleft>inv i \<cdot> f : \<I> \<rightarrow> \<I>\<guillemotright>" and "iso (inv i \<cdot> f)"
     and "(inv i \<cdot> f) \<cdot> \<iota> = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
     proof -
       show 1: "\<guillemotleft>inv i \<cdot> f : \<I> \<rightarrow> \<I>\<guillemotright>"
         using assms iso_i inv_in_hom by blast
       show "iso (inv i \<cdot> f)"
         using assms 1 iso_i inv_in_hom
         by (intro isos_compose, auto)
       show "(inv i \<cdot> f) \<cdot> \<iota> = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
       proof -
         have "(inv i \<cdot> f) \<cdot> \<iota> = (inv i \<cdot> \<iota>\<^sub>1) \<cdot> (f \<otimes> f)"
           using assms iso_i comp_assoc by auto
         also have "... = (\<iota> \<cdot> (inv i \<otimes> inv i)) \<cdot> (f \<otimes> f)"
           using assms iso_i invert_opposite_sides_of_square
                 inv_tensor \<iota>_in_hom C\<^sub>1.\<iota>_in_hom tensor_in_hom tensor_preserves_iso
                 inv_in_hom i_maps_\<iota>_to_\<iota>\<^sub>1 unity_def seqI'
           by metis
         also have "... = \<iota> \<cdot> (inv i \<cdot> f \<otimes> inv i \<cdot> f)"
           using assms 1 iso_i interchange comp_assoc by fastforce
         finally show ?thesis by blast
       qed
     qed
 
     lemma unit_unique_upto_unique_iso:
     shows "\<exists>!f. \<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
     proof
       show "\<guillemotleft>i : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso i \<and> i \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (i \<otimes> i)"
         using iso_i i_maps_\<iota>_to_\<iota>\<^sub>1 by auto
       show "\<And>f. \<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f) \<Longrightarrow> f = i"
       proof -
         fix f
         assume f: "\<guillemotleft>f : \<I> \<rightarrow> \<I>\<^sub>1\<guillemotright> \<and> iso f \<and> f \<cdot> \<iota> = \<iota>\<^sub>1 \<cdot> (f \<otimes> f)"
         have "inv i \<cdot> f = \<I>"
           using f inv_i_iso_\<iota> iso_commuting_with_\<iota>_equals_\<I> by blast
         hence "ide (C (inv i) f)"
           using iso_i by simp
         thus "f = i"
           using section_retraction_of_iso(2) [of "inv i" f] inverse_arrow_unique inv_is_inverse
                 iso_i
           by blast
       qed
     qed
 
   end
 
   section "Elementary Monoidal Category"
 
   text\<open>
     Although the economy of data assumed by @{locale monoidal_category} is useful for general
     results, to establish interpretations it is more convenient to work with a traditional
     definition of monoidal category.  The following locale provides such a definition.
     It permits a monoidal category to be specified by giving the tensor product and the
     components of the associator and unitors, which are required only to satisfy elementary
     conditions that imply functoriality and naturality, without having to worry about
     extensionality or formal interpretations for the various functors and natural transformations.
 \<close>
 
   locale elementary_monoidal_category =
     category C
   for C :: "'a comp"                  (infixr "\<cdot>" 55)
   and tensor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"       (infixr "\<otimes>" 53)
   and unity :: 'a                      ("\<I>")
   and lunit :: "'a \<Rightarrow> 'a"              ("\<l>[_]")
   and runit :: "'a \<Rightarrow> 'a"              ("\<r>[_]")
   and assoc :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<a>[_, _, _]") +
   assumes ide_unity [simp]: "ide \<I>"
   and iso_lunit: "ide a \<Longrightarrow> iso \<l>[a]"
   and iso_runit: "ide a \<Longrightarrow> iso \<r>[a]"
   and iso_assoc: "\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> iso \<a>[a, b, c]"
   and tensor_in_hom [simp]: "\<lbrakk> \<guillemotleft>f : a \<rightarrow> b\<guillemotright>; \<guillemotleft>g : c \<rightarrow> d\<guillemotright> \<rbrakk> \<Longrightarrow> \<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
   and tensor_preserves_ide: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes> b)"
   and interchange: "\<lbrakk> seq g f; seq g' f' \<rbrakk> \<Longrightarrow> (g \<otimes> g') \<cdot> (f \<otimes> f') = g \<cdot> f \<otimes> g' \<cdot> f'"
   and lunit_in_hom [simp]: "ide a \<Longrightarrow> \<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
   and lunit_naturality: "arr f \<Longrightarrow> \<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
   and runit_in_hom [simp]: "ide a \<Longrightarrow> \<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
   and runit_naturality: "arr f \<Longrightarrow> \<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
   and assoc_in_hom [simp]:
       "\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
   and assoc_naturality:
       "\<lbrakk> arr f0; arr f1; arr f2 \<rbrakk> \<Longrightarrow> \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)
                                         = (f0 \<otimes> (f1 \<otimes> f2)) \<cdot> \<a>[dom f0, dom f1, dom f2]"
   and triangle: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
   and pentagon: "\<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
                    (a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)
                      = \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
 
   text\<open>
     An interpretation for the \<open>monoidal_category\<close> locale readily induces an
     interpretation for the \<open>elementary_monoidal_category\<close> locale.
 \<close>
       
   context monoidal_category
   begin
 
     lemma induces_elementary_monoidal_category:
       shows "elementary_monoidal_category C tensor \<I> lunit runit assoc"
         using \<iota>_in_hom iso_assoc tensor_preserves_ide assoc_in_hom tensor_in_hom
               assoc_naturality lunit_naturality runit_naturality lunit_in_hom runit_in_hom
               iso_lunit iso_runit interchange pentagon triangle
         by unfold_locales auto
 
   end
 
   context elementary_monoidal_category
   begin
 
     interpretation CC: product_category C C ..
     interpretation CCC: product_category C CC.comp ..
 
     definition T :: "'a * 'a \<Rightarrow> 'a"
     where "T f \<equiv> if CC.arr f then (fst f \<otimes> snd f) else null"
 
     lemma T_simp [simp]:
     assumes "arr f" and "arr g"
     shows "T (f, g) = f \<otimes> g"
       using assms T_def by simp
 
     lemma arr_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "arr (f \<otimes> g)"
       using assms tensor_in_hom by blast
 
     lemma dom_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "dom (f \<otimes> g) = dom f \<otimes> dom g"
       using assms tensor_in_hom by blast
 
     lemma cod_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "cod (f \<otimes> g) = cod f \<otimes> cod g"
       using assms tensor_in_hom by blast
 
     interpretation T: binary_endofunctor C T
       using tensor_in_hom interchange T_def
       apply unfold_locales
           apply auto[4]
       by (elim CC.seqE, auto)
 
     lemma binary_endofunctor_T:
     shows "binary_endofunctor C T" ..
 
     interpretation ToTC: "functor" CCC.comp C T.ToTC
       using T.functor_ToTC by auto
 
     interpretation ToCT: "functor" CCC.comp C T.ToCT
       using T.functor_ToCT by auto
 
     definition \<alpha>
     where "\<alpha> f \<equiv> if CCC.arr f then (fst f \<otimes> (fst (snd f) \<otimes> snd (snd f))) \<cdot>
                                    \<a>[dom (fst f), dom (fst (snd f)), dom (snd (snd f))]
                   else null"
 
     lemma \<alpha>_ide_simp [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<alpha> (a, b, c) = \<a>[a, b, c]"
       unfolding \<alpha>_def using assms assoc_in_hom comp_cod_arr
       by (metis CC.arrI CCC.arrI fst_conv ide_char in_homE snd_conv)
 
     lemma arr_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>[a, b, c]"
       using assms assoc_in_hom by blast
 
     lemma dom_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms assoc_in_hom by blast
 
     lemma cod_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
       using assms assoc_in_hom by blast
       
     interpretation \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>
     proof -
       interpret \<alpha>: transformation_by_components CCC.comp C T.ToTC T.ToCT \<alpha>
         apply unfold_locales
         unfolding \<alpha>_def T.ToTC_def T.ToCT_def T_def
         using comp_arr_dom comp_cod_arr assoc_naturality
         by simp_all
       interpret \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>.map
         using iso_assoc \<alpha>.map_simp_ide assoc_in_hom tensor_preserves_ide \<alpha>_def
         by (unfold_locales, auto)
       have "\<alpha> = \<alpha>.map"
         using assoc_naturality \<alpha>_def comp_cod_arr T.ToTC_def T_def \<alpha>.map_def by auto
       thus "natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>"
         using \<alpha>.natural_isomorphism_axioms by simp
     qed
 
     interpretation \<alpha>': inverse_transformation CCC.comp C T.ToTC T.ToCT \<alpha> ..
 
     interpretation L: "functor" C C \<open>\<lambda>f. T (\<I>, f)\<close>
       using T.fixing_ide_gives_functor_1 by auto
 
     interpretation R: "functor" C C \<open>\<lambda>f. T (f, \<I>)\<close>
       using T.fixing_ide_gives_functor_2 by auto
 
     interpretation \<ll>: natural_isomorphism C C \<open>\<lambda>f. T (\<I>, f)\<close> map
                         \<open>\<lambda>f. if arr f then f \<cdot> \<l>[dom f] else null\<close>
     proof -
       interpret \<ll>: transformation_by_components C C \<open>\<lambda>f. T (\<I>, f)\<close> map \<open>\<lambda>a. \<l>[a]\<close>
         using lunit_naturality by (unfold_locales, auto)
       interpret \<ll>: natural_isomorphism C C \<open>\<lambda>f. T (\<I>, f)\<close> map \<ll>.map
         using iso_lunit by (unfold_locales, simp)
       have "\<ll>.map = (\<lambda>f. if arr f then f \<cdot> \<l>[dom f] else null)"
         using \<ll>.map_def lunit_naturality by fastforce
       thus "natural_isomorphism C C (\<lambda>f. T (\<I>, f)) map (\<lambda>f. if arr f then f \<cdot> \<l>[dom f] else null)"
         using \<ll>.natural_isomorphism_axioms by force
     qed
 
     interpretation \<rho>: natural_isomorphism C C \<open>\<lambda>f. T (f, \<I>)\<close> map
                         \<open>\<lambda>f. if arr f then f \<cdot> \<r>[dom f] else null\<close>
     proof -
       interpret \<rho>: transformation_by_components C C \<open>\<lambda>f. T (f, \<I>)\<close> map \<open>\<lambda>a. \<r>[a]\<close>
         using runit_naturality by (unfold_locales, auto)
       interpret \<rho>: natural_isomorphism C C \<open>\<lambda>f. T (f, \<I>)\<close> map \<rho>.map
         using iso_runit \<rho>.map_simp_ide by (unfold_locales, simp)
       have "(\<lambda>f. if arr f then f \<cdot> \<r>[dom f] else null) = \<rho>.map"
         using \<rho>.map_def runit_naturality T_simp by fastforce
       thus "natural_isomorphism C C (\<lambda>f. T (f, \<I>)) map (\<lambda>f. if arr f then f \<cdot> \<r>[dom f] else null)"
         using \<rho>.natural_isomorphism_axioms by force
     qed
 
     text\<open>
       The endofunctors \<open>\<lambda>f. T (\<I>, f)\<close> and \<open>\<lambda>f. T (f, \<I>)\<close> are equivalence functors,
       due to the existence of the unitors.
 \<close>
 
     interpretation L: equivalence_functor C C \<open>\<lambda>f. T (\<I>, f)\<close>
     proof -
       interpret endofunctor C \<open>\<lambda>f. T (\<I>, f)\<close> ..
       show "equivalence_functor C C (\<lambda>f. T (\<I>, f))"
         using isomorphic_to_identity_is_equivalence \<ll>.natural_isomorphism_axioms by simp
     qed
 
     interpretation R: equivalence_functor C C \<open>\<lambda>f. T (f, \<I>)\<close>
     proof -
       interpret endofunctor C \<open>\<lambda>f. T (f, \<I>)\<close> ..
       show "equivalence_functor C C (\<lambda>f. T (f, \<I>))"
         using isomorphic_to_identity_is_equivalence \<rho>.natural_isomorphism_axioms by simp
     qed
 
     text\<open>
       To complete an interpretation of the @{locale "monoidal_category"} locale,
       we define @{term "\<iota> \<equiv> \<l>[\<I>]"}.
       We could also have chosen @{term "\<iota> \<equiv> \<rho>[\<I>]"} as the two are equal, though to prove
       that requires some work yet.
 \<close>
 
     definition \<iota>
     where "\<iota> \<equiv> \<l>[\<I>]"
 
     lemma \<iota>_in_hom:
     shows "\<guillemotleft>\<iota> : \<I> \<otimes> \<I> \<rightarrow> \<I>\<guillemotright>"
       using lunit_in_hom \<iota>_def by simp
 
     lemma induces_monoidal_category:
     shows "monoidal_category C T \<alpha> \<iota>"
     proof -
       have 1: "\<guillemotleft>\<iota> : \<I> \<otimes> \<I> \<rightarrow> \<I>\<guillemotright>"
         using lunit_in_hom \<iota>_def by simp
       interpret L: equivalence_functor C C \<open>\<lambda>f. T (cod \<iota>, f)\<close>
       proof -
         have "(\<lambda>f. T (\<I>, f)) = (\<lambda>f. T (cod \<iota>, f))" using 1 by fastforce
         thus "equivalence_functor C C (\<lambda>f. T (cod \<iota>, f))"
           using L.equivalence_functor_axioms T_def by simp
       qed
       interpret R: equivalence_functor C C \<open>\<lambda>f. T (f, cod \<iota>)\<close>
       proof -
         have "(\<lambda>f. T (f, \<I>)) = (\<lambda>f. T (f, cod \<iota>))" using 1 by fastforce
         thus "equivalence_functor C C (\<lambda>f. T (f, cod \<iota>))"
           using R.equivalence_functor_axioms T_def by simp
       qed
       show ?thesis
       proof
         show "\<guillemotleft>\<iota> : T (cod \<iota>, cod \<iota>) \<rightarrow> cod \<iota>\<guillemotright>" using 1 by fastforce
         show "iso \<iota>" using iso_lunit \<iota>_def by simp
         show "\<And>a b c d. \<lbrakk> ide a; ide b; ide c; ide d \<rbrakk> \<Longrightarrow>
                         T (a, \<alpha> (b, c, d)) \<cdot> \<alpha> (a, T (b, c), d) \<cdot> T (\<alpha> (a, b, c), d)
                           = \<alpha> (a, b, T (c, d)) \<cdot> \<alpha> (T (a, b), c, d)"
           using pentagon tensor_preserves_ide by simp
       qed
     qed
 
     interpretation MC: monoidal_category C T \<alpha> \<iota>
       using induces_monoidal_category by auto
 
     text\<open>
       We now show that the notions defined in the interpretation \<open>MC\<close> agree with their
       counterparts in the present locale.  These facts are needed if we define an
       interpretation for the @{locale elementary_monoidal_category} locale, use it to
       obtain the induced interpretation for @{locale monoidal_category}, and then want to
       transfer facts obtained in the induced interpretation back to the original one.
 \<close>
 
     lemma \<I>_agreement:
     shows "MC.unity = \<I>"
       by (metis MC.unity_def \<iota>_def ide_unity in_homE lunit_in_hom)
 
     lemma L_agreement:
     shows "MC.L = (\<lambda>f. T (\<I>, f))"
       using \<iota>_in_hom MC.unity_def by auto
 
     lemma R_agreement:
     shows "MC.R = (\<lambda>f. T (f, \<I>))"
       using \<iota>_in_hom MC.unity_def by auto
 
     text\<open>
       We wish to show that the components of the unitors @{term MC.\<ll>} and @{term MC.\<rho>}
       defined in the induced interpretation \<open>MC\<close> agree with those given by the
       parameters @{term lunit} and @{term runit} to the present locale.  To avoid a lengthy
       development that repeats work already done in the @{locale monoidal_category} locale,
       we establish the agreement in a special case and then use the properties already
       shown for \<open>MC\<close> to prove the general case.  In particular, we first show that
       @{term "\<l>[\<I>] = MC.lunit MC.unity"} and @{term "\<r>[\<I>] = MC.runit MC.unity"},
       from which it follows by facts already proved for @{term MC} that both are equal to @{term \<iota>}.
       We then show that for an arbitrary identity @{term a} the arrows @{term "\<l>[a]"}
       and @{term "\<r>[a]"} satisfy the equations that uniquely characterize the components
       @{term "MC.lunit a"} and @{term "MC.runit a"}, respectively, and are therefore equal
       to those components.
 \<close>
       
     lemma unitor_coincidence:
     shows "\<l>[\<I>] = \<iota>" and "\<r>[\<I>] = \<iota>"
     proof -
       have "\<r>[\<I>] = MC.runit MC.unity"
       proof (intro MC.runit_eqI)
         show 1: "\<guillemotleft>\<r>[\<I>] : MC.tensor MC.unity MC.unity \<rightarrow> MC.unity\<guillemotright>"
           using runit_in_hom \<iota>_in_hom MC.unity_def by auto
         show "MC.tensor \<r>[\<I>] MC.unity
                 = MC.tensor MC.unity \<iota> \<cdot> MC.assoc MC.unity MC.unity MC.unity"
           using T_def \<iota>_in_hom \<iota>_def triangle MC.unity_def
           by (metis 1 MC.ide_unity T_simp \<alpha>_ide_simp ideD(1) in_homE)
       qed
       moreover have "\<l>[\<I>] = MC.lunit MC.unity"
       proof (intro MC.lunit_eqI)
         show "\<guillemotleft>\<l>[\<I>] : MC.tensor MC.unity MC.unity \<rightarrow> MC.unity\<guillemotright>"
           using lunit_in_hom [of \<I>] \<iota>_in_hom MC.unity_def by auto
         show "MC.tensor MC.unity \<l>[\<I>]
                 = MC.tensor \<iota> MC.unity \<cdot> MC.assoc' MC.unity MC.unity MC.unity"
           using T_def lunit_in_hom \<iota>_in_hom \<iota>_def MC.\<iota>_triangle by argo
       qed
       moreover have "MC.lunit MC.unity = \<iota> \<and> MC.runit MC.unity = \<iota>"
         using MC.unitor_coincidence by simp
       ultimately have 1: "\<l>[\<I>] = \<iota> \<and> \<r>[\<I>] = \<iota>" by simp
       show "\<l>[\<I>] = \<iota>" using 1 by simp
       show "\<r>[\<I>] = \<iota>" using 1 by simp
     qed
 
     lemma lunit_char:
     assumes "ide a"
     shows "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a"
     proof -
       have "(\<r>[\<I>] \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a
                 = ((\<I> \<otimes> \<l>[a]) \<cdot> \<a>[\<I>, \<I>, a]) \<cdot> MC.assoc' MC.unity MC.unity a"
         using assms triangle by simp
       also have "... = \<I> \<otimes> \<l>[a]"
         using assms MC.assoc_inv comp_arr_inv \<I>_agreement iso_assoc comp_arr_dom comp_assoc
         by (metis MC.\<iota>_is_iso \<alpha>_ide_simp arr_tensor ideD(1) ide_unity invert_side_of_triangle(2)
             iso_is_arr triangle unitor_coincidence(2))
       finally have "\<I> \<otimes> \<l>[a] = (\<r>[\<I>] \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a" by argo
       thus "\<I> \<otimes> \<l>[a] = (\<iota> \<otimes> a) \<cdot> MC.assoc' MC.unity MC.unity a"
         using unitor_coincidence by auto
     qed
     
     lemma runit_char:
     assumes "ide a"
     shows "\<r>[a] \<otimes> \<I> = (a \<otimes> \<iota>) \<cdot> \<a>[a, \<I>, \<I>]"
       using assms triangle \<iota>_def by simp
 
     lemma \<ll>_agreement:
     shows "MC.\<ll> = (\<lambda>f. if arr f then f \<cdot> \<l>[dom f] else null)"
     proof
       fix f
       have "\<not> arr f \<Longrightarrow> MC.\<ll> f = null" by simp 
       moreover have "arr f \<Longrightarrow> MC.\<ll> f = f \<cdot> \<l>[dom f]"
       proof -
         have "\<And>a. ide a \<Longrightarrow> \<l>[a] = MC.lunit a"
           using \<I>_agreement T_def lunit_char \<iota>_in_hom iso_lunit
           apply (intro MC.lunit_eqI)
            apply auto
           by blast
         thus ?thesis
           by (metis ide_dom ext seqE)
       qed
       ultimately show "MC.\<ll> f = (if arr f then f \<cdot> \<l>[dom f] else null)" by simp
     qed
 
     lemma \<rho>_agreement:
     shows "MC.\<rho> = (\<lambda>f. if arr f then f \<cdot> \<r>[dom f] else null)"
     proof
       fix f
       have "\<not> arr f \<Longrightarrow> MC.\<rho> f = null" by simp
       moreover have "arr f \<Longrightarrow> MC.\<rho> f = f \<cdot> \<r>[dom f]"
       proof -
         have "\<And>a. ide a \<Longrightarrow> \<r>[a] = MC.runit a"
           using \<I>_agreement T_def runit_char \<iota>_in_hom iso_runit
           apply (intro MC.runit_eqI)
            apply auto
           by blast
         thus ?thesis
           by (metis ide_dom local.ext seqE)
       qed
       ultimately show "MC.\<rho> f = (if arr f then f \<cdot> \<r>[dom f] else null)" by simp
     qed
 
     lemma lunit_agreement:
     assumes "ide a"
     shows "MC.lunit a = \<l>[a]"
       using assms comp_cod_arr \<ll>_agreement
       by (metis (no_types, lifting) MC.\<ll>_ide_simp ide_char in_homE lunit_in_hom)
 
     lemma runit_agreement:
     assumes "ide a"
     shows "MC.runit a = \<r>[a]"
       using assms comp_cod_arr \<rho>_agreement
       by (metis (no_types, lifting) MC.\<rho>_ide_simp ide_char in_homE runit_in_hom)
 
   end
 
   section "Strict Monoidal Category"
 
   text\<open>
     A monoidal category is \emph{strict} if the components of the associator and unitors
     are all identities.
 \<close>
       
   locale strict_monoidal_category =
     monoidal_category +
   assumes strict_assoc: "\<lbrakk> ide a0; ide a1; ide a2 \<rbrakk> \<Longrightarrow> ide \<a>[a0, a1, a2]"
   and strict_lunit: "ide a \<Longrightarrow> \<l>[a] = a"
   and strict_runit: "ide a \<Longrightarrow> \<r>[a] = a"
   begin
 
     lemma strict_unit:
     shows "\<iota> = \<I>"
       using strict_lunit unitor_coincidence(1) by auto
 
     lemma tensor_assoc [simp]:
     assumes "arr f0" and "arr f1" and "arr f2"
     shows "(f0 \<otimes> f1) \<otimes> f2 = f0 \<otimes> f1 \<otimes> f2"
     proof -
       have "(f0 \<otimes> f1) \<otimes> f2 = \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
         using assms assoc_in_hom [of "cod f0" "cod f1" "cod f2"] strict_assoc comp_cod_arr
         by auto
       also have "... = (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
         using assms assoc_naturality by simp
       also have "... = f0 \<otimes> f1 \<otimes> f2"
         using assms assoc_in_hom [of "dom f0" "dom f1" "dom f2"] strict_assoc comp_arr_dom
         by auto
       finally show ?thesis by simp
     qed
 
   end
 
   section "Opposite Monoidal Category"
 
   text\<open>
     The \emph{opposite} of a monoidal category has the same underlying category, but the
     arguments to the tensor product are reversed and the associator is inverted and its
     arguments reversed.
 \<close>
       
   locale opposite_monoidal_category =
     C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>
   for C :: "'a comp"      (infixr "\<cdot>" 55)
   and T\<^sub>C :: "'a * 'a \<Rightarrow> 'a"
   and \<alpha>\<^sub>C :: "'a * 'a * 'a \<Rightarrow> 'a"
   and \<iota> :: 'a
   begin
 
     abbreviation T
     where "T f \<equiv> T\<^sub>C (snd f, fst f)"
 
     abbreviation \<alpha>
     where "\<alpha> f \<equiv> C.\<alpha>' (snd (snd f), fst (snd f), fst f)"
 
   end
 
   sublocale opposite_monoidal_category \<subseteq> monoidal_category C T \<alpha> \<iota>
   proof -
     interpret T: binary_endofunctor C T
       using C.T.is_extensional C.CC.seq_char C.interchange by (unfold_locales, auto)
     interpret ToTC: "functor" C.CCC.comp C T.ToTC
       using T.functor_ToTC by auto
     interpret ToCT: "functor" C.CCC.comp C T.ToCT
       using T.functor_ToCT by auto
     interpret \<alpha>: natural_transformation C.CCC.comp C T.ToTC T.ToCT \<alpha>
       using C.\<alpha>'.is_extensional C.CCC.dom_char C.CCC.cod_char T.ToTC_def T.ToCT_def
             C.\<alpha>'_simp C.\<alpha>'.naturality
       by (unfold_locales) auto
     interpret \<alpha>: natural_isomorphism C.CCC.comp C T.ToTC T.ToCT \<alpha>
       using C.\<alpha>'.components_are_iso by (unfold_locales, simp)
     interpret L: equivalence_functor C C \<open>\<lambda>f. T (C.cod \<iota>, f)\<close>
       using C.R.equivalence_functor_axioms by simp
     interpret R: equivalence_functor C C \<open>\<lambda>f. T (f, C.cod \<iota>)\<close>
       using C.L.equivalence_functor_axioms by simp
     show "monoidal_category C T \<alpha> \<iota>"
       using C.\<iota>_in_hom C.\<iota>_is_iso C.unity_def C.pentagon' C.comp_assoc
       by (unfold_locales) auto
   qed
 
   context opposite_monoidal_category
   begin
 
     lemma lunit_simp:
     assumes "C.ide a"
     shows "lunit a = C.runit a"
       using assms lunit_char C.iso_assoc by (intro C.runit_eqI, auto)
 
     lemma runit_simp:
     assumes "C.ide a"
     shows "runit a = C.lunit a"
       using assms runit_char C.iso_assoc by (intro C.lunit_eqI, auto)
 
   end
 
   section "Monoidal Language"
 
   text\<open>
     In this section we assume that a category @{term C} is given, and we define a
     formal syntax of terms constructed from arrows of @{term C} using function symbols
     that correspond to unity, composition, tensor, the associator and its formal inverse,
     and the left and right unitors and their formal inverses.
     We will use this syntax to state and prove the coherence theorem and then to construct
     the free monoidal category generated by @{term C}.
 \<close>
 
   locale monoidal_language =
     C: category C
     for C :: "'a comp"                     (infixr "\<cdot>" 55)
   begin
 
     datatype (discs_sels) 't "term" =
       Prim 't                              ("\<^bold>\<langle>_\<^bold>\<rangle>")
     | Unity                                ("\<^bold>\<I>")
     | Tensor "'t term" "'t term"           (infixr "\<^bold>\<otimes>" 53)
     | Comp "'t term" "'t term"             (infixr "\<^bold>\<cdot>" 55)
     | Lunit "'t term"                      ("\<^bold>\<l>\<^bold>[_\<^bold>]")
     | Lunit' "'t term"                     ("\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Runit "'t term"                      ("\<^bold>\<r>\<^bold>[_\<^bold>]")
     | Runit' "'t term"                     ("\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[_\<^bold>]")
     | Assoc "'t term" "'t term" "'t term"  ("\<^bold>\<a>\<^bold>[_, _, _\<^bold>]")
     | Assoc' "'t term" "'t term" "'t term" ("\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[_, _, _\<^bold>]")
 
     lemma not_is_Tensor_Unity:
     shows "\<not> is_Tensor Unity"
       by simp
 
     text\<open>
       We define formal domain and codomain functions on terms.
 \<close>
 
     primrec Dom :: "'a term \<Rightarrow> 'a term"
     where "Dom \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.dom f\<^bold>\<rangle>"
         | "Dom \<^bold>\<I> = \<^bold>\<I>"
         | "Dom (t \<^bold>\<otimes> u) = (Dom t \<^bold>\<otimes> Dom u)"
         | "Dom (t \<^bold>\<cdot> u) = Dom u"
         | "Dom \<^bold>\<l>\<^bold>[t\<^bold>] = (\<^bold>\<I> \<^bold>\<otimes> Dom t)"
         | "Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<r>\<^bold>[t\<^bold>] = (Dom t \<^bold>\<otimes> \<^bold>\<I>)"
         | "Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Dom t"
         | "Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = ((Dom t \<^bold>\<otimes> Dom u) \<^bold>\<otimes> Dom v)"
         | "Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Dom t \<^bold>\<otimes> (Dom u \<^bold>\<otimes> Dom v))"
 
     primrec Cod :: "'a term \<Rightarrow> 'a term"
     where "Cod \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.cod f\<^bold>\<rangle>"
         | "Cod \<^bold>\<I> = \<^bold>\<I>"
         | "Cod (t \<^bold>\<otimes> u) = (Cod t \<^bold>\<otimes> Cod u)"
         | "Cod (t \<^bold>\<cdot> u) = Cod t"
         | "Cod \<^bold>\<l>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = (\<^bold>\<I> \<^bold>\<otimes> Cod t)"
         | "Cod \<^bold>\<r>\<^bold>[t\<^bold>] = Cod t"
         | "Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = (Cod t \<^bold>\<otimes> \<^bold>\<I>)"
         | "Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Cod t \<^bold>\<otimes> (Cod u \<^bold>\<otimes> Cod v))"
         | "Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = ((Cod t \<^bold>\<otimes> Cod u) \<^bold>\<otimes> Cod v)"
 
     text\<open>
       A term is a ``formal arrow'' if it is constructed from arrows of @{term[source=true] C}
       in such a way that composition is applied only to formally composable pairs of terms.
 \<close>
 
     primrec Arr :: "'a term \<Rightarrow> bool"
     where "Arr \<^bold>\<langle>f\<^bold>\<rangle> = C.arr f"
         | "Arr \<^bold>\<I> = True"
         | "Arr (t \<^bold>\<otimes> u) = (Arr t \<and> Arr u)"
         | "Arr (t \<^bold>\<cdot> u) = (Arr t \<and> Arr u \<and> Dom t = Cod u)"
         | "Arr \<^bold>\<l>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Arr t"
         | "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v)"
         | "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Arr t \<and> Arr u \<and> Arr v)"
 
     abbreviation Par :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "Par t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Dom u \<and> Cod t = Cod u"
 
     abbreviation Seq :: "'a term \<Rightarrow> 'a term \<Rightarrow> bool"
     where "Seq t u \<equiv> Arr t \<and> Arr u \<and> Dom t = Cod u"
 
     abbreviation Hom :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term set"
     where "Hom a b \<equiv> { t. Arr t \<and> Dom t = a \<and> Cod t = b }"
 
     text\<open>
       A term is a ``formal identity'' if it is constructed from identity arrows of
       @{term[source=true] C} and @{term "\<^bold>\<I>"} using only the \<open>\<^bold>\<otimes>\<close> operator.
 \<close>
 
     primrec Ide :: "'a term \<Rightarrow> bool"
     where "Ide \<^bold>\<langle>f\<^bold>\<rangle> = C.ide f"
         | "Ide \<^bold>\<I> = True"
         | "Ide (t \<^bold>\<otimes> u) = (Ide t \<and> Ide u)"
         | "Ide (t \<^bold>\<cdot> u) = False"
         | "Ide \<^bold>\<l>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = False"
         | "Ide \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = False"
 
     lemma Ide_implies_Arr [simp]:
     shows "Ide t \<Longrightarrow> Arr t"
       by (induct t) auto
 
     lemma Arr_implies_Ide_Dom [elim]:
     shows "Arr t \<Longrightarrow> Ide (Dom t)"
       by (induct t) auto
 
     lemma Arr_implies_Ide_Cod [elim]:
     shows "Arr t \<Longrightarrow> Ide (Cod t)"
       by (induct t) auto
 
     lemma Ide_in_Hom [simp]:
     shows "Ide t \<Longrightarrow> t \<in> Hom t t"
       by (induct t) auto
 
     text\<open>
       A formal arrow is ``canonical'' if the only arrows of @{term[source=true] C} used in its
       construction are identities.
 \<close>
 
     primrec Can :: "'a term \<Rightarrow> bool"
     where "Can \<^bold>\<langle>f\<^bold>\<rangle> = C.ide f"
         | "Can \<^bold>\<I> = True"
         | "Can (t \<^bold>\<otimes> u) = (Can t \<and> Can u)"
         | "Can (t \<^bold>\<cdot> u) = (Can t \<and> Can u \<and> Dom t = Cod u)"
         | "Can \<^bold>\<l>\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<r>\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = Can t"
         | "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v)"
         | "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = (Can t \<and> Can u \<and> Can v)"
 
     lemma Ide_implies_Can:
     shows "Ide t \<Longrightarrow> Can t"
       by (induct t) auto
 
     lemma Can_implies_Arr:
     shows "Can t \<Longrightarrow> Arr t"
       by (induct t) auto
 
     text\<open>
       We next define the formal inverse of a term.
       This is only sensible for formal arrows built using only isomorphisms of
       @{term[source=true] C}; in particular, for canonical formal arrows.
 \<close>
 
     primrec Inv :: "'a term \<Rightarrow> 'a term"
     where "Inv \<^bold>\<langle>f\<^bold>\<rangle> = \<^bold>\<langle>C.inv f\<^bold>\<rangle>"
         | "Inv \<^bold>\<I> = \<^bold>\<I>"
         | "Inv (t \<^bold>\<otimes> u) = (Inv t \<^bold>\<otimes> Inv u)"
         | "Inv (t \<^bold>\<cdot> u) = (Inv u \<^bold>\<cdot> Inv t)"
         | "Inv \<^bold>\<l>\<^bold>[t\<^bold>] = \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<l>\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<r>\<^bold>[t\<^bold>] = \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<^bold>\<r>\<^bold>[Inv t\<^bold>]"
         | "Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
         | "Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<^bold>\<a>\<^bold>[Inv t, Inv u, Inv v\<^bold>]"
 
     lemma Inv_preserves_Ide:
     shows "Ide t \<Longrightarrow> Ide (Inv t)"
       by (induct t) auto
 
     lemma Inv_preserves_Can:
     assumes "Can t"
     shows "Can (Inv t)" and "Dom (Inv t) = Cod t" and "Cod (Inv t) = Dom t"
     proof -
       have 0: "Can t \<Longrightarrow> Can (Inv t) \<and> Dom (Inv t) = Cod t \<and> Cod (Inv t) = Dom t"
         by (induct t) auto
       show "Can (Inv t)" using assms 0 by blast
       show "Dom (Inv t) = Cod t" using assms 0 by blast
       show "Cod (Inv t) = Dom t" using assms 0 by blast
     qed
 
     lemma Inv_in_Hom [simp]:
     assumes "Can t"
     shows "Inv t \<in> Hom (Cod t) (Dom t)"
       using assms Inv_preserves_Can Can_implies_Arr by simp
 
     lemma Inv_Ide [simp]:
     assumes "Ide a"
     shows "Inv a = a"
       using assms by (induct a) auto
 
     lemma Inv_Inv [simp]:
     assumes "Can t"
     shows "Inv (Inv t) = t"
       using assms by (induct t) auto
 
     text\<open>
       We call a term ``diagonal'' if it is either @{term "\<^bold>\<I>"} or it is constructed from
       arrows of @{term[source=true] C} using only the \<open>\<^bold>\<otimes>\<close> operator associated to the right.
       Essentially, such terms are lists of arrows of @{term[source=true] C}, where @{term "\<^bold>\<I>"}
       represents the empty list and \<open>\<^bold>\<otimes>\<close> is used as the list constructor.
       We call them ``diagonal'' because terms can regarded as defining ``interconnection matrices''
       of arrows connecting ``inputs'' to ``outputs'', and from this point of view diagonal
       terms correspond to diagonal matrices.  The matrix point of view is suggestive for the
       extension of the results presented here to the symmetric monoidal and cartesian monoidal
       cases.
 \<close>
 
     fun Diag :: "'a term \<Rightarrow> bool"
     where "Diag \<^bold>\<I> = True"
         | "Diag \<^bold>\<langle>f\<^bold>\<rangle> = C.arr f"
         | "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u) = (C.arr f \<and> Diag u \<and> u \<noteq> \<^bold>\<I>)"
         | "Diag _ = False"
 
     lemma Diag_TensorE:
     assumes "Diag (Tensor t u)"
     shows "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" and "C.arr (un_Prim t)" and "Diag t" and "Diag u" and "u \<noteq> \<^bold>\<I>"
     proof -
       have 1: "t = \<^bold>\<langle>un_Prim t\<^bold>\<rangle> \<and> C.arr (un_Prim t) \<and> Diag t \<and> Diag u \<and> u \<noteq> \<^bold>\<I>"
         using assms by (cases t; simp; cases u; simp)
       show "\<^bold>\<langle>un_Prim t\<^bold>\<rangle> = t" using 1 by simp
       show "C.arr (un_Prim t)" using 1 by simp
       show "Diag t" using 1 by simp
       show "Diag u" using 1 by simp
       show "u \<noteq> \<^bold>\<I>" using 1 by simp
     qed
 
     lemma Diag_implies_Arr [elim]:
     shows "Diag t \<Longrightarrow> Arr t"
       apply (induct t, simp_all)
       by (simp add: Diag_TensorE)
 
     lemma Dom_preserves_Diag [elim]:
     shows "Diag t \<Longrightarrow> Diag (Dom t)"
     apply (induct t, simp_all)
     proof -
       fix u v
       assume I2: "Diag v \<Longrightarrow> Diag (Dom v)"
       assume uv: "Diag (u \<^bold>\<otimes> v)"
       show "Diag (Dom u \<^bold>\<otimes> Dom v)"
       proof -
         have 1: "is_Prim (Dom u) \<and> C.arr (un_Prim (Dom u)) \<and>
                  Dom u = \<^bold>\<langle>C.dom (un_Prim u)\<^bold>\<rangle>"
           using uv by (cases u; simp; cases v, simp_all)
         have 2: "Diag v \<and> v \<noteq> \<^bold>\<I> \<and> \<not> is_Comp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
           using uv by (cases u; simp; cases v, simp_all)
         have "Diag (Dom v) \<and> Dom v \<noteq> \<^bold>\<I>"
           using 2 I2 by (cases v, simp_all)
         thus ?thesis using 1 by force
       qed
     qed
     
     lemma Cod_preserves_Diag [elim]:
     shows "Diag t \<Longrightarrow> Diag (Cod t)"
     apply (induct t, simp_all)
     proof -
       fix u v
       assume I2: "Diag v \<Longrightarrow> Diag (Cod v)"
       assume uv: "Diag (u \<^bold>\<otimes> v)"
       show "Diag (Cod u \<^bold>\<otimes> Cod v)"
       proof -
         have 1: "is_Prim (Cod u) \<and> C.arr (un_Prim (Cod u)) \<and> Cod u = \<^bold>\<langle>C.cod (un_Prim u)\<^bold>\<rangle>"
           using uv by (cases u; simp; cases v; simp)
         have 2: "Diag v \<and> v \<noteq> \<^bold>\<I> \<and> \<not> is_Comp v \<and> \<not> is_Lunit' v \<and> \<not> is_Runit' v"
           using uv by (cases u; simp; cases v; simp)
         have "Diag (Cod v) \<and> Cod v \<noteq> \<^bold>\<I>"
           using I2 2 by (cases v, simp_all)
         thus ?thesis using 1 by force
       qed
     qed
 
     lemma Inv_preserves_Diag:
     assumes "Can t" and "Diag t"
     shows "Diag (Inv t)"
     proof -
       have "Can t \<and> Diag t \<Longrightarrow> Diag (Inv t)"
         apply (induct t, simp_all)
         by (metis (no_types, lifting) Can.simps(1) Inv.simps(1) Inv.simps(2) Diag.simps(3)
             Inv_Inv Diag_TensorE(1) C.inv_ide)
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       The following function defines the ``dimension'' of a term,
       which is the number of arrows of @{term C} it contains.
       For diagonal terms, this is just the length of the term when regarded as a list
       of arrows of @{term C}.
       Alternatively, if a term is regarded as defining an interconnection matrix,
       then the dimension is the number of inputs (or outputs).
 \<close>
 
     primrec dim :: "'a term \<Rightarrow> nat"
     where "dim \<^bold>\<langle>f\<^bold>\<rangle> = 1"
         | "dim \<^bold>\<I> = 0"
         | "dim (t \<^bold>\<otimes> u) = (dim t + dim u)"
         | "dim (t \<^bold>\<cdot> u) = dim t"
         | "dim \<^bold>\<l>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = dim t"
         | "dim \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
         | "dim \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = dim t + dim u + dim v"
 
     text\<open>
       The following function defines a tensor product for diagonal terms.
       If terms are regarded as lists, this is just list concatenation.
       If terms are regarded as matrices, this corresponds to constructing a block
       diagonal matrix.
 \<close>
 
     fun TensorDiag      (infixr "\<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>" 53)
     where "\<^bold>\<I> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = u"
         | "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<I> = t"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u"
         | "(t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
         | "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = undefined"
 
     lemma TensorDiag_Prim [simp]:
     assumes "t \<noteq> \<^bold>\<I>"
     shows "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> t = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> t"
       using assms by (cases t, simp_all)
 
     lemma TensorDiag_term_Unity [simp]:
     shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<I> = t"
       by (cases "t = \<^bold>\<I>"; cases t, simp_all)
 
     lemma TensorDiag_Diag:
     assumes "Diag (t \<^bold>\<otimes> u)"
     shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = t \<^bold>\<otimes> u"
       using assms TensorDiag_Prim by (cases t, simp_all)
 
     lemma TensorDiag_preserves_Diag:
     assumes "Diag t" and "Diag u"
     shows "Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
     and "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u"
     and "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
     proof -
       have 0: "\<And>u. \<lbrakk> Diag t; Diag u \<rbrakk> \<Longrightarrow>
                      Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
                                        Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
       apply (induct t, simp_all)
       proof -
         fix f :: 'a and u :: "'a term"
         assume f: "C.arr f"
         assume u: "Diag u"
         show "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
                                  Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
           using u f by (cases u, simp_all)
         next
         fix u v w
         assume I1: "\<And>u. Diag v \<Longrightarrow> Diag u \<Longrightarrow> Diag (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
                                               Dom (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
                                               Cod (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
         assume I2: "\<And>u. Diag w \<Longrightarrow>  Diag u \<Longrightarrow> Diag (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
                                                Dom (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
                                                Cod (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
         assume vw: "Diag (v \<^bold>\<otimes> w)"
         assume u: "Diag u"
         show "Diag ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<and>
               Dom ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = (Dom v \<^bold>\<otimes> Dom w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<and>
               Cod ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = (Cod v \<^bold>\<otimes> Cod w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
         proof -
           have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> Diag v"
             using vw Diag_implies_Arr Diag_TensorE [of v w] by force
           have w: "Diag w"
             using vw by (simp add: Diag_TensorE)
           have "u = \<^bold>\<I> \<Longrightarrow> ?thesis" by (simp add: vw)
           moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
             using u v w I1 I2 Dom_preserves_Diag [of u] Cod_preserves_Diag [of u]
             by (cases u, simp_all)
           ultimately show ?thesis by blast
         qed
       qed
       show "Diag (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) " using assms 0 by blast
       show "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u" using assms 0 by blast
       show "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u" using assms 0 by blast
     qed
 
     lemma TensorDiag_in_Hom:
     assumes "Diag t" and "Diag u"
     shows "t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u \<in> Hom (Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u) (Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)"
       using assms TensorDiag_preserves_Diag Diag_implies_Arr by simp
 
     lemma Dom_TensorDiag:
     assumes "Diag t" and "Diag u"
     shows "Dom (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Dom t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u"
       using assms TensorDiag_preserves_Diag(2) by simp
 
     lemma Cod_TensorDiag:
     assumes "Diag t" and "Diag u"
     shows "Cod (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Cod t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u"
       using assms TensorDiag_preserves_Diag(3) by simp
 
     lemma not_is_Tensor_TensorDiagE:
     assumes "\<not> is_Tensor (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)" and "Diag t" and "Diag u"
     and "t \<noteq> \<^bold>\<I>" and "u \<noteq> \<^bold>\<I>"
     shows "False"
     proof -
       have "\<lbrakk> \<not> is_Tensor (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u); Diag t; Diag u; t \<noteq> \<^bold>\<I>; u \<noteq> \<^bold>\<I> \<rbrakk> \<Longrightarrow> False"
       apply (induct t, simp_all)
       proof -
         fix v w
         assume I2: "\<not> is_Tensor (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<Longrightarrow> Diag w \<Longrightarrow> w \<noteq> \<^bold>\<I> \<Longrightarrow> False"
         assume 1: "\<not> is_Tensor ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
         assume vw: "Diag (v \<^bold>\<otimes> w)"
         assume u: "Diag u"
         assume 2: "u \<noteq> \<^bold>\<I>"
         show "False"
         proof -
           have v: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle>"
             using vw Diag_TensorE [of v w] by force
           have w: "Diag w \<and> w \<noteq> \<^bold>\<I>"
             using vw Diag_TensorE [of v w] by simp
           have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = v \<^bold>\<otimes> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
           proof -
             have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
               using u 2 by (cases u, simp_all)
             also have "... = v \<^bold>\<otimes> (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
               using u v w I2 TensorDiag_Prim not_is_Tensor_Unity by metis
             finally show ?thesis by simp
           qed
           thus ?thesis using 1 by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma TensorDiag_assoc:
     assumes "Diag t" and "Diag u" and "Diag v"
     shows "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
     proof -
       have "\<And>n t u v. \<lbrakk> dim t = n; Diag t; Diag u; Diag v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
       proof -
         fix n
         show "\<And>t u v. \<lbrakk> dim t = n; Diag t; Diag u; Diag v \<rbrakk> \<Longrightarrow>
                         (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
         proof (induction n rule: nat_less_induct)
           fix n :: nat and t :: "'a term" and u v
           assume I: "\<forall>m<n. \<forall>t u v. dim t = m \<longrightarrow> Diag t \<longrightarrow> Diag u \<longrightarrow> Diag v \<longrightarrow>
                                    (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
           assume dim: "dim t = n"
           assume t: "Diag t"
           assume u: "Diag u"
           assume v: "Diag v"
           show "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
           proof -
             have "t = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
             moreover have "u = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
             moreover have "v = \<^bold>\<I> \<Longrightarrow> ?thesis" by simp
             moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I> \<and> is_Prim t \<Longrightarrow> ?thesis"
               using v by (cases t, simp_all, cases u, simp_all; cases v, simp_all)
             moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I> \<and> is_Tensor t \<Longrightarrow> ?thesis"
             proof (cases t; simp)
               fix w :: "'a term" and x :: "'a term"
               assume 1: "u \<noteq> \<^bold>\<I> \<and> v \<noteq> \<^bold>\<I>"
               assume 2: "t = (w \<^bold>\<otimes> x)"
               show "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
               proof -
                 have w: "w = \<^bold>\<langle>un_Prim w\<^bold>\<rangle>"
                   using t 1 2 Diag_TensorE [of w x] by auto
                 have x: "Diag x"
                   using t w 1 2 by (cases w, simp_all)
                 have "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = (w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v"
                   using u v w x 1 2 by (cases u, simp_all)
                 also have "... = (w \<^bold>\<otimes> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v"
                   using t w u 1 2 TensorDiag_Prim not_is_Tensor_TensorDiagE Diag_TensorE
                         not_is_Tensor_Unity
                   by metis
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
                   using u v w x 1 by (cases u, simp_all; cases v, simp_all)
                 also have "... = w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (x \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v))"
                 proof -
                   have "dim x < dim t"
                     using w 2 by (cases w, simp_all)
                   thus ?thesis 
                     using u v x dim I by simp
                 qed
                 also have "... = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
                 proof -
                   have 3: "is_Tensor (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
                     using u v 1 not_is_Tensor_TensorDiagE by auto
                   obtain u' :: "'a term" and v' where uv': "u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v = u' \<^bold>\<otimes> v'"
                     using 3 is_Tensor_def by blast
                   thus ?thesis by simp
                 qed
                 finally show ?thesis by simp
               qed
             qed
             moreover have "t = \<^bold>\<I> \<or> is_Prim t \<or> is_Tensor t"
               using t by (cases t, simp_all)
             ultimately show ?thesis by blast
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma TensorDiag_preserves_Ide:
     assumes "Ide t" and "Ide u" and "Diag t" and "Diag u"
     shows "Ide (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
       using assms
       by (metis (mono_tags, lifting) Arr_implies_Ide_Dom Ide_in_Hom Diag_implies_Arr
           TensorDiag_preserves_Diag(1) TensorDiag_preserves_Diag(2) mem_Collect_eq)
 
     lemma TensorDiag_preserves_Can:
     assumes "Can t" and "Can u" and "Diag t" and "Diag u"
     shows "Can (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
       proof (induct t; simp)
         show "\<And>x u. C.ide x \<and> C.arr x \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (\<^bold>\<langle>x\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
           by (metis Ide.simps(1) Ide.simps(2) Ide_implies_Can Diag.simps(2) TensorDiag_Prim
                     TensorDiag_preserves_Ide Can.simps(3))
         show "\<And>t1 t2 u. (\<And>u. Diag t1 \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<Longrightarrow>
                          (\<And>u. Diag t2 \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow> Can (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<Longrightarrow>
                          Can t1 \<and> Can t2 \<and> Diag (t1 \<^bold>\<otimes> t2) \<Longrightarrow> Can u \<and> Diag u \<Longrightarrow>
                          Can ((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
           by (metis Diag_TensorE(3) Diag_TensorE(4) TensorDiag_Diag TensorDiag_assoc
                     TensorDiag_preserves_Diag(1))
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Inv_TensorDiag:
     assumes "Can t" and "Can u" and "Diag t" and "Diag u"
     shows "Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u \<rbrakk> \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
       proof (induct t, simp_all)
         fix f u
         assume f: "C.ide f \<and> C.arr f"
         assume u: "Can u \<and> Diag u"
         show "Inv (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv u"
           using f u by (cases u, simp_all)
         next
         fix t u v
         assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v \<rbrakk> \<Longrightarrow> Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
         assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v \<rbrakk> \<Longrightarrow> Inv (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
         assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
         have t: "Can t \<and> Diag t"
           using tu Diag_TensorE [of t u] by force
         have u: "Can u \<and> Diag u"
           using t tu by (cases t, simp_all)
         assume v: "Can v \<and> Diag v"
         show "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = (Inv t \<^bold>\<otimes> Inv u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
         proof -
           have "v = Unity \<Longrightarrow> ?thesis" by simp
           moreover have "v \<noteq> Unity \<Longrightarrow> ?thesis"
           proof -
             assume 1: "v \<noteq> Unity"
             have "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v) = Inv (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v))"
               using 1 by (cases v, simp_all)
             also have "... = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv (u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> v)"
               using t u v I1 TensorDiag_preserves_Diag TensorDiag_preserves_Can
                     Inv_preserves_Diag Inv_preserves_Can
               by simp
             also have "... = Inv t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (Inv u \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v)"
               using t u v I2 TensorDiag_preserves_Diag TensorDiag_preserves_Can
                     Inv_preserves_Diag Inv_preserves_Can
               by simp
             also have "... = (Inv t \<^bold>\<otimes> Inv u) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv v"
               using v 1 by (cases v, simp_all)
             finally show ?thesis by blast
           qed
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       The following function defines composition for compatible diagonal terms,
       by ``pushing the composition down'' to arrows of \<open>C\<close>.
 \<close>
 
     fun CompDiag :: "'a term \<Rightarrow> 'a term \<Rightarrow> 'a term"      (infixr "\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>" 55)
     where "\<^bold>\<I> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = u"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<langle>g\<^bold>\<rangle> = \<^bold>\<langle>f \<cdot> g\<^bold>\<rangle>"
         | "(u \<^bold>\<otimes> v) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (w \<^bold>\<otimes> x) = (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<^bold>\<otimes> v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<I> = t"
         | "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> _ = undefined \<^bold>\<cdot> undefined"
 
     text\<open>
       Note that the last clause above is not relevant to diagonal terms.
       We have chosen a provably non-diagonal value in order to validate associativity.
 \<close>
 
     lemma CompDiag_preserves_Diag:
     assumes "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     and "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
     and "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
     proof -
       have 0: "\<And>u. \<lbrakk> Diag t; Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
                      Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
       proof (induct t, simp_all add: Diag_TensorE)
         fix f u
         assume f: "C.arr f"
         assume u: "Diag u"
         assume 1: "\<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
         show "Diag (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = \<^bold>\<langle>C.cod f\<^bold>\<rangle>"
           using f u 1 by (cases u, simp_all)
         next
         fix u v w
         assume I2: "\<And>u. \<lbrakk> Diag u; Dom w = Cod u \<rbrakk> \<Longrightarrow>
                           Diag (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod w"
         assume vw: "Diag (v \<^bold>\<otimes> w)"
         have v: "Diag v"
           using vw Diag_TensorE [of v w] by force
         have w: "Diag w"
           using vw Diag_TensorE [of v w] by force
         assume u: "Diag u"
         assume 1: "(Dom v \<^bold>\<otimes> Dom w) = Cod u"
         show "Diag ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<and> Dom ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u \<and>
                                      Cod ((v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod v \<^bold>\<otimes> Cod w"
           using u v w 1
         proof (cases u, simp_all)
           fix x y
           assume 2: "u = Tensor x y"
           have 4: "is_Prim x \<and> x = \<^bold>\<langle>un_Prim x\<^bold>\<rangle> \<and> C.arr (un_Prim x) \<and> Diag y \<and> y \<noteq> \<^bold>\<I>"
             using u 2 by (cases x, cases y, simp_all)
           have 5: "is_Prim v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr (un_Prim v) \<and> Diag w \<and> w \<noteq> \<^bold>\<I>"
             using v w vw by (cases v, simp_all)
           have 6: "C.dom (un_Prim v) = C.cod (un_Prim x) \<and> Dom w = Cod y"
             using 1 2 4 5 apply (cases u, simp_all)
             by (metis Cod.simps(1) Dom.simps(1) term.simps(1))
           have "(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u = \<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y"
             using 2 4 5 6 CompDiag.simps(2) [of "un_Prim v" "un_Prim x"] by simp
           moreover have "Diag (\<^bold>\<langle>un_Prim v \<cdot> un_Prim x\<^bold>\<rangle> \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
           proof -
             have "Diag (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"
               using I2 4 5 6 by simp
             thus ?thesis
               using 4 5 6 Diag.simps(3) [of "un_Prim v \<cdot> un_Prim x" "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y)"]
               by (cases w; cases y) auto
           qed
           ultimately show "Diag (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x \<^bold>\<otimes> w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) \<and>
                            Dom (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Dom x \<and> Dom (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Dom y \<and>
                            Cod (v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Cod v \<and> Cod (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y) = Cod w"
             using 4 5 6 I2
             by (metis (full_types) C.cod_comp C.dom_comp Cod.simps(1) CompDiag.simps(2)
                 Dom.simps(1) C.seqI)
         qed
       qed
       show "Diag (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)" using assms 0 by blast
       show "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u" using assms 0 by blast
       show "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t" using assms 0 by blast
     qed
 
     lemma CompDiag_in_Hom:
     assumes "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<in> Hom (Dom u) (Cod t)"
       using assms CompDiag_preserves_Diag Diag_implies_Arr by simp
 
     lemma Dom_CompDiag:
     assumes "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Dom (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Dom u"
       using assms CompDiag_preserves_Diag(2) by simp
 
     lemma Cod_CompDiag:
     assumes "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Cod (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Cod t"
       using assms CompDiag_preserves_Diag(3) by simp
 
     lemma CompDiag_Cod_Diag [simp]:
     assumes "Diag t"
     shows "Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
     proof -
       have "Diag t \<Longrightarrow> Cod t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
         using C.comp_cod_arr
         apply (induct t, auto)
         by (auto simp add: Diag_TensorE)
       thus ?thesis using assms by blast
     qed
 
     lemma CompDiag_Diag_Dom [simp]:
     assumes "Diag t"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
     proof -
       have "Diag t \<Longrightarrow> t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Dom t = t"
         using C.comp_arr_dom
         apply (induct t, auto)
         by (auto simp add: Diag_TensorE)
       thus ?thesis using assms by blast
     qed
 
     lemma CompDiag_Ide_Diag [simp]:
     assumes "Diag t" and "Ide a" and "Dom a = Cod t"
     shows "a \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = t"
       using assms Ide_in_Hom by simp
 
     lemma CompDiag_Diag_Ide [simp]:
     assumes "Diag t" and "Ide a" and "Dom t = Cod a"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> a = t"
       using assms Ide_in_Hom by auto
 
     lemma CompDiag_assoc:
     assumes "Diag t" and "Diag u" and "Diag v"
     and "Dom t = Cod u" and "Dom u = Cod v"
     shows "(t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
     proof -
       have "\<And>u v. \<lbrakk> Diag t; Diag u; Diag v; Dom t = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                     (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
       proof (induct t, simp_all)
         fix f u v
         assume f: "C.arr f"
         assume u: "Diag u"
         assume v: "Diag v"
         assume 1: "\<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
         assume 2: "Dom u = Cod v"
         show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
           using C.comp_assoc by (cases u, simp_all; cases v, simp_all)
         next
         fix u v w x
         assume I1: "\<And>u v. \<lbrakk> Diag w; Diag u; Diag v; Dom w = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                             (w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume I2: "\<And>u v. \<lbrakk> Diag x; Diag u; Diag v; Dom x = Cod u; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                             (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume wx: "Diag (w \<^bold>\<otimes> x)"
         assume u: "Diag u"
         assume v: "Diag v"
         assume 1: "(Dom w \<^bold>\<otimes> Dom x) = Cod u"
         assume 2: "Dom u = Cod v"
         show "((w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v = (w \<^bold>\<otimes> x) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v"
         proof -
           have w: "Diag w"
             using wx Diag_TensorE by blast
           have x: "Diag x"
             using wx Diag_TensorE by blast
           have "is_Tensor u"
             using u 1 by (cases u) simp_all
           thus ?thesis
             using u v apply (cases u, simp_all, cases v, simp_all)
           proof -
             fix u1 u2 v1 v2
             assume 3: "u = (u1 \<^bold>\<otimes> u2)"
             assume 4: "v = (v1 \<^bold>\<otimes> v2)"
             show "(w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 = w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1 \<and>
                   (x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2 = x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2"
             proof -
               have "Diag u1 \<and> Diag u2"
                 using u 3 Diag_TensorE by blast
               moreover have "Diag v1 \<and> Diag v2"
                 using v 4 Diag_TensorE by blast
               ultimately show ?thesis using w x I1 I2 1 2 3 4 by simp
             qed
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma CompDiag_preserves_Ide:
     assumes "Ide t" and "Ide u" and "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Ide (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Ide t; Ide u; Diag t; Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Ide (CompDiag t u)"
         by (induct t; simp)
       thus ?thesis using assms by blast
     qed
 
     lemma CompDiag_preserves_Can:
     assumes "Can t" and "Can u" and "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u)"
       proof (induct t, simp_all)
         fix t u v
         assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v; Dom t = Cod v \<rbrakk> \<Longrightarrow> Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v; Dom u = Cod v \<rbrakk> \<Longrightarrow> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
         have t: "Can t \<and> Diag t"
           using tu Diag_TensorE by blast
         have u: "Can u \<and> Diag u"
           using tu Diag_TensorE by blast
         assume v: "Can v \<and> Diag v"
         assume 1: "(Dom t \<^bold>\<otimes> Dom u) = Cod v"
         show "Can ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v)"
         proof -
           have 2: "(Dom t \<^bold>\<otimes> Dom u) = Cod v" using 1 by simp
           show ?thesis
             using v 2
           proof (cases v; simp)
             fix w x
             assume wx: "v = (w \<^bold>\<otimes> x)"
             have "Can w \<and> Diag w" using v wx Diag_TensorE [of w x] by auto
             moreover have "Can x \<and> Diag x" using v wx Diag_TensorE [of w x] by auto
             moreover have "Dom t = Cod w" using 2 wx by simp
             moreover have ux: "Dom u = Cod x" using 2 wx by simp
             ultimately show "Can (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) \<and> Can (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x)"
               using t u I1 I2 by simp
           qed
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Inv_CompDiag:
     assumes "Can t" and "Can u" and "Diag t" and "Diag u" and "Dom t = Cod u"
     shows "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
     proof -
       have "\<And>u. \<lbrakk> Can t \<and> Diag t; Can u \<and> Diag u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
               Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u) = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
       proof (induct t, simp_all)
         show "\<And>x u. \<lbrakk> C.ide x \<and> C.arr x; Can u \<and> Diag u; \<^bold>\<langle>x\<^bold>\<rangle> = Cod u \<rbrakk> \<Longrightarrow>
                       Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv (Cod u)"
           by (metis CompDiag_Diag_Dom Inv_Ide Inv_preserves_Can(2) Inv_preserves_Diag
                     Ide.simps(1))
         show "\<And>u. Can u \<and> Diag u \<Longrightarrow> \<^bold>\<I> = Cod u \<Longrightarrow> Inv u = Inv u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<I>"
           by (simp add: Inv_preserves_Can(2) Inv_preserves_Diag)
         fix t u v
         assume tu: "Can t \<and> Can u \<and> Diag (t \<^bold>\<otimes> u)"
         have t: "Can t \<and> Diag t"
           using tu Diag_TensorE by blast
         have u: "Can u \<and> Diag u"
           using tu Diag_TensorE by blast
         assume I1: "\<And>v. \<lbrakk> Diag t; Can v \<and> Diag v; Dom t = Cod v \<rbrakk> \<Longrightarrow>
                           Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t"
         assume I2: "\<And>v. \<lbrakk> Diag u; Can v \<and> Diag v; Dom u = Cod v \<rbrakk> \<Longrightarrow>
                           Inv (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv u"
         assume v: "Can v \<and> Diag v"
         assume 1: "(Dom t \<^bold>\<otimes> Dom u) = Cod v"
         show "Inv ((t \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) = Inv v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (Inv t \<^bold>\<otimes> Inv u)"
           using v 1
         proof (cases v, simp_all)
           fix w x
           assume wx: "v = (w \<^bold>\<otimes> x)"
           have "Can w \<and> Diag w" using v wx Diag_TensorE [of w x] by auto
           moreover have "Can x \<and> Diag x" using v wx Diag_TensorE [of w x] by auto
           moreover have "Dom t = Cod w" using wx 1 by simp
           moreover have "Dom u = Cod x" using wx 1 by simp
           ultimately show "Inv (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w) = Inv w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t \<and>
                            Inv (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x) = Inv x \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv u"
             using t u I1 I2 by simp
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     lemma Can_and_Diag_implies_Ide:
     assumes "Can t" and "Diag t"
     shows "Ide t"
     proof -
       have "\<lbrakk> Can t; Diag t \<rbrakk> \<Longrightarrow> Ide t"
         apply (induct t, simp_all)
         by (simp add: Diag_TensorE)
       thus ?thesis using assms by blast
     qed
 
     lemma CompDiag_Can_Inv [simp]:
     assumes "Can t" and "Diag t"
     shows "t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv t = Cod t"
       using assms Can_and_Diag_implies_Ide Ide_in_Hom by simp
       
     lemma CompDiag_Inv_Can [simp]:
     assumes "Can t" and "Diag t"
     shows "Inv t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> t = Dom t"
       using assms Can_and_Diag_implies_Ide Ide_in_Hom by simp
 
     text\<open>
       The next fact is a syntactic version of the interchange law, for diagonal terms.
 \<close>
 
     lemma CompDiag_TensorDiag:
     assumes "Diag t" and "Diag u" and "Diag v" and "Diag w"
     and "Seq t v" and "Seq u w"
     shows "(t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
     proof -
       have "\<And>u v w. \<lbrakk> Diag t; Diag u; Diag v; Diag w; Seq t v; Seq u w \<rbrakk> \<Longrightarrow>
                       (t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
       proof (induct t, simp_all)
         fix u v w
         assume u: "Diag u"
         assume v: "Diag v"
         assume w: "Diag w"
         assume uw: "Seq u w"
         show "Arr v \<and> \<^bold>\<I> = Cod v \<Longrightarrow> u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
           using u v w uw by (cases v) simp_all
         show "\<And>f. \<lbrakk> C.arr f; Arr v \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod v \<rbrakk> \<Longrightarrow>
                     (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
         proof -
           fix f
           assume f: "C.arr f"
           assume 1: "Arr v \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod v"
           show "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
           proof -
             have 2: "v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr (un_Prim v)" using v 1 by (cases v) simp_all
             have "u = \<^bold>\<I> \<Longrightarrow> ?thesis"
               using v w uw 1 2 Cod.simps(3) CompDiag_Cod_Diag Dom.simps(2)
                     TensorDiag_Prim TensorDiag_term_Unity TensorDiag_preserves_Diag(3)
               by (cases w) simp_all
             moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
             proof -
               assume 3: "u \<noteq> \<^bold>\<I>"
               hence 4: "w \<noteq> \<^bold>\<I>" using u w uw by (cases u, simp_all; cases w, simp_all)
               have "(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<otimes> w)"
               proof -
                 have "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u"
                   using u f 3 TensorDiag_Diag by (cases u) simp_all
                 moreover have "v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w = v \<^bold>\<otimes> w"
                   using w 2 4 TensorDiag_Diag by (cases v, simp_all; cases w, simp_all)
                 ultimately show ?thesis by simp
               qed
               also have 5: "... = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<otimes> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)" by simp
               also have "... = (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                 using f u w uw 1 2 3 4 5
                       TensorDiag_Diag TensorDiag_Prim TensorDiag_preserves_Diag(1)
                       CompDiag_preserves_Diag(1)
                 by (metis Cod.simps(3) Dom.simps(1) Dom.simps(3) Diag.simps(2))
               finally show ?thesis by blast
             qed
             ultimately show ?thesis by blast
           qed
         qed
         fix t1 t2
         assume I2: "\<And>u v w. \<lbrakk> Diag t2; Diag u; Diag v; Diag w;
                               Arr v \<and> Dom t2 = Cod v; Seq u w \<rbrakk> \<Longrightarrow>
                               (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
         assume t12: "Diag (t1 \<^bold>\<otimes> t2)"
         have t1: "t1 = \<^bold>\<langle>un_Prim t1\<^bold>\<rangle> \<and> C.arr (un_Prim t1) \<and> Diag t1"
           using t12 by (cases t1) simp_all
         have t2: "Diag t2 \<and> t2 \<noteq> \<^bold>\<I>"
           using t12 by (cases t1) simp_all
         assume 1: "Arr t1 \<and> Arr t2 \<and> Arr v \<and> Dom t1 \<^bold>\<otimes> Dom t2 = Cod v"
         show "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) = ((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
         proof -
           have "u = \<^bold>\<I> \<Longrightarrow> ?thesis"
             using w uw TensorDiag_term_Unity CompDiag_Cod_Diag by (cases w) simp_all
           moreover have "u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
           proof -
             assume u': "u \<noteq> \<^bold>\<I>"
             hence w': "w \<noteq> \<^bold>\<I>" using u w uw by (cases u; simp; cases w; simp)
             show ?thesis
               using 1 v
             proof (cases v, simp_all)
               fix v1 v2
               assume v12: "v = Tensor v1 v2"
               have v1: "v1 = \<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<and> C.arr (un_Prim v1) \<and> Diag v1"
                 using v v12 by (cases v1) simp_all
               have v2: "Diag v2 \<and> v2 \<noteq> \<^bold>\<I>"
                 using v v12 by (cases v1) simp_all
               have 2: "v = (\<^bold>\<langle>un_Prim v1\<^bold>\<rangle> \<^bold>\<otimes> v2)"
                 using v1 v12 by simp
               show "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<otimes> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)
                       = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
               proof -
                 have 3: "(t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u = t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
                   using u u' by (cases u) simp_all
                 have 4: "v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w = v1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)"
                   using v w v1 v2 2 TensorDiag_assoc TensorDiag_Diag by metis
                 have "((t1 \<^bold>\<otimes> t2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((v1 \<^bold>\<otimes> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)
                         = (t1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v1 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w))"
                   using 3 4 v12 by simp
                 also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w))"
                 proof -
                   have "is_Tensor (t2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u)"
                     using t2 u u' not_is_Tensor_TensorDiagE by auto
                   moreover have "is_Tensor (v2 \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w)"
                     using v2 v12 w w' not_is_Tensor_TensorDiagE by auto
                   ultimately show ?thesis
                     using u u' v w t1 v1 t12 v12 TensorDiag_Prim not_is_Tensor_Unity
                     by (metis (no_types, lifting) CompDiag.simps(2) CompDiag.simps(3)
                         is_Tensor_def)
                 qed
                 also have "... = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                   using u w uw t2 v2 1 2 Diag_implies_Arr I2 by fastforce
                 also have "... = ((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)"
                 proof -
                   have "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w \<noteq> Unity"
                   proof -
                     have "Arr v1 \<and> \<^bold>\<langle>C.dom (un_Prim t1)\<^bold>\<rangle> = Cod v1"
                       using t1 v1 1 2 by (cases t1, auto)
                     thus ?thesis
                       using t1 t2 v1 v2 u w uw u' CompDiag_preserves_Diag
                             TensorDiag_preserves_Diag TensorDiag_Prim
                       by (metis (mono_tags, lifting) Cod.simps(2) Cod.simps(3)
                           TensorDiag.simps(2) term.distinct(3))
                   qed
                   hence "((t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<otimes> (t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2)) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w)
                            = (t1 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v1) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> ((t2 \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> v2) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w))"
                     by (cases "u \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> w") simp_all
                   thus ?thesis by argo
                 qed
                 finally show ?thesis by blast
               qed
             qed
           qed
           ultimately show ?thesis by blast
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       The following function reduces an arrow to diagonal form.
       The precise relationship between a term and its diagonalization is developed below.
 \<close>
 
     fun Diagonalize :: "'a term \<Rightarrow> 'a term"   ("\<^bold>\<lfloor>_\<^bold>\<rfloor>")
     where "\<^bold>\<lfloor>\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<rfloor> = \<^bold>\<langle>f\<^bold>\<rangle>"
         | "\<^bold>\<lfloor>\<^bold>\<I>\<^bold>\<rfloor> = \<^bold>\<I>"
         | "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"
         | "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
 
     lemma Diag_Diagonalize:
     assumes "Arr t"
     shows "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor>" and "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" and "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
     proof -
       have 0: "Arr t \<Longrightarrow> Diag \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
         using TensorDiag_preserves_Diag CompDiag_preserves_Diag TensorDiag_assoc
         apply (induct t)
                  apply auto
          apply (metis (full_types))
         by (metis (full_types))
       show "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor>" using assms 0 by blast
       show "Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>" using assms 0 by blast
       show "Cod \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>" using assms 0 by blast
     qed
 
     lemma Diagonalize_in_Hom:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>"
       using assms Diag_Diagonalize Diag_implies_Arr by blast
 
     lemma Diagonalize_Dom:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Diagonalize_in_Hom by simp
 
     lemma Diagonalize_Cod:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Diagonalize_in_Hom by simp
 
     lemma Diagonalize_preserves_Ide:
     assumes "Ide a"
     shows "Ide \<^bold>\<lfloor>a\<^bold>\<rfloor>"
     proof -
       have "Ide a \<Longrightarrow> Ide \<^bold>\<lfloor>a\<^bold>\<rfloor>"
         using Ide_implies_Arr TensorDiag_preserves_Ide Diag_Diagonalize
         by (induct a) simp_all
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       The diagonalizations of canonical arrows are identities.
 \<close>
 
     lemma Ide_Diagonalize_Can:
     assumes "Can t"
     shows "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Can t \<Longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using Can_implies_Arr TensorDiag_preserves_Ide Diag_Diagonalize CompDiag_preserves_Ide
               TensorDiag_preserves_Diag
         by (induct t) auto
       thus ?thesis using assms by blast
     qed
 
     lemma Diagonalize_preserves_Can:
     assumes "Can t"
     shows "Can \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Ide_Diagonalize_Can Ide_implies_Can by auto
 
     lemma Diagonalize_Diag [simp]:
     assumes "Diag t"
     shows "\<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
     proof -
       have "Diag t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = t"
         apply (induct t, simp_all)
         using TensorDiag_Prim Diag_TensorE by metis
       thus ?thesis using assms by blast
     qed
 
     lemma Diagonalize_Diagonalize [simp]:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms Diag_Diagonalize Diagonalize_Diag by blast
 
     lemma Diagonalize_Tensor:
     assumes "Arr t" and "Arr u"
     shows "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<^bold>\<rfloor>"
       using assms Diagonalize_Diagonalize by simp
 
     lemma Diagonalize_Tensor_Unity_Arr [simp]:
     assumes "Arr u"
     shows "\<^bold>\<lfloor>\<^bold>\<I> \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       using assms by simp
 
     lemma Diagonalize_Tensor_Arr_Unity [simp]:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>t \<^bold>\<otimes> \<^bold>\<I>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms by simp
 
     lemma Diagonalize_Tensor_Prim_Arr [simp]:
     assumes "arr f" and "Arr u" and "\<^bold>\<lfloor>u\<^bold>\<rfloor> \<noteq> Unity"
     shows "\<^bold>\<lfloor>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       using assms by simp
 
     lemma Diagonalize_Tensor_Tensor:
     assumes "Arr t" and "Arr u" and "Arr v"
     shows "\<^bold>\<lfloor>(t \<^bold>\<otimes> u) \<^bold>\<otimes> v\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<otimes> (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>v\<^bold>\<rfloor>)\<^bold>\<rfloor>"
       using assms Diag_Diagonalize Diagonalize_Diagonalize by (simp add: TensorDiag_assoc)
 
     lemma Diagonalize_Comp_Cod_Arr:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Arr t \<Longrightarrow> \<^bold>\<lfloor>Cod t \<^bold>\<cdot> t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using C.comp_cod_arr
         apply (induct t, simp_all)
         using CompDiag_TensorDiag Arr_implies_Ide_Cod Ide_in_Hom Diag_Diagonalize
               Diagonalize_in_Hom
            apply simp
         using CompDiag_preserves_Diag CompDiag_Cod_Diag Diag_Diagonalize
           apply metis
         using CompDiag_TensorDiag Arr_implies_Ide_Cod Ide_in_Hom TensorDiag_in_Hom
               TensorDiag_preserves_Diag Diag_Diagonalize Diagonalize_in_Hom TensorDiag_assoc
         by simp_all
       thus ?thesis using assms by blast
     qed
 
     lemma Diagonalize_Comp_Arr_Dom:
     assumes "Arr t"
     shows "\<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Arr t \<Longrightarrow> \<^bold>\<lfloor>t \<^bold>\<cdot> Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         by (metis CompDiag_Diag_Dom Diag_Diagonalize(1-2) Diagonalize.simps(4))
       thus ?thesis using assms by blast
     qed
 
     lemma Diagonalize_Inv:
     assumes "Can t"
     shows "\<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
     proof -
       have "Can t \<Longrightarrow> \<^bold>\<lfloor>Inv t\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       proof (induct t, simp_all)
         fix u v
         assume I1: "\<^bold>\<lfloor>Inv u\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         assume I2: "\<^bold>\<lfloor>Inv v\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>"
         show "Can u \<and> Can v \<Longrightarrow> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
           using Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
                 I1 I2
           by simp
         show "Can u \<and> Can v \<and> Dom u = Cod v \<Longrightarrow> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>)"
           using Inv_CompDiag Diag_Diagonalize Can_implies_Arr Diagonalize_in_Hom
                 Diagonalize_preserves_Can I1 I2
           by simp
         fix w
         assume I3: "\<^bold>\<lfloor>Inv w\<^bold>\<rfloor> = Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>"
         assume uvw: "Can u \<and> Can v \<and> Can w"
         show "Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (Inv \<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor>) = Inv ((\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>)"
           using uvw I1 I2 I3
                 Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
                 TensorDiag_preserves_Diag TensorDiag_preserves_Can TensorDiag_assoc
           by simp
         show "(Inv \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Inv \<^bold>\<lfloor>w\<^bold>\<rfloor> = Inv (\<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (\<^bold>\<lfloor>v\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>w\<^bold>\<rfloor>))"
-          using uvw I1 I2 I3
-                Inv_TensorDiag Diag_Diagonalize Can_implies_Arr Diagonalize_preserves_Can
-                TensorDiag_preserves_Diag TensorDiag_preserves_Can
-          apply simp
-          using TensorDiag_assoc [of "\<^bold>\<lfloor>u\<^bold>\<rfloor>" "\<^bold>\<lfloor>v\<^bold>\<rfloor>" "\<^bold>\<lfloor>w\<^bold>\<rfloor>"] by metis
+          by (simp add: Can_implies_Arr Ide_Diagonalize_Can TensorDiag_assoc
+              TensorDiag_preserves_Diag(1) TensorDiag_preserves_Ide Diag_Diagonalize(1) uvw)
       qed
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       Our next objective is to begin making the connection, to be completed in a
       subsequent section, between arrows and their diagonalizations.
       To summarize, an arrow @{term t} and its diagonalization @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"} are opposite sides
       of a square whose other sides are certain canonical terms
       \<open>Dom t\<^bold>\<down> \<in> Hom (Dom t) \<^bold>\<lfloor>Dom t\<^bold>\<rfloor>\<close> and \<open>Cod t\<^bold>\<down> \<in> Hom (Cod t) \<^bold>\<lfloor>Cod t\<^bold>\<rfloor>\<close>,
       where \<open>Dom t\<^bold>\<down>\<close> and \<open>Cod t\<^bold>\<down>\<close> are defined by the function \<open>red\<close>
       below.  The coherence theorem amounts to the statement that every such square commutes
       when the formal terms involved are evaluated in the evident way in any monoidal category.
 
       Function \<open>red\<close> defined below takes an identity term @{term a} to a canonical arrow
       \<open>a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>\<close>.  The auxiliary function \<open>red2\<close> takes a pair @{term "(a, b)"}
       of diagonal identity terms and produces a canonical arrow
       \<open>a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>\<close>.
       The canonical arrow \<open>a\<^bold>\<down>\<close> amounts to a ``parallel innermost reduction''
       from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"}, where the reduction steps are canonical arrows
       that involve the unitors and associator only in their uninverted forms.
       In general, a parallel innermost reduction from @{term a} will not be unique:
       at some points there is a choice available between left and right unitors
       and at other points there are choices between unitors and associators.
       These choices are inessential, and the ordering of the clauses in the function definitions
       below resolves them in an arbitrary way.  What is more important is having chosen an
       innermost reduction, which is what allows us to write these definitions in structurally
       recursive form.
 
       The essence of coherence is that the axioms for a monoidal category allow us to
       prove that any reduction from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"} is equivalent
       (under evaluation of terms) to a parallel innermost reduction.
       The problematic cases are terms of the form @{term "((a \<^bold>\<otimes> b) \<^bold>\<otimes> c) \<^bold>\<otimes> d"},
       which present a choice between an inner and outer reduction that lead to terms
       with different structures.  It is of course the pentagon axiom that ensures the
       confluence (under evaluation) of the two resulting paths.
 
       Although simple in appearance, the structurally recursive definitions below were
       difficult to get right even after I started to understand what I was doing.
       I wish I could have just written them down straightaway.  If so, then I could have
       avoided laboriously constructing and then throwing away thousands of lines of proof
       text that used a non-structural, ``operational'' approach to defining a reduction
       from @{term a} to @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor>"}.
 \<close>
 
     fun red2                       (infixr "\<^bold>\<Down>" 53)
     where "\<^bold>\<I> \<^bold>\<Down> a = \<^bold>\<l>\<^bold>[a\<^bold>]"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> \<^bold>\<I> = \<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]"
         | "\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> a = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> a"
         | "(a \<^bold>\<otimes> b) \<^bold>\<Down> \<^bold>\<I> = \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
         | "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<^bold>\<cdot> (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
         | "a \<^bold>\<Down> b = undefined"
 
     fun red                         ("_\<^bold>\<down>" [56] 56)
     where "\<^bold>\<I>\<^bold>\<down> = \<^bold>\<I>"
         | "\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>\<down> = \<^bold>\<langle>f\<^bold>\<rangle>"
         | "(a \<^bold>\<otimes> b)\<^bold>\<down> = (if Diag (a \<^bold>\<otimes> b) then a \<^bold>\<otimes> b else (\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<cdot> (a\<^bold>\<down> \<^bold>\<otimes> b\<^bold>\<down>))"
         | "a\<^bold>\<down> = undefined"
 
     lemma red_Diag [simp]:
     assumes "Diag a"
     shows "a\<^bold>\<down> = a"
       using assms by (cases a) simp_all
 
     lemma red2_Diag:
     assumes "Diag (a \<^bold>\<otimes> b)"
     shows "a \<^bold>\<Down> b = a \<^bold>\<otimes> b"
     proof -
       have a: "a = \<^bold>\<langle>un_Prim a\<^bold>\<rangle>"
         using assms Diag_TensorE by metis
       have b: "Diag b \<and> b \<noteq> \<^bold>\<I>"
         using assms Diag_TensorE by metis
       show ?thesis using a b
         apply (cases b)
           apply simp_all
          apply (metis red2.simps(3))
         by (metis red2.simps(4))
     qed
 
     lemma Can_red2:
     assumes "Ide a" and "Diag a" and "Ide b" and "Diag b"
     shows "Can (a \<^bold>\<Down> b)"
     and "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
     proof -
       have 0: "\<And>b. \<lbrakk> Ide a \<and> Diag a; Ide b \<and> Diag b \<rbrakk> \<Longrightarrow>
                      Can (a \<^bold>\<Down> b) \<and> a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
       proof (induct a, simp_all)
         fix b
         show "Ide b \<and> Diag b \<Longrightarrow> Can b \<and> Dom b = b \<and> Cod b = b"
           using Ide_implies_Can Ide_in_Hom Diagonalize_Diag by auto
         fix f
         show "\<lbrakk> C.ide f \<and> C.arr f; Ide b \<and> Diag b \<rbrakk> \<Longrightarrow>
                 Can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Arr (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) \<and> Dom (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b \<and>
                                                 Cod (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b) = \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b"
           using Ide_implies_Can Ide_in_Hom by (cases b; auto)
         next
         fix a b c
         assume ab: "Ide a \<and> Ide b \<and> Diag (Tensor a b)"
         assume c: "Ide c \<and> Diag c"
         assume I1: "\<And>c. \<lbrakk> Diag a; Ide c \<and> Diag c \<rbrakk> \<Longrightarrow>
                           Can (a \<^bold>\<Down> c) \<and> Arr (a \<^bold>\<Down> c) \<and> Dom (a \<^bold>\<Down> c) = a \<^bold>\<otimes> c \<and>
                                                        Cod (a \<^bold>\<Down> c) = a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
         assume I2: "\<And>c. \<lbrakk> Diag b; Ide c \<and> Diag c \<rbrakk> \<Longrightarrow>
                           Can (b \<^bold>\<Down> c) \<and> Arr (b \<^bold>\<Down> c) \<and> Dom (b \<^bold>\<Down> c) = b \<^bold>\<otimes> c \<and>
                                                        Cod (b \<^bold>\<Down> c) = b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
         show "Can ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) \<and> Arr ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) \<and>
               Dom ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c \<and>
               Cod ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
         proof -
           have a: "Diag a \<and> Ide a"
             using ab Diag_TensorE by blast
           have b: "Diag b \<and> Ide b"
             using ab Diag_TensorE by blast
           have "c = \<^bold>\<I> \<Longrightarrow> ?thesis"
           proof -
             assume 1: "c = \<^bold>\<I>"
             have 2: "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
               using 1 by simp
             have 3: "Can (a \<^bold>\<Down> b) \<and> Arr (a \<^bold>\<Down> b) \<and> Dom (a \<^bold>\<Down> b) = a \<^bold>\<otimes> b \<and> Cod (a \<^bold>\<Down> b) = a \<^bold>\<otimes> b"
               using a b ab 1 2 I1 Diagonalize_Diag Diagonalize.simps(3) by metis
             hence 4: "Seq (a \<^bold>\<Down> b) \<^bold>\<r>\<^bold>[a \<^bold>\<otimes> b\<^bold>]"
               using ab
               by (metis (mono_tags, lifting) Arr.simps(7) Cod.simps(3) Cod.simps(7)
                   Diag_implies_Arr Ide_in_Hom mem_Collect_eq)
             have "Can ((a \<^bold>\<otimes> b) \<^bold>\<Down> c)"
               using 1 2 3 4 ab by (simp add: Ide_implies_Can)
             moreover have "Dom ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c"
               using 1 2 3 4 a b ab I1 Ide_in_Hom TensorDiag_preserves_Diag by simp
             moreover have "Cod ((a \<^bold>\<otimes> b) \<^bold>\<Down> c) = \<^bold>\<lfloor>(a \<^bold>\<otimes> b) \<^bold>\<otimes> c\<^bold>\<rfloor>"
              using 1 2 3 4 ab using Diagonalize_Diag by fastforce
             ultimately show ?thesis using Can_implies_Arr by (simp add: 1 ab)
           qed
           moreover have "c \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
           proof -
             assume 1: "c \<noteq> \<^bold>\<I>"
             have 2: "(a \<^bold>\<otimes> b) \<^bold>\<Down> c = (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<^bold>\<cdot> (a \<^bold>\<otimes> b \<^bold>\<Down> c) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
               using 1 a b ab c by (cases c; simp)
             have 3: "Can (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<and> Dom (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor> \<and>
                                           Cod (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = \<^bold>\<lfloor>a \<^bold>\<otimes> (b \<^bold>\<otimes> c)\<^bold>\<rfloor>"
             proof -
               have "Can (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) \<and> Dom (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor> \<and>
                                          Cod (a \<^bold>\<Down> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>) = \<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor>"
                 using a c ab 1 2 I1 Diag_implies_Arr Diag_Diagonalize(1)
                       Diagonalize_preserves_Ide TensorDiag_preserves_Ide
                       TensorDiag_preserves_Diag(1)
                 by auto
               moreover have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> (b \<^bold>\<otimes> c)\<^bold>\<rfloor>"
                 using ab c Diagonalize_Tensor Diagonalize_Diagonalize Diag_implies_Arr
                 by (metis Arr.simps(3) Diagonalize.simps(3))
               ultimately show ?thesis by metis
             qed
             have 4: "Can (b \<^bold>\<Down> c) \<and> Dom (b \<^bold>\<Down> c) = b \<^bold>\<otimes> c \<and> Cod (b \<^bold>\<Down> c) = \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>"
               using b c ab 1 2 I2 by simp
             hence "Can (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) \<and> Dom (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) = a \<^bold>\<otimes> (b \<^bold>\<otimes> c) \<and>
                                         Cod (a \<^bold>\<otimes> (b \<^bold>\<Down> c)) = a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>"
               using ab Ide_implies_Can Ide_in_Hom by force
             moreover have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
             proof -
               have "\<^bold>\<lfloor>a \<^bold>\<otimes> \<^bold>\<lfloor>b \<^bold>\<otimes> c\<^bold>\<rfloor>\<^bold>\<rfloor> = a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)"
                 using a b c 4
                 by (metis Arr_implies_Ide_Dom Can_implies_Arr Ide_implies_Arr
                     Diag_Diagonalize(1) Diagonalize.simps(3) Diagonalize_Diag)
               also have "... = (a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"
                 using a b ab c TensorDiag_assoc by metis
               also have "... = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
                 using a b c by (metis Diagonalize.simps(3) Diagonalize_Diag)
               finally show ?thesis by blast
             qed
             moreover have "Can \<^bold>\<a>\<^bold>[a, b, c\<^bold>] \<and> Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>] = (a \<^bold>\<otimes> b) \<^bold>\<otimes> c \<and>
                                             Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>] = a \<^bold>\<otimes> (b \<^bold>\<otimes> c)"
               using ab c Ide_implies_Can Ide_in_Hom by auto
             ultimately show ?thesis
-              using ab c 2 3 4 Diag_implies_Arr Diagonalize_Diagonalize Ide_implies_Can
+              using c 2 3 4 Diagonalize_Diagonalize Ide_implies_Can
                     Diagonalize_Diag Arr_implies_Ide_Dom Can_implies_Arr
               by (metis Can.simps(4) Cod.simps(4) Dom.simps(4) Diagonalize.simps(3))
           qed
           ultimately show ?thesis by blast
         qed
       qed
       show "Can (a \<^bold>\<Down> b)" using assms 0 by blast
       show "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>" using 0 assms by blast
     qed
 
     lemma red2_in_Hom:
     assumes "Ide a" and "Diag a" and "Ide b" and "Diag b"
     shows "a \<^bold>\<Down> b \<in> Hom (a \<^bold>\<otimes> b) \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
       using assms Can_red2 Can_implies_Arr by simp
 
     lemma Can_red:
     assumes "Ide a"
     shows "Can (a\<^bold>\<down>)" and "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
     proof -
       have 0: "Ide a \<Longrightarrow> Can (a\<^bold>\<down>) \<and> a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
       proof (induct a, simp_all)
         fix b c
         assume b: "Can (b\<^bold>\<down>) \<and> Arr (b\<^bold>\<down>) \<and> Dom (b\<^bold>\<down>) = b \<and> Cod (b\<^bold>\<down>) = \<^bold>\<lfloor>b\<^bold>\<rfloor>"
         assume c: "Can (c\<^bold>\<down>) \<and> Arr (c\<^bold>\<down>) \<and> Dom (c\<^bold>\<down>) = c \<and> Cod (c\<^bold>\<down>) = \<^bold>\<lfloor>c\<^bold>\<rfloor>"
         assume bc: "Ide b \<and> Ide c"
         show "(Diag (b \<^bold>\<otimes> c) \<longrightarrow>
                  Can b \<and> Can c \<and> Dom b = b \<and> Dom c = c \<and> Cod b \<^bold>\<otimes> Cod c = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
               (\<not> Diag (b \<^bold>\<otimes> c) \<longrightarrow>
                  Can (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and> Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
                  Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)"
         proof
           show "Diag (b \<^bold>\<otimes> c) \<longrightarrow>
                   Can b \<and> Can c \<and> Dom b = b \<and> Dom c = c \<and> Cod b \<^bold>\<otimes> Cod c = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
             using bc Diag_TensorE Ide_implies_Can Inv_preserves_Can(2)
                   CompDiag_Ide_Diag Inv_Ide Diagonalize.simps(3) Diagonalize_Diag
             by (metis CompDiag_Inv_Can)
           show "\<not> Diag (b \<^bold>\<otimes> c) \<longrightarrow>
                   Can (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and> Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Arr (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) \<and>
                                     Dom (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<otimes> \<^bold>\<lfloor>c\<^bold>\<rfloor> \<and> Cod (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>) = \<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>"
-            using b c bc Ide_in_Hom Ide_implies_Can Diagonalize_Diag Can_red2 Diag_Diagonalize
-                  Ide_implies_Arr Diagonalize_Tensor Diagonalize_preserves_Ide
-                  TensorDiag_preserves_Diag TensorDiag_preserves_Ide
-                  TensorDiag_preserves_Can
-            by (cases b) simp_all
+            using b c bc Ide_in_Hom Ide_implies_Can Can_red2 Diag_Diagonalize
+                  Diagonalize_preserves_Ide TensorDiag_preserves_Diag TensorDiag_preserves_Ide
+            by force
         qed
       qed
       show "Can (a\<^bold>\<down>)" using assms 0 by blast
       show "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>" using assms 0 by blast
     qed
 
     lemma red_in_Hom:
     assumes "Ide a"
     shows "a\<^bold>\<down> \<in> Hom a \<^bold>\<lfloor>a\<^bold>\<rfloor>"
       using assms Can_red Can_implies_Arr by simp
 
     lemma Diagonalize_red [simp]:
     assumes "Ide a"
     shows "\<^bold>\<lfloor>a\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>a\<^bold>\<rfloor>"
       using assms Can_red Ide_Diagonalize_Can Diagonalize_in_Hom Ide_in_Hom by fastforce
 
     lemma Diagonalize_red2 [simp]:
     assumes "Ide a" and "Ide b" and "Diag a" and "Diag b"
     shows "\<^bold>\<lfloor>a \<^bold>\<Down> b\<^bold>\<rfloor> = \<^bold>\<lfloor>a \<^bold>\<otimes> b\<^bold>\<rfloor>"
       using assms Can_red2 Ide_Diagonalize_Can Diagonalize_in_Hom [of "a \<^bold>\<Down> b"]
             red2_in_Hom Ide_in_Hom
       by simp
 
   end
 
   section "Coherence"
 
   text\<open>
     If @{term D} is a monoidal category, then a functor \<open>V: C \<rightarrow> D\<close> extends
     in an evident way to an evaluation map that interprets each formal arrow of the
     monoidal language of @{term C} as an arrow of @{term D}.
 \<close>
 
   locale evaluation_map =
     monoidal_language C +
     monoidal_category D T \<alpha> \<iota> +
     V: "functor" C D V
   for C :: "'c comp"                  (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"                  (infixr "\<cdot>" 55)
   and T :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha> :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota> :: 'd
   and V :: "'c \<Rightarrow> 'd"
   begin
 
     no_notation C.in_hom               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     notation unity                     ("\<I>")
     notation runit                     ("\<r>[_]")
     notation lunit                     ("\<l>[_]")
     notation assoc'                    ("\<a>\<^sup>-\<^sup>1[_, _, _]")
     notation runit'                    ("\<r>\<^sup>-\<^sup>1[_]")
     notation lunit'                    ("\<l>\<^sup>-\<^sup>1[_]")
 
     primrec eval :: "'c term \<Rightarrow> 'd"    ("\<lbrace>_\<rbrace>")
     where "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = V f"
         | "\<lbrace>\<^bold>\<I>\<rbrace> = \<I>"
         | "\<lbrace>t \<^bold>\<otimes> u\<rbrace> = \<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>"
         | "\<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         | "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<ll> \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<ll>' \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<rho> \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<rho>' \<lbrace>t\<rbrace>"
         | "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
         | "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>' (\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"
 
     text\<open>
       Identity terms evaluate to identities of \<open>D\<close> and evaluation preserves
       domain and codomain.
 \<close>
 
     lemma ide_eval_Ide [simp]:
     shows "Ide t \<Longrightarrow> ide \<lbrace>t\<rbrace>"
       by (induct t, auto)
 
     lemma eval_in_hom:
     shows "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
       apply (induct t)
                apply auto[4]
           apply fastforce
     proof -
       fix t u v
       assume I: "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
       show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
         using I arr_dom_iff_arr [of "\<lbrace>t\<rbrace>"] by force
       show "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
         using I arr_cod_iff_arr [of "\<lbrace>t\<rbrace>"] by force
       show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>\<guillemotright>"
         using I arr_dom_iff_arr [of "\<lbrace>t\<rbrace>"] by force
       assume I1: "Arr t \<Longrightarrow> \<guillemotleft>\<lbrace>t\<rbrace> : \<lbrace>Dom t\<rbrace> \<rightarrow> \<lbrace>Cod t\<rbrace>\<guillemotright>"
       assume I2: "Arr u \<Longrightarrow> \<guillemotleft>\<lbrace>u\<rbrace> : \<lbrace>Dom u\<rbrace> \<rightarrow> \<lbrace>Cod u\<rbrace>\<guillemotright>"
       assume I3: "Arr v \<Longrightarrow> \<guillemotleft>\<lbrace>v\<rbrace> : \<lbrace>Dom v\<rbrace> \<rightarrow> \<lbrace>Cod v\<rbrace>\<guillemotright>"
       show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
       proof -
         assume 1: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         have t: "\<guillemotleft>\<lbrace>t\<rbrace> : dom \<lbrace>t\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace>\<guillemotright>" using 1 I1 by auto
         have u: "\<guillemotleft>\<lbrace>u\<rbrace> : dom \<lbrace>u\<rbrace> \<rightarrow> cod \<lbrace>u\<rbrace>\<guillemotright>" using 1 I2 by auto
         have v: "\<guillemotleft>\<lbrace>v\<rbrace> : dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>v\<rbrace>\<guillemotright>" using 1 I3 by auto
         have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
           using t u v \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by auto
         moreover have "\<guillemotleft>(\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] :
                          (dom \<lbrace>t\<rbrace> \<otimes> dom \<lbrace>u\<rbrace>) \<otimes> dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace> \<otimes> cod \<lbrace>u\<rbrace> \<otimes> cod \<lbrace>v\<rbrace>\<guillemotright>"
           using t u v by (elim in_homE, auto)
         moreover have "\<lbrace>Dom t\<rbrace> = dom \<lbrace>t\<rbrace> \<and> \<lbrace>Dom u\<rbrace> = dom \<lbrace>u\<rbrace> \<and> \<lbrace>Dom v\<rbrace> = dom \<lbrace>v\<rbrace> \<and>
                        \<lbrace>Cod t\<rbrace> = cod \<lbrace>t\<rbrace> \<and> \<lbrace>Cod u\<rbrace> = cod \<lbrace>u\<rbrace> \<and> \<lbrace>Cod v\<rbrace> = cod \<lbrace>v\<rbrace>"
           using 1 I1 I2 I3 by auto
         ultimately show "\<guillemotleft>\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
           by simp
       qed
       show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow>  \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
        proof -
         assume 1: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
         have t: "\<guillemotleft>\<lbrace>t\<rbrace> : dom \<lbrace>t\<rbrace> \<rightarrow> cod \<lbrace>t\<rbrace>\<guillemotright>" using 1 I1 by auto
         have u: "\<guillemotleft>\<lbrace>u\<rbrace> : dom \<lbrace>u\<rbrace> \<rightarrow> cod \<lbrace>u\<rbrace>\<guillemotright>" using 1 I2 by auto
         have v: "\<guillemotleft>\<lbrace>v\<rbrace> : dom \<lbrace>v\<rbrace> \<rightarrow> cod \<lbrace>v\<rbrace>\<guillemotright>" using 1 I3 by auto
         have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>]"
           using 1 I1 I2 I3 \<alpha>'_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by auto
         moreover have "\<guillemotleft>((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>] :
                           dom \<lbrace>t\<rbrace> \<otimes> dom \<lbrace>u\<rbrace> \<otimes> dom \<lbrace>v\<rbrace> \<rightarrow> (cod \<lbrace>t\<rbrace> \<otimes> cod \<lbrace>u\<rbrace>) \<otimes> cod \<lbrace>v\<rbrace>\<guillemotright>"
           using t u v assoc'_in_hom [of "dom \<lbrace>t\<rbrace>" "dom \<lbrace>u\<rbrace>" "dom \<lbrace>v\<rbrace>"]
           by (elim in_homE, auto)
         moreover have "\<lbrace>Dom t\<rbrace> = dom \<lbrace>t\<rbrace> \<and> \<lbrace>Dom u\<rbrace> = dom \<lbrace>u\<rbrace> \<and> \<lbrace>Dom v\<rbrace> = dom \<lbrace>v\<rbrace> \<and>
                        \<lbrace>Cod t\<rbrace> = cod \<lbrace>t\<rbrace> \<and> \<lbrace>Cod u\<rbrace> = cod \<lbrace>u\<rbrace> \<and> \<lbrace>Cod v\<rbrace> = cod \<lbrace>v\<rbrace>"
           using 1 I1 I2 I3 by auto
         ultimately show " \<guillemotleft>\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> : \<lbrace>Dom \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> \<rightarrow> \<lbrace>Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>\<guillemotright>"
           by simp
       qed
     qed
 
     lemma arr_eval [simp]:
     assumes "Arr f"
     shows "arr \<lbrace>f\<rbrace>"
       using assms eval_in_hom by auto
 
     lemma dom_eval [simp]:
     assumes "Arr f"
     shows "dom \<lbrace>f\<rbrace> = \<lbrace>Dom f\<rbrace>"
       using assms eval_in_hom by auto
       
     lemma cod_eval [simp]:
     assumes "Arr f"
     shows "cod \<lbrace>f\<rbrace> = \<lbrace>Cod f\<rbrace>"
       using assms eval_in_hom by auto
       
     lemma eval_Prim [simp]:
     assumes "C.arr f"
     shows "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle>\<rbrace> = V f"
       by simp
 
     lemma eval_Tensor [simp]:
     assumes "Arr t" and "Arr u"
     shows "\<lbrace>t \<^bold>\<otimes> u\<rbrace> = \<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>"
       using assms eval_in_hom by auto
 
     lemma eval_Comp [simp]:
     assumes "Arr t" and "Arr u" and "Dom t = Cod u"
     shows " \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
       using assms by simp
 
     lemma eval_Lunit [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = \<l>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<I> \<otimes> \<lbrace>t\<rbrace>)"
       using assms lunit_naturality [of "\<lbrace>t\<rbrace>"] by simp
 
     lemma eval_Lunit' [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
       using assms lunit'_naturality [of "\<lbrace>t\<rbrace>"] \<ll>'.map_simp [of "\<lbrace>t\<rbrace>"] \<ll>_ide_simp
             Arr_implies_Ide_Cod
       by simp
 
     lemma eval_Runit [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = \<r>[\<lbrace>Cod t\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<I>)"
       using assms runit_naturality [of "\<lbrace>t\<rbrace>"] by simp
 
     lemma eval_Runit' [simp]:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>Cod t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>"
       using assms runit'_naturality [of "\<lbrace>t\<rbrace>"] \<rho>'.map_simp [of "\<lbrace>t\<rbrace>"] \<rho>_ide_simp
             Arr_implies_Ide_Cod
       by simp
 
     lemma eval_Assoc [simp]:
     assumes "Arr t" and "Arr u" and "Arr v"
     shows "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>)"
       using assms \<alpha>.is_natural_2 [of "(\<lbrace>t\<rbrace>, \<lbrace>u\<rbrace>, \<lbrace>v\<rbrace>)"] by auto
 
     lemma eval_Assoc' [simp]:
     assumes "Arr t" and "Arr u" and "Arr v"
     shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>)"
       using assms \<alpha>'_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] assoc'_naturality [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"]
       by simp
 
     text\<open>
       The following are conveniences for the case of identity arguments
       to avoid having to get rid of the extra identities that are introduced by
       the general formulas above.
 \<close>
 
     lemma eval_Lunit_Ide [simp]:
     assumes "Ide a"
     shows "\<lbrace>\<^bold>\<l>\<^bold>[a\<^bold>]\<rbrace> = \<l>[\<lbrace>a\<rbrace>]"
       using assms comp_cod_arr by simp
 
     lemma eval_Lunit'_Ide [simp]:
     assumes "Ide a"
     shows "\<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]\<rbrace> = \<l>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>]"
       using assms comp_cod_arr by simp
 
     lemma eval_Runit_Ide [simp]:
     assumes "Ide a"
     shows "\<lbrace>\<^bold>\<r>\<^bold>[a\<^bold>]\<rbrace> = \<r>[\<lbrace>a\<rbrace>]"
       using assms comp_cod_arr by simp
 
     lemma eval_Runit'_Ide [simp]:
     assumes "Ide a"
     shows "\<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]\<rbrace> = \<r>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>]"
       using assms comp_cod_arr by simp
 
     lemma eval_Assoc_Ide [simp]:
     assumes "Ide a" and "Ide b" and "Ide c"
     shows "\<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace> = \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
       using assms by simp
 
     lemma eval_Assoc'_Ide [simp]:
     assumes "Ide a" and "Ide b" and "Ide c"
     shows "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]\<rbrace> = \<a>\<^sup>-\<^sup>1[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
       using assms \<alpha>'_ide_simp by simp
 
     text\<open>
       Canonical arrows evaluate to isomorphisms in \<open>D\<close>, and formal inverses evaluate
       to inverses in \<open>D\<close>.
 \<close>
 
     lemma iso_eval_Can:
     shows "Can t \<Longrightarrow> iso \<lbrace>t\<rbrace>"
-      using Can_implies_Arr iso_is_arr \<ll>'.preserves_iso \<rho>'.preserves_iso
-            \<alpha>.preserves_iso \<alpha>'.preserves_iso Arr_implies_Ide_Dom Arr_implies_Ide_Cod
+      using Can_implies_Arr \<ll>'.preserves_iso \<rho>'.preserves_iso \<alpha>.preserves_iso \<alpha>'.preserves_iso
+            Arr_implies_Ide_Dom
       by (induct t) auto
 
     lemma eval_Inv_Can:
     shows "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
       apply (induct t)
       using iso_eval_Can inv_comp Can_implies_Arr
                apply auto[4]
     proof -
       fix t
       assume I: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
       show "Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
         using I \<ll>'.is_natural_2 [of "inv \<lbrace>t\<rbrace>"] iso_eval_Can \<ll>_ide_simp iso_is_arr
              comp_cod_arr inv_comp
         by simp
       show "Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
         using I \<rho>'.is_natural_2 [of "inv \<lbrace>t\<rbrace>"] iso_eval_Can \<rho>_ide_simp iso_is_arr
               comp_cod_arr inv_comp
         by simp
       show "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         hence 1: "iso \<lbrace>t\<rbrace>" using iso_eval_Can by simp
         have "inv \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv (\<ll>' \<lbrace>t\<rbrace>)"
           using t by simp
         also have "... = inv (\<l>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>)"
           using 1 \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"] \<ll>'_ide_simp iso_is_arr by auto
         also have "... = \<lbrace>Inv \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
           using t I 1 iso_is_arr inv_comp by auto
         finally show ?thesis by simp
       qed
       show "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
       proof -
         assume t: "Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         hence 1: "iso \<lbrace>t\<rbrace>" using iso_eval_Can by simp
         have "inv \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace> = inv (\<rho>' \<lbrace>t\<rbrace>)"
           using t by simp
         also have "... = inv (\<r>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>] \<cdot> \<lbrace>t\<rbrace>)"
           using 1 \<rho>'.is_natural_2 [of "\<lbrace>t\<rbrace>"] \<rho>'_ide_simp iso_is_arr by auto
         also have "... = \<lbrace>Inv \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
           using t I 1 iso_is_arr inv_comp by auto
         finally show ?thesis by simp
       qed
       next
       fix t u v
       assume I1: "Can t \<Longrightarrow> \<lbrace>Inv t\<rbrace> = inv \<lbrace>t\<rbrace>"
       assume I2: "Can u \<Longrightarrow> \<lbrace>Inv u\<rbrace> = inv \<lbrace>u\<rbrace>"
       assume I3: "Can v \<Longrightarrow> \<lbrace>Inv v\<rbrace> = inv \<lbrace>v\<rbrace>"
       show "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
       proof -
         assume tuv: "Can \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         have t: "iso \<lbrace>t\<rbrace>" using tuv iso_eval_Can by auto
         have u: "iso \<lbrace>u\<rbrace>" using tuv iso_eval_Can by auto
         have v: "iso \<lbrace>v\<rbrace>" using tuv iso_eval_Can by auto
         have "\<lbrace>Inv \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha>' (inv \<lbrace>t\<rbrace>, inv \<lbrace>u\<rbrace>, inv \<lbrace>v\<rbrace>)"
           using tuv I1 I2 I3 by simp
         also have "... = inv (\<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>))"
           using t u v \<alpha>'_simp iso_is_arr inv_comp by auto
         also have "... = inv ((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
           using t u v iso_is_arr assoc_naturality by simp
         also have "... = inv \<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace>"
           using t u v iso_is_arr \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"] by simp
         finally show ?thesis by simp
       qed
       show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> \<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
       proof -
         assume tuv: "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
         have t: "iso \<lbrace>t\<rbrace>" using tuv iso_eval_Can by auto
         have u: "iso \<lbrace>u\<rbrace>" using tuv iso_eval_Can by auto
         have v: "iso \<lbrace>v\<rbrace>" using tuv iso_eval_Can by auto
         have "\<lbrace>Inv \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<alpha> (inv \<lbrace>t\<rbrace>, inv \<lbrace>u\<rbrace>, inv \<lbrace>v\<rbrace>)"
           using tuv I1 I2 I3 by simp
         also have "... = (inv \<lbrace>t\<rbrace> \<otimes> inv \<lbrace>u\<rbrace> \<otimes> inv \<lbrace>v\<rbrace>) \<cdot> \<a>[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>]"
           using t u v iso_is_arr \<alpha>_simp [of "inv \<lbrace>t\<rbrace>" "inv \<lbrace>u\<rbrace>" "inv \<lbrace>v\<rbrace>"] by simp
         also have "... = inv (\<a>\<^sup>-\<^sup>1[cod \<lbrace>t\<rbrace>, cod \<lbrace>u\<rbrace>, cod \<lbrace>v\<rbrace>] \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace> \<otimes> \<lbrace>v\<rbrace>))"
           using t u v iso_is_arr inv_comp by auto
         also have "... = inv (((\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) \<otimes> \<lbrace>v\<rbrace>) \<cdot> \<a>\<^sup>-\<^sup>1[dom \<lbrace>t\<rbrace>, dom \<lbrace>u\<rbrace>, dom \<lbrace>v\<rbrace>])"
           using t u v iso_is_arr assoc'_naturality by simp
         also have "... = inv \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace>"
           using t u v iso_is_arr \<alpha>'_simp by auto
         finally show ?thesis by blast
       qed
     qed
 
     text\<open>
       The operation \<open>\<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>\<close> evaluates to composition in \<open>D\<close>.
 \<close>
 
     lemma eval_CompDiag:
     assumes "Diag t" and "Diag u" and "Seq t u"
     shows "\<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
     proof -
       have "\<And>u. \<lbrakk> Diag t; Diag u; Seq t u \<rbrakk> \<Longrightarrow> \<lbrace>t \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         using eval_in_hom comp_cod_arr
       proof (induct t, simp_all)
         fix u f
         assume u: "Diag u"
         assume f: "C.arr f"
         assume 1: "Arr u \<and> \<^bold>\<langle>C.dom f\<^bold>\<rangle> = Cod u"
         show "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = V f \<cdot> \<lbrace>u\<rbrace>"
           using f u 1 as_nat_trans.preserves_comp_2 by (cases u; simp)
         next
         fix u v w
         assume I1: "\<And>u. \<lbrakk> Diag v; Diag u; Arr u \<and> Dom v = Cod u \<rbrakk> \<Longrightarrow>
                          \<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>v\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         assume I2: "\<And>u. \<lbrakk> Diag w; Diag u; Arr u \<and> Dom w = Cod u \<rbrakk> \<Longrightarrow>
                          \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = \<lbrace>w\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         assume vw: "Diag (Tensor v w)"
         have v: "Diag v \<and> v = Prim (un_Prim v)"
           using vw by (simp add: Diag_TensorE)
         have w: "Diag w"
           using vw by (simp add: Diag_TensorE)
         assume u: "Diag u"
         assume 1: "Arr v \<and> Arr w \<and> Arr u \<and> Dom v \<^bold>\<otimes> Dom w = Cod u"
         show "\<lbrace>(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> u\<rbrace> = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
           using u 1 eval_in_hom CompDiag_in_Hom
         proof (cases u, simp_all)
           fix x y
           assume 3: "u = x \<^bold>\<otimes> y"
           assume 4: "Arr v \<and> Arr w \<and> Dom v = Cod x \<and> Dom w = Cod y"
           have x: "Diag x"
             using u 1 3 Diag_TensorE [of x y] by simp
           have y: "Diag y"
             using u x 1 3 Diag_TensorE [of x y] by simp
           show "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> x\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> y\<rbrace> = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<cdot> (\<lbrace>x\<rbrace> \<otimes> \<lbrace>y\<rbrace>)"
             using v w x y 4 I1 I2 CompDiag_in_Hom eval_in_hom Diag_implies_Arr interchange
             by auto
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       For identity terms @{term a} and @{term b}, the reduction @{term "(a \<^bold>\<otimes> b)\<^bold>\<down>"}
       factors (under evaluation in \<open>D\<close>) into the parallel reduction @{term "a\<^bold>\<down> \<^bold>\<otimes> b\<^bold>\<down>"},
       followed by a reduction of its codomain @{term "\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>"}.
 \<close>
 
     lemma eval_red_Tensor:
     assumes "Ide a" and "Ide b"
     shows "\<lbrace>(a \<^bold>\<otimes> b)\<^bold>\<down>\<rbrace> = \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>)"
     proof -
       have "Diag (a \<^bold>\<otimes> b) \<Longrightarrow> ?thesis"
         using assms Can_red2 Ide_implies_Arr red_Diag
               Diagonalize_Diag red2_Diag Can_implies_Arr iso_eval_Can iso_is_arr
         apply simp
         using Diag_TensorE eval_Tensor Diagonalize_Diag Diag_implies_Arr red_Diag
               tensor_preserves_ide ide_eval_Ide dom_eval comp_arr_dom
         by metis
       moreover have "\<not> Diag (a \<^bold>\<otimes> b) \<Longrightarrow> ?thesis"
         using assms Can_red2 by (simp add: Can_red(1) iso_eval_Can)
       ultimately show ?thesis by blast
     qed
 
     lemma eval_red2_Diag_Unity:
     assumes "Ide a" and "Diag a"
     shows "\<lbrace>a \<^bold>\<Down> \<^bold>\<I>\<rbrace> = \<r>[\<lbrace>a\<rbrace>]"
       using assms tensor_preserves_ide \<rho>_ide_simp unitor_coincidence \<iota>_in_hom comp_cod_arr
       by (cases a, auto)
 
     text\<open>
       Define a formal arrow t to be ``coherent'' if the square formed by @{term t}, @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"}
       and the reductions @{term "Dom t\<^bold>\<down>"} and @{term "Cod t\<^bold>\<down>"} commutes under evaluation
       in \<open>D\<close>.  We will show that all formal arrows are coherent.
       Since the diagonalizations of canonical arrows are identities, a corollary is that parallel
       canonical arrows have equal evaluations.
 \<close>
 
     abbreviation coherent
     where "coherent t \<equiv> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
 
     text\<open>
       Diagonal arrows are coherent, since for such arrows @{term t} the reductions
       @{term "Dom t\<^bold>\<down>"} and @{term "Cod t\<^bold>\<down>"} are identities.
 \<close>
 
     lemma Diag_implies_coherent:
     assumes "Diag t"
     shows "coherent t"
       using assms Diag_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod
             Dom_preserves_Diag Cod_preserves_Diag Diagonalize_Diag red_Diag
             comp_arr_dom comp_cod_arr
       by simp
 
     text\<open>
       The evaluation of a coherent arrow @{term t} has a canonical factorization in \<open>D\<close>
       into the evaluations of a reduction @{term "Dom t\<^bold>\<down>"}, diagonalization @{term "\<^bold>\<lfloor>t\<^bold>\<rfloor>"},
       and inverse reduction @{term "Inv (Cod t\<^bold>\<down>)"}.
       This will later allow us to use the term @{term "Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"}
       as a normal form for @{term t}.
 \<close>
 
     lemma canonical_factorization:
     assumes "Arr t"
     shows "coherent t \<longleftrightarrow> \<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
     proof
       assume 1: "coherent t"
       have "inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>"
         using 1 by simp
       also have "... = (inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>t\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>t\<rbrace>"
         using assms 1 red_in_Hom inv_in_hom Arr_implies_Ide_Cod Can_red iso_eval_Can
               comp_cod_arr Ide_in_Hom inv_is_inverse
         by (simp add: comp_inv_arr)
       finally show "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
       next
       assume 1: "\<lbrace>t\<rbrace> = inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
       hence "\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>" by simp
       also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> inv \<lbrace>Cod t\<^bold>\<down>\<rbrace>) \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom t\<^bold>\<down>\<rbrace>"
         using assms 1 red_in_Hom Arr_implies_Ide_Cod Can_red iso_eval_Can inv_is_inverse
               Diagonalize_in_Hom comp_arr_inv comp_cod_arr Arr_implies_Ide_Dom Diagonalize_in_Hom
         by auto
       finally show "coherent t" by blast
     qed
 
     text\<open>
       A canonical arrow is coherent if and only if its formal inverse is.
 \<close>
 
     lemma Can_implies_coherent_iff_coherent_Inv:
     assumes "Can t"
     shows "coherent t \<longleftrightarrow> coherent (Inv t)"
     proof
       have 1: "\<And>t. Can t \<Longrightarrow> coherent t \<Longrightarrow> coherent (Inv t)"
       proof -
         fix t
         assume "Can t"
         hence t: "Can t \<and> Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and>
                   arr \<lbrace>t\<rbrace> \<and> iso \<lbrace>t\<rbrace> \<and> inverse_arrows \<lbrace>t\<rbrace> (inv \<lbrace>t\<rbrace>) \<and>
                   Can \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Arr \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> arr \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> iso \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                   inverse_arrows \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<and> Inv t \<in> Hom (Cod t) (Dom t)"
           using assms Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod iso_eval_Can
                 inv_is_inverse Diagonalize_in_Hom Diagonalize_preserves_Can Inv_in_Hom
           by simp
         assume coh: "coherent t"
         have "\<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace> = (inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace>) \<cdot> \<lbrace>Cod (Inv t)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv t\<rbrace>"
           using t red_in_Hom comp_cod_arr comp_inv_arr
           by (simp add: canonical_factorization coh Diagonalize_preserves_Can
               \<open>Can t\<close> inv_is_inverse)
         also have "... = inv \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> inv \<lbrace>t\<rbrace>"
           using t eval_Inv_Can coh comp_assoc by auto
         also have "... = \<lbrace>\<^bold>\<lfloor>Inv t\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (Inv t)\<^bold>\<down>\<rbrace>"
           using t Diagonalize_Inv eval_Inv_Can comp_arr_inv red_in_Hom comp_arr_dom comp_assoc
           by auto
         finally show "coherent (Inv t)" by blast
       qed
       show "coherent t \<Longrightarrow> coherent (Inv t)" using assms 1 by simp
       show "coherent (Inv t) \<Longrightarrow> coherent t"
       proof -
         assume "coherent (Inv t)"
         hence "coherent (Inv (Inv t))"
           using assms 1 Inv_preserves_Can by blast
         thus ?thesis using assms by simp
       qed
     qed
 
     text\<open>
       Some special cases of coherence are readily dispatched.
 \<close>
 
     lemma coherent_Unity:
     shows "coherent \<^bold>\<I>"
       by simp
 
     lemma coherent_Prim:
     assumes "Arr \<^bold>\<langle>f\<^bold>\<rangle>"
     shows "coherent \<^bold>\<langle>f\<^bold>\<rangle>"
       using assms by simp
 
     lemma coherent_Lunit_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<l>\<^bold>[a\<^bold>]"
     proof -
       have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
                ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
       thus ?thesis
         using a lunit_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>"] comp_cod_arr by auto
     qed
       
     lemma coherent_Runit_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<r>\<^bold>[a\<^bold>]"
     proof -
       have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
                ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<lbrace>a\<^bold>\<down>\<rbrace> \<in> hom \<lbrace>a\<rbrace> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>"
         using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom
         by auto
       have "\<lbrace>Cod \<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<r>\<^bold>[a\<^bold>]\<rbrace> = \<lbrace>a\<^bold>\<down>\<rbrace> \<cdot> \<r>[\<lbrace>a\<rbrace>]"
         using a runit_in_hom comp_cod_arr by simp
       also have "... = \<r>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>] \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<I>)"
         using a eval_Runit runit_naturality [of "\<lbrace>red a\<rbrace>"] by auto
       also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<r>\<^bold>[a\<^bold>]\<^bold>\<down>\<rbrace>"
       proof -
         have "\<not> Diag (a \<^bold>\<otimes> \<^bold>\<I>)" by (cases a; simp)
         thus ?thesis
           using a comp_cod_arr red2_in_Hom eval_red2_Diag_Unity Diag_Diagonalize
                 Diagonalize_preserves_Ide
           by auto
       qed
       finally show ?thesis by blast
     qed
 
     lemma coherent_Lunit'_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
       using assms Ide_implies_Can coherent_Lunit_Ide
             Can_implies_coherent_iff_coherent_Inv [of "Lunit a"] by simp
 
     lemma coherent_Runit'_Ide:
     assumes "Ide a"
     shows "coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[a\<^bold>]"
       using assms Ide_implies_Can coherent_Runit_Ide
             Can_implies_coherent_iff_coherent_Inv [of "Runit a"] by simp
 
     text\<open>
       To go further, we need the next result, which is in some sense the crux of coherence:
       For diagonal identities @{term a}, @{term b}, and @{term c},
       the reduction @{term "((a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c) \<^bold>\<cdot> ((a \<^bold>\<Down> b) \<^bold>\<otimes> c)"} from @{term "(a \<^bold>\<otimes> b) \<^bold>\<otimes> c"}
       that first reduces the subterm @{term "a \<^bold>\<otimes> b"} and then reduces the result,
       is equivalent under evaluation in \<open>D\<close> to the reduction that first
       applies the associator @{term "\<^bold>\<a>\<^bold>[a, b, c\<^bold>]"} and then applies the reduction
       @{term "(a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (a \<^bold>\<otimes> (b \<^bold>\<Down> c))"} from @{term "a \<^bold>\<otimes> (b \<^bold>\<otimes> c)"}.
       The triangle and pentagon axioms are used in the proof.
 \<close>
 
     lemma coherence_key_fact:
     assumes "Ide a \<and> Diag a" and "Ide b \<and> Diag b" and "Ide c \<and> Diag c"
     shows "\<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
              = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
     proof -
       have "b = \<^bold>\<I> \<Longrightarrow> ?thesis"
         using assms not_is_Tensor_TensorDiagE eval_red2_Diag_Unity triangle
               comp_cod_arr comp_assoc
         by simp
         text \<open>The triangle is used!\<close>
       moreover have "c = \<^bold>\<I> \<Longrightarrow> ?thesis"
         using assms TensorDiag_preserves_Diag TensorDiag_preserves_Ide
               not_is_Tensor_TensorDiagE eval_red2_Diag_Unity
               red2_in_Hom runit_tensor runit_naturality [of "\<lbrace>a \<^bold>\<Down> b\<rbrace>"] comp_assoc
         by simp
       moreover have "\<lbrakk> b \<noteq> \<^bold>\<I>; c \<noteq> \<^bold>\<I> \<rbrakk> \<Longrightarrow> ?thesis"
       proof -
         assume b': "b \<noteq> \<^bold>\<I>"
         hence b: "Ide b \<and> Diag b \<and> Arr b \<and> b \<noteq> \<^bold>\<I> \<and>
                   ide \<lbrace>b\<rbrace> \<and> arr \<lbrace>b\<rbrace> \<and> \<^bold>\<lfloor>b\<^bold>\<rfloor> = b \<and> b\<^bold>\<down> = b \<and> Dom b = b \<and> Cod b = b"
           using assms Diagonalize_preserves_Ide Ide_in_Hom by simp
         assume c': "c \<noteq> \<^bold>\<I>"
         hence c: "Ide c \<and> Diag c \<and> Arr c \<and> c \<noteq> \<^bold>\<I> \<and>
                   ide \<lbrace>c\<rbrace> \<and> arr \<lbrace>c\<rbrace> \<and> \<^bold>\<lfloor>c\<^bold>\<rfloor> = c \<and> c\<^bold>\<down> = c \<and> Dom c = c \<and> Cod c = c"
           using assms Diagonalize_preserves_Ide Ide_in_Hom by simp
         have "\<And>a. Ide a \<and> Diag a \<Longrightarrow>
                    \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                       = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
         proof -
           fix a :: "'c term"
           show "Ide a \<and> Diag a \<Longrightarrow>
                 \<lbrace>(a \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>a \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                    = (\<lbrace>a \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (\<lbrace>a\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             apply (induct a)
             using b c TensorDiag_in_Hom apply simp_all
           proof -
             show "\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>b\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)
                     = ((\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> \<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]) \<cdot> (\<I> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               have "\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<l>[\<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>] \<cdot> (\<I> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] =
                     \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>b \<^bold>\<Down> c\<rbrace> \<cdot> \<l>[\<lbrace>b\<rbrace> \<otimes> \<lbrace>c\<rbrace>])  \<cdot> \<a>[\<I>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using b c red2_in_Hom lunit_naturality [of "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] by simp
               thus ?thesis
                 using b c red2_in_Hom lunit_tensor comp_arr_dom comp_cod_arr comp_assoc by simp
             qed
             show "\<And>f. C.ide f \<and> C.arr f \<Longrightarrow>
                        \<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                          = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               fix f
               assume f: "C.ide f \<and> C.arr f"
               show "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                       = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
               proof -
                 have "\<lbrace>(\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<otimes> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                         = ((V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                           ((V f \<otimes> \<lbrace>b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>)"
                 proof -
                   have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b\<rbrace> = V f \<otimes> \<lbrace>b\<rbrace>"
                     using assms f b c red2_Diag by simp
                   moreover have "\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> = V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>"
                   proof -
                     have "is_Tensor (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)"
                       using assms b c not_is_Tensor_TensorDiagE by blast
                     thus ?thesis
                       using assms f b c red2_Diag TensorDiag_preserves_Diag(1)
                       by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"; simp)
                   qed
                   ultimately show ?thesis
                     using assms b c by (cases c, simp_all)
                 qed
                 also have "... = ((V f \<otimes> \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                   using b c f TensorDiag_in_Hom red2_in_Hom comp_arr_dom comp_cod_arr
                   by simp
                 also have "... = (\<lbrace>\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> (V f \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[V f, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                     using b c f Ide_implies_Arr TensorDiag_preserves_Ide not_is_Tensor_TensorDiagE
                     by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c", simp_all; blast)
                 finally show ?thesis by blast
               qed
             qed
             fix d e
             assume I: "Diag e \<Longrightarrow> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                                     = (\<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace> \<cdot> (\<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             assume de: "Ide d \<and> Ide e \<and> Diag (d \<^bold>\<otimes> e)"
             show "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                     = (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot> \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
             proof -
               let ?f = "un_Prim d"
               have "is_Prim d"
                 using de by (cases d, simp_all)
               hence "d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f"
                 using de by (cases d, simp_all)
               hence d: "Ide d \<and> Arr d \<and> Dom d = d \<and> Cod d = d \<and> Diag d \<and>
                         d = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.ide ?f \<and> ide \<lbrace>d\<rbrace> \<and> arr \<lbrace>d\<rbrace>"
                 using de ide_eval_Ide Ide_implies_Arr Diag_Diagonalize(1) Ide_in_Hom
                       Diag_TensorE [of d e]
                 by simp
               have "Diag e \<and> e \<noteq> \<^bold>\<I>"
                 using de Diag_TensorE by metis
               hence e: "Ide e \<and> Arr e \<and> Dom e = e \<and> Cod e = e \<and> Diag e \<and>
                         e \<noteq> \<^bold>\<I> \<and> ide \<lbrace>e\<rbrace> \<and> arr \<lbrace>e\<rbrace>"
                 using de Ide_in_Hom by simp
               have 1: "is_Tensor (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<and> is_Tensor (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c) \<and> is_Tensor (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))"
                 using b c e de not_is_Tensor_TensorDiagE TensorDiag_preserves_Diag
                       not_is_Tensor_TensorDiagE [of e "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c"]
                 by auto
               have "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)
                       = ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                          \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]) \<cdot>
                         ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
               proof -
                 have "\<lbrace>((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>
                          = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot>
                            \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]"
                 proof -
                   have "((d \<^bold>\<otimes> e) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<Down> c"
                     using b c d e de 1 TensorDiag_Diag TensorDiag_preserves_Diag TensorDiag_assoc
                           TensorDiag_Prim not_is_Tensor_Unity
                     by metis
                   also have "... = (d \<^bold>\<Down> (\<^bold>\<lfloor>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b, c\<^bold>]"
                     using c d 1 by (cases c) simp_all
                   also have "... = (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)) \<^bold>\<cdot> (d \<^bold>\<otimes> ((e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c)) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b, c\<^bold>]"
-                    using b c d e 1 TensorDiag_preserves_Diag red2_Diag TensorDiag_assoc
-                    by (cases d) auto
+                    by (metis 1 Diagonalize_Diag TensorDiag_assoc TensorDiag_preserves_Diag(1)
+                              b c d e is_Tensor_def red2.simps(4))
                   finally show ?thesis
                     using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Diag
                           TensorDiag_preserves_Ide
                     by simp
                 qed
                 moreover have "\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> b\<rbrace>
                                  = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>]"
                 proof -
                   have "(d \<^bold>\<otimes> e) \<^bold>\<Down> b = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
                       using b c d e de 1 TensorDiag_Prim Diagonalize_Diag
                       by (cases b) simp_all
                   also have "... = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
                     using b d e 1 TensorDiag_preserves_Diag red2_Diag
-                    by (cases d) auto
+                    by (metis Diag.simps(3) de term.disc(12))
                   finally have "(d \<^bold>\<otimes> e) \<^bold>\<Down> b = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> b)) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b\<^bold>]"
                     by simp
                   thus ?thesis using b d e eval_in_hom TensorDiag_in_Hom red2_in_Hom by simp
                 qed
                 ultimately show ?thesis by argo
               qed
               also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> \<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot>
                                ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>) \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
                 using b c d e red2_in_Hom TensorDiag_preserves_Ide
                       TensorDiag_preserves_Diag interchange comp_cod_arr comp_assoc
                 by simp
               also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
                 using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
                       TensorDiag_preserves_Diag assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e \<^bold>\<Down> b\<rbrace>" "\<lbrace>c\<rbrace>"]
                       comp_permute [of "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b\<rbrace>, \<lbrace>c\<rbrace>]" "(\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b\<rbrace>) \<otimes> \<lbrace>c\<rbrace>"
                                        "\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)" "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"]
                 by simp
               also have "... = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
                 using b c d e TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
                       TensorDiag_preserves_Diag interchange
                       comp_reduce [of "\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace>"
                                       "\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)"
                                       "\<lbrace>d\<rbrace> \<otimes> \<lbrace>(e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b) \<^bold>\<Down> c\<rbrace> \<cdot> (\<lbrace>e \<^bold>\<Down> b\<rbrace> \<otimes> \<lbrace>c\<rbrace>)"
                                       "\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"]
                  by simp
               also have "... = (((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                 (\<lbrace>d\<rbrace> \<otimes> \<a>[\<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>])) \<cdot>
                                \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace> \<otimes> \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>] \<cdot> (\<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>] \<otimes> \<lbrace>c\<rbrace>)"
                 using b c d e I TensorDiag_in_Hom red2_in_Hom TensorDiag_preserves_Ide
                       TensorDiag_preserves_Diag interchange
                 by simp
               also have "... = ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> (\<lbrace>e\<rbrace> \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>))) \<cdot>
                                  \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace> \<otimes> \<lbrace>c\<rbrace>] \<cdot> \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
                 using b c d e comp_assoc red2_in_Hom TensorDiag_in_Hom ide_eval_Ide
                       TensorDiag_preserves_Diag tensor_preserves_ide TensorDiag_preserves_Ide
                       pentagon
                 by simp
               text \<open>The pentagon is used!\<close>
               also have "... = (((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>) \<cdot>
                                  \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]) \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
-                using b c d e 1 red2_in_Hom TensorDiag_preserves_Ide
-                      TensorDiag_preserves_Diag assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"]
-                      comp_cod_arr comp_assoc
+                using b c d e red2_in_Hom TensorDiag_preserves_Ide TensorDiag_preserves_Diag
+                      assoc_naturality [of "\<lbrace>d\<rbrace>" "\<lbrace>e\<rbrace>" "\<lbrace>b \<^bold>\<Down> c\<rbrace>"] comp_cod_arr comp_assoc
                 by simp
               also have "... = (\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace> \<cdot> ((\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>) \<otimes> \<lbrace>b \<^bold>\<Down> c\<rbrace>)) \<cdot>
                                \<a>[\<lbrace>d\<rbrace> \<otimes> \<lbrace>e\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
               proof -
                 have "\<lbrace>(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>
                            = (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot> (\<lbrace>d\<rbrace> \<otimes> \<lbrace>e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)\<rbrace>) \<cdot>
                               \<a>[\<lbrace>d\<rbrace>, \<lbrace>e\<rbrace>, \<lbrace>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<rbrace>]"
                 proof -
                   have "(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)
                           = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>\<rfloor>)) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
                     using b c e not_is_Tensor_TensorDiagE
                     by (cases "b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c") auto
                   also have "... = (d \<^bold>\<Down> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
                     using b c d e 1 TensorDiag_preserves_Diag Diagonalize_Diag by simp
                   also have "... = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
                                    \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
                     using b c d e 1 TensorDiag_preserves_Diag(1) red2_Diag
-                    by (cases d) auto
+                    by (metis Diag.simps(3) de not_is_Tensor_Unity)
                   finally have "(d \<^bold>\<otimes> e) \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c)
                                   = (d \<^bold>\<otimes> (e \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot> (d \<^bold>\<otimes> (e \<^bold>\<Down> (b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c))) \<^bold>\<cdot>
                                     \<^bold>\<a>\<^bold>[d, e, b \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> c\<^bold>]"
                     by blast
                   thus ?thesis
                     using b c d e red2_in_Hom TensorDiag_in_Hom TensorDiag_preserves_Diag
                           TensorDiag_preserves_Ide
                     by simp
                 qed
                 thus ?thesis using d e b c by simp
               qed
               finally show ?thesis by simp
             qed
           qed
         qed
         thus ?thesis using assms(1) by blast
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma coherent_Assoc_Ide:
     assumes "Ide a" and "Ide b" and "Ide c"
     shows "coherent \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
     proof -
       have a: "Ide a \<and> Arr a \<and> Dom a = a \<and> Cod a = a \<and>
                ide \<lbrace>a\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>a\<^bold>\<down>\<rbrace> : \<lbrace>a\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
         using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
       have b: "Ide b \<and> Arr b \<and> Dom b = b \<and> Cod b = b \<and>
                ide \<lbrace>b\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>b\<^bold>\<down>\<rbrace> : \<lbrace>b\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
         using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
       have c: "Ide c \<and> Arr c \<and> Dom c = c \<and> Cod c = c \<and>
                ide \<lbrace>c\<rbrace> \<and> ide \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<and> \<guillemotleft>\<lbrace>c\<^bold>\<down>\<rbrace> : \<lbrace>c\<rbrace> \<rightarrow> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>\<guillemotright>"
         using assms Ide_implies_Arr Ide_in_Hom Diagonalize_preserves_Ide red_in_Hom by auto
       have "\<lbrace>Cod \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<rbrace>
               = (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<otimes> (\<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
                  (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)) \<cdot> \<a>[\<lbrace>a\<rbrace>, \<lbrace>b\<rbrace>, \<lbrace>c\<rbrace>]"
         using a b c red_in_Hom red2_in_Hom Diagonalize_in_Hom Diag_Diagonalize
               Diagonalize_preserves_Ide interchange Ide_in_Hom eval_red_Tensor
               comp_cod_arr [of "\<lbrace>a\<^bold>\<down>\<rbrace>"]
         by simp
       also have "... = ((\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> (\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>c\<^bold>\<rfloor>)\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
                         \<a>[\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace>, \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>]) \<cdot> ((\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"
         using a b c red_in_Hom Diag_Diagonalize TensorDiag_preserves_Diag
                assoc_naturality [of "\<lbrace>a\<^bold>\<down>\<rbrace>" "\<lbrace>b\<^bold>\<down>\<rbrace>" "\<lbrace>c\<^bold>\<down>\<rbrace>"] comp_assoc
          by simp
       also have "... = (\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace>)) \<cdot>
                        ((\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"
         using a b c Diag_Diagonalize Diagonalize_preserves_Ide coherence_key_fact by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom \<^bold>\<a>\<^bold>[a, b, c\<^bold>]\<^bold>\<down>\<rbrace>"
         using a b c red_in_Hom red2_in_Hom TensorDiag_preserves_Diag
               Diagonalize_preserves_Ide TensorDiag_preserves_Ide Diag_Diagonalize interchange
               eval_red_Tensor TensorDiag_assoc comp_cod_arr [of "\<lbrace>c\<^bold>\<down>\<rbrace>"]
               comp_cod_arr [of "\<lbrace>(\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>b\<^bold>\<rfloor>) \<^bold>\<Down> \<^bold>\<lfloor>c\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>a\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>b\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>a\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>b\<^bold>\<down>\<rbrace>) \<otimes> \<lbrace>c\<^bold>\<down>\<rbrace>)"]
               comp_assoc
         by simp
       finally show ?thesis by blast
     qed
 
     lemma coherent_Assoc'_Ide:
     assumes "Ide a" and "Ide b" and "Ide c"
     shows "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>]"
     proof -
       have "Can \<^bold>\<a>\<^bold>[a, b, c\<^bold>]" using assms Ide_implies_Can by simp
       moreover have "\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[a, b, c\<^bold>] = Inv \<^bold>\<a>\<^bold>[a, b, c\<^bold>]"
         using assms Inv_Ide by simp
       ultimately show ?thesis
         using assms Ide_implies_Can coherent_Assoc_Ide Inv_Ide
               Can_implies_coherent_iff_coherent_Inv
         by metis
     qed
 
     text\<open>
       The next lemma implies coherence for the special case of a term that is the tensor
       of two diagonal arrows.
 \<close>
 
     lemma eval_red2_naturality:
     assumes "Diag t" and "Diag u"
     shows "\<lbrace>Cod t \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>t \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom t \<^bold>\<Down> Dom u\<rbrace>"
     proof -
       have *: "\<And>t u. Diag (t \<^bold>\<otimes> u) \<Longrightarrow> arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>u\<rbrace>"
         using Diag_implies_Arr by force
       have "t = \<^bold>\<I> \<Longrightarrow> ?thesis"
         using assms Diag_implies_Arr lunit_naturality [of "\<lbrace>u\<rbrace>"]
               Arr_implies_Ide_Dom Arr_implies_Ide_Cod comp_cod_arr
         by simp
       moreover have "t \<noteq> \<^bold>\<I> \<and> u = \<^bold>\<I> \<Longrightarrow> ?thesis"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod
               Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
               eval_red2_Diag_Unity runit_naturality [of "\<lbrace>t\<rbrace>"]
         by simp
       moreover have "t \<noteq> \<^bold>\<I> \<and> u \<noteq> \<^bold>\<I> \<Longrightarrow> ?thesis"
         using assms * Arr_implies_Ide_Dom Arr_implies_Ide_Cod
               Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
         apply (induct t, simp_all)
       proof -
         fix f
         assume f: "C.arr f"
         assume "u \<noteq> \<^bold>\<I>"
         hence u: "u \<noteq> \<^bold>\<I> \<and>
                   Diag u \<and> Diag (Dom u) \<and> Diag (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
                   arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
           using assms(2) Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
                 Arr_implies_Ide_Dom Arr_implies_Ide_Cod
           by simp
         hence 1: "Dom u \<noteq> \<^bold>\<I> \<and> Cod u \<noteq> \<^bold>\<I>" using u by (cases u, simp_all)
         show "\<lbrace>\<^bold>\<langle>C.cod f\<^bold>\<rangle> \<^bold>\<Down> Cod u\<rbrace> \<cdot> (V f \<otimes> \<lbrace>u\<rbrace>) = (V f \<otimes> \<lbrace>u\<rbrace>) \<cdot> \<lbrace>\<^bold>\<langle>C.dom f\<^bold>\<rangle> \<^bold>\<Down> Dom u\<rbrace>"
           using f u 1 Diag_implies_Arr red2_Diag comp_arr_dom comp_cod_arr by simp
         next
         fix v w
         assume I2: "\<lbrakk> w \<noteq> Unity; Diag w \<rbrakk> \<Longrightarrow>
                       \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace> \<cdot> (\<lbrace>w\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>"
         assume "u \<noteq> \<^bold>\<I>"
         hence u: "u \<noteq> \<^bold>\<I> \<and> Arr u \<and> Arr (Dom u) \<and> Arr (Cod u) \<and>
                   Diag u \<and> Diag (Dom u) \<and> Diag (Cod u) \<and> Ide (Dom u) \<and> Ide (Cod u) \<and>
                   arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
           using assms(2) Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag
                 Arr_implies_Ide_Dom Arr_implies_Ide_Cod
           by simp
         assume vw: "Diag (v \<^bold>\<otimes> w)"
         let ?f = "un_Prim v"
         have "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f"
           using vw by (metis Diag_TensorE(1) Diag_TensorE(2))
         hence "Arr v \<and> v = \<^bold>\<langle>un_Prim v\<^bold>\<rangle> \<and> C.arr ?f \<and> Diag v" by (cases v; simp)
         hence v: "v = \<^bold>\<langle>?f\<^bold>\<rangle> \<and> C.arr ?f \<and> Arr v \<and> Ide (Dom v) \<and> Ide (Cod v) \<and> Diag v \<and>
                   Diag (Dom v) \<and> arr \<lbrace>v\<rbrace> \<and> arr \<lbrace>Dom v\<rbrace> \<and> arr \<lbrace>Cod v\<rbrace> \<and>
                   ide \<lbrace>Dom v\<rbrace> \<and> ide \<lbrace>Cod v\<rbrace>"
           by (cases v, simp_all)
         have "Diag w \<and> w \<noteq> \<^bold>\<I>"
           using vw v by (metis Diag.simps(3))
         hence w: "w \<noteq> \<^bold>\<I> \<and> Arr w \<and> Arr (Dom w) \<and> Arr (Cod w) \<and>
                   Diag w \<and> Diag (Dom w) \<and> Diag (Cod w) \<and>
                   Ide (Dom w) \<and> Ide (Cod w) \<and>
                   arr \<lbrace>w\<rbrace> \<and> arr \<lbrace>Dom w\<rbrace> \<and> arr \<lbrace>Cod w\<rbrace> \<and> ide \<lbrace>Dom w\<rbrace> \<and> ide \<lbrace>Cod w\<rbrace>"
           using vw * Diag_implies_Arr Dom_preserves_Diag Cod_preserves_Diag Arr_implies_Ide_Dom
                 Arr_implies_Ide_Cod ide_eval_Ide Ide_implies_Arr Ide_in_Hom
           by simp
         show "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)
                 = \<lbrace>(v \<^bold>\<otimes> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
         proof -
           have u': "Dom u \<noteq> \<^bold>\<I> \<and> Cod u \<noteq> \<^bold>\<I>" using u by (cases u) simp_all
           have w':  "Dom w \<noteq> \<^bold>\<I> \<and> Cod w \<noteq> \<^bold>\<I>" using w by (cases w) simp_all
           have D: "Diag (Dom v \<^bold>\<otimes> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u))"
           proof -
             have "Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u \<noteq> \<^bold>\<I>"
               using u u' w w' not_is_Tensor_TensorDiagE by blast
             moreover have "Diag (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u)"
               using u w TensorDiag_preserves_Diag by simp
             moreover have "Dom v = \<^bold>\<langle>C.dom ?f\<^bold>\<rangle>"
               using v by (cases v, simp_all)
             ultimately show ?thesis
               using u v w TensorDiag_preserves_Diag by auto
           qed
           have C: "Diag (Cod v \<^bold>\<otimes> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u))"
           proof -
             have "Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u \<noteq> \<^bold>\<I>"
               using u u' w w' not_is_Tensor_TensorDiagE by blast
             moreover have "Diag (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)"
               using u w TensorDiag_preserves_Diag by simp
             moreover have "Cod v = \<^bold>\<langle>C.cod ?f\<^bold>\<rangle>"
               using v by (cases v, simp_all)
             ultimately show ?thesis
               using u v w by (cases "Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u") simp_all
           qed
           have "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace> \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)
                   = (\<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                     \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
           proof -
             have "(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u
                     = (Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Cod v \<^bold>\<otimes> Cod w \<^bold>\<Down> Cod u) \<^bold>\<cdot>
                       \<^bold>\<a>\<^bold>[Cod v, Cod w, Cod u\<^bold>]"
               using u v w by (cases u, simp_all)
             hence "\<lbrace>(Cod v \<^bold>\<otimes> Cod w) \<^bold>\<Down> Cod u\<rbrace>
                      = \<lbrace>Cod v \<^bold>\<Down> (Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u)\<rbrace> \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                        \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
               using u v w by simp
             thus ?thesis by argo
           qed
           also have "... = ((\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot>
                             \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot> ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
             using u v w C red2_Diag by simp
           also have "... = ((\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<cdot> \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]) \<cdot>
                            ((\<lbrace>v\<rbrace> \<otimes> \<lbrace>w\<rbrace>) \<otimes> \<lbrace>u\<rbrace>)"
           proof -
             have "(\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) \<cdot> (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>)
                      = \<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>"
               using u v w comp_cod_arr red2_in_Hom by simp
             moreover have
                 "seq (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Cod u\<rbrace>) (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>)"
               using u v w red2_in_Hom TensorDiag_in_Hom Ide_in_Hom by simp
             moreover have "seq (\<lbrace>Cod v\<rbrace> \<otimes> \<lbrace>Cod w \<^bold>\<Down> Cod u\<rbrace>) \<a>[\<lbrace>Cod v\<rbrace>, \<lbrace>Cod w\<rbrace>, \<lbrace>Cod u\<rbrace>]"
               using u v w red2_in_Hom by simp
             ultimately show ?thesis
               using u v w comp_reduce by presburger
           qed
           also have
             "... = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using u v w I2 red2_in_Hom TensorDiag_in_Hom interchange comp_reduce
                   assoc_naturality [of "\<lbrace>v\<rbrace>" "\<lbrace>w\<rbrace>" "\<lbrace>u\<rbrace>"] comp_cod_arr comp_assoc
             by simp
           also have "... = (\<lbrace>v\<rbrace> \<otimes> \<lbrace>w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace>) \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using u v w red2_in_Hom TensorDiag_in_Hom interchange comp_reduce comp_arr_dom
             by simp
           also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                            \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             using u u' v w not_is_Tensor_TensorDiagE TensorDiag_Prim [of "w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u" ?f]
             by force
           also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
                           (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
           proof -
             have
               "\<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                  \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>] =
                (\<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace>) \<cdot>
                (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using u v w comp_arr_dom TensorDiag_in_Hom TensorDiag_preserves_Diag by simp
             also have "... = \<lbrace>v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot>
                             (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot> \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using comp_assoc by simp
             finally show ?thesis by blast
           qed
           also have "... = \<lbrace>(v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> w) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> u\<rbrace> \<cdot> \<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>"
           proof -
             have
               "\<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>
                      = \<lbrace>Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u)\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                        \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
             proof -
               have "(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u
                        = (Dom v \<^bold>\<Down> (Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>)) \<^bold>\<cdot> (Dom v \<^bold>\<otimes> (Dom w \<^bold>\<Down> Dom u)) \<^bold>\<cdot>
                          \<^bold>\<a>\<^bold>[Dom v, Dom w, Dom u\<^bold>]"
                 using u u' v w red2_in_Hom TensorDiag_in_Hom tensor_in_hom Ide_in_Hom
                 by (cases u) auto
               thus ?thesis
                 using u v w red2_in_Hom by simp
             qed
             also have
               "... = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                              \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               using D TensorDiag_Diag red2_Diag by simp
             finally have
               "\<lbrace>(Dom v \<^bold>\<otimes> Dom w) \<^bold>\<Down> Dom u\<rbrace>
                    = \<lbrace>Dom v \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom w \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> Dom u\<rbrace> \<cdot> (\<lbrace>Dom v\<rbrace> \<otimes> \<lbrace>Dom w \<^bold>\<Down> Dom u\<rbrace>) \<cdot>
                      \<a>[\<lbrace>Dom v\<rbrace>, \<lbrace>Dom w\<rbrace>, \<lbrace>Dom u\<rbrace>]"
               by blast
             thus ?thesis
               using assms v w TensorDiag_assoc by auto
           qed
           finally show ?thesis
             using vw TensorDiag_Diag by simp
         qed
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma Tensor_preserves_coherent:
     assumes "Arr t" and "Arr u" and "coherent t" and "coherent u"
     shows "coherent (t \<^bold>\<otimes> u)"
     proof -
       have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
         by auto
       have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
                arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
         by auto
       have "\<lbrace>Cod (t \<^bold>\<otimes> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)
               = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Cod u\<^bold>\<down>\<rbrace>)) \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)"
         using t u eval_red_Tensor by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Cod u\<^bold>\<down>\<rbrace>) \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>)"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using assms t u Diagonalize_in_Hom red_in_Hom interchange by simp
       also have "... = (\<lbrace>\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor>\<rbrace> \<otimes> \<lbrace>\<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace>)) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using comp_assoc by simp
       also have "... = (\<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace>) \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using assms t u Diag_Diagonalize Diagonalize_in_Hom
               eval_red2_naturality [of "Diagonalize t" "Diagonalize u"]
         by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>\<rbrace> \<cdot> (\<lbrace>Dom t\<^bold>\<down>\<rbrace> \<otimes> \<lbrace>Dom u\<^bold>\<down>\<rbrace>)"
         using comp_assoc by simp
       also have "... = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<otimes> Dom u)\<^bold>\<down>\<rbrace>"
         using t u eval_red_Tensor by simp
       finally have "\<lbrace>Cod (t \<^bold>\<otimes> u)\<^bold>\<down>\<rbrace> \<cdot> (\<lbrace>t\<rbrace> \<otimes> \<lbrace>u\<rbrace>) = \<lbrace>\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>(Dom t \<^bold>\<otimes> Dom u)\<^bold>\<down>\<rbrace>"
         by blast
       thus ?thesis using t u by simp
     qed
 
     lemma Comp_preserves_coherent:
     assumes "Arr t" and "Arr u" and "Dom t = Cod u"
     and "coherent t" and "coherent u"
     shows "coherent (t \<^bold>\<cdot> u)"
     proof -
       have t: "Arr t \<and> Ide (Dom t) \<and> Ide (Cod t) \<and> Ide \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<and>
                arr \<lbrace>t\<rbrace> \<and> arr \<lbrace>Dom t\<rbrace> \<and> ide \<lbrace>Dom t\<rbrace> \<and> arr \<lbrace>Cod t\<rbrace> \<and> ide \<lbrace>Cod t\<rbrace>"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
         by auto
       have u: "Arr u \<and> Ide (Dom u) \<and> Ide (Cod u) \<and> Ide \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<and>
                arr \<lbrace>u\<rbrace> \<and> arr \<lbrace>Dom u\<rbrace> \<and> ide \<lbrace>Dom u\<rbrace> \<and> arr \<lbrace>Cod u\<rbrace> \<and> ide \<lbrace>Cod u\<rbrace>"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
         by auto
       have "\<lbrace>Cod (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t \<^bold>\<cdot> u\<rbrace> = \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace> \<cdot> \<lbrace>u\<rbrace>"
         using t u by simp
       also have "... = (\<lbrace>Cod t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>t\<rbrace>) \<cdot> \<lbrace>u\<rbrace>"
       proof -
         (* TODO: I still haven't figured out how to do this without spoon-feeding it. *)
         have "seq \<lbrace>Cod t\<^bold>\<down>\<rbrace> \<lbrace>t\<rbrace>"
           using assms t red_in_Hom by (intro seqI, auto)
         moreover have "seq \<lbrace>t\<rbrace> \<lbrace>u\<rbrace>"
           using assms t u by auto
         ultimately show ?thesis using comp_assoc by auto
       qed
       also have "... = \<lbrace>\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor>\<rbrace> \<cdot> \<lbrace>Dom (t \<^bold>\<cdot> u)\<^bold>\<down>\<rbrace>"
         using t u assms red_in_Hom Diag_Diagonalize comp_assoc
         by (simp add: Diag_implies_Arr eval_CompDiag)
       finally show "coherent (t \<^bold>\<cdot> u)" by blast
     qed
 
     text\<open>
       The main result: ``Every formal arrow is coherent.''
 \<close>
 
     theorem coherence:
     assumes "Arr t"
     shows "coherent t"
     proof -
       have "Arr t \<Longrightarrow> coherent t"
       proof (induct t)
         fix u v
         show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<otimes> v)
                   \<Longrightarrow> coherent (u \<^bold>\<otimes> v)"
           using Tensor_preserves_coherent by simp
         show "\<lbrakk> Arr u \<Longrightarrow> coherent u; Arr v \<Longrightarrow> coherent v \<rbrakk> \<Longrightarrow> Arr (u \<^bold>\<cdot> v)
                   \<Longrightarrow> coherent (u \<^bold>\<cdot> v)"
           using Comp_preserves_coherent by simp
         next
         show "coherent \<^bold>\<I>" by simp
         fix f
         show "Arr \<^bold>\<langle>f\<^bold>\<rangle> \<Longrightarrow> coherent \<^bold>\<langle>f\<^bold>\<rangle>" by simp
         next
         fix t
         assume I: "Arr t \<Longrightarrow> coherent t"
         show Lunit: "Arr \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^bold>[t\<^bold>]"
           using I Arr_implies_Ide_Dom coherent_Lunit_Ide Ide_in_Hom Ide_implies_Arr
                 Comp_preserves_coherent [of t "\<^bold>\<l>\<^bold>[Dom t\<^bold>]"] Diagonalize_Comp_Arr_Dom \<ll>_ide_simp
           by auto
         show Runit: "Arr \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^bold>[t\<^bold>]"
           using I Arr_implies_Ide_Dom coherent_Runit_Ide Ide_in_Hom Ide_implies_Arr
                 Comp_preserves_coherent [of t "\<^bold>\<r>\<^bold>[Dom t\<^bold>]"] Diagonalize_Comp_Arr_Dom \<rho>_ide_simp
           by auto
         show "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         proof -
           assume "Arr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
           hence t: "Arr t" by simp
           have "coherent (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
             using t I Arr_implies_Ide_Cod coherent_Lunit'_Ide Ide_in_Hom
                   Comp_preserves_coherent [of "\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
             by fastforce
           thus ?thesis
             using t Arr_implies_Ide_Cod Ide_implies_Arr Ide_in_Hom Diagonalize_Comp_Cod_Arr
                   eval_in_hom \<ll>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
             by force
         qed
         show "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> coherent \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
         proof -
           assume "Arr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]"
           hence t: "Arr t" by simp
           have "coherent (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>] \<^bold>\<cdot> t)"
             using t I Arr_implies_Ide_Cod coherent_Runit'_Ide Ide_in_Hom
                   Comp_preserves_coherent [of "\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[Cod t\<^bold>]" t]
             by fastforce
           thus ?thesis
             using t Arr_implies_Ide_Cod Ide_implies_Arr Ide_in_Hom Diagonalize_Comp_Cod_Arr
                   eval_in_hom \<rho>'.is_natural_2 [of "\<lbrace>t\<rbrace>"]
             by force
         qed
         next
         fix t u v
         assume I1: "Arr t \<Longrightarrow> coherent t"
         assume I2: "Arr u \<Longrightarrow> coherent u"
         assume I3: "Arr v \<Longrightarrow> coherent v"
         show "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
         proof -
           assume tuv: "Arr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]"
           have t: "Arr t" using tuv by simp
           have u: "Arr u" using tuv by simp
           have v: "Arr v" using tuv by simp
           have "coherent ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
           proof -
             have "Arr (t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<and> coherent (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
             proof
               have 1: "Arr t \<and> coherent t" using t I1 by simp
               have 2: "Arr (u \<^bold>\<otimes> v) \<and> coherent (u \<^bold>\<otimes> v)"
                 using u v I2 I3 Tensor_preserves_coherent by force
               show "Arr (t \<^bold>\<otimes> u \<^bold>\<otimes> v) " using 1 2 by simp
               show "coherent (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
                 using 1 2 Tensor_preserves_coherent by blast
             qed
             moreover have "Arr \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom by simp
             moreover have "coherent \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom coherent_Assoc_Ide by blast
             moreover have "Dom (t \<^bold>\<otimes> u \<^bold>\<otimes> v) = Cod \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom Ide_in_Hom by simp
             ultimately show ?thesis
               using t u v Arr_implies_Ide_Dom Ide_implies_Arr
                     Comp_preserves_coherent [of "t \<^bold>\<otimes> u \<^bold>\<otimes> v" "\<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]"]
               by blast
           qed
           moreover have "Par \<^bold>\<a>\<^bold>[t, u, v\<^bold>] ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
             using t u v Arr_implies_Ide_Dom Ide_implies_Arr Ide_in_Hom by simp
           moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>(t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
           proof -
             have "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>
                      = (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> ((\<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>)"
             proof -
               have 1: "Diag \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Diag \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Diag \<^bold>\<lfloor>v\<^bold>\<rfloor> \<and>
                        Dom \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom u\<^bold>\<rfloor> \<and> Dom \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom v\<^bold>\<rfloor>"
                 using t u v Diag_Diagonalize by blast
               moreover have "Diag (\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>)"
                 using 1 TensorDiag_preserves_Diag(1) by blast
               moreover have "\<And>t. Arr t \<Longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Dom t\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
                 using t Diagonalize_Comp_Arr_Dom by simp
               moreover have "Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>Dom \<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor>"
                 using Diag_Diagonalize tuv by blast
               ultimately show ?thesis
                 using t u v tuv 1 TensorDiag_assoc TensorDiag_preserves_Diag(2)
                 by (metis (no_types) Diagonalize.simps(9))
             qed
             thus ?thesis
               using t u v Diagonalize_Comp_Arr_Dom CompDiag_TensorDiag Diag_Diagonalize
               by simp
           qed
           moreover have "\<lbrace>\<^bold>\<a>\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>(t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
             using t u v Arr_implies_Ide_Dom Ide_implies_Arr \<alpha>_simp [of "\<lbrace>t\<rbrace>" "\<lbrace>u\<rbrace>" "\<lbrace>v\<rbrace>"]
             by simp
           ultimately show "coherent \<^bold>\<a>\<^bold>[t, u, v\<^bold>]" by argo
         qed
         show "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] \<Longrightarrow> coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
         proof -
           assume tuv: "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]"
           have t: "Arr t" using tuv by simp
           have u: "Arr u" using tuv by simp
           have v: "Arr v" using tuv by simp
           have "coherent (((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
           proof -
             have "Arr ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<and> coherent ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)"
             proof
               have 1: "Arr v \<and> coherent v" using v I3 by simp
               have 2: "Arr (t \<^bold>\<otimes> u) \<and> coherent (t \<^bold>\<otimes> u)"
                 using t u I1 I2 Tensor_preserves_coherent by force
               show "Arr ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)" using 1 2 by simp
               show "coherent ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)"
                 using 1 2 Tensor_preserves_coherent by blast
             qed
             moreover have "Arr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom by simp
             moreover have "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom coherent_Assoc'_Ide by blast
             moreover have "Dom ((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) = Cod \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"
               using t u v Arr_implies_Ide_Dom Ide_in_Hom by simp
             ultimately show ?thesis
               using t u v Arr_implies_Ide_Dom Ide_implies_Arr
                     Comp_preserves_coherent [of "((t \<^bold>\<otimes> u) \<^bold>\<otimes> v)" "\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]"]
               by metis
           qed
           moreover have "Par \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] (((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>])"
             using t u v Arr_implies_Ide_Dom Ide_implies_Arr Ide_in_Hom by simp
           moreover have "\<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<^bold>\<rfloor> = \<^bold>\<lfloor>((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<^bold>\<rfloor>"
             using t u v Diagonalize_Comp_Arr_Dom CompDiag_TensorDiag Diag_Diagonalize
                   TensorDiag_assoc TensorDiag_preserves_Diag TensorDiag_in_Hom
                   CompDiag_Diag_Dom [of "(\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
             by simp
           moreover have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]\<rbrace> = \<lbrace>((t \<^bold>\<otimes> u) \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Dom t, Dom u, Dom v\<^bold>]\<rbrace>"
             using t u v Arr_implies_Ide_Dom Ide_implies_Arr eval_in_hom comp_cod_arr
                   \<alpha>'.is_natural_1 \<alpha>'_simp
             by simp
           ultimately show "coherent \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]" by argo
         qed
       qed
       thus ?thesis using assms by blast
     qed
 
     text\<open>
       MacLane \cite{MacLane71} says: ``A coherence theorem asserts `Every diagram commutes',''
       but that is somewhat misleading.  A coherence theorem provides some kind of hopefully
       useful way of distinguishing diagrams that definitely commute from diagrams that might not.
       The next result expresses coherence for monoidal categories in this way.
       As the hypotheses can be verified algorithmically (using the functions @{term Dom},
       @{term Cod}, @{term Arr}, and @{term Diagonalize}) if we are given an oracle for equality
       of arrows in \<open>C\<close>, the result provides a decision procedure, relative to \<open>C\<close>,
       for the word problem for the free monoidal category generated by \<open>C\<close>.
 \<close>
 
     corollary eval_eqI:
     assumes "Par t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
       using assms coherence canonical_factorization by simp
 
     text\<open>
       Our final corollary expresses coherence in a more ``MacLane-like'' fashion:
       parallel canonical arrows are equivalent under evaluation.
 \<close>
 
     corollary maclane_coherence:
     assumes "Par t u" and "Can t" and "Can u"
     shows "\<lbrace>t\<rbrace> = \<lbrace>u\<rbrace>"
     proof (intro eval_eqI)
       show "Par t u" by fact
       show "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
       proof -
         have "Ide \<^bold>\<lfloor>t\<^bold>\<rfloor> \<and> Ide \<^bold>\<lfloor>u\<^bold>\<rfloor> \<and> Par \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor>"
           using assms eval_eqI Ide_Diagonalize_Can Diagonalize_in_Hom by simp
         thus ?thesis using Ide_in_Hom by auto
       qed
     qed
 
   end
 
 end