(*  Title:       FreeMonoidalCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "The Free Monoidal Category"

text_raw\<open>
\label{fmc-chap}
\<close>

theory FreeMonoidalCategory
imports Category3.Subcategory MonoidalFunctor
begin

  text \<open>
    In this theory, we use the monoidal language of a category @{term C} defined in
    @{theory MonoidalCategory.MonoidalCategory} to give a construction of the free monoidal category
    \<open>\<F>C\<close> generated by @{term C}.
    The arrows of \<open>\<F>C\<close> are the equivalence classes of formal arrows obtained
    by declaring two formal arrows to be equivalent if they are parallel and have the
    same diagonalization.
    Composition, tensor, and the components of the associator and unitors are all
    defined in terms of the corresponding syntactic constructs.
    After defining \<open>\<F>C\<close> and showing that it does indeed have the structure of
    a monoidal category, we prove the freeness: every functor from @{term C} to a
    monoidal category @{term D} extends uniquely to a strict monoidal functor from
    \<open>\<F>C\<close> to @{term D}.

    We then consider the full subcategory \<open>\<F>\<^sub>SC\<close> of \<open>\<F>C\<close> whose objects
    are the equivalence classes of diagonal identity terms
    ({\em i.e.}~equivalence classes of lists of identity arrows of @{term C}),
    and we show that this category is monoidally equivalent to \<open>\<F>C\<close>.
    In addition, we show that \<open>\<F>\<^sub>SC\<close> is the free strict monoidal category,
    as any functor from \<open>C\<close> to a strict monoidal category @{term D} extends uniquely
    to a strict monoidal functor from \<open>\<F>\<^sub>SC\<close> to @{term D}.
\<close>

  section "Syntactic Construction"

  locale free_monoidal_category =
    monoidal_language C
    for C :: "'c comp"
  begin

    no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
    notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")

    text \<open>
      Two terms of the monoidal language of @{term C} are defined to be equivalent if
      they are parallel formal arrows with the same diagonalization.
\<close>

    abbreviation equiv
    where "equiv t u \<equiv> Par t u \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"

    text \<open>
      Arrows of \<open>\<F>C\<close> will be the equivalence classes of formal arrows
      determined by the relation @{term equiv}.  We define here the property of being an
      equivalence class of the relation @{term equiv}.  Later we show that this property
      coincides with that of being an arrow of the category that we will construct.
\<close>

    type_synonym 'a arr = "'a term set"
    definition ARR where "ARR f \<equiv> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = Collect (equiv t))"

    lemma not_ARR_empty:
    shows "\<not>ARR {}"
      using ARR_def by simp

    lemma ARR_eqI:
    assumes "ARR f" and "ARR g" and "f \<inter> g \<noteq> {}"
    shows "f = g"
      using assms ARR_def by fastforce

    text \<open>
      We will need to choose a representative of each equivalence class as a normal form.
      The requirements we have of these representatives are: (1) the normal form of an
      arrow @{term t} is equivalent to @{term t}; (2) equivalent arrows have identical
      normal forms; (3) a normal form is a canonical term if and only if its diagonalization
      is an identity.  It follows from these properties and coherence that a term and its
      normal form have the same evaluation in any monoidal category.  We choose here as a
      normal form for an arrow @{term t} the particular term @{term "Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"}.
      However, the only specific properties of this definition we actually use are the
      three we have just stated.
\<close>

    definition norm  ("\<^bold>\<parallel>_\<^bold>\<parallel>")
    where "\<^bold>\<parallel>t\<^bold>\<parallel> = Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"

    text \<open>
      If @{term t} is a formal arrow, then @{term t} is equivalent to its normal form.
\<close>

    lemma equiv_norm_Arr:
    assumes "Arr t"
    shows "equiv \<^bold>\<parallel>t\<^bold>\<parallel> t"
    proof -
      have "Par t (Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)"
        using assms Diagonalize_in_Hom red_in_Hom Inv_in_Hom Arr_implies_Ide_Dom
                Arr_implies_Ide_Cod Ide_implies_Arr Can_red
        by auto
      moreover have "\<^bold>\<lfloor>(Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
        using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
              Diagonalize_in_Hom Diagonalize_Inv [of "Cod t\<^bold>\<down>"] Diag_Diagonalize
              CompDiag_Diag_Dom [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"] CompDiag_Cod_Diag [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
        by (simp add: Diagonalize_red [of "Cod t"] Can_red(1))
      ultimately show ?thesis using norm_def by simp
    qed

    text \<open>
      Equivalent arrows have identical normal forms.
\<close>

    lemma norm_respects_equiv:
    assumes "equiv t u"
    shows "\<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
      using assms norm_def by simp

    text \<open>
      The normal form of an arrow is canonical if and only if its diagonalization
      is an identity term.
\<close>

    lemma Can_norm_iff_Ide_Diagonalize:
    assumes "Arr t"
    shows "Can \<^bold>\<parallel>t\<^bold>\<parallel> \<longleftrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
      using assms norm_def Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
            Inv_preserves_Can Diagonalize_preserves_Can red_in_Hom Diagonalize_in_Hom
            Ide_Diagonalize_Can
      by fastforce

    text \<open>
      We now establish various additional properties of normal forms that are consequences
      of the three already proved.  The definition \<open>norm_def\<close> is not used subsequently.
\<close>

    lemma norm_preserves_Can:
    assumes "Can t"
    shows "Can \<^bold>\<parallel>t\<^bold>\<parallel>"
      using assms Can_implies_Arr Can_norm_iff_Ide_Diagonalize Ide_Diagonalize_Can by simp

    lemma Par_Arr_norm:
    assumes "Arr t"
    shows "Par \<^bold>\<parallel>t\<^bold>\<parallel> t"
      using assms equiv_norm_Arr by auto

    lemma Diagonalize_norm [simp]:
    assumes "Arr t"
    shows " \<^bold>\<lfloor>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
      using assms equiv_norm_Arr by auto

    lemma unique_norm:
    assumes "ARR f"
    shows "\<exists>!t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t"
    proof
      have 1: "(SOME t. t \<in> f) \<in> f"
        using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] by auto
      show "\<And>t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t \<Longrightarrow> t = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
        using assms ARR_def 1 by auto
      show "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
        using assms ARR_def 1 norm_respects_equiv by blast
    qed

    lemma Dom_norm:
    assumes "Arr t"
    shows "Dom \<^bold>\<parallel>t\<^bold>\<parallel> = Dom t"
      using assms Par_Arr_norm by metis

    lemma Cod_norm:
    assumes "Arr t"
    shows "Cod \<^bold>\<parallel>t\<^bold>\<parallel> = Cod t"
      using assms Par_Arr_norm by metis

    lemma norm_in_Hom:
    assumes "Arr t"
    shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> Hom (Dom t) (Cod t)"
      using assms Par_Arr_norm [of t] by simp

    text \<open>
      As all the elements of an equivalence class have the same normal form, we can
      use the normal form of an arbitrarily chosen element as a canonical representative.
\<close>

    definition rep where "rep f \<equiv> \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"

    lemma rep_in_ARR:
    assumes "ARR f"
    shows "rep f \<in> f"
      using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] equiv_norm_Arr rep_def ARR_def
      by fastforce

    lemma Arr_rep_ARR:
    assumes "ARR f"
    shows "Arr (rep f)"
      using assms ARR_def rep_in_ARR by auto

    text \<open>
      We next define a function \<open>mkarr\<close> that maps formal arrows to their equivalence classes.
      For terms that are not formal arrows, the function yields the empty set.
\<close>

    definition mkarr where "mkarr t = Collect (equiv t)"

    lemma mkarr_extensionality:
    assumes "\<not>Arr t"
    shows "mkarr t = {}"
      using assms mkarr_def by simp

    lemma ARR_mkarr:
    assumes "Arr t"
    shows "ARR (mkarr t)"
      using assms ARR_def mkarr_def by auto

    lemma mkarr_memb_ARR:
    assumes "ARR f" and "t \<in> f"
    shows "mkarr t = f"
      using assms ARR_def mkarr_def by simp

    lemma mkarr_rep_ARR [simp]:
    assumes "ARR f"
    shows "mkarr (rep f) = f"
      using assms rep_in_ARR mkarr_memb_ARR by auto

    lemma Arr_in_mkarr:
    assumes "Arr t"
    shows "t \<in> mkarr t"
      using assms mkarr_def by simp

    text \<open>
      Two terms are related by @{term equiv} iff they are both formal arrows
      and have identical normal forms.
\<close>

    lemma equiv_iff_eq_norm:
    shows "equiv t u \<longleftrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
    proof
      show "equiv t u \<Longrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
        using mkarr_def Arr_in_mkarr ARR_mkarr unique_norm by blast
      show "Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel> \<Longrightarrow> equiv t u"
        using Par_Arr_norm Diagonalize_norm by metis
    qed

    lemma norm_norm [simp]:
    assumes "Arr t"
    shows "\<^bold>\<parallel>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>"
    proof -
      have "t \<in> mkarr t"
        using assms Arr_in_mkarr by blast
      moreover have "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> mkarr t"
        using assms equiv_norm_Arr mkarr_def by simp
      ultimately show ?thesis using assms ARR_mkarr unique_norm by auto
    qed

    lemma norm_in_ARR:
    assumes "ARR f" and "t \<in> f"
    shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> f"
      using assms ARR_def equiv_iff_eq_norm norm_norm Par_Arr_norm by fastforce

    lemma norm_rep_ARR [simp]:
    assumes "ARR f"
    shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
      using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] rep_def norm_norm by fastforce

    lemma norm_memb_eq_rep_ARR:
    assumes "ARR f" and "t \<in> f"
    shows "norm t = rep f"
      using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] unique_norm rep_def by metis

    lemma rep_mkarr:
    assumes "Arr f"
    shows "rep (mkarr f) = \<^bold>\<parallel>f\<^bold>\<parallel>"
      using assms ARR_mkarr Arr_in_mkarr norm_memb_eq_rep_ARR by fastforce

    text \<open>
      To prove that two terms determine the same equivalence class,
      it suffices to show that they are parallel formal arrows with
      identical diagonalizations.
\<close>

    lemma mkarr_eqI [intro]:
    assumes "Par f g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
    shows "mkarr f = mkarr g"
      using assms by (metis ARR_mkarr equiv_iff_eq_norm rep_mkarr mkarr_rep_ARR)

    text \<open>
      We use canonical representatives to lift the formal domain and codomain functions
      from terms to equivalence classes.
\<close>

    abbreviation DOM where "DOM f \<equiv> Dom (rep f)"
    abbreviation COD where "COD f \<equiv> Cod (rep f)"

    lemma DOM_mkarr:
    assumes "Arr t"
    shows "DOM (mkarr t) = Dom t"
      using assms rep_mkarr by (metis Par_Arr_norm)

    lemma COD_mkarr:
    assumes "Arr t"
    shows "COD (mkarr t) = Cod t"
      using assms rep_mkarr by (metis Par_Arr_norm)

    text \<open>
      A composition operation can now be defined on equivalence classes
      using the syntactic constructor \<open>Comp\<close>.
\<close>

    definition comp      (infixr "\<cdot>" 55)
      where "comp f g \<equiv> (if ARR f \<and> ARR g \<and> DOM f = COD g
                         then mkarr ((rep f) \<^bold>\<cdot> (rep g)) else {})"

    text \<open>
      We commence the task of showing that the composition \<open>comp\<close> so defined
      determines a category.
\<close>

    interpretation partial_magma comp
      apply unfold_locales
      using comp_def not_ARR_empty by metis

    notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    text \<open>
      The empty set serves as the null for the composition.
\<close>

    lemma null_char:
    shows "null = {}"
    proof -
      let ?P = "\<lambda>n. \<forall>f. f \<cdot> n = n \<and> n \<cdot> f = n"
      have "?P {}" using comp_def not_ARR_empty by simp
      moreover have "\<exists>!n. ?P n" using ex_un_null by metis
      ultimately show ?thesis using null_def theI_unique [of ?P "{}"]
        by (metis comp_null(2))
    qed

    lemma ARR_comp:
    assumes "ARR f" and "ARR g" and "DOM f = COD g"
    shows "ARR (f \<cdot> g)"
      using assms comp_def Arr_rep_ARR ARR_mkarr(1) by simp

    lemma DOM_comp [simp]:
    assumes "ARR f" and "ARR g" and "DOM f = COD g"
    shows "DOM (f \<cdot> g) = DOM g"
      using assms comp_def ARR_comp Arr_rep_ARR DOM_mkarr by simp

    lemma COD_comp [simp]:
    assumes "ARR f" and "ARR g" and "DOM f = COD g"
    shows "COD (f \<cdot> g) = COD f"
      using assms comp_def ARR_comp Arr_rep_ARR COD_mkarr by simp

    lemma comp_assoc:
    assumes "g \<cdot> f \<noteq> null" and "h \<cdot> g \<noteq> null"
    shows "h \<cdot> (g \<cdot> f) = (h \<cdot> g) \<cdot> f"
    proof -
      have 1: "ARR f \<and> ARR g \<and> ARR h \<and> DOM h = COD g \<and> DOM g = COD f"
        using assms comp_def not_ARR_empty null_char by metis
      hence 2: "Arr (rep f) \<and> Arr (rep g) \<and> Arr (rep h) \<and>
                Dom (rep h) = Cod (rep g) \<and> Dom (rep g) = Cod (rep f)"
        using Arr_rep_ARR by simp
      have 3: "h \<cdot> g \<cdot> f = mkarr (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f)))"
        using 1 comp_def ARR_comp COD_comp by simp
      also have "... = mkarr (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
      proof -
        have "equiv (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
        proof -
          have "Par (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
            using 1 2 3 DOM_mkarr ARR_comp COD_comp mkarr_extensionality not_ARR_empty
            by (metis Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
            (* Here metis claims it is not using snd_map_prod, but removing it fails. *)
          moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
            using 1 2 Arr_rep_ARR rep_mkarr rep_in_ARR assms(1) ARR_comp mkarr_extensionality
                  comp_def equiv_iff_eq_norm norm_memb_eq_rep_ARR null_char
            by auto
          ultimately show ?thesis using equiv_iff_eq_norm by blast
        qed
        thus ?thesis
          using mkarr_def by force
      qed
      also have "... = mkarr ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
      proof -
        have "Par (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
          using 2 by simp
        moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
          using 2 Diag_Diagonalize by (simp add: CompDiag_assoc)
        ultimately show ?thesis
          using equiv_iff_eq_norm by (simp add: mkarr_def)
      qed
      also have "... = mkarr (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f)"
      proof -
        have "equiv (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
        proof -
          have "Par (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
            using 1 2 Arr_rep_ARR DOM_comp ARR_comp COD_comp comp_def by auto
          moreover have "\<^bold>\<lfloor>rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
            using assms(2) 1 2 ARR_comp Arr_rep_ARR mkarr_extensionality rep_mkarr rep_in_ARR
                  equiv_iff_eq_norm norm_memb_eq_rep_ARR comp_def null_char
            by simp
          ultimately show ?thesis using equiv_iff_eq_norm by blast
        qed
        thus ?thesis
          using mkarr_def by auto
      qed
      also have "... = (h \<cdot> g) \<cdot> f"
        using 1 comp_def ARR_comp DOM_comp by simp
      finally show ?thesis by blast
    qed

    lemma Comp_in_comp_ARR:
    assumes "ARR f" and "ARR g" and "DOM f = COD g"
    and "t \<in> f" and "u \<in> g"
    shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
    proof -
      have "equiv (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
      proof -
        have 1: "Par (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
          using assms ARR_def Arr_rep_ARR COD_mkarr DOM_mkarr mkarr_memb_ARR
                mkarr_extensionality
          by (metis (no_types, lifting) Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
          (* Here metis claims it is not using snd_map_prod, but removing it fails. *)
        moreover have "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> rep g\<^bold>\<rfloor>"
          using assms 1 rep_in_ARR equiv_iff_eq_norm norm_memb_eq_rep_ARR
          by (metis (no_types, lifting) Arr.simps(4) Diagonalize.simps(4))
        ultimately show ?thesis by simp
      qed
      thus ?thesis
        using assms comp_def mkarr_def by simp
    qed

    text \<open>
      Ultimately, we will show that that the identities of the category are those
      equivalence classes, all of whose members diagonalize to formal identity arrows,
      having the further property that their canonical representative is a formal
      endo-arrow.
\<close>

    definition IDE where "IDE f \<equiv> ARR f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>) \<and> DOM f = COD f"

    lemma IDE_implies_ARR:
    assumes "IDE f"
    shows "ARR f"
      using assms IDE_def ARR_def by auto

    lemma IDE_mkarr_Ide:
    assumes "Ide a"
    shows "IDE (mkarr a)"
    proof -
      have "DOM (mkarr a) = COD (mkarr a)"
        using assms mkarr_def equiv_iff_eq_norm Par_Arr_norm COD_mkarr DOM_mkarr Ide_in_Hom
        by (metis Ide_implies_Can Inv_Ide Ide_implies_Arr Inv_preserves_Can(2))
      moreover have "ARR (mkarr a) \<and> (\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
      proof -
        have "ARR (mkarr a)" using assms ARR_mkarr Ide_implies_Arr by simp
        moreover have "\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
          using assms mkarr_def Diagonalize_preserves_Ide by fastforce
        ultimately show ?thesis by blast
      qed
      ultimately show ?thesis using IDE_def by blast
    qed

    lemma IDE_implies_ide:
    assumes "IDE a"
    shows "ide a"
    proof (unfold ide_def)
      have "a \<cdot> a \<noteq> null"
      proof -
        have "rep a \<^bold>\<cdot> rep a \<in> a \<cdot> a"
          using assms IDE_def comp_def Arr_rep_ARR Arr_in_mkarr by simp
        thus ?thesis
          using null_char by auto
      qed
      moreover have "\<And>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f)"
      proof
        fix f :: "'c arr"
        show "a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f"
        proof
          assume f: "a \<cdot> f \<noteq> null"
          hence "ARR f"
            using comp_def null_char by auto
          have "rep a \<^bold>\<cdot> rep f \<in> a \<cdot> f"
            using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
          moreover have "rep a \<^bold>\<cdot> rep f \<in> f"
          proof -
            have "rep f \<in> f"
              using \<open>ARR f\<close> rep_in_ARR by auto
            moreover have "equiv (rep a \<^bold>\<cdot> rep f) (rep f)"
            proof -
              have 1: "Par (rep a \<^bold>\<cdot> rep f) (rep f)"
                using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
                by (metis Cod.simps(4) Dom.simps(4))
              moreover have "\<^bold>\<lfloor>rep a \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
                using assms f 1 comp_def IDE_def CompDiag_Ide_Diag Diag_Diagonalize(1)
                      Diag_Diagonalize(2) Diag_Diagonalize(3) rep_in_ARR
                by auto
              ultimately show ?thesis by auto
            qed
            ultimately show ?thesis
              using \<open>ARR f\<close> ARR_def by auto
          qed
          ultimately show "a \<cdot> f = f"
            using mkarr_memb_ARR comp_def by auto
        qed
        show "f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f"
        proof
          assume f: "f \<cdot> a \<noteq> null"
          hence "ARR f"
            using comp_def null_char by auto
          have "rep f \<^bold>\<cdot> rep a \<in> f \<cdot> a"
            using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
          moreover have "rep f \<^bold>\<cdot> rep a \<in> f"
          proof -
            have "rep f \<in> f"
              using \<open>ARR f\<close> rep_in_ARR by auto
            moreover have "equiv (rep f \<^bold>\<cdot> rep a) (rep f)"
            proof -
              have 1: "Par (rep f \<^bold>\<cdot> rep a) (rep f)"
                using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
                by (metis Cod.simps(4) Dom.simps(4))
              moreover have "\<^bold>\<lfloor>rep f \<^bold>\<cdot> rep a\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
                using assms f 1 comp_def IDE_def CompDiag_Diag_Ide
                      Diag_Diagonalize(1) Diag_Diagonalize(2) Diag_Diagonalize(3)
                      rep_in_ARR
                by force
              ultimately show ?thesis by auto
            qed
            ultimately show ?thesis
              using \<open>ARR f\<close> ARR_def by auto
          qed
          ultimately show "f \<cdot> a = f"
            using mkarr_memb_ARR comp_def by auto
        qed
      qed
      ultimately show "a \<cdot> a \<noteq> null \<and>
                       (\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"
        by blast
    qed

    lemma ARR_iff_has_domain:
    shows "ARR f \<longleftrightarrow> domains f \<noteq> {}"
    proof
      assume f: "domains f \<noteq> {}"
      show "ARR f" using f domains_def comp_def null_char by auto
      next
      assume f: "ARR f"
      have "Ide (DOM f)"
        using f ARR_def by (simp add: Arr_implies_Ide_Dom Arr_rep_ARR)
      hence "IDE (mkarr (DOM f))" using IDE_mkarr_Ide by metis
      hence "ide (mkarr (DOM f))" using IDE_implies_ide by simp
      moreover have "f \<cdot> mkarr (DOM f) = f"
      proof -
        have 1: "rep f \<^bold>\<cdot> DOM f \<in> f \<cdot> mkarr (DOM f)"
          using f Comp_in_comp_ARR
          using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (DOM f))\<close>
                \<open>Ide (DOM f)\<close> Arr_in_mkarr COD_mkarr
          by fastforce
        moreover have "rep f \<^bold>\<cdot> DOM f \<in> f"
        proof -
          have 2: "rep f \<in> f" using f rep_in_ARR by simp
          moreover have "equiv (rep f \<^bold>\<cdot> DOM f) (rep f)"
            using f 1 2 mkarr_memb_ARR mkarr_extensionality \<open>ide (mkarr (DOM f))\<close>
                  emptyE equiv_iff_eq_norm norm_memb_eq_rep_ARR null_char ide_def
            by metis
          ultimately show ?thesis
            using f ARR_eqI 1 \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
        qed
        ultimately show ?thesis
          using f ARR_eqI \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
      qed
      ultimately show "domains f \<noteq> {}"
        using f domains_def not_ARR_empty null_char by auto
    qed

    lemma ARR_iff_has_codomain:
    shows "ARR f \<longleftrightarrow> codomains f \<noteq> {}"
    proof
      assume f: "codomains f \<noteq> {}"
      show "ARR f" using f codomains_def comp_def null_char by auto
      next
      assume f: "ARR f"
      have "Ide (COD f)"
        using f ARR_def by (simp add: Arr_rep_ARR Arr_implies_Ide_Cod)
      hence "IDE (mkarr (COD f))" using IDE_mkarr_Ide by metis
      hence "ide (mkarr (COD f))" using IDE_implies_ide by simp
      moreover have "mkarr (COD f) \<cdot> f = f"
      proof -
        have 1: "COD f \<^bold>\<cdot> rep f \<in> mkarr (COD f) \<cdot> f"
          using f Comp_in_comp_ARR
          using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (COD f))\<close>
                \<open>Ide (COD f)\<close> Arr_in_mkarr DOM_mkarr
          by fastforce
        moreover have "COD f \<^bold>\<cdot> rep f \<in> f"
          using 1 null_char norm_rep_ARR norm_memb_eq_rep_ARR mkarr_memb_ARR
                \<open>ide (mkarr (COD f))\<close> emptyE equiv_iff_eq_norm mkarr_extensionality ide_def
          by metis
        ultimately show ?thesis
          using f ARR_eqI \<open>ide (mkarr (COD f))\<close> null_char ide_def by auto
      qed
      ultimately show "codomains f \<noteq> {}"
        using codomains_def f not_ARR_empty null_char by auto
    qed

    lemma arr_iff_ARR:
    shows "arr f \<longleftrightarrow> ARR f"
      using arr_def ARR_iff_has_domain ARR_iff_has_codomain by simp

    text \<open>
      The arrows of the category are the equivalence classes of formal arrows.
\<close>

    lemma arr_char:
    shows "arr f \<longleftrightarrow> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = mkarr t)"
      using arr_iff_ARR ARR_def mkarr_def by simp

    lemma seq_char:
    shows "seq g f \<longleftrightarrow> g \<cdot> f \<noteq> null"
    proof
      show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
        using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
              Arr_rep_ARR arr_iff_ARR
        by auto
      show "seq g f \<Longrightarrow> g \<cdot> f \<noteq> null"
        by auto
    qed

    lemma seq_char':
    shows "seq g f \<longleftrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
    proof
      show "ARR f \<and> ARR g \<and> DOM g = COD f \<Longrightarrow> seq g f"
        using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
              Arr_rep_ARR arr_iff_ARR
        by auto
      have "\<not> (ARR f \<and> ARR g \<and> DOM g = COD f) \<Longrightarrow> g \<cdot> f = null"
        using comp_def null_char by auto
      thus "seq g f \<Longrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
        using ext by fastforce
    qed

    text \<open>
      Finally, we can show that the composition \<open>comp\<close> determines a category.
\<close>

    interpretation category comp
    proof
      show "\<And>f. domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
        using ARR_iff_has_domain ARR_iff_has_codomain by simp
      show 1: "\<And>f g. g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
        using comp_def ARR_comp null_char arr_iff_ARR by metis
      fix f g h
      show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
        using seq_char' by auto
      show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
        using seq_char' by auto
      show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
        using seq_char' ARR_comp arr_iff_ARR by auto
      show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
        using seq_char comp_assoc by auto
    qed

    lemma mkarr_rep [simp]:
    assumes "arr f"
    shows "mkarr (rep f) = f"
      using assms arr_iff_ARR by simp

    lemma arr_mkarr [simp]:
    assumes "Arr t"
    shows "arr (mkarr t)"
      using assms by (simp add: ARR_mkarr arr_iff_ARR)

    lemma mkarr_memb:
    assumes "t \<in> f" and "arr f"
    shows "Arr t" and "mkarr t = f"
      using assms arr_char mkarr_extensionality by auto

    lemma rep_in_arr [simp]:
    assumes "arr f"
    shows "rep f \<in> f"
      using assms by (simp add: rep_in_ARR arr_iff_ARR)

    lemma Arr_rep [simp]:
    assumes "arr f"
    shows "Arr (rep f)"
      using assms mkarr_memb rep_in_arr by blast

    lemma rep_in_Hom:
    assumes "arr f"
    shows "rep f \<in> Hom (DOM f) (COD f)"
      using assms by simp

    lemma norm_memb_eq_rep:
    assumes "arr f" and "t \<in> f"
    shows "\<^bold>\<parallel>t\<^bold>\<parallel> = rep f"
      using assms arr_iff_ARR norm_memb_eq_rep_ARR by auto

    lemma norm_rep:
    assumes "arr f"
    shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
      using assms norm_memb_eq_rep by simp

    text \<open>
      Composition, domain, and codomain on arrows reduce to the corresponding
      syntactic operations on their representative terms.
\<close>

    lemma comp_mkarr [simp]:
    assumes "Arr t" and "Arr u" and "Dom t = Cod u"
    shows "mkarr t \<cdot> mkarr u = mkarr (t \<^bold>\<cdot> u)"
      using assms
      by (metis (no_types, lifting) ARR_mkarr ARR_comp ARR_def Arr_in_mkarr COD_mkarr
          Comp_in_comp_ARR DOM_mkarr mkarr_def)

    lemma dom_simp:
    assumes "arr f"
    shows "dom f = mkarr (DOM f)"
      using assms dom_char by simp

    lemma cod_char:
    shows "cod f = (if arr f then mkarr (COD f) else null)"
    proof -
      have "\<not>arr f \<Longrightarrow> ?thesis"
        using cod_def by (simp add: arr_def)
      moreover have "arr f \<Longrightarrow> ?thesis"
      proof -
        assume f: "arr f"
        have "cod f = mkarr (COD f)"
        proof (intro cod_eqI)
          have 1: "Ide (COD f)"
            using f arr_char by (metis Arr_rep Arr_implies_Ide_Cod)
          hence 2: "IDE (mkarr (COD f))"
            using IDE_mkarr_Ide by metis
          thus "ide (mkarr (COD f))" using IDE_implies_ide by simp
          moreover show "seq (mkarr (COD f)) f"
          proof -
            have "mkarr (COD f) \<cdot> f \<noteq> null"
              using f 1 2 ARR_def DOM_mkarr IDE_implies_ARR Ide_in_Hom ARR_comp IDE_def
                    ARR_iff_has_codomain ARR_iff_has_domain null_char arr_def
              by (metis (mono_tags, lifting) mem_Collect_eq)
            thus ?thesis using seq_char by simp
          qed
        qed
        thus ?thesis using f by simp
      qed
      ultimately show ?thesis by blast
    qed

    lemma cod_simp:
    assumes "arr f"
    shows "cod f = mkarr (COD f)"
      using assms cod_char by simp

    lemma Dom_memb:
    assumes "arr f" and "t \<in> f"
    shows "Dom t = DOM f"
      using assms DOM_mkarr mkarr_extensionality arr_char by fastforce

    lemma Cod_memb:
    assumes "arr f" and "t \<in> f"
    shows "Cod t = COD f"
      using assms COD_mkarr mkarr_extensionality arr_char by fastforce

    lemma dom_mkarr [simp]:
    assumes "Arr t"
    shows "dom (mkarr t) = mkarr (Dom t)"
      using assms dom_char DOM_mkarr arr_mkarr by auto

    lemma cod_mkarr [simp]:
    assumes "Arr t"
    shows "cod (mkarr t) = mkarr (Cod t)"
      using assms cod_char COD_mkarr arr_mkarr by auto

    lemma mkarr_in_hom:
    assumes "Arr t"
    shows "\<guillemotleft>mkarr t : mkarr (Dom t) \<rightarrow> mkarr (Cod t)\<guillemotright>"
      using assms arr_mkarr dom_mkarr cod_mkarr by auto

    lemma DOM_in_dom [intro]:
    assumes "arr f"
    shows "DOM f \<in> dom f"
      using assms dom_char
      by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_dom not_arr_null null_char)

    lemma COD_in_cod [intro]:
    assumes "arr f"
    shows "COD f \<in> cod f"
      using assms cod_char
      by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_cod not_arr_null null_char)

    lemma DOM_dom:
    assumes "arr f"
    shows "DOM (dom f) = DOM f"
      using assms Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr dom_char rep_mkarr Par_Arr_norm
            Ide_in_Hom
      by simp

    lemma DOM_cod:
    assumes "arr f"
    shows "DOM (cod f) = COD f"
      using assms Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr cod_char rep_mkarr Par_Arr_norm
            Ide_in_Hom
      by simp

    lemma memb_equiv:
    assumes "arr f" and "t \<in> f" and "u \<in> f"
    shows "Par t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
    proof -
      show "Par t u"
        using assms Cod_memb Dom_memb mkarr_memb(1) by metis
      show "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
        using assms arr_iff_ARR ARR_def by auto
    qed

    text \<open>
      Two arrows can be proved equal by showing that they are parallel and
      have representatives with identical diagonalizations.
\<close>

    lemma arr_eqI:
    assumes "par f g" and "t \<in> f" and "u \<in> g" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
    shows "f = g"
    proof -
      have "Arr t \<and> Arr u" using assms mkarr_memb(1) by blast
      moreover have "Dom t = Dom u \<and> Cod t = Cod u"
        using assms Dom_memb Cod_memb comp_def arr_char comp_arr_dom comp_cod_arr
        by (metis (full_types))
      ultimately have "Par t u" by simp
      thus ?thesis
        using assms arr_char by (metis rep_mkarr rep_in_arr equiv_iff_eq_norm)
    qed

    lemma comp_char:
    shows "f \<cdot> g = (if seq f g then mkarr (rep f \<^bold>\<cdot> rep g) else null)"
      using comp_def seq_char arr_char by meson

    text \<open>
      The mapping that takes identity terms to their equivalence classes is injective.
\<close>

    lemma mkarr_inj_on_Ide:
    assumes "Ide t" and "Ide u" and "mkarr t = mkarr u"
    shows "t = u"
      using assms
      by (metis (mono_tags, lifting) COD_mkarr Ide_in_Hom mem_Collect_eq)

    lemma Comp_in_comp [intro]:
    assumes "arr f" and "g \<in> hom (dom g) (dom f)" and "t \<in> f" and "u \<in> g"
    shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
    proof -
      have "ARR f" using assms arr_iff_ARR by simp
      moreover have "ARR g" using assms arr_iff_ARR by auto
      moreover have "DOM f = COD g"
        using assms dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Cod Arr_implies_Ide_Dom
        by force
      ultimately show ?thesis using assms Comp_in_comp_ARR by simp
    qed

    text \<open>
      An arrow is defined to be ``canonical'' if some (equivalently, all) its representatives
      diagonalize to an identity term.
\<close>

    definition can
    where "can f \<equiv> arr f \<and> (\<exists>t. t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"

    lemma can_def_alt:
    shows "can f \<longleftrightarrow> arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
    proof
      assume "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
      thus "can f" using can_def arr_char by fastforce
      next
      assume f: "can f"
      show "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
      proof -
        obtain t where t: "t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>" using f can_def by auto
        have "ARR f" using f can_def arr_char ARR_def mkarr_def by simp
        hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>" using t unique_norm by auto
        hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
          using t by (metis \<open>ARR f\<close> equiv_iff_eq_norm arr_iff_ARR mkarr_memb(1))
        hence "\<forall>u. u \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>u\<^bold>\<rfloor>"
          using t by metis
        thus ?thesis using f can_def by blast
      qed
    qed

    lemma can_implies_arr:
    assumes "can f"
    shows "arr f"
      using assms can_def by auto

    text \<open>
      The identities of the category are precisely the canonical endo-arrows.
\<close>

    lemma ide_char:
    shows "ide f \<longleftrightarrow> can f \<and> dom f = cod f"
    proof
      assume f: "ide f"
      show "can f \<and> dom f = cod f"
        using f can_def arr_char dom_char cod_char IDE_def Arr_implies_Ide_Cod can_def_alt
              Arr_rep IDE_mkarr_Ide
        by (metis ideD(1) ideD(3))
      next
      assume f: "can f \<and> dom f = cod f"
      show "ide f"
      proof -
        have "f = dom f"
        proof (intro arr_eqI)
          show "par f (dom f)" using f can_def by simp
          show "rep f \<in> f" using f can_def by simp
          show "DOM f \<in> dom f" using f can_def by auto
          show "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
          proof -
            have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
              using f can_def Diagonalize_in_Hom by simp
            moreover have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" using f can_def_alt rep_in_arr by simp
            ultimately show ?thesis
              using f can_def Ide_in_Hom by simp
          qed
        qed
        thus ?thesis using f can_implies_arr ide_dom [of f] by auto
      qed
    qed

    lemma ide_iff_IDE:
    shows "ide a \<longleftrightarrow> IDE a"
      using ide_char IDE_def can_def_alt arr_iff_ARR dom_char cod_char mkarr_inj_on_Ide
            Arr_implies_Ide_Cod Arr_implies_Ide_Dom Arr_rep
      by auto

    lemma ide_mkarr_Ide:
    assumes "Ide a"
    shows "ide (mkarr a)"
      using assms IDE_mkarr_Ide ide_iff_IDE by simp

    lemma rep_dom:
    assumes "arr f"
    shows "rep (dom f) = \<^bold>\<parallel>DOM f\<^bold>\<parallel>"
      using assms dom_simp rep_mkarr Arr_rep Arr_implies_Ide_Dom by simp

    lemma rep_cod:
    assumes "arr f"
    shows "rep (cod f) = \<^bold>\<parallel>COD f\<^bold>\<parallel>"
      using assms cod_simp rep_mkarr Arr_rep Arr_implies_Ide_Cod by simp

    lemma rep_preserves_seq:
    assumes "seq g f"
    shows "Seq (rep g) (rep f)"
      using assms Arr_rep dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Dom
            Arr_implies_Ide_Cod
      by auto

    lemma rep_comp:
    assumes "seq g f"
    shows "rep (g \<cdot> f) = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
    proof -
      have "rep (g \<cdot> f) = rep (mkarr (rep g \<^bold>\<cdot> rep f))"
        using assms comp_char by metis
      also have "... = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
        using assms rep_preserves_seq rep_mkarr by simp
      finally show ?thesis by blast
    qed

    text \<open>
      The equivalence classes of canonical terms are canonical arrows.
\<close>

    lemma can_mkarr_Can:
    assumes "Can t"
    shows "can (mkarr t)"
      using assms Arr_in_mkarr Can_implies_Arr Ide_Diagonalize_Can arr_mkarr can_def by blast

    lemma ide_implies_can:
    assumes "ide a"
    shows "can a"
      using assms ide_char by blast

    lemma Can_rep_can:
    assumes "can f"
    shows "Can (rep f)"
    proof -
      have "Can \<^bold>\<parallel>rep f\<^bold>\<parallel>"
        using assms can_def_alt Can_norm_iff_Ide_Diagonalize by auto
      moreover have "rep f = \<^bold>\<parallel>rep f\<^bold>\<parallel>"
        using assms can_implies_arr norm_rep by simp
      ultimately show ?thesis by simp
    qed

    text \<open>
      Parallel canonical arrows are identical.
\<close>

    lemma can_coherence:
    assumes "par f g" and "can f" and "can g"
    shows "f = g"
    proof -
      have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
      proof -
        have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
          using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
        also have "... = \<^bold>\<lfloor>DOM g\<^bold>\<rfloor>"
          using assms dom_char equiv_iff_eq_norm
          by (metis DOM_in_dom mkarr_memb(1) rep_mkarr arr_dom_iff_arr)
        also have "... = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
          using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
        finally show ?thesis by blast
      qed
      hence "rep f = rep g"
        using assms rep_in_arr norm_memb_eq_rep equiv_iff_eq_norm
        by (metis (no_types, lifting) arr_eqI)
      thus ?thesis
        using assms arr_eqI [of f g] rep_in_arr [of f] rep_in_arr [of g] by metis
    qed

    text \<open>
      Canonical arrows are invertible, and their inverses can be obtained syntactically.
\<close>

    lemma inverse_arrows_can:
    assumes "can f"
    shows "inverse_arrows f (mkarr (Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>))"
    proof
      let ?t = "(Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>)"
      have 1: "rep f \<in> f \<and> Arr (rep f) \<and> Can (rep f) \<and> Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms can_def_alt rep_in_arr rep_in_arr(1) Can_rep_can by simp
      hence 2: "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
        using Diagonalize_in_Hom [of "rep f"] Ide_in_Hom by auto
      have 3: "Can ?t"
        using assms 1 2 Can_red Ide_implies_Can Diagonalize_in_Hom Inv_preserves_Can
              Arr_implies_Ide_Cod Arr_implies_Ide_Dom Diag_Diagonalize
        by simp
      have 4: "DOM f = Cod ?t"
        using assms can_def Can_red
        by (simp add: Arr_implies_Ide_Dom Inv_preserves_Can(3))
      have 5: "COD f = Dom ?t"
        using assms can_def Can_red Arr_rep Arr_implies_Ide_Cod by simp
      have 6: "antipar f (mkarr ?t)"
        using assms 3 4 5 dom_char cod_char can_def cod_mkarr dom_mkarr Can_implies_Arr
        by simp
      show "ide (f \<cdot> mkarr ?t)"
      proof -
        have 7: "par (f \<cdot> mkarr ?t) (dom (f \<cdot> mkarr ?t))"
          using assms 6 by auto
        moreover have "can (f \<cdot> mkarr ?t)"
        proof -
          have 8: "Comp (rep f) ?t \<in> (f \<cdot> mkarr ?t)"
            using assms 1 3 4 6 can_implies_arr Arr_in_mkarr COD_mkarr Comp_in_comp_ARR
                  Can_implies_Arr arr_iff_ARR seq_char'
            by meson
          moreover have "Can (rep f \<^bold>\<cdot> ?t)"
            using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
           ultimately show ?thesis
            using can_mkarr_Can 7 mkarr_memb(2) by metis
        qed
        moreover have "can (dom (f \<cdot> mkarr ?t))"
          using 7 ide_implies_can by force
        ultimately have "f \<cdot> mkarr ?t = dom (f \<cdot> mkarr ?t)"
          using can_coherence by meson
        thus ?thesis
          using 7 ide_dom by metis
      qed
      show "ide (mkarr ?t \<cdot> f)"
      proof -
        have 7: "par (mkarr ?t \<cdot> f) (cod (mkarr ?t \<cdot> f))"
          using assms 6 by auto
        moreover have "can (mkarr ?t \<cdot> f)"
        proof -
          have 8: "Comp ?t (rep f) \<in> mkarr ?t \<cdot> f"
            using assms 1 3 6 7 Arr_in_mkarr Comp_in_comp_ARR Can_implies_Arr arr_char
                  comp_def
            by meson
          moreover have "Can (?t \<^bold>\<cdot> rep f)"
            using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
          ultimately show ?thesis
            using can_mkarr_Can 7 mkarr_memb(2) by metis
        qed
        moreover have "can (cod (mkarr ?t \<cdot> f))"
          using 7 ide_implies_can by force
        ultimately have "mkarr ?t \<cdot> f = cod (mkarr ?t \<cdot> f)"
          using can_coherence by meson
        thus ?thesis
          using 7 can_implies_arr ide_cod by metis
      qed
    qed

    lemma inv_mkarr [simp]:
    assumes "Can t"
    shows "inv (mkarr t) = mkarr (Inv t)"
    proof -
      have t: "Can t \<and> Arr t \<and> Can (Inv t) \<and> Arr (Inv t) \<and> Ide (Dom t) \<and> Ide (Cod t)"
        using assms Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod
              Inv_preserves_Can
        by simp
      have "inverse_arrows (mkarr t) (mkarr (Inv t))"
      proof
        show "ide (mkarr t \<cdot> mkarr (Inv t))"
        proof -
          have "mkarr (Cod t) = mkarr (Comp t (Inv t))"
            using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
            by (intro mkarr_eqI, auto)
          also have "... = mkarr t \<cdot> mkarr (Inv t)"
            using t comp_mkarr Inv_in_Hom by simp
          finally have "mkarr (Cod t) = mkarr t \<cdot> mkarr (Inv t)"
            by blast
          thus ?thesis using t ide_mkarr_Ide [of "Cod t"] by simp
        qed
        show "ide (mkarr (Inv t) \<cdot> mkarr t)"
        proof -
          have "mkarr (Dom t) = mkarr (Inv t \<^bold>\<cdot> t)"
            using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
            by (intro mkarr_eqI, auto)
          also have "... = mkarr (Inv t) \<cdot> mkarr t"
            using t comp_mkarr Inv_in_Hom by simp
          finally have "mkarr (Dom t) = mkarr (Inv t) \<cdot> mkarr t"
            by blast
          thus ?thesis using t ide_mkarr_Ide [of "Dom t"] by simp
        qed
      qed
      thus ?thesis using inverse_unique by auto
    qed

    lemma iso_can:
    assumes "can f"
    shows "iso f"
      using assms inverse_arrows_can by auto

    text \<open>
      The following function produces the unique canonical arrow between two given objects,
      if such an arrow exists.
\<close>

    definition mkcan
    where "mkcan a b = mkarr (Inv (COD b\<^bold>\<down>) \<^bold>\<cdot> (DOM a\<^bold>\<down>))"

    lemma can_mkcan:
    assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
    shows "can (mkcan a b)" and "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
    proof -
      show "can (mkcan a b)"
        using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
              Inv_preserves_Can can_mkarr_Can
        by simp
      show "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
        using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red Inv_in_Hom
              dom_char [of a] cod_char [of b] mkarr_rep mkarr_in_hom can_implies_arr
        by auto
    qed

    lemma dom_mkcan:
    assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
    shows "dom (mkcan a b) = a"
      using assms can_mkcan by blast

    lemma cod_mkcan:
    assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
    shows "cod (mkcan a b) = b"
      using assms can_mkcan by blast

    lemma can_coherence':
    assumes "can f"
    shows "mkcan (dom f) (cod f) = f"
    proof -
      have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms Ide_Diagonalize_Can Can_rep_can by simp
      hence "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using Ide_in_Hom by simp
      hence "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
        using assms can_implies_arr Arr_rep Diagonalize_in_Hom by simp
      moreover have "DOM f = DOM (dom f)"
        using assms can_implies_arr dom_char rep_mkarr Arr_implies_Ide_Dom Ide_implies_Arr
              Par_Arr_norm [of "DOM f"] Ide_in_Hom
        by auto
      moreover have "COD f = COD (cod f)"
        using assms can_implies_arr cod_char rep_mkarr Arr_implies_Ide_Cod Ide_implies_Arr
              Par_Arr_norm [of "COD f"] Ide_in_Hom
        by auto
      ultimately have "can (mkcan (dom f) (cod f)) \<and> par f (mkcan (dom f) (cod f))"
        using assms can_implies_arr can_mkcan dom_mkcan cod_mkcan by simp
      thus ?thesis using assms can_coherence by blast
    qed

    lemma Ide_Diagonalize_rep_ide:
    assumes "ide a"
    shows "Ide \<^bold>\<lfloor>rep a\<^bold>\<rfloor>"
      using assms ide_implies_can can_def_alt rep_in_arr by simp

    lemma Diagonalize_DOM:
    assumes "arr f"
    shows "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
      using assms Diag_Diagonalize by simp

    lemma Diagonalize_COD:
    assumes "arr f"
    shows "\<^bold>\<lfloor>COD f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
      using assms Diag_Diagonalize by simp

    lemma Diagonalize_rep_preserves_seq:
    assumes "seq g f"
    shows "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
      using assms Diagonalize_DOM Diagonalize_COD Diag_implies_Arr Diag_Diagonalize(1)
            rep_preserves_seq
      by force

    lemma Dom_Diagonalize_rep:
    assumes "arr f"
    shows "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (dom f)\<^bold>\<rfloor>"
      using assms Diagonalize_rep_preserves_seq [of f "dom f"] Ide_Diagonalize_rep_ide Ide_in_Hom
      by simp

    lemma Cod_Diagonalize_rep:
    assumes "arr f"
    shows "Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (cod f)\<^bold>\<rfloor>"
      using assms Diagonalize_rep_preserves_seq [of "cod f" f] Ide_Diagonalize_rep_ide Ide_in_Hom
      by simp

    lemma mkarr_Diagonalize_rep:
    assumes "arr f" and "Diag (DOM f)" and "Diag (COD f)"
    shows "mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = f"
    proof -
      have "mkarr (rep f) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms rep_in_Hom Diagonalize_in_Hom Diag_Diagonalize Diagonalize_Diag
        by (intro mkarr_eqI, simp_all)
      thus ?thesis using assms mkarr_rep by auto
    qed

    text \<open>
      We define tensor product of arrows via the constructor @{term Tensor} on terms.
\<close>

    definition tensor\<^sub>F\<^sub>M\<^sub>C      (infixr "\<otimes>" 53)
      where "f \<otimes> g \<equiv> (if arr f \<and> arr g then mkarr (rep f \<^bold>\<otimes> rep g) else null)"

    lemma arr_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "arr (f \<otimes> g)"
      using assms tensor\<^sub>F\<^sub>M\<^sub>C_def arr_mkarr by simp

    lemma rep_tensor:
    assumes "arr f" and "arr g"
    shows "rep (f \<otimes> g) = \<^bold>\<parallel>rep f \<^bold>\<otimes> rep g\<^bold>\<parallel>"
      using assms tensor\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp

    lemma Par_memb_rep:
    assumes "arr f" and "t \<in> f"
    shows "Par t (rep f)"
      using assms mkarr_memb apply simp
      using rep_in_Hom Dom_memb Cod_memb by metis

    lemma Tensor_in_tensor [intro]:
    assumes "arr f" and "arr g" and "t \<in> f" and "u \<in> g"
    shows "t \<^bold>\<otimes> u \<in> f \<otimes> g"
    proof -
      have "equiv (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
      proof -
        have 1: "Par (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
        proof -
          have "Par t (rep f) \<and> Par u (rep g)" using assms Par_memb_rep by blast
          thus ?thesis by simp
        qed
        moreover have "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<otimes> rep g\<^bold>\<rfloor>"
          using assms 1 equiv_iff_eq_norm rep_mkarr norm_norm mkarr_memb(2)
          by (metis Arr.simps(3) Diagonalize.simps(3))
        ultimately show ?thesis by simp
      qed
      thus ?thesis
        using assms tensor\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
    qed

    lemma DOM_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "DOM (f \<otimes> g) = DOM f \<^bold>\<otimes> DOM g"
      by (metis (no_types, lifting) DOM_mkarr Dom.simps(3) mkarr_extensionality arr_char
          arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)

    lemma COD_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "COD (f \<otimes> g) = COD f \<^bold>\<otimes> COD g"
      by (metis (no_types, lifting) COD_mkarr Cod.simps(3) mkarr_extensionality arr_char
          arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)

    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>"
    proof -
      have f: "arr f \<and> dom f = a \<and> cod f = b" using assms(1) by auto
      have g: "arr g \<and> dom g = c \<and> cod g = d" using assms(2) by auto
      have "dom (f \<otimes> g) = dom f \<otimes> dom g"
        using f g arr_tensor dom_char Tensor_in_tensor [of "dom f" "dom g" "DOM f" "DOM g"]
              DOM_in_dom mkarr_memb(2) DOM_tensor arr_dom_iff_arr
        by metis
      moreover have "cod (f \<otimes> g) = cod f \<otimes> cod g"
        using f g arr_tensor cod_char Tensor_in_tensor [of "cod f" "cod g" "COD f" "COD g"]
              COD_in_cod mkarr_memb(2) COD_tensor arr_cod_iff_arr
        by metis
      ultimately show ?thesis using assms arr_tensor by blast
    qed

    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 [of f] 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 [of f] by blast

    lemma tensor_mkarr [simp]:
    assumes "Arr t" and "Arr u"
    shows "mkarr t \<otimes> mkarr u = mkarr (t \<^bold>\<otimes> u)"
      using assms by (meson Tensor_in_tensor arr_char Arr_in_mkarr arr_mkarr arr_tensor)

    lemma tensor_preserves_ide:
    assumes "ide a" and "ide b"
    shows "ide (a \<otimes> b)"
    proof -
      have "can (a \<otimes> b)"
        using assms tensor\<^sub>F\<^sub>M\<^sub>C_def Can_rep_can ide_implies_can can_mkarr_Can by simp
      moreover have "dom (a \<otimes> b) = cod (a \<otimes> b)"
        using assms tensor_in_hom by simp
      ultimately show ?thesis using ide_char by metis
    qed

    lemma tensor_preserves_can:
    assumes "can f" and "can g"
    shows "can (f \<otimes> g)"
      using assms can_implies_arr Can_rep_can tensor\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can by simp

    lemma comp_preserves_can:
    assumes "can f" and "can g" and "dom f = cod g"
    shows "can (f \<cdot> g)"
    proof -
      have 1: "ARR f \<and> ARR g \<and> DOM f = COD g"
        using assms can_implies_arr arr_iff_ARR Arr_implies_Ide_Cod Arr_implies_Ide_Dom
              mkarr_inj_on_Ide cod_char dom_char
        by simp
      hence "Can (rep f \<^bold>\<cdot> rep g)"
        using assms can_implies_arr Can_rep_can by force
      thus ?thesis
        using assms 1 can_implies_arr comp_char can_mkarr_Can seq_char' by simp
    qed

    text \<open>
      The remaining structure required of a monoidal category is also defined syntactically.
\<close>

    definition unity\<^sub>F\<^sub>M\<^sub>C :: "'c arr"                                  ("\<I>")
      where "\<I> = mkarr \<^bold>\<I>"

    definition lunit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr"                         ("\<l>[_]")
    where "\<l>[a] = mkarr \<^bold>\<l>\<^bold>[rep a\<^bold>]"

    definition runit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr"                         ("\<r>[_]")
    where "\<r>[a] = mkarr \<^bold>\<r>\<^bold>[rep a\<^bold>]"

    definition assoc\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr"     ("\<a>[_, _, _]")
    where "\<a>[a, b, c] = mkarr \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]"

    lemma can_lunit:
    assumes "ide a"
    shows "can \<l>[a]"
      using assms lunit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
      by (simp add: Can_rep_can ide_implies_can)

    lemma lunit_in_hom:
    assumes "ide a"
    shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
    proof -
      have "dom \<l>[a] = \<I> \<otimes> a"
        using assms lunit\<^sub>F\<^sub>M\<^sub>C_def unity\<^sub>F\<^sub>M\<^sub>C_def Ide_implies_Arr dom_mkarr dom_char tensor_mkarr
              Arr_rep
        by (metis Arr.simps(2) Arr.simps(5) Arr_implies_Ide_Dom Dom.simps(5)
                  ideD(1) ideD(2))
      moreover have "cod \<l>[a] = a"
        using assms lunit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
      ultimately show ?thesis
        using assms arr_cod_iff_arr by (intro in_homI, fastforce)
    qed

    lemma arr_lunit [simp]:
    assumes "ide a"
    shows "arr \<l>[a]"
      using assms can_lunit can_implies_arr by simp

    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

    lemma can_runit:
    assumes "ide a"
    shows "can \<r>[a]"
      using assms runit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
      by (simp add: Can_rep_can ide_implies_can)

    lemma runit_in_hom [simp]:
    assumes "ide a"
    shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
    proof -
      have "dom \<r>[a] = a \<otimes> \<I>"
        using assms Arr_rep Arr.simps(2) Arr.simps(7) Arr_implies_Ide_Dom Dom.simps(7)
              Ide_implies_Arr dom_mkarr dom_char ideD(1) ideD(2) runit\<^sub>F\<^sub>M\<^sub>C_def tensor_mkarr
              unity\<^sub>F\<^sub>M\<^sub>C_def
        by metis
      moreover have "cod \<r>[a] = a"
        using assms runit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
      ultimately show ?thesis
        using assms arr_cod_iff_arr by (intro in_homI, fastforce)
    qed

    lemma arr_runit [simp]:
    assumes "ide a"
    shows "arr \<r>[a]"
      using assms can_runit can_implies_arr by simp

    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 can_assoc:
    assumes "ide a" and "ide b" and "ide c"
    shows "can \<a>[a, b, c]"
      using assms assoc\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
      by (simp add: Can_rep_can ide_implies_can)

    lemma assoc_in_hom:
    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>"
    proof -
      have "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
      proof -
        have "dom \<a>[a, b, c] = mkarr (Dom \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
          using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
        also have "... = mkarr ((DOM a \<^bold>\<otimes> DOM b) \<^bold>\<otimes> DOM c)"
          by simp
        also have "... = (a \<otimes> b) \<otimes> c"
          by (metis mkarr_extensionality arr_tensor assms dom_char
              ideD(1) ideD(2) not_arr_null null_char tensor_mkarr)
        finally show ?thesis by blast
      qed
      moreover have "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
      proof -
        have "cod \<a>[a, b, c] = mkarr (Cod \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
          using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
        also have "... = mkarr (COD a \<^bold>\<otimes> COD b \<^bold>\<otimes> COD c)"
          by simp
        also have "... = a \<otimes> b \<otimes> c"
          by (metis mkarr_extensionality arr_tensor assms(1) assms(2) assms(3) cod_char
              ideD(1) ideD(3) not_arr_null null_char tensor_mkarr)
        finally show ?thesis by blast
      qed
      moreover have "arr \<a>[a, b, c]"
        using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) arr_mkarr by simp
      ultimately show ?thesis by auto
    qed

    lemma arr_assoc [simp]:
    assumes "ide a" and "ide b" and "ide c"
    shows "arr \<a>[a, b, c]"
      using assms can_assoc can_implies_arr 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 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

    lemma ide_unity [simp]:
    shows "ide \<I>"
      using unity\<^sub>F\<^sub>M\<^sub>C_def Arr.simps(2) Dom.simps(2) arr_mkarr dom_mkarr ide_dom
      by metis

    lemma Unity_in_unity [simp]:
    shows "\<^bold>\<I> \<in> \<I>"
      using unity\<^sub>F\<^sub>M\<^sub>C_def Arr_in_mkarr by simp

    lemma rep_unity [simp]:
    shows "rep \<I> = \<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>"
      using unity\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp

    lemma Lunit_in_lunit [intro]:
    assumes "arr f" and "t \<in> f"
    shows "\<^bold>\<l>\<^bold>[t\<^bold>] \<in> \<l>[f]"
    proof -
      have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms
        by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
                  norm_rep)
      thus ?thesis
        by (simp add: mkarr_def lunit\<^sub>F\<^sub>M\<^sub>C_def)
    qed

    lemma Runit_in_runit [intro]:
    assumes "arr f" and "t \<in> f"
    shows "\<^bold>\<r>\<^bold>[t\<^bold>] \<in> \<r>[f]"
    proof -
      have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms
        by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
                  norm_rep)
      thus ?thesis
        by (simp add: mkarr_def runit\<^sub>F\<^sub>M\<^sub>C_def)
    qed

    lemma Assoc_in_assoc [intro]:
    assumes "arr f" and "arr g" and "arr h"
    and "t \<in> f" and "u \<in> g" and "v \<in> h"
    shows "\<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<in> \<a>[f, g, h]"
    proof -
      have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
        using assms
        by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                  norm_rep)
      moreover have "Arr u \<and> Arr (rep g) \<and> Dom u = DOM g \<and> Cod u = COD g \<and>
                     \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
        using assms
        by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                  norm_rep)
      moreover have "Arr v \<and> Arr (rep h) \<and> Dom v = DOM h \<and> Cod v = COD h \<and>
                     \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h\<^bold>\<rfloor>"
        using assms
        by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                  norm_rep)
      ultimately show ?thesis
        using assoc\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
    qed

    text \<open>
      At last, we can show that we've constructed a monoidal category.
\<close>

    interpretation EMC: elementary_monoidal_category
                          comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
    proof
      show "ide \<I>" using ide_unity by auto
      show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" by auto
      show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" by auto
      show "\<And>a. ide a \<Longrightarrow> iso \<l>[a]" using can_lunit iso_can by auto
      show "\<And>a. ide a  \<Longrightarrow> iso \<r>[a]" using can_runit iso_can by auto
      show "\<And>a b c. \<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>" by auto
      show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> iso \<a>[a, b, c]" using can_assoc iso_can by auto
      show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes> b)" using tensor_preserves_ide by auto
      fix f a b g c d
      show "\<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>"
        using tensor_in_hom by auto
      next
      text \<open>Naturality of left unitor.\<close>
      fix f
      assume f: "arr f"
      show "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
      proof (intro arr_eqI)
        show "par (\<l>[cod f] \<cdot> (\<I> \<otimes> f)) (f \<cdot> \<l>[dom f])"
          using f by simp
        show "\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f) \<in> \<l>[cod f] \<cdot> (\<I> \<otimes> f)"
          using f by fastforce
        show "rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<l>[dom f]"
          using f by fastforce
        show "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
          using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
      qed
      text \<open>Naturality of right unitor.\<close>
      show "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
      proof (intro arr_eqI)
        show "par (\<r>[cod f] \<cdot> (f \<otimes> \<I>)) (f \<cdot> \<r>[dom f])"
          using f by simp
        show "\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>) \<in> \<r>[cod f] \<cdot> (f \<otimes> \<I>)"
          using f by fastforce
        show "rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<r>[dom f]"
          using f by fastforce
        show "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
          using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
      qed
      next
      text \<open>Naturality of associator.\<close>
      fix f0 :: "'c arr" and f1 f2
      assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
      show "\<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]"
      proof (intro arr_eqI)
        show 1: "par (\<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 f0 f1 f2 by force
        show "\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)
                \<in> \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
          using f0 f1 f2 by fastforce
        show "(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]
                \<in> (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
          using f0 f1 f2 by fastforce
        show "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                = \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
        proof -
          have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                  = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
          proof -
            have b0: "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
              using f0 Cod_Diagonalize_rep by simp
            have b1: "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
              using f1 Cod_Diagonalize_rep by simp
            have b2: "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
              using f2 Cod_Diagonalize_rep by simp
            have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                      = (\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
                        (\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>)"
              using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
            also have "... = \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                             \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
            proof -
              have "Seq \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<and>
                    Seq \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
                by auto
              thus ?thesis
                using f0 f1 f2 b0 b1 b2 TensorDiag_in_Hom TensorDiag_preserves_Diag
                      Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                      CompDiag_TensorDiag
                  by simp
            qed
            also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
            proof -
              have "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
                using f0 b0 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"] Diag_Diagonalize
                by simp
              moreover have "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
                using f1 b1 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"] Diag_Diagonalize
                by simp
              moreover have "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                using f2 b2 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"] Diag_Diagonalize
                by simp
              ultimately show ?thesis by argo
            qed
            finally show ?thesis by blast
          qed
          also have "... = \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot>
                           \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
          proof -
            have a0: "\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
              using f0 Dom_Diagonalize_rep by simp
            have a1: "\<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
              using f1 Dom_Diagonalize_rep by simp
            have a2: "\<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
              using f2 Dom_Diagonalize_rep by simp
            have "\<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>
                    = (\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
                      (\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>)"
               using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
            also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                             \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
            proof -
              have "Seq \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<and>
                    Seq \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
                using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
                by auto
              thus ?thesis
                using f0 f1 f2 a0 a1 a2 TensorDiag_in_Hom TensorDiag_preserves_Diag
                      Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                      CompDiag_TensorDiag
                by force
            qed
            also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
            proof -
              have "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
                using f0 a0 CompDiag_Diag_Dom [of "Diagonalize (rep f0)"] Diag_Diagonalize
                by simp
              moreover have "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
                using f1 a1 CompDiag_Diag_Dom [of "Diagonalize (rep f1)"] Diag_Diagonalize
                by simp
              moreover have "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                using f2 a2 CompDiag_Diag_Dom [of "Diagonalize (rep f2)"] Diag_Diagonalize
                by simp
              ultimately show ?thesis by argo
            qed
            finally show ?thesis by argo
          qed
          finally show ?thesis by blast
        qed
      qed
      next
      text \<open>Tensor preserves composition (interchange).\<close>
      fix f g f' g'
      show "\<lbrakk> seq g f; seq g' f' \<rbrakk> \<Longrightarrow> (g \<otimes> g') \<cdot> (f \<otimes> f') = g \<cdot> f \<otimes> g' \<cdot> f'"
      proof -
        assume gf: "seq g f"
        assume gf': "seq g' f'"
        show ?thesis
        proof (intro arr_eqI)
          show "par ((g \<otimes> g') \<cdot> (f \<otimes> f')) (g \<cdot> f \<otimes> g' \<cdot> f')"
            using gf gf' by fastforce
          show "(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f') \<in> (g \<otimes> g') \<cdot> (f \<otimes> f')"
            using gf gf' by force
          show "rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f' \<in> g \<cdot> f \<otimes> g' \<cdot> f'"
           using gf gf'
           by (meson Comp_in_comp_ARR Tensor_in_tensor rep_in_arr seqE seq_char')
          show "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
          proof -
            have "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor>
                    = (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>)"
              by auto
            also have "... =  \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"
              using gf gf' Arr_rep Diagonalize_rep_preserves_seq
                    CompDiag_TensorDiag [of "\<^bold>\<lfloor>rep g\<^bold>\<rfloor>" " \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"]
                    Diag_Diagonalize Diagonalize_DOM Diagonalize_COD
              by force
            also have "... = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
              by auto
            finally show ?thesis by blast
          qed
        qed
      qed
      next
      text \<open>The triangle.\<close>
      fix a b
      assume a: "ide a"
      assume b: "ide b"
      show "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
      proof -
        have "par ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b]) (\<r>[a] \<otimes> b)"
          using a b by simp
        moreover have "can ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b])"
          using a b ide_implies_can comp_preserves_can tensor_preserves_can can_assoc can_lunit
          by simp
        moreover have "can (\<r>[a] \<otimes> b)"
          using a b ide_implies_can can_runit tensor_preserves_can by simp
        ultimately show ?thesis using can_coherence by blast
      qed
      next
      text \<open>The pentagon.\<close>
      fix a b c d
      assume a: "ide a"
      assume b: "ide b"
      assume c: "ide c"
      assume d: "ide d"
      show "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)
              = \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
      proof -
        let ?LHS = "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)"
        let ?RHS = "\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
        have "par ?LHS ?RHS"
          using a b c d can_assoc tensor_preserves_ide by auto
        moreover have "can ?LHS"
          using a b c d ide_implies_can comp_preserves_can tensor_preserves_can can_assoc
                tensor_preserves_ide
          by simp
        moreover have "can ?RHS"
          using a b c d comp_preserves_can tensor_preserves_can can_assoc tensor_in_hom
                tensor_preserves_ide
          by simp
        ultimately show ?thesis using can_coherence by blast
      qed
    qed

    lemma is_elementary_monoidal_category:
    shows "elementary_monoidal_category
             comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C"
      ..

    abbreviation T\<^sub>F\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.T\<^sub>E\<^sub>M\<^sub>C"
    abbreviation \<alpha>\<^sub>F\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
    abbreviation \<iota>\<^sub>F\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"

    interpretation MC: monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
      using EMC.induces_monoidal_category by auto

    lemma induces_monoidal_category:
    shows "monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C"
      ..

  end

  sublocale free_monoidal_category \<subseteq>
              elementary_monoidal_category
                 comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
    using is_elementary_monoidal_category by auto

  sublocale free_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
    using induces_monoidal_category by auto

  section "Proof of Freeness"

  text \<open>
    Now we proceed on to establish the freeness of \<open>\<F>C\<close>: each functor
    from @{term C} to a monoidal category @{term D} extends uniquely
    to a strict monoidal functor from \<open>\<F>C\<close> to D.
\<close>

  context free_monoidal_category
  begin

    lemma rep_lunit:
    assumes "ide a"
    shows "rep \<l>[a] = \<^bold>\<parallel>\<^bold>\<l>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
      using assms Lunit_in_lunit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<l>[a]"]
      by simp

    lemma rep_runit:
    assumes "ide a"
    shows "rep \<r>[a] = \<^bold>\<parallel>\<^bold>\<r>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
      using assms Runit_in_runit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<r>[a]"]
      by simp

    lemma rep_assoc:
    assumes "ide a" and "ide b" and "ide c"
    shows "rep \<a>[a, b, c] = \<^bold>\<parallel>\<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]\<^bold>\<parallel>"
      using assms Assoc_in_assoc [of a b c "rep a" "rep b" "rep c"] rep_in_arr
            norm_memb_eq_rep [of "\<a>[a, b, c]"]
      by simp

    lemma mkarr_Unity:
    shows "mkarr \<^bold>\<I> = \<I>"
      using unity\<^sub>F\<^sub>M\<^sub>C_def by simp

    text \<open>
      The unitors and associator were given syntactic definitions in terms of
      corresponding terms, but these were only for the special case of identity
      arguments (\emph{i.e.}~the components of the natural transformations).
      We need to show that @{term mkarr} gives the correct result for \emph{all}
      terms.
\<close>

    lemma mkarr_Lunit:
    assumes "Arr t"
    shows "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = \<ll> (mkarr t)"
    proof -
      have "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
        using assms Arr_implies_Ide_Dom Ide_in_Hom Diagonalize_preserves_Ide
              Diag_Diagonalize Par_Arr_norm
        by (intro mkarr_eqI) simp_all
      also have "... = mkarr t \<cdot> mkarr \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
        using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
      also have "... = mkarr t \<cdot> \<l>[dom (mkarr t)]"
      proof -
        have "arr \<l>[mkarr (Dom t)]"
          using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
        moreover have "\<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<l>[mkarr (Dom t)]"
          using assms Arr_implies_Ide_Dom Lunit_in_lunit rep_mkarr
                rep_in_arr [of "mkarr (Dom t)"]
          by simp
        ultimately show ?thesis
          using assms mkarr_memb(2) by simp
      qed
      also have "... = \<ll> (mkarr t)"
        using assms Arr_implies_Ide_Dom ide_mkarr_Ide lunit_agreement by simp
      finally show ?thesis by blast
    qed

    lemma mkarr_Lunit':
    assumes "Arr t"
    shows "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<ll>' (mkarr t)"
    proof -
      have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
        using assms Arr_implies_Ide_Cod Ide_in_Hom Diagonalize_preserves_Ide
              Diag_Diagonalize Par_Arr_norm
        by (intro mkarr_eqI) simp_all
      also have "... = mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
        using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
      also have "... = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
      proof -
        have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>])"
          using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
                Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
          by (intro mkarr_eqI, simp_all)
        thus ?thesis by argo
      qed
      also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
      proof -
        have "mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = lunit' (cod (mkarr t)) \<cdot> mkarr t"
          using assms Arr_implies_Ide_Cod rep_mkarr Par_Arr_norm inv_mkarr
                norm_preserves_Can Ide_implies_Can lunit_agreement \<ll>'_ide_simp
                Can_implies_Arr arr_mkarr cod_mkarr ide_cod lunit\<^sub>F\<^sub>M\<^sub>C_def
          by (metis (no_types, lifting) Can.simps(5))
        also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
          using assms \<ll>'_ide_simp arr_mkarr ide_cod by presburger
        finally show ?thesis by blast
      qed
      also have "... = \<ll>' (mkarr t)"
        using assms \<ll>'.is_natural_2 [of "mkarr t"] by simp
      finally show ?thesis by blast
    qed

    lemma mkarr_Runit:
    assumes "Arr t"
    shows "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = \<rho> (mkarr t)"
    proof -
      have "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
      proof -
        have "\<not> Diag (Dom t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Dom t") simp_all
        thus ?thesis
          using assms Par_Arr_norm Arr_implies_Ide_Dom Ide_in_Hom Diag_Diagonalize
                Diagonalize_preserves_Ide
          by (intro mkarr_eqI) simp_all
      qed
      also have "... = mkarr t \<cdot> mkarr \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
        using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
      also have "... = mkarr t \<cdot> \<r>[dom (mkarr t)]"
      proof -
        have "arr \<r>[mkarr (Dom t)]"
          using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
        moreover have "\<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<r>[mkarr (Dom t)]"
          using assms Arr_implies_Ide_Dom Runit_in_runit rep_mkarr
                rep_in_arr [of "mkarr (Dom t)"]
          by simp
        moreover have "mkarr (Dom t) = mkarr \<^bold>\<parallel>Dom t\<^bold>\<parallel>"
          using assms mkarr_rep rep_mkarr arr_mkarr Ide_implies_Arr Arr_implies_Ide_Dom
          by metis
        ultimately show ?thesis
          using assms mkarr_memb(2) by simp
      qed
      also have "... = \<rho> (mkarr t)"
        using assms Arr_implies_Ide_Dom ide_mkarr_Ide runit_agreement by simp
      finally show ?thesis by blast
    qed

    lemma mkarr_Runit':
    assumes "Arr t"
    shows "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<rho>' (mkarr t)"
    proof -
      have "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
      proof -
        have "\<not> Diag (Cod t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Cod t") simp_all
        thus ?thesis
          using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom
                Diagonalize_preserves_Ide Diag_Diagonalize
          by (intro mkarr_eqI) simp_all
      qed
      also have "... = mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
        using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
      also have "... = mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
      proof -
        have "mkarr (Runit' (norm (Cod t))) = mkarr (Inv (Runit (norm (Cod t))))"
          using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
                Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
          by (intro mkarr_eqI) simp_all
        thus ?thesis by argo
      qed
      also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
      proof -
        have "mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = runit' (cod (mkarr t)) \<cdot> mkarr t"
          using assms Arr_implies_Ide_Cod rep_mkarr inv_mkarr norm_preserves_Can
                Ide_implies_Can runit_agreement Can_implies_Arr arr_mkarr cod_mkarr
                ide_cod runit\<^sub>F\<^sub>M\<^sub>C_def
          by (metis (no_types, lifting) Can.simps(7))
        also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
        proof -
          have "runit' (cod (mkarr t)) = \<rho>' (cod (mkarr t))"
            using assms \<rho>'_ide_simp arr_mkarr ide_cod by blast
          thus ?thesis by argo
        qed
        finally show ?thesis by blast
      qed
      also have "... = \<rho>' (mkarr t)"
        using assms \<rho>'.is_natural_2 [of "mkarr t"] by simp
      finally show ?thesis by blast
    qed

    lemma mkarr_Assoc:
    assumes "Arr t" and "Arr u" and "Arr v"
    shows "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<alpha> (mkarr t, mkarr u, mkarr v)"
    proof -
      have "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = mkarr ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>, \<^bold>\<parallel>Dom u\<^bold>\<parallel>, \<^bold>\<parallel>Dom v\<^bold>\<parallel>\<^bold>])"
        using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Ide_in_Hom
              Diag_Diagonalize Diagonalize_preserves_Ide TensorDiag_preserves_Ide
              TensorDiag_preserves_Diag TensorDiag_assoc Par_Arr_norm
        by (intro mkarr_eqI, simp_all)
      also have "... = \<alpha> (mkarr t, mkarr u, mkarr v)"
        using assms Arr_implies_Ide_Dom rep_mkarr Ide_in_Hom assoc\<^sub>F\<^sub>M\<^sub>C_def
              Par_Arr_norm [of "Dom t"] Par_Arr_norm [of "Dom u"] Par_Arr_norm [of "Dom v"]
              \<alpha>_simp
        by simp
      finally show ?thesis by blast
    qed

    lemma mkarr_Assoc':
    assumes "Arr t" and "Arr u" and "Arr v"
    shows "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<alpha>' (mkarr t, mkarr u, mkarr v)"
    proof -
      have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (t \<^bold>\<otimes> u \<^bold>\<otimes> v))"
        using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom Diag_Diagonalize
              TensorDiag_preserves_Diag CompDiag_Cod_Diag [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 (intro mkarr_eqI, simp_all)
      also have "... = mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
        using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
      also have "... = mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
      proof -
        have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] =
              mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>])"
          using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom Ide_implies_Can
                norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
          by (intro mkarr_eqI, simp_all)
        thus ?thesis by argo
      qed
      also have "... = inv (mkarr \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
        using assms Arr_implies_Ide_Cod Ide_implies_Can norm_preserves_Can by simp
      also have "... = \<alpha>' (mkarr t, mkarr u, mkarr v)"
      proof -
        have "mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (Cod t \<^bold>\<otimes> Cod u \<^bold>\<otimes> Cod v))
               = mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]"
          using assms Arr_implies_Ide_Cod Inv_in_Hom norm_preserves_Can Diagonalize_Inv
                Ide_implies_Can Diag_Diagonalize Ide_in_Hom Diagonalize_preserves_Ide
                Par_Arr_norm TensorDiag_preserves_Diag
                CompDiag_Cod_Diag [of "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod v\<^bold>\<rfloor>"]
          by (intro mkarr_eqI) simp_all
        thus ?thesis
          using assms Arr_implies_Ide_Cod rep_mkarr assoc\<^sub>F\<^sub>M\<^sub>C_def \<alpha>'.map_simp by simp
      qed
      finally show ?thesis by blast
    qed

    text \<open>
      Next, we define the ``inclusion of generators'' functor from @{term C} to \<open>\<F>C\<close>.
\<close>

    definition inclusion_of_generators
    where "inclusion_of_generators \<equiv> \<lambda>f. if C.arr f then mkarr \<^bold>\<langle>f\<^bold>\<rangle> else null"

    lemma inclusion_is_functor:
    shows "functor C comp inclusion_of_generators"
      unfolding inclusion_of_generators_def
      apply unfold_locales
          apply auto[4]
      by (elim C.seqE, simp, intro mkarr_eqI, auto)

  end

  text \<open>
    We now show that, given a functor @{term V} from @{term C} to a
    a monoidal category @{term D}, the evaluation map that takes formal arrows
    of the monoidal language of @{term C} to arrows of @{term D}
    induces a strict monoidal functor from \<open>\<F>C\<close> to @{term D}.
\<close>

  locale evaluation_functor =
    C: category C +
    D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
    \<F>C: free_monoidal_category C
  for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and V :: "'c \<Rightarrow> 'd"
  begin

    notation eval         ("\<lbrace>_\<rbrace>")

    definition map
    where "map f \<equiv> if \<F>C.arr f then \<lbrace>\<F>C.rep f\<rbrace> else D.null"

    text \<open>
      It follows from the coherence theorem that a formal arrow and its normal
      form always have the same evaluation.
\<close>

    lemma eval_norm:
    assumes "Arr t"
    shows "\<lbrace>\<^bold>\<parallel>t\<^bold>\<parallel>\<rbrace> = \<lbrace>t\<rbrace>"
      using assms \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm coherence canonical_factorization
      by simp

    interpretation "functor" \<F>C.comp D map
    proof
      fix f
      show "\<not>\<F>C.arr f \<Longrightarrow> map f = D.null" using map_def by simp
      assume f: "\<F>C.arr f"
      show "D.arr (map f)" using f map_def \<F>C.arr_char by simp
      show "D.dom (map f) = map (\<F>C.dom f)"
        using f map_def eval_norm \<F>C.rep_dom Arr_implies_Ide_Dom by auto
      show "D.cod (map f) = map (\<F>C.cod f)"
        using f map_def eval_norm \<F>C.rep_cod Arr_implies_Ide_Cod by auto
      next
      fix f g
      assume fg: "\<F>C.seq g f"
      show "map (\<F>C.comp g f) = D (map g) (map f)"
        using fg map_def \<F>C.rep_comp \<F>C.rep_preserves_seq eval_norm by auto
    qed

    lemma is_functor:
    shows "functor \<F>C.comp D map" ..

    interpretation FF: product_functor \<F>C.comp \<F>C.comp D D map map ..
    interpretation FoT: composite_functor \<F>C.CC.comp \<F>C.comp D \<F>C.T\<^sub>F\<^sub>M\<^sub>C map ..
    interpretation ToFF: composite_functor \<F>C.CC.comp D.CC.comp D FF.map T\<^sub>D ..

    interpretation strict_monoidal_functor
                     \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
    proof
      show "map \<F>C.\<iota> = \<iota>\<^sub>D"
        using \<F>C.\<iota>_def \<F>C.lunit_agreement map_def \<F>C.rep_lunit \<F>C.Arr_rep [of \<I>]
              eval_norm \<F>C.lunit_agreement D.unitor_coincidence D.comp_cod_arr D.\<iota>_in_hom
        by auto
      show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
                  map (\<F>C.tensor f g) = D.tensor (map f) (map g)"
        using map_def \<F>C.rep_tensor \<F>C.Arr_rep eval_norm by simp
      show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
                      map (\<F>C.assoc a b c) = D.assoc (map a) (map b) (map c)"
        using map_def \<F>C.assoc\<^sub>F\<^sub>M\<^sub>C_def \<F>C.rep_mkarr eval_norm by auto
    qed

    lemma is_strict_monoidal_functor:
    shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
      ..

  end

  sublocale evaluation_functor \<subseteq> strict_monoidal_functor
                                   \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
    using is_strict_monoidal_functor by auto

  text \<open>
    The final step in proving freeness is to show that the evaluation functor
    is the \emph{unique} strict monoidal extension of the functor @{term V}
    to \<open>\<F>C\<close>. This is done by induction, exploiting the syntactic construction
    of \<open>\<F>C\<close>.
\<close>

  text \<open>
    To ease the statement and proof of the result, we define a locale that
    expresses that @{term F} is a strict monoidal extension to monoidal
    category @{term C}, of a functor @{term "V"} from @{term "C\<^sub>0"} to a
    monoidal category @{term D}, along a functor @{term I} from
    @{term "C\<^sub>0"} to @{term C}.
\<close>

  locale strict_monoidal_extension =
    C\<^sub>0: category C\<^sub>0 +
    C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
    D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    I: "functor" C\<^sub>0 C I +
    V: "functor" C\<^sub>0 D V +
    strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F
  for C\<^sub>0 :: "'c\<^sub>0 comp"
  and C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
  and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
  and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
  and \<iota>\<^sub>C :: "'c"
  and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and I :: "'c\<^sub>0 \<Rightarrow> 'c"
  and V :: "'c\<^sub>0 \<Rightarrow> 'd"
  and F :: "'c \<Rightarrow> 'd" +
  assumes is_extension: "\<forall>f. C\<^sub>0.arr f \<longrightarrow> F (I f) = V f"

  sublocale evaluation_functor \<subseteq>
              strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                        \<F>C.inclusion_of_generators V map
  proof -
    interpret inclusion: "functor" C \<F>C.comp \<F>C.inclusion_of_generators
      using \<F>C.inclusion_is_functor by auto
    show "strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                    \<F>C.inclusion_of_generators V map"
      apply unfold_locales
      using map_def \<F>C.rep_mkarr eval_norm \<F>C.inclusion_of_generators_def by simp
  qed

  text \<open>
    A special case of interest is a strict monoidal extension to \<open>\<F>C\<close>,
    of a functor @{term V} from a category @{term C} to a monoidal category @{term D},
    along the inclusion of generators from @{term C} to \<open>\<F>C\<close>.
    The evaluation functor induced by @{term V} is such an extension.
\<close>

  locale strict_monoidal_extension_to_free_monoidal_category =
    C: category C +
    monoidal_language C +
    \<F>C: free_monoidal_category C +
    strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                              \<F>C.inclusion_of_generators V F
  for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and V :: "'c \<Rightarrow> 'd"
  and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"
  begin

    lemma strictly_preserves_everything:
    shows "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
    and "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
    and "\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow> F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
    and "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
           F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
    and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
    and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
    and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
    and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
    and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
           F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]) = \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
    and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
           F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
             = D.\<alpha>' (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
    proof -
      show "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
        using is_extension \<F>C.inclusion_of_generators_def by simp
      show "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
        using \<F>C.mkarr_Unity \<F>C.\<iota>_def strictly_preserves_unity \<F>C.\<I>_agreement by auto
      show tensor_case:
           "\<And>t u.\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow>
                   F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
      proof -
          fix t u
          assume t: "Arr t" and u: "Arr u"
          have "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.tensor (\<F>C.mkarr t) (\<F>C.mkarr u))"
            using t u \<F>C.tensor_mkarr \<F>C.arr_mkarr by simp
          also have "... = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
            using t u \<F>C.arr_mkarr strictly_preserves_tensor by blast
          finally show "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
            by fast
      qed
      show "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
              F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
      proof -
        fix t u
        assume t: "Arr t" and u: "Arr u" and tu: "Dom t = Cod u"
        show "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
        proof -
          have "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t \<cdot> \<F>C.mkarr u)"
            using t u tu \<F>C.comp_mkarr by simp
          also have "... = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
            using t u tu \<F>C.arr_mkarr by fastforce
          finally show ?thesis by blast
        qed
      qed
      show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
        using \<F>C.mkarr_Lunit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_lunit
        by simp
      show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
        using \<F>C.mkarr_Runit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_runit
        by simp
      show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
              F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>])
                = \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
        using \<F>C.mkarr_Assoc strictly_preserves_assoc \<F>C.ide_mkarr_Ide tensor_case
        by simp
      show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
      proof -
        assume t: "Arr t"
        have "F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.lunit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
          using t \<F>C.mkarr_Lunit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<ll>'.map_simp
                \<F>C.comp_cod_arr
          by simp
        also have "... = D.lunit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
          using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_lunit
                preserves_inv
          by simp
        also have "... = D.\<ll>'.map (F (\<F>C.mkarr t))"
          using t D.\<ll>'.map_simp D.comp_cod_arr by simp
        finally show ?thesis by blast
      qed
      show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
      proof -
        assume t: "Arr t"
        have "F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.runit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
          using t \<F>C.mkarr_Runit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<rho>'.map_simp
                \<F>C.comp_cod_arr
          by simp
        also have "... = D.runit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
          using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_runit
                preserves_inv
          by simp
        also have "... = D.\<rho>'.map (F (\<F>C.mkarr t))"
          using t D.\<rho>'.map_simp D.comp_cod_arr by simp
        finally show ?thesis by blast
      qed
      show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
              F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
                = D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
      proof -
        assume t: "Arr t" and u: "Arr u" and v: "Arr v"
        have "F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]) =
                F (\<F>C.assoc' (\<F>C.mkarr (Cod t)) (\<F>C.mkarr (Cod u)) (\<F>C.mkarr (Cod v))) \<cdot>\<^sub>D
                  (F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
          using t u v \<F>C.mkarr_Assoc' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<alpha>'.map_simp
                tensor_case \<F>C.iso_assoc
          by simp
        also have "... = D.assoc' (D.cod (F (\<F>C.mkarr t))) (D.cod (F (\<F>C.mkarr u)))
                                  (D.cod (F (\<F>C.mkarr v))) \<cdot>\<^sub>D
                                  (F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
            using t u v \<F>C.ide_mkarr_Ide Arr_implies_Ide_Cod preserves_inv \<F>C.iso_assoc
                  strictly_preserves_assoc
                    [of "\<F>C.mkarr (Cod t)" "\<F>C.mkarr (Cod u)" "\<F>C.mkarr (Cod v)"]
            by simp
        also have "... = D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
          using t u v D.\<alpha>'.map_simp by simp
        finally show ?thesis by blast
      qed
    qed

  end

  sublocale evaluation_functor \<subseteq> strict_monoidal_extension_to_free_monoidal_category
                                   C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V map
    ..

  context free_monoidal_category
  begin

    text \<open>
      The evaluation functor induced by @{term V} is the unique strict monoidal
      extension of @{term V} to \<open>\<F>C\<close>.
\<close>

    theorem is_free:
    assumes "strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
    shows "F = evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
    proof -
      interpret F: strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
        using assms by auto
      interpret E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..
      have Ide_case: "\<And>a. Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
      proof -
        fix a
        show "Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
          using E.strictly_preserves_everything F.strictly_preserves_everything Ide_implies_Arr
          by (induct a, auto)
      qed
      show ?thesis
      proof
        fix f
        have "\<not>arr f \<Longrightarrow> F f = E.map f"
          using E.is_extensional F.is_extensional by simp
        moreover have "arr f \<Longrightarrow> F f = E.map f"
        proof -
          assume f: "arr f"
          have "Arr (rep f) \<and> f = mkarr (rep f)" using f mkarr_rep by simp
          moreover have "\<And>t. Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
          proof -
            fix t
            show "Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
              using Ide_case E.strictly_preserves_everything F.strictly_preserves_everything
                    Arr_implies_Ide_Dom Arr_implies_Ide_Cod
              by (induct t, auto)
          qed
          ultimately show "F f = E.map f" by metis
        qed
        ultimately show "F f = E.map f" by blast
      qed
    qed

  end

  section "Strict Subcategory"

  context free_monoidal_category
  begin

    text \<open>
      In this section we show that \<open>\<F>C\<close> is monoidally equivalent to its full subcategory
      \<open>\<F>\<^sub>SC\<close> whose objects are the equivalence classes of diagonal identity terms,
      and that this subcategory is the free strict monoidal category generated by @{term C}.
\<close>

    interpretation \<F>\<^sub>SC: full_subcategory comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close>
      by (unfold_locales) auto

    text \<open>
      The mapping defined on equivalence classes by diagonalizing their representatives
      is a functor from the free monoidal category to the subcategory @{term "\<F>\<^sub>SC"}.
\<close>

    definition D
    where "D \<equiv> \<lambda>f. if arr f then mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> else \<F>\<^sub>SC.null"

    text \<open>
      The arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes whose canonical representative
      term has diagonal formal domain and codomain.
\<close>

    lemma strict_arr_char:
    shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
    proof
      show "arr f \<and> Diag (DOM f) \<and> Diag (COD f) \<Longrightarrow> \<F>\<^sub>SC.arr f"
        using \<F>\<^sub>SC.arr_char DOM_dom DOM_cod by simp
      show "\<F>\<^sub>SC.arr f \<Longrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
        using \<F>\<^sub>SC.arr_char Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr DOM_dom DOM_cod
        by force
    qed

    text \<open>
      Alternatively, the arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes
      that are preserved by diagonalization of representatives.
\<close>

    lemma strict_arr_char':
    shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> D f = f"
    proof
      fix f
      assume f: "\<F>\<^sub>SC.arr f"
      show "arr f \<and> D f = f"
      proof
        show "arr f" using f \<F>\<^sub>SC.arr_char by blast
        show "D f = f"
          using f strict_arr_char mkarr_Diagonalize_rep D_def by simp
      qed
      next
      assume f: "arr f \<and> D f = f"
      show "\<F>\<^sub>SC.arr f"
      proof -
        have "arr f" using f by simp
        moreover have "Diag (DOM f)"
        proof -
          have "DOM f = DOM (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
          also have "... = Dom \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
            using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
          also have "... = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
            using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
          finally have "DOM f = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
          thus ?thesis using f Arr_rep Diag_Diagonalize Dom_preserves_Diag by metis
        qed
        moreover have "Diag (COD f)"
        proof -
          have "COD f = COD (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
          also have "... = Cod \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
            using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
          also have "... = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
            using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
          finally have "COD f = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
          thus ?thesis using f Arr_rep Diag_Diagonalize Cod_preserves_Diag by metis
        qed
        ultimately show ?thesis using strict_arr_char by auto
      qed
    qed

    interpretation D: "functor" comp \<F>\<^sub>SC.comp D
    proof -
      have 1: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)"
        unfolding strict_arr_char D_def
        using arr_mkarr Diagonalize_in_Hom Arr_rep rep_mkarr Par_Arr_norm
              Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diag_Diagonalize
        by force
      show "functor comp \<F>\<^sub>SC.comp D"
      proof
        show "\<And>f. \<not> arr f \<Longrightarrow> D f = \<F>\<^sub>SC.null" using D_def by simp
        show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)" by fact
        show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.dom (D f) = D (dom f)"
          using D_def Diagonalize_in_Hom \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.arr_char
                rep_mkarr rep_dom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
          by simp
        show 2: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.cod (D f) = D (cod f)"
          using D_def Diagonalize_in_Hom \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.arr_char
                rep_mkarr rep_cod Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
          by simp
        fix f g
        assume fg: "seq g f"
        hence fg': "arr f \<and> arr g \<and> dom g = cod f" by blast
        show "D (g \<cdot> f) = \<F>\<^sub>SC.comp (D g) (D f)"
        proof -
          have seq: "\<F>\<^sub>SC.seq (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
          proof -
            have 3: "\<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) \<and> \<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
              using fg' 1 arr_char D_def by force
            moreover have "\<F>\<^sub>SC.dom (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) = \<F>\<^sub>SC.cod (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
              using fg' 2 3 \<F>\<^sub>SC.dom_char rep_in_Hom mkarr_in_hom D_def
                    Dom_Diagonalize_rep Diag_implies_Arr Diag_Diagonalize(1) \<F>\<^sub>SC.arr_char
              by force
            ultimately show ?thesis using \<F>\<^sub>SC.seqI by auto
          qed
          have "mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor> = \<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
          proof -
            have Seq: "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
              using fg rep_preserves_seq Diagonalize_in_Hom by force
            hence 4: "\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD g\<^bold>\<rfloor>"
              using fg' Seq Diagonalize_in_Hom by auto
            have "\<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) = mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<cdot> mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
              using seq \<F>\<^sub>SC.comp_char \<F>\<^sub>SC.seq_char by meson
            also have "... = mkarr (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
              using Seq comp_mkarr by fastforce
            also have "... = mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
            proof (intro mkarr_eqI)
              show "Par (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
                using fg 4 rep_in_Hom rep_preserves_seq rep_in_Hom Diagonalize_in_Hom
                      Par_Arr_norm
                apply (elim seqE, auto)
                by (simp_all add: rep_comp)
              show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>\<^bold>\<rfloor>"
                using fg rep_preserves_seq norm_in_Hom Diag_Diagonalize Diagonalize_Diag
                apply auto
                by (simp add: rep_comp)
            qed
            finally show ?thesis by blast
          qed
          thus ?thesis using fg D_def by auto
        qed
      qed
    qed

    lemma diagonalize_is_functor:
    shows "functor comp \<F>\<^sub>SC.comp D" ..

    lemma diagonalize_strict_arr:
    assumes "\<F>\<^sub>SC.arr f"
    shows "D f = f"
      using assms arr_char D_def strict_arr_char Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr
            mkarr_Diagonalize_rep [of f]
      by auto

    lemma diagonalize_is_idempotent:
    shows "D o D = D"
      unfolding D_def
      using D.is_extensional \<F>\<^sub>SC.null_char Arr_rep Diagonalize_in_Hom mkarr_Diagonalize_rep
            strict_arr_char rep_mkarr
      by fastforce

    lemma diagonalize_tensor:
    assumes "arr f" and "arr g"
    shows "D (f \<otimes> g) = D (D f \<otimes> D g)"
      unfolding D_def
      using assms strict_arr_char rep_in_Hom Diagonalize_in_Hom tensor_mkarr rep_tensor
            Diagonalize_in_Hom rep_mkarr Diagonalize_norm Diagonalize_Tensor
      by force

    lemma ide_diagonalize_can:
    assumes "can f"
    shows "ide (D f)"
      using assms D_def Can_rep_can Ide_Diagonalize_Can ide_mkarr_Ide can_implies_arr
      by simp

    text \<open>
      We next show that the diagonalization functor and the inclusion of the full subcategory
      \<open>\<F>\<^sub>SC\<close> underlie an equivalence of categories.  The arrows @{term "mkarr (DOM a\<^bold>\<down>)"},
      determined by reductions of canonical representatives, are the components of a
      natural isomorphism.
\<close>

    interpretation S: full_inclusion_functor comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close> ..
    interpretation DoS: composite_functor \<F>\<^sub>SC.comp comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map D
      ..
    interpretation SoD: composite_functor comp \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map ..

    interpretation \<nu>: transformation_by_components
                        comp comp map SoD.map \<open>\<lambda>a. mkarr (DOM a\<^bold>\<down>)\<close>
    proof
      fix a
      assume a: "ide a"
      show "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : map a \<rightarrow> SoD.map a\<guillemotright>"
      proof -
        have "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : a \<rightarrow> mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>\<guillemotright>"
          using a Arr_implies_Ide_Dom red_in_Hom dom_char [of a] by auto
        moreover have "map a = a"
          using a map_simp by simp
        moreover have "SoD.map a = mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>"
          using a D.preserves_ide \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp D_def Ide_Diagonalize_rep_ide
                Ide_in_Hom Diagonalize_in_Hom
          by force
        ultimately show ?thesis by simp
      qed
      next
      fix f
      assume f: "arr f"
      show "mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f = SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>)"
      proof -
        have "SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<cdot> mkarr (DOM f\<^bold>\<down>)"
          using f DOM_dom D.preserves_arr \<F>\<^sub>SC.map_simp D_def by simp
        also have "... = mkarr (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>)"
          using f Diagonalize_in_Hom red_in_Hom comp_mkarr Arr_implies_Ide_Dom
          by simp
        also have "... = mkarr (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
        proof (intro mkarr_eqI)
          show "Par (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>) (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
            using f Diagonalize_in_Hom red_in_Hom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
            by simp
          show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
          proof -
            have "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>DOM f\<^bold>\<down>\<^bold>\<rfloor>"
              using f by simp
            also have "... = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
              using f Arr_implies_Ide_Dom Can_red Ide_Diagonalize_Can [of "DOM f\<^bold>\<down>"]
                    Diag_Diagonalize CompDiag_Diag_Ide
              by force
            also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
              using f Arr_implies_Ide_Cod Can_red Ide_Diagonalize_Can [of "COD f\<^bold>\<down>"]
                    Diag_Diagonalize CompDiag_Diag_Ide
              by force
            also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
              by simp
            finally show ?thesis by blast
          qed
        qed
        also have "... = mkarr (COD f\<^bold>\<down>) \<cdot> mkarr (rep f)"
          using f comp_mkarr rep_in_Hom red_in_Hom Arr_implies_Ide_Cod by blast
        also have "... = mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f"
          using f DOM_cod by simp
        finally show ?thesis by blast
      qed
    qed

    interpretation \<nu>: natural_isomorphism comp comp map SoD.map \<nu>.map
      apply unfold_locales
      using \<nu>.map_simp_ide rep_in_Hom Arr_implies_Ide_Dom Can_red can_mkarr_Can iso_can
      by simp

    text \<open>
      The restriction of the diagonalization functor to the subcategory \<open>\<F>\<^sub>SC\<close>
      is the identity.
\<close>

    lemma DoS_eq_\<F>\<^sub>SC:
    shows "DoS.map = \<F>\<^sub>SC.map"
    proof
      fix f
      have "\<not> \<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
        using DoS.is_extensional \<F>\<^sub>SC.map_def by simp
      moreover have "\<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
        using \<F>\<^sub>SC.map_simp strict_arr_char Diagonalize_Diag D_def mkarr_Diagonalize_rep
        by simp
      ultimately show "DoS.map f = \<F>\<^sub>SC.map f" by blast
    qed

    interpretation \<mu>: transformation_by_components
                        \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<open>\<lambda>a. a\<close>
      using \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp DoS_eq_\<F>\<^sub>SC \<F>\<^sub>SC.map_simp \<F>\<^sub>SC.comp_cod_arr \<F>\<^sub>SC.comp_arr_dom
      by (unfold_locales, intro \<F>\<^sub>SC.in_homI, auto)

    interpretation \<mu>: natural_isomorphism \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map
      apply unfold_locales using \<mu>.map_simp_ide \<F>\<^sub>SC.ide_is_iso by simp

    interpretation equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map ..

    text \<open>
      We defined the natural isomorphisms @{term \<mu>} and @{term \<nu>} by giving their
      components (\emph{i.e.}~their values at objects).  However, it is helpful
      in exporting these facts to have simple characterizations of their values
      for all arrows.
\<close>

    definition \<mu>
    where "\<mu> \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then f else \<F>\<^sub>SC.null"

    definition \<nu>
    where "\<nu> \<equiv> \<lambda>f. if arr f then mkarr (COD f\<^bold>\<down>) \<cdot> f else null"

    lemma \<mu>_char:
    shows "\<mu>.map = \<mu>"
    proof (intro NaturalTransformation.eqI)
      show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map" ..
      have "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map \<F>\<^sub>SC.map \<F>\<^sub>SC.map"
        using DoS.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
      moreover have "\<F>\<^sub>SC.map = \<mu>" unfolding \<mu>_def using \<F>\<^sub>SC.map_def by blast
      ultimately show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>"
        using \<F>\<^sub>SC.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
      show "\<And>a. \<F>\<^sub>SC.ide a \<Longrightarrow> \<mu>.map a = \<mu> a"
        using \<mu>.map_simp_ide \<F>\<^sub>SC.ideD \<mu>_def by simp
    qed

    lemma \<nu>_char:
    shows "\<nu>.map = \<nu>"
      unfolding \<nu>.map_def \<nu>_def using map_simp DOM_cod by fastforce

    lemma is_equivalent_to_strict_subcategory:
    shows "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
    proof -
      have "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map" ..
      thus "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
        using \<nu>_char \<mu>_char by simp
    qed

    text \<open>
      The inclusion of generators functor from @{term C} to \<open>\<F>C\<close>
      corestricts to a functor from @{term C} to \<open>\<F>\<^sub>SC\<close>.
\<close>

    interpretation I: "functor" C comp inclusion_of_generators
      using inclusion_is_functor by auto
    interpretation DoI: composite_functor C comp \<F>\<^sub>SC.comp inclusion_of_generators D ..

    lemma DoI_eq_I:
    shows "DoI.map = inclusion_of_generators"
    proof
      fix f
      have "\<not> C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
        using DoI.is_extensional I.is_extensional \<F>\<^sub>SC.null_char by blast
      moreover have "C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
      proof -
        assume f: "C.arr f"
        have "DoI.map f = D (inclusion_of_generators f)" using f by simp
        also have "... = inclusion_of_generators f"
        proof -
          have "\<F>\<^sub>SC.arr (inclusion_of_generators f)"
            using f arr_mkarr rep_mkarr Par_Arr_norm [of "\<^bold>\<langle>f\<^bold>\<rangle>"] strict_arr_char
                  inclusion_of_generators_def
            by simp
          thus ?thesis using f strict_arr_char' by blast
        qed
        finally show "DoI.map f = inclusion_of_generators f" by blast
      qed
      ultimately show "DoI.map f = inclusion_of_generators f" by blast
    qed

  end

  text \<open>
    Next, we show that the subcategory \<open>\<F>\<^sub>SC\<close> inherits monoidal structure from
    the ambient category \<open>\<F>C\<close>, and that this monoidal structure is strict.
\<close>

  locale free_strict_monoidal_category =
    monoidal_language C +
    \<F>C: free_monoidal_category C +
    full_subcategory \<F>C.comp "\<lambda>f. \<F>C.ide f \<and> Diag (\<F>C.DOM f)"
    for C :: "'c comp"
  begin

    interpretation D: "functor" \<F>C.comp comp \<F>C.D
      using \<F>C.diagonalize_is_functor by auto

    notation comp           (infixr "\<cdot>\<^sub>S" 55)

    definition tensor\<^sub>S      (infixr "\<otimes>\<^sub>S" 53)
    where "f \<otimes>\<^sub>S g \<equiv> \<F>C.D (\<F>C.tensor f g)"

    definition assoc\<^sub>S       ("\<a>\<^sub>S[_, _, _]")
    where "assoc\<^sub>S a b c \<equiv> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c"

    lemma tensor_char:
    assumes "arr f" and "arr g"
    shows "f \<otimes>\<^sub>S g = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>)"
      unfolding \<F>C.D_def tensor\<^sub>S_def
      using assms arr_char \<F>C.rep_tensor by simp

    lemma tensor_in_hom [simp]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
    shows "\<guillemotleft>f \<otimes>\<^sub>S g : a \<otimes>\<^sub>S c \<rightarrow> b \<otimes>\<^sub>S d\<guillemotright>"
      unfolding tensor\<^sub>S_def
      using assms D.preserves_hom D.preserves_arr arr_char in_hom_char by simp

    lemma arr_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "arr (f \<otimes>\<^sub>S g)"
      using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast

    lemma dom_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "dom (f \<otimes>\<^sub>S g) = dom f \<otimes>\<^sub>S dom g"
      using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast

    lemma cod_tensor [simp]:
    assumes "arr f" and "arr g"
    shows "cod (f \<otimes>\<^sub>S g) = cod f \<otimes>\<^sub>S cod g"
      using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast

    lemma tensor_preserves_ide:
    assumes "ide a" and "ide b"
    shows "ide (a \<otimes>\<^sub>S b)"
      using assms tensor\<^sub>S_def D.preserves_ide \<F>C.tensor_preserves_ide ide_char
      by fastforce

    lemma tensor_tensor:
    assumes "arr f" and "arr g" and "arr h"
    shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
    and "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
    proof -
      show "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
      proof -
        have "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (f \<otimes>\<^sub>S g)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
          using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
                \<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
          by simp
        also have
          "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>))\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                           \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
          using assms arr_char tensor_char by simp
        also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
          using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize
                TensorDiag_preserves_Diag arr_char
          by force
        also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
          using assms Diag_Diagonalize TensorDiag_preserves_Diag TensorDiag_assoc arr_char
          by force
        finally show ?thesis by blast
      qed
      show "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
      proof -
        have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>\<^bold>\<rfloor>)"
          using assms Diag_Diagonalize TensorDiag_preserves_Diag arr_char by force
        also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                                   (\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>))\<^bold>\<rfloor>))"
          using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize arr_char by force
        also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep (g \<otimes>\<^sub>S h)\<^bold>\<rfloor>)"
           using assms tensor_char by simp
        also have "... = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
          using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
                \<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
          by simp
        finally show ?thesis by blast
      qed
    qed

    lemma tensor_assoc:
    assumes "arr f" and "arr g" and "arr h"
    shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
      using assms tensor_tensor by presburger

    lemma arr_unity:
    shows "arr \<I>"
      using \<F>C.rep_unity \<F>C.Par_Arr_norm \<F>C.\<I>_agreement \<F>C.strict_arr_char by force

    lemma tensor_unity_arr:
    assumes "arr f"
    shows "\<I> \<otimes>\<^sub>S f = f"
      using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
      by simp

    lemma tensor_arr_unity:
    assumes "arr f"
    shows "f \<otimes>\<^sub>S \<I> = f"
      using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
      by simp

    lemma assoc_char:
    assumes "ide a" and "ide b" and "ide c"
    shows "\<a>\<^sub>S[a, b, c] = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep c\<^bold>\<rfloor>)"
      using assms tensor_tensor(2) assoc\<^sub>S_def ideD(1) by simp

    lemma assoc_in_hom:
    assumes "ide a" and "ide b" and "ide c"
    shows "\<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
      using assms tensor_preserves_ide ideD tensor_assoc assoc\<^sub>S_def
      by (metis (no_types, lifting) ide_in_hom)

    text \<open>The category \<open>\<F>\<^sub>SC\<close> is a monoidal category.\<close>

    interpretation EMC: elementary_monoidal_category comp tensor\<^sub>S \<I> \<open>\<lambda>a. a\<close> \<open>\<lambda>a. a\<close> assoc\<^sub>S
    proof
      show "ide \<I>"
        using ide_char arr_char \<F>C.rep_mkarr \<F>C.Dom_norm \<F>C.Cod_norm \<F>C.\<I>_agreement
        by auto
      show "\<And>a. ide a \<Longrightarrow> iso a"
        using ide_char arr_char iso_char by auto
      show "\<And>f a b g c d. \<lbrakk> in_hom a b f; in_hom c d g \<rbrakk> \<Longrightarrow> in_hom (a \<otimes>\<^sub>S c) (b \<otimes>\<^sub>S d) (f \<otimes>\<^sub>S g)"
        using tensor_in_hom by blast
      show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes>\<^sub>S b)"
        using tensor_preserves_ide by blast
      show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> iso \<a>\<^sub>S[a, b, c]"
        using tensor_preserves_ide ide_is_iso assoc\<^sub>S_def by presburger
      show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
        using assoc_in_hom by blast
      show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (a \<otimes>\<^sub>S b) \<cdot>\<^sub>S \<a>\<^sub>S[a, \<I>, b] = a \<otimes>\<^sub>S b"
        using ide_def tensor_unity_arr assoc\<^sub>S_def ideD(1) tensor_preserves_ide comp_ide_self
        by simp
      show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (\<I> \<otimes>\<^sub>S f) = f \<cdot>\<^sub>S dom f"
        using tensor_unity_arr comp_arr_dom comp_cod_arr by presburger
      show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (f \<otimes>\<^sub>S \<I>) = f \<cdot>\<^sub>S dom f"
        using tensor_arr_unity comp_arr_dom comp_cod_arr by presburger
      next
      fix a
      assume a: "ide a"
      show "\<guillemotleft>a : \<I> \<otimes>\<^sub>S a \<rightarrow> a\<guillemotright>"
        using a tensor_unity_arr ide_in_hom [of a] by fast
      show "\<guillemotleft>a : a \<otimes>\<^sub>S \<I> \<rightarrow> a\<guillemotright>"
        using a tensor_arr_unity ide_in_hom [of a] by fast
      next
      fix f g f' g'
      assume fg: "seq g f"
      assume fg': "seq g' f'"
      show "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
      proof -
        have A: "\<F>C.seq g f" and B: "\<F>C.seq g' f'"
          using fg fg' seq_char by auto
        have "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = \<F>C.D ((g \<otimes> g') \<cdot> (f \<otimes> f'))"
          using A B tensor\<^sub>S_def by fastforce
        also have "... = \<F>C.D (g \<cdot> f \<otimes> g' \<cdot> f')"
          using A B \<F>C.interchange \<F>C.T_simp \<F>C.seqE by metis
        also have "... = \<F>C.D (g \<cdot> f) \<otimes>\<^sub>S \<F>C.D (g' \<cdot> f')"
          using A B tensor\<^sub>S_def \<F>C.T_simp \<F>C.seqE \<F>C.diagonalize_tensor arr_char
          by (metis (no_types, lifting) D.preserves_reflects_arr)
        also have "... = \<F>C.D g \<cdot>\<^sub>S \<F>C.D f \<otimes>\<^sub>S \<F>C.D g' \<cdot>\<^sub>S \<F>C.D f'"
          using A B by simp
        also have "... = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
           using fg fg' \<F>C.diagonalize_strict_arr by (elim seqE, simp)
        finally show ?thesis by blast
      qed
      next
      fix f0 f1 f2
      assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
      show "\<a>\<^sub>S[cod f0, cod f1, cod f2] \<cdot>\<^sub>S ((f0 \<otimes>\<^sub>S f1) \<otimes>\<^sub>S f2)
              = (f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2) \<cdot>\<^sub>S \<a>\<^sub>S[dom f0, dom f1, dom f2]"
        using f0 f1 f2 assoc\<^sub>S_def tensor_assoc dom_tensor cod_tensor arr_tensor
              comp_cod_arr [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "cod f0 \<otimes>\<^sub>S cod f1 \<otimes>\<^sub>S cod f2"]
              comp_arr_dom [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "dom f0 \<otimes>\<^sub>S dom f1 \<otimes>\<^sub>S dom f2"]
        by presburger
      next
      fix a b c d
      assume a: "ide a" and b: "ide b" and c: "ide c" and d: "ide d"
      show "(a \<otimes>\<^sub>S \<a>\<^sub>S[b, c, d]) \<cdot>\<^sub>S \<a>\<^sub>S[a, b \<otimes>\<^sub>S c, d] \<cdot>\<^sub>S (\<a>\<^sub>S[a, b, c] \<otimes>\<^sub>S d)
               = \<a>\<^sub>S[a, b, c \<otimes>\<^sub>S d] \<cdot>\<^sub>S \<a>\<^sub>S[a \<otimes>\<^sub>S b, c, d]"
        unfolding assoc\<^sub>S_def
        using a b c d tensor_assoc tensor_preserves_ide ideD tensor_in_hom
              comp_arr_dom [of "a \<otimes>\<^sub>S b \<otimes>\<^sub>S c \<otimes>\<^sub>S d"]
        by simp
    qed

    lemma is_elementary_monoidal_category:
    shows "elementary_monoidal_category comp tensor\<^sub>S \<I> (\<lambda>a. a) (\<lambda>a. a) assoc\<^sub>S" ..

    abbreviation T\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.T\<^sub>E\<^sub>M\<^sub>C"
    abbreviation \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
    abbreviation \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"

    lemma is_monoidal_category:
    shows "monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C"
      using EMC.induces_monoidal_category by auto

  end

  sublocale free_strict_monoidal_category \<subseteq>
              elementary_monoidal_category comp tensor\<^sub>S \<I> "\<lambda>a. a" "\<lambda>a. a" assoc\<^sub>S
    using is_elementary_monoidal_category by auto

  sublocale free_strict_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
    using is_monoidal_category by auto

  sublocale free_strict_monoidal_category \<subseteq>
              strict_monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
    using tensor_preserves_ide assoc_agreement lunit_agreement runit_agreement
    apply unfold_locales
    unfolding assoc\<^sub>S_def
      apply presburger
     apply meson
    by meson

  context free_strict_monoidal_category
  begin

    text \<open>
      The inclusion of generators functor from @{term C} to \<open>\<F>\<^sub>SC\<close> is the composition
      of the inclusion of generators from @{term C} to \<open>\<F>C\<close> and the diagonalization
      functor, which projects \<open>\<F>C\<close> to \<open>\<F>\<^sub>SC\<close>.  As the diagonalization functor
      is the identity map on the image of @{term C}, the composite functor amounts to the
      corestriction to \<open>\<F>\<^sub>SC\<close> of the inclusion of generators of \<open>\<F>C\<close>.
\<close>

    interpretation D: "functor" \<F>C.comp comp \<F>C.D
      using \<F>C.diagonalize_is_functor by auto

    interpretation I: composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D
    proof -
      interpret "functor" C \<F>C.comp \<F>C.inclusion_of_generators
        using \<F>C.inclusion_is_functor by blast
      show "composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D" ..
    qed

    definition inclusion_of_generators
    where "inclusion_of_generators \<equiv> \<F>C.inclusion_of_generators"

    lemma inclusion_is_functor:
    shows "functor C comp inclusion_of_generators"
      using \<F>C.DoI_eq_I I.functor_axioms inclusion_of_generators_def
      by auto

    text \<open>
      The diagonalization functor is strict monoidal.
\<close>

    interpretation D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                              comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                              \<F>C.D
    proof
      show "\<F>C.D \<F>C.\<iota> = \<iota>"
      proof -
        have "\<F>C.D \<F>C.\<iota> = \<F>C.mkarr \<^bold>\<lfloor>\<F>C.rep \<F>C.\<iota>\<^bold>\<rfloor>"
          unfolding \<F>C.D_def using \<F>C.\<iota>_in_hom by auto
        also have "... = \<F>C.mkarr \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[\<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>\<^bold>]\<^bold>\<rfloor>"
          using \<F>C.\<iota>_def \<F>C.rep_unity \<F>C.rep_lunit \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm
          by auto
        also have "... = \<iota>"
          using \<F>C.unity\<^sub>F\<^sub>M\<^sub>C_def \<F>C.\<I>_agreement \<iota>_def by simp
        finally show ?thesis by blast
      qed
      show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
                    \<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
      proof -
        fix f g
        assume f: "\<F>C.arr f" and g: "\<F>C.arr g"
        have fg: "arr (\<F>C.D f) \<and> arr (\<F>C.D g)"
          using f g D.preserves_arr by blast
        have "\<F>C.D (\<F>C.tensor f g) = f \<otimes>\<^sub>S g"
          using tensor\<^sub>S_def by simp
        also have "f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
          using f g tensor\<^sub>S_def by simp
        also have "... = \<F>C.D f \<otimes>\<^sub>S \<F>C.D g"
          using f g fg tensor\<^sub>S_def \<F>C.T_simp \<F>C.diagonalize_tensor arr_char
          by (metis (no_types, lifting))
        also have "... = tensor (\<F>C.D f) (\<F>C.D g)"
          using fg T_simp by simp
        finally show "\<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
          by blast
      qed
      show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
                      \<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
      proof -
        fix a b c
        assume a: "\<F>C.ide a" and b: "\<F>C.ide b" and c: "\<F>C.ide c"
        have abc: "ide (\<F>C.D a) \<and> ide (\<F>C.D b) \<and> ide (\<F>C.D c)"
          using a b c D.preserves_ide by blast
        have abc': "\<F>C.ide (\<F>C.D a) \<and> \<F>C.ide (\<F>C.D b) \<and> \<F>C.ide (\<F>C.D c)"
            using a b c D.preserves_ide ide_char by simp
        have 1: "\<And>f g. \<F>C.arr f \<Longrightarrow> \<F>C.arr g \<Longrightarrow> f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
          using tensor\<^sub>S_def by simp
        have 2: "\<And>f. ide f \<Longrightarrow> \<F>C.ide f" using ide_char by blast
        have "assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c) = \<F>C.D a \<otimes>\<^sub>S \<F>C.D b \<otimes>\<^sub>S \<F>C.D c"
          using abc \<alpha>_ide_simp assoc\<^sub>S_def by simp
        also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (\<F>C.D b \<otimes> \<F>C.D c)"
          using abc' 1 by auto
        also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (b \<otimes> c)"
          using b c \<F>C.diagonalize_tensor by force
        also have "... = \<F>C.D (\<F>C.D a \<otimes> \<F>C.D (b \<otimes> c))"
          using 1 b c abc D.preserves_ide \<F>C.tensor_preserves_ide ide_char
          by simp
        also have "... = \<F>C.D (a \<otimes> b \<otimes> c)"
          using a b c \<F>C.diagonalize_tensor by force
        also have "... = \<F>C.D \<a>[a, b, c]"
        proof -
          have "\<F>C.can \<a>[a, b, c]" using a b c \<F>C.can_assoc by simp
          hence "\<F>C.ide (\<F>C.D \<a>[a, b, c])"
            using a b c \<F>C.ide_diagonalize_can by simp
          moreover have "\<F>C.cod (\<F>C.D \<a>[a, b, c]) = \<F>C.D (a \<otimes> b \<otimes> c)"
            using a b c \<F>C.assoc_in_hom D.preserves_hom
            by (metis (no_types, lifting) cod_char in_homE)
          ultimately show ?thesis by simp
        qed
        also have "... = \<F>C.D (\<F>C.assoc a b c)"
          using a b c by simp
        finally show "\<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
          by blast
      qed
    qed

    lemma diagonalize_is_strict_monoidal_functor:
    shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                   comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                   \<F>C.D"
      ..

    interpretation \<phi>: natural_isomorphism
                        \<F>C.CC.comp comp D.T\<^sub>DoFF.map D.FoT\<^sub>C.map D.\<phi>
      using D.structure_is_natural_isomorphism by simp

    text \<open>
      The diagonalization functor is part of a monoidal equivalence between the
      free monoidal category and the subcategory @{term "\<F>\<^sub>SC"}.
\<close>

    interpretation E: equivalence_of_categories comp \<F>C.comp \<F>C.D map \<F>C.\<nu> \<F>C.\<mu>
      using \<F>C.is_equivalent_to_strict_subcategory by auto

    interpretation D: monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                       comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                       \<F>C.D D.\<phi>
      using D.monoidal_functor_axioms by metis

    interpretation equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                                           \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                                           \<F>C.D D.\<phi> \<I>
                                                           map \<F>C.\<nu> \<F>C.\<mu>
       ..

    text \<open>
      The category @{term "\<F>C"} is monoidally equivalent to its subcategory @{term "\<F>\<^sub>SC"}.
\<close>

    theorem monoidally_equivalent_to_free_monoidal_category:
    shows "equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                              \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                              \<F>C.D D.\<phi>
                                              map \<F>C.\<nu> \<F>C.\<mu>"
      ..

  end

  text \<open>
    We next show that the evaluation functor induced on the free monoidal category
    generated by @{term C} by a functor @{term V} from @{term C} to a strict monoidal
    category @{term D} restricts to a strict monoidal functor on the subcategory @{term "\<F>\<^sub>SC"}.
\<close>

  locale strict_evaluation_functor =
    D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
    \<F>C: free_monoidal_category C +
    E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
    \<F>\<^sub>SC: free_strict_monoidal_category C
  for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and V :: "'c \<Rightarrow> 'd"
  begin

    notation \<F>C.in_hom   ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
    notation \<F>\<^sub>SC.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")

    (* TODO: This is just the restriction of the evaluation functor to a subcategory.
       It would be useful to define a restriction_of_functor locale that does this in general
       and gives the lemma that it yields a functor. *)

    definition map
    where "map \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then E.map f else D.null"

    interpretation "functor" \<F>\<^sub>SC.comp D map
      unfolding map_def
      apply unfold_locales
          apply simp
      using \<F>\<^sub>SC.arr_char E.preserves_arr
         apply simp
      using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char E.preserves_dom
        apply simp
      using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.cod_char E.preserves_cod
       apply simp
      using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.comp_char E.preserves_comp
      by (elim \<F>\<^sub>SC.seqE, auto)

    lemma is_functor:
    shows "functor \<F>\<^sub>SC.comp D map" ..

    text \<open>
       Every canonical arrow is an equivalence class of canonical terms.
       The evaluations in \<open>D\<close> of all such terms are identities,
       due to the strictness of \<open>D\<close>.
\<close>

    lemma ide_eval_Can:
    shows "Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>"
    proof (induct t)
      show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
      show "Can \<^bold>\<I> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<I>\<rbrace>" by simp
      show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<otimes> t2) \<rbrakk> \<Longrightarrow>
                     D.ide \<lbrace>t1 \<^bold>\<otimes> t2\<rbrace>"
        by simp
      show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<cdot> t2) \<rbrakk> \<Longrightarrow>
                     D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
      proof -
        fix t1 t2
        assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
        and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
        and t12: "Can (t1 \<^bold>\<cdot> t2)"
        show "D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
          using t1 t2 t12 Can_implies_Arr eval_in_hom [of t1] eval_in_hom [of t2] D.comp_ide_arr
          by fastforce
      qed
      show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
        using D.strict_lunit by simp
      show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
        using D.strict_lunit by simp
      show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
        using D.strict_runit by simp
      show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
        using D.strict_runit by simp
      fix t1 t2 t3
      assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
      and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
      and t3: "Can t3 \<Longrightarrow> D.ide \<lbrace>t3\<rbrace>"
      show "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
      proof -
        assume "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]"
        hence t123: "D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
          using t1 t2 t3 by simp
        have "\<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
          using t123 D.strict_assoc D.assoc_in_hom [of "\<lbrace>t1\<rbrace>" "\<lbrace>t2\<rbrace>" "\<lbrace>t3\<rbrace>"] apply simp
          by (elim D.in_homE, simp)
        thus ?thesis using t123 by simp
      qed
      show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
      proof -
        assume "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]"
        hence t123: "Can t1 \<and> Can t2 \<and> Can t3 \<and> D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
          using t1 t2 t3 by simp
        have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>
                 = D.inv \<a>\<^sub>D[D.cod \<lbrace>t1\<rbrace>, D.cod \<lbrace>t2\<rbrace>, D.cod \<lbrace>t3\<rbrace>] \<cdot>\<^sub>D (\<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>)"
          using t123 eval_Assoc' [of t1 t2 t3] Can_implies_Arr by simp
        also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
        proof -
          have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
          proof -
            have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = D.cod \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>]"
              using t123 D.strict_assoc by simp
            also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
              using t123 by simp
            finally show ?thesis by blast
          qed
          thus ?thesis
            using t123 D.strict_assoc D.comp_arr_dom by auto
        qed
        finally have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>" by blast
        thus ?thesis using t123 by auto
      qed
    qed

    lemma ide_eval_can:
    assumes "\<F>C.can f"
    shows "D.ide (E.map f)"
    proof -
      have "f = \<F>C.mkarr (\<F>C.rep f)"
        using assms \<F>C.can_implies_arr \<F>C.mkarr_rep by blast
      moreover have 1: "Can (\<F>C.rep f)"
        using assms \<F>C.Can_rep_can by simp
      moreover have "D.ide \<lbrace>\<F>C.rep f\<rbrace>"
        using assms ide_eval_Can by (simp add: 1)
      ultimately show ?thesis using assms \<F>C.can_implies_arr E.map_def by force
    qed

    text \<open>
       Diagonalization transports formal arrows naturally along reductions,
       which are canonical terms and therefore evaluate to identities of \<open>D\<close>.
       It follows that the evaluation in \<open>D\<close> of a formal arrow is equal to the
       evaluation of its diagonalization.
\<close>

    lemma map_diagonalize:
    assumes f: "\<F>C.arr f"
    shows "E.map (\<F>C.D f) = E.map f"
    proof -
      interpret EQ: equivalence_of_categories
                      \<F>\<^sub>SC.comp \<F>C.comp \<F>C.D \<F>\<^sub>SC.map \<F>C.\<nu> \<F>C.\<mu>
        using \<F>C.is_equivalent_to_strict_subcategory by auto
      have 1: "\<F>C.seq (\<F>\<^sub>SC.map (\<F>C.D f)) (\<F>C.\<nu> (\<F>C.dom f))"
      proof
        show "\<guillemotleft>\<F>C.\<nu> (\<F>C.dom f) : \<F>C.dom f \<rightarrow> \<F>C.D (\<F>C.dom f)\<guillemotright>"
          using f \<F>\<^sub>SC.map_simp EQ.F.preserves_arr
          by (intro \<F>C.in_homI, simp_all)
        show "\<guillemotleft>\<F>\<^sub>SC.map (\<F>C.D f) : \<F>C.D (\<F>C.dom f) \<rightarrow> \<F>C.cod (\<F>C.D f)\<guillemotright>"
          using f \<F>\<^sub>SC.map_simp \<F>C.arr_iff_in_hom EQ.F.preserves_hom \<F>\<^sub>SC.arr_char
                \<F>\<^sub>SC.in_hom_char [of "\<F>C.D f" "\<F>C.D (\<F>C.dom f)" "\<F>C.D (\<F>C.cod f)"]
          by (intro \<F>C.in_homI, auto)
      qed
      have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f =
            E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
      proof -
        have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f = E.map (\<F>C.\<nu> (\<F>C.cod f) \<cdot> f)"
          using f by simp
        also have "... = E.map (\<F>C.D f \<cdot> \<F>C.\<nu> (\<F>C.dom f))"
          using f EQ.\<eta>.naturality \<F>\<^sub>SC.map_simp EQ.F.preserves_arr by simp
        also have "... = E.map (\<F>\<^sub>SC.map (\<F>C.D f)) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
          using f 1 E.preserves_comp_2 EQ.F.preserves_arr \<F>\<^sub>SC.map_simp
          by (metis (no_types, lifting))
        also have "... = E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
          using f EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by simp
        finally show ?thesis by blast
      qed
      moreover have "\<And>a. \<F>C.ide a \<Longrightarrow> D.ide (E.map (\<F>C.\<nu> a))"
        using \<F>C.\<nu>_def \<F>C.Arr_rep Arr_implies_Ide_Cod Can_red \<F>C.can_mkarr_Can
              ide_eval_can
        by (metis (no_types, lifting) EQ.\<eta>.preserves_reflects_arr \<F>C.seqE
            \<F>C.comp_preserves_can \<F>C.ideD(1) \<F>C.ide_implies_can)
      moreover have "D.cod (E.map f) = D.dom (E.map (\<F>C.\<nu> (\<F>C.cod f)))"
        using f E.preserves_hom EQ.\<eta>.preserves_hom by simp
      moreover have "D.dom (E.map (\<F>C.D f)) = D.cod (E.map (\<F>C.\<nu> (\<F>C.dom f)))"
          using f 1 E.preserves_seq EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by auto
      ultimately show ?thesis
        using f D.comp_arr_dom D.ideD D.arr_dom_iff_arr E.is_natural_2
        by (metis E.preserves_cod \<F>C.ide_cod \<F>C.ide_dom)
    qed

    lemma strictly_preserves_tensor:
    assumes "\<F>\<^sub>SC.arr f" and "\<F>\<^sub>SC.arr g"
    shows "map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
    proof -
      have 1: "\<F>C.arr (f \<otimes> g)"
        using assms \<F>\<^sub>SC.arr_char \<F>C.tensor_in_hom by auto
      have 2: "\<F>\<^sub>SC.arr (\<F>\<^sub>SC.tensor f g)"
        using assms \<F>\<^sub>SC.tensor_in_hom [of f g] \<F>\<^sub>SC.T_simp by fastforce
      have "map (\<F>\<^sub>SC.tensor f g) = E.map (f \<otimes> g)"
      proof -
        have "map (\<F>\<^sub>SC.tensor f g) = map (f \<otimes>\<^sub>S g)"
          using assms \<F>\<^sub>SC.T_simp by simp
        also have "... = map (\<F>C.D (f \<otimes> g))"
          using assms \<F>C.tensor\<^sub>F\<^sub>M\<^sub>C_def \<F>\<^sub>SC.tensor\<^sub>S_def \<F>\<^sub>SC.arr_char by force
        also have "... = E.map (f \<otimes> g)"
        proof -
          interpret Diag: "functor" \<F>C.comp \<F>\<^sub>SC.comp \<F>C.D
            using \<F>C.diagonalize_is_functor by auto
          show ?thesis
            using assms 1 map_diagonalize [of "f \<otimes> g"] Diag.preserves_arr map_def by simp
        qed
        finally show ?thesis by blast
      qed
      thus ?thesis
        using assms \<F>\<^sub>SC.arr_char E.strictly_preserves_tensor map_def by simp
    qed

    lemma is_strict_monoidal_functor:
    shows "strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
    proof
      show "\<And>f g. \<F>\<^sub>SC.arr f \<Longrightarrow> \<F>\<^sub>SC.arr g \<Longrightarrow> map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
        using strictly_preserves_tensor by fast
      show "map \<F>\<^sub>SC.\<iota> = \<iota>\<^sub>D"
        using \<F>\<^sub>SC.arr_unity \<F>\<^sub>SC.\<iota>_def map_def E.map_def \<F>C.rep_mkarr E.eval_norm D.strict_unit
        by auto
      fix a b c
      assume a: "\<F>\<^sub>SC.ide a" and b: "\<F>\<^sub>SC.ide b" and c: "\<F>\<^sub>SC.ide c"
      show "map (\<F>\<^sub>SC.assoc a b c) = \<a>\<^sub>D[map a, map b, map c]"
      proof -
        have "map (\<F>\<^sub>SC.assoc a b c) = map a \<otimes>\<^sub>D map b \<otimes>\<^sub>D map c"
          using a b c \<F>\<^sub>SC.\<alpha>_def \<F>\<^sub>SC.assoc_agreement \<F>\<^sub>SC.assoc\<^sub>S_def \<F>\<^sub>SC.arr_tensor
                \<F>\<^sub>SC.T_simp \<F>\<^sub>SC.ideD(1) \<F>\<^sub>SC.strict_assoc preserves_ide [of "\<F>\<^sub>SC.assoc a b c"]
                strictly_preserves_tensor
          by force
        also have "... = \<a>\<^sub>D[map a, map b, map c]"
          using a b c D.strict_assoc D.assoc_in_hom [of "map a" "map b" "map c"] by auto
        finally show ?thesis by blast
      qed
    qed

  end

  sublocale strict_evaluation_functor \<subseteq>
              strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
    using is_strict_monoidal_functor by auto

  locale strict_monoidal_extension_to_free_strict_monoidal_category =
    C: category C +
    monoidal_language C +
    \<F>\<^sub>SC: free_strict_monoidal_category C +
    strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                \<F>\<^sub>SC.inclusion_of_generators V F
  for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
  and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and V :: "'c \<Rightarrow> 'd"
  and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"

  sublocale strict_evaluation_functor \<subseteq>
              strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                          \<F>\<^sub>SC.inclusion_of_generators V map
  proof -
    interpret V: "functor" C \<F>\<^sub>SC.comp \<F>\<^sub>SC.inclusion_of_generators
      using \<F>\<^sub>SC.inclusion_is_functor by auto
    show "strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                    \<F>\<^sub>SC.inclusion_of_generators V map"
    proof
      show "\<forall>f. C.arr f \<longrightarrow> map (\<F>\<^sub>SC.inclusion_of_generators f) = V f"
        using V.preserves_arr E.is_extension map_def \<F>\<^sub>SC.inclusion_of_generators_def by simp
    qed
  qed

  context free_strict_monoidal_category
  begin

    text \<open>
      We now have the main result of this section: the evaluation functor on \<open>\<F>\<^sub>SC\<close>
      induced by a functor @{term V} from @{term C} to a strict monoidal category @{term D}
      is the unique strict monoidal extension of @{term V} to \<open>\<F>\<^sub>SC\<close>.
\<close>

    theorem is_free:
    assumes "strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D"
    and "strict_monoidal_extension_to_free_strict_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
    shows "F = strict_evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
    proof -
      interpret D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
        using assms(1) by auto

      text \<open>
        Let @{term F} be a given extension of V to a strict monoidal functor defined on
        \<open>\<F>\<^sub>SC\<close>.
\<close>
      interpret F: strict_monoidal_extension_to_free_strict_monoidal_category
                     C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
        using assms(2) by auto

      text \<open>
        Let @{term E\<^sub>S} be the evaluation functor from \<open>\<F>\<^sub>SC\<close> to @{term D}
        induced by @{term V}.  Then @{term E\<^sub>S} is also a strict monoidal extension of @{term V}.
\<close>
      interpret E\<^sub>S: strict_evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..

      text \<open>
        Let @{term D} be the strict monoidal functor @{term "\<F>C.D"} that projects
        \<open>\<F>C\<close> to the subcategory \<open>\<F>\<^sub>SC\<close>.
\<close>
      interpret D: "functor" \<F>C.comp comp \<F>C.D
        using \<F>C.diagonalize_is_functor by auto
      interpret D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota>
                                           comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha> \<iota>
                                           \<F>C.D
        using diagonalize_is_strict_monoidal_functor by blast

      text \<open>
         The composite functor \<open>F o D\<close> is also an extension of @{term V}
         to a strict monoidal functor on \<open>\<F>C\<close>.
\<close>
      interpret FoD: composite_functor \<F>C.comp comp D \<F>C.D F ..
      interpret FoD: strict_monoidal_functor
                       \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<open>F o \<F>C.D\<close>
        using D.strict_monoidal_functor_axioms F.strict_monoidal_functor_axioms
              strict_monoidal_functors_compose
        by fast
      interpret FoD: strict_monoidal_extension_to_free_monoidal_category
                       C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V FoD.map
      proof
        show "\<forall>f. C.arr f \<longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
        proof -
          have "\<And>f. C.arr f \<Longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
          proof -
            fix f
            assume f: "C.arr f"
            have "FoD.map (\<F>C.inclusion_of_generators f)
                    = F (\<F>C.D (\<F>C.inclusion_of_generators f))"
              using f by simp
            also have "... = F (inclusion_of_generators f)"
              using f \<F>C.strict_arr_char' F.I.preserves_arr inclusion_of_generators_def by simp
            also have "... = V f"
              using f F.is_extension by simp
            finally show "FoD.map (\<F>C.inclusion_of_generators f) = V f"
              by blast
          qed
          thus ?thesis by blast
        qed
      qed

      text \<open>
         By the freeness of \<open>\<F>C\<close>, we have that \<open>F o D\<close>
         is equal to the evaluation functor @{term "E\<^sub>S.E.map"} induced by @{term V}
         on \<open>\<F>C\<close>.  Moreover, @{term E\<^sub>S.map} coincides with @{term "E\<^sub>S.E.map"} on
         \<open>\<F>\<^sub>SC\<close> and \<open>F o D\<close> coincides with @{term F} on
         \<open>\<F>\<^sub>SC\<close>.  Therefore, @{term F} coincides with @{term E} on their common
         domain \<open>\<F>\<^sub>SC\<close>, showing @{term "F = E\<^sub>S.map"}.
\<close>
      have "\<And>f. arr f \<Longrightarrow> F f = E\<^sub>S.map f"
        using \<F>C.strict_arr_char' \<F>C.is_free [of D] E\<^sub>S.E.evaluation_functor_axioms
              FoD.strict_monoidal_extension_to_free_monoidal_category_axioms E\<^sub>S.map_def
        by simp
      moreover have "\<And>f. \<not>arr f \<Longrightarrow> F f = E\<^sub>S.map f"
        using F.is_extensional E\<^sub>S.is_extensional arr_char by auto
      ultimately show "F = E\<^sub>S.map" by blast
    qed

  end

end