Theory RTSEnrichedCategory

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

section "RTS-Enriched Categories"

 text ‹
   The category RTS is cartesian closed, hence monoidal closed.
   This implies that each hom-set of RTS itself carries the structure of an RTS,
   so that RTS becomes a category ``enriched in itself''.
   In this section we show that RTS-categories are essentially the same thing as
   categories enriched in RTS, and that the RTS-category RTS is equivalent to
   the RTS-category determined by RTS regarded as a category enriched in itself.
   Thus, the complete structure of the RTS-category RTS is already determined by
   its ordinary subcategory RTS.
 ›

theory RTSEnrichedCategory
imports RTSCatx RTSCat EnrichedCategoryBasics.CartesianClosedMonoidalCategory
        EnrichedCategoryBasics.EnrichedCategory
begin

  context rtscat
  begin

    (*
      TODO: There are currently definitions in @{locale cartesian_monoidal_category} that
      conflict with definitions in @{locale elementary_cartesian_closed_monoidal_category}.
      To make the interpretation of @{locale elementary_cartesian_closed_monoidal_category},
      we have to import the former using qualified names to avoid the clashes.
      At some point I will hopefully settle on a good systematic way to combine locales
      with a minimum of such clashes, but this is a stopgap for now.
    *)

    sublocale CMC: cartesian_monoidal_category comp Prod α ι
      using extends_to_cartesian_monoidal_categoryECC by blast

    text ‹
      The tensor for @{locale elementary_cartesian_closed_monoidal_category} is given by the
      binary functor Prod›.  This functor is defined in uncurried form, which is consistent
      with its nature as a functor defined on a product category.  However, the tensor
      @{term CMC.tensor} defined in @{locale monoidal_category} is a curried version.
      There might be a way to streamline this, if the various monoidal category locales were
      changed so that the binary functor used to specify the tensor were given in curried form,
      but I have not yet attempted to do this. For now, we have two versions of tensor,
      which we need to show are equal to each other.
    ›

    lemma tensor_agreement:
    assumes "arr f" and "arr g"
    shows "CMC.tensor f g = f  g"
      by simp

    text ‹
      The situation with tupling and ``duplicators'' is similar.
    ›

    lemma tuple_agreement:
    assumes "span f g"
    shows "CMC.tuple f g = f, g"
    proof (intro pr_joint_monic [of "cod f" "cod g" "CMC.tuple f g" "f, g"])
      show "ide (cod f)" and "ide (cod g)"
        using assms by auto
      show "seq 𝔭0[cod f, cod g] (CMC.tuple f g)"
        by (metis (no_types, lifting) CMC.ECC.seq_pr_tuple ide (cod f)
            ide (cod g) assms pr_agreement(1))
      show "𝔭0[cod f, cod g]  CMC.tuple f g = 𝔭0[cod f, cod g]  f, g"
        using assms pr_agreement(1-2)
        by (metis (no_types, lifting) CMC.ECC.pr_tuple(2) ide (cod f)
            ide(cod g) pr_tuple(2))
      show "𝔭1[cod f, cod g]  CMC.tuple f g = 𝔭1[cod f, cod g]  f, g"
        using assms pr_agreement(1-2)
        by (metis (no_types, lifting) CMC.ECC.pr_tuple(1) ide (cod f)
            ide (cod g) pr_tuple(1))
    qed

    lemma dup_agreement:
    assumes "arr f"
    shows "CMC.dup f = dup f"
      using assms tuple_agreement by simp

    sublocale elementary_cartesian_closed_monoidal_category
                comp Prod α ι exp eval curry
      using extends_to_elementary_cartesian_closed_monoidal_categoryECCC
      by blast

    text ‹
      We have a need for the following expansion of associators in terms of tensor and
      projections.  This is actually the definition of the associators given
      in @{locale category_with_binary_products}, but it could (and perhaps should) be proved
      as a consequence of the locale assumptions in @{locale elementary_cartesian_category}.
      Here we already have the fact assoc_agreement› which expresses that the definition
      of associators given in @{locale category_with_binary_products} agrees with the version
      derived from the locale parameters in @{locale cartesian_monoidal_category},
      and prod_eq_tensor›, which expresses that the tensor equals the cartesian product.
      So we can just use these facts, together with the definition from
      @{locale elementary_cartesian_category}, to avoid a longer proof.
    ›

    lemma assoc_expansion:
    assumes "ide a" and "ide b" and "ide c"
    shows "CMC.assoc a b c =
           𝔭1[a, b]  𝔭1[a  b, c], 𝔭0[a, b]  𝔭1[a  b, c], 𝔭0[a  b, c] "
      using assms assoc_def assoc_agreement by simp

    (* TODO: After removing clashes, there is an ECMC qualifier that I don't really want. *)
    lemma extends_to_enriched_category:
    shows "enriched_category comp Prod α ι
             (Collect ide) exp ECMC.Id ECMC.Comp"
      using ECMC.is_enriched_in_itself by blast

  end

  locale rts_enriched_category =
    universe arr_type +
    RTS: rtscat arr_type +
    enriched_category RTS.comp RTS.Prod RTS.α RTS.ι Obj Hom Id Comp
  for arr_type :: "'A itself"
  and Obj :: "'O set"
  and Hom :: "'O  'O  'A rtscatx.arr"
  and Id :: "'O  'A rtscatx.arr"
  and Comp :: "'O  'O  'O  'A rtscatx.arr"
  begin

    (*
     * TODO: The subscripts are needed to avoid a later clash with
     * sublocale declarations.  Qualified names can be used instead,
     * but the result seems to be worse.
     *)
    abbreviation HOMEC
    where "HOMEC a b  RTS.Rts (Hom a b)"

  end

  locale hom_rts =
    rts_enriched_category +
  fixes a :: 'b
  and b :: 'b
  assumes a: "a  Obj"
  and b: "b  Obj"
  begin

    sublocale extensional_rts HOMEC a b
      using a b by force

    sublocale small_rts HOMEC a b
      using a b by force

  end

  locale rts_enriched_functor =
    RTS: rtscat arr_type +
    A: rts_enriched_category arr_type ObjA HomA IdA CompA +
    B: rts_enriched_category arr_type ObjB HomB IdB CompB +
    enriched_functor RTS.comp RTS.Prod RTS.α RTS.ι
  for arr_type :: "'A itself"
  begin

    lemma is_local_simulation:
    assumes "a  ObjA" and "b  ObjA"
    shows "simulation (A.HOMEC a b) (B.HOMEC (Fo a) (Fo b))
             (RTS.Map (Fa a b))"
      using assms preserves_Hom [of a b] RTS.arrD [of "Fa a b"] by auto

  end

  locale fully_faithful_rts_enriched_functor =
    rts_enriched_functor +
    fully_faithful_enriched_functor RTS.comp RTS.Prod RTS.α RTS.ι

section "RTS-Enriched Categories induce RTS-Categories"

  text‹
    Here we show that every RTS-enriched category determines a corresponding RTS-category.
    This is done by combining the RTS's underlying the homs of the RTS-enriched category,
    forming a global RTS that provides the vertical structure of the RTS-category.
    The composition operation of the RTS-enriched category is used to obtain the
    horizontal structure.
  ›

  locale rts_category_of_enriched_category =
    universe arr_type +
    RTS: rtscat arr_type +
    rts_enriched_category arr_type Obj Hom Id Comp
  for arr_type :: "'A itself"
  and Obj :: "'O set"
  and Hom :: "'O  'O  'A rtscatx.arr"
  and Id :: "'O  'A rtscatx.arr"
  and Comp :: "'O  'O  'O  'A rtscatx.arr"
  begin

    notation RTS.in_hom    ("«_ : _  _»")
    notation RTS.prod      (infixr "" 51)
    notation RTS.one       ("𝟭")
    notation RTS.assoc     ("𝖺[_, _, _]")
    notation RTS.lunit     ("𝗅[_]")
    notation RTS.runit     ("𝗋[_]")

    text‹
      Here we define the ``global RTS'', obtained as the disjoint union of all the
      hom-RTS's.  Note that types 'O and 'A are fixed in the current context:
      type 'O is the type of ``objects'' of the given RTS-enriched category,
      and type 'A is the type of the universe that underlies the base category RTS›.
    ›

    datatype ('o, 'a) arr =
      Null
    | MkArr 'o 'o 'a

    fun Dom :: "('O, 'A) arr  'O"
    where "Dom (MkArr a _ _) = a"
        | "Dom _ = undefined"

    fun Cod :: "('O, 'A) arr  'O"
    where "Cod (MkArr _ b _) = b"
        | "Cod _ = undefined"

    fun Trn :: "('O, 'A) arr  'A"
    where "Trn (MkArr _ _ t) = t"
        | "Trn _ = undefined"

    abbreviation Arr :: "('O, 'A) arr  bool"
    where "Arr  λt. t  Null  Dom t  Obj  Cod t  Obj 
                     residuation.arr (HOMEC (Dom t) (Cod t)) (Trn t)"

    abbreviation Ide :: "('O, 'A) arr  bool"
    where "Ide  λt. t  Null  Dom t  Obj  Cod t  Obj 
                     residuation.ide (HOMEC (Dom t) (Cod t)) (Trn t)"

    definition Con :: "('O, 'A) arr  ('O, 'A) arr  bool"
    where "Con t u  Arr t  Arr u  Dom t = Dom u  Cod t = Cod u 
                     residuation.con (HOMEC (Dom t) (Cod t)) (Trn t) (Trn u)"

    text‹
      The global residuation is obtained by combining the local residuations of
      each of the hom-RTS's.
    ›

    fun resid  (infix "\\" 70)
    where "resid Null u = Null"
        | "resid t Null = Null"
        | "resid t u = (if Con t u
                        then MkArr (Dom t) (Cod t)
                               (HOMEC (Dom t) (Cod t) (Trn t) (Trn u))
                        else Null)"

    sublocale V: ResiduatedTransitionSystem.partial_magma resid
      apply unfold_locales
      by (metis Trn.cases resid.simps(1-2))

    lemma null_char:
    shows "V.null = Null"
      by (metis V.null_is_zero(2) resid.simps(1))

    lemma ConI [intro]:
    assumes "Arr t" and "Arr u" and "Dom t = Dom u" and "Cod t = Cod u"
    and "residuation.con (HOMEC (Dom t) (Cod t)) (Trn t) (Trn u)"
    shows "Con t u"
      using assms Con_def by simp

    lemma ConE [elim]:
    assumes "Con t u"
    and "Arr t; Arr u; Dom t = Dom u; Cod t = Cod u;
          residuation.con (HOMEC (Dom t) (Cod t)) (Trn t) (Trn u)  T"
    shows T
      using assms Con_def by blast

    lemma Con_sym:
    assumes "Con t u"
    shows "Con u t"
      using assms Con_def extensional_rts_def residuation.con_sym
            rts.axioms(1)
      by fastforce

    lemma resid_ne_Null_imp_Con:
    assumes "t \\ u  Null"
    shows "Con t u"
      using assms resid.elims by metis
 
    sublocale V: residuation resid
    proof
      fix t u :: "('O, 'A) arr"
      assume tu: "t \\ u  V.null"
      interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
        using tu null_char resid_ne_Null_imp_Con
        by unfold_locales auto
      show "t \\ u  V.null  u \\ t  V.null"
        using tu null_char Con_sym
        apply (cases t; cases u)
           apply simp_all
        by metis
      show "(t \\ u) \\ (t \\ u)  V.null"
        using tu null_char hom.arr_resid hom.con_arr_self Con_def
        apply (cases t; cases u)
           apply simp_all
        by metis
      next
      fix t u v :: "('O, 'A) arr"
      assume tuv: "(v \\ t) \\ (u \\ t)  V.null"
      have tu: "Con t u"
        using tuv null_char Con_sym resid_ne_Null_imp_Con
        by (metis Con_def)
      have tv: "Con t v"
        using tuv null_char Con_sym resid_ne_Null_imp_Con
        by (metis Con_def)
      interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
        using tu null_char arr.exhaust resid.simps(1-3)
           apply unfold_locales
        by blast+
      show "(v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
      proof -
        have "td tc tt ud uc ut vd vc vt.
                 t = MkArr td tc tt; u = MkArr ud uc ut; v = MkArr vd vc vt
                     ?thesis"
        proof -
          fix td tc tt ud uc ut vd vc vt
          assume t: "t = MkArr td tc tt"
          assume u: "u = MkArr ud uc ut"
          assume v: "v = MkArr vd vc vt"
          show "(v \\ t) \\ (u \\ t) = (v \\ u) \\ (t \\ u)"
            using t u v tu tv tuv Con_def hom.cube null_char
            apply auto[1]
            by (metis Cod.simps(1) Dom.simps(1) hom.con_sym hom.arr_resid
              hom.arr_resid_iff_con hom.resid_reflects_con)+
        qed
        thus ?thesis
          using tu tv tuv hom.cube hom.arr_resid_iff_con hom.resid_reflects_con
                null_char resid_ne_Null_imp_Con
          apply (cases v, blast)
          apply (cases u, blast)
          apply (cases t, blast)
          by metis
      qed
    qed

    notation V.con  (infix "" 50)

    lemma con_char:
    shows "t  u  Con t u"
    proof
      show "t  u  Con t u"
        using null_char resid_ne_Null_imp_Con by auto
      show "Con t u  t  u"
        using null_char
        by (cases t; cases u) auto
    qed

    lemma arr_char:
    shows "V.arr t  Arr t"
      by (metis Con_def RTS.ideDRTSC V.arr_def con_char extensional_rts.axioms(1)
          ide_Hom residuation.arrE rts.axioms(1))

    lemma ide_char:
    shows "V.ide t  Ide t"
    proof (cases "V.arr t")
      show "¬ V.arr t  ?thesis"
        by (metis RTS.ideDRTSC V.arrI V.ide_def arr_char ide_Hom
            residuation.ide_implies_arr rts.axioms(1) small_rts_def)
      assume t: "V.arr t"
      interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
        using t arr_char
        by unfold_locales auto
      show ?thesis
        using t null_char con_char V.ide_def arr_char hom.ide_def
        by (cases t) auto
    qed

    lemma con_implies_Par:
    assumes "t  u"
    shows "Dom t = Dom u" and "Cod t = Cod u"
      using assms con_char by blast+

    lemma Dom_resid [simp]:
    assumes "t  u"
    shows "Dom (t \\ u) = Dom t"
      using assms con_char
      by (cases t; cases u) auto

    lemma Cod_resid [simp]:
    assumes "t  u"
    shows "Cod (t \\ u) = Cod t"
      using assms con_char
      by (cases t; cases u) auto

    lemma Trn_resid [simp]:
    assumes "t  u"
    shows "Trn (t \\ u) = HOMEC (Dom t) (Cod t) (Trn t) (Trn u)"
      using assms con_char
      by (cases t; cases u) auto

    text‹
      Targets of arrows of the global RTS agree with the local
      versions from which they were derived.
      The same will be shown for sources below.
    ›

    lemma trg_char:
    shows "V.trg t = (if V.arr t
                      then MkArr (Dom t) (Cod t)
                             (residuation.trg (HOMEC (Dom t) (Cod t)) (Trn t))
                      else Null)"
    proof (cases "V.arr t")
      show "¬ V.arr t  ?thesis"
        using V.con_def V.trg_def null_char by auto
      show "V.arr t  ?thesis"
        using null_char V.not_arr_null
        apply (cases t)
         apply auto[1]
        by (metis (no_types, lifting) RTS.ideDRTSC V.arrE V.trg_def
            arr_char con_char ide_Hom resid.simps(3)
            residuation.resid_arr_self rts.axioms(1) small_rts_def)
    qed

    sublocale rts resid
    proof
      show "t. V.arr t  V.ide (V.trg t)"
        by (simp add: arr_char extensional_rts.axioms(1) ide_char
            rts.ide_trg trg_char)
      show 1: "a t. V.ide a; t  a  t \\ a = t"
      proof -
        fix a t
        assume a: "V.ide a"
        assume con: "t  a"
        have "t \\ a  Null  t  Null"
          using con null_char by auto
        moreover have "Dom (t \\ a) = Dom t  Cod (t \\ a) = Cod t"
          using a con ide_char con_char Con_def
          by (metis V.arrE V.arr_resid_iff_con V.con_sym V.cube V.ideE)
        moreover have "Trn (t \\ a) = Trn t"
          using a con ide_char con_char small_rts_def Con_def
          by (metis (no_types, lifting) RTS.ideDRTSC(1) Trn_resid ide_Hom
              rts.resid_arr_ide)
        ultimately show "t \\ a = t"
          by (metis Cod.elims Dom.simps(1) Trn.simps(1))
      qed
      show "a t. V.ide a; a  t  V.ide (a \\ t)"
        using ide_char con_char
        by (metis 1 V.arr_resid V.con_arr_self V.con_sym V.cube V.ideE V.ideI)
      show "t u. t  u  a. V.ide a  a  t  a  u"
      proof -
        fix t u
        assume tu: "t  u"
        interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
          using tu con_char arr_char
          by unfold_locales blast+
        have 1: "hom.con (Trn t) (Trn u)"
          using tu con_char by auto
        obtain α where α: "hom.ide α  hom.con α (Trn t)  hom.con α (Trn u)"
          using 1 hom.con_imp_coinitial_ax by auto
        have "V.ide (MkArr (Dom t) (Cod t) α)"
          using tu α V.con_implies_arr arr_char ide_char by auto
        moreover have "MkArr (Dom t) (Cod t) α  t 
                         MkArr (Dom t) (Cod t) α  u"
          using α tu con_char hom.ide_implies_arr Con_def by auto
        ultimately show "a. V.ide a  V.con a t  V.con a u" by blast
      qed
      show "t u v. V.ide (t \\ u); u  v  t \\ u  v \\ u"
      proof -
        fix t u v
        assume tu: "V.ide (t \\ u)"
        assume uv: "u  v"
        have 1: "t \\ u  V.null"
          using tu by auto
        interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
          using 1 con_char arr_char
          by unfold_locales blast+
        have "hom.con (HOMEC (Dom t) (Cod t) (Trn t) (Trn u))
                      (HOMEC (Dom t) (Cod t) (Trn v) (Trn u))"
        proof -
          have "hom.con (Trn t) (Trn u)"
            using tu 1 con_char by auto
          have "hom.ide (HOMEC (Dom t) (Cod t) (Trn t) (Trn u))"
            using tu 1 ide_char Dom.simps(1) Cod.simps(1) Trn.simps(1) V.conI
            by auto
          moreover have "hom.con (Trn u) (Trn v)"
            using uv con_char 1 V.conI Con_def by fastforce
          ultimately show ?thesis
            using hom.con_target by blast
        qed
        thus "t \\ u  v \\ u"
          unfolding con_char Con_def
          using tu uv 1 null_char V.arr_resid arr_char V.ide_implies_arr
          apply clarsimp
          apply (intro conjI) (* 7 goals *)
          subgoal by (meson V.con_sym)
          subgoal using V.arr_resid V.con_sym by meson
          by (metis (mono_tags, lifting) Cod_resid Dom_resid Trn_resid
              V.conI V.con_sym con_implies_Par(1-2))+
      qed
    qed

    lemma is_rts:
    shows "rts resid"
      ..

    sublocale V: extensional_rts resid
    proof
      fix t u
      assume tu: "cong t u"
      have 1: "t \\ u  V.null"
        using tu by auto
      interpret hom: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
        using 1 con_char arr_char [of t]
        by unfold_locales blast+
      have "t  Null  u  Null"
        using tu con_char by fastforce
      moreover have "Dom t = Dom u  Cod t = Cod u"
        using tu 1 con_char by blast
      moreover have "Trn t = Trn u"
        by (metis Cod_resid Dom_resid Trn_resid calculation(2)
            hom.extensional ide_char prfx_implies_con tu)
      ultimately show "t = u"
        by (cases t; cases u) auto
    qed

    lemma is_extensional_rts:
    shows "extensional_rts resid"
      ..

    lemma arr_MkArr [intro]:
    assumes "a  Obj" and "b  Obj"
    and "residuation.arr (HOMEC a b) t"
    shows "V.arr (MkArr a b t)"
      using assms arr_char by auto

    lemma arr_eqI:
    assumes "t  V.null" and "u  V.null"
    and "Dom t = Dom u" and "Cod t = Cod u" and "Trn t = Trn u"
    shows "t = u"
      using assms null_char
      by (metis Cod.elims Dom.simps(1) Trn.simps(1))

    lemma MkArr_Trn:
    assumes "V.arr t"
    shows "t = MkArr (Dom t) (Cod t) (Trn t)"
      using assms null_char V.not_arr_null
      by (intro arr_eqI) auto

    lemma src_char:
    shows "V.src t = (if V.arr t
                      then MkArr (Dom t) (Cod t)
                             (weakly_extensional_rts.src
                                (HOMEC (Dom t) (Cod t)) (Trn t))
                      else Null)"
    proof (cases "V.arr t")
      show "¬ V.arr t  ?thesis"
        using null_char V.src_def by presburger
      assume t: "V.arr t"
      show ?thesis
      proof -
        interpret Hom: extensional_rts RTS.Rts (Hom (Dom t) (Cod t))
          using t ide_Hom arr_char RTS.ide_char RTS.arrD by metis
        have "V.ide (MkArr (Dom t) (Cod t) (Hom.src (Trn t)))"
          unfolding ide_char
          using t arr_char by auto
        moreover have "t  MkArr (Dom t) (Cod t) (Hom.src (Trn t))"
          using t MkArr_Trn con_char Con_def by auto
        ultimately show ?thesis
          using V.sources_char V.src_in_sources by auto
      qed
    qed

    text‹
      Here we use the composition operation of the original RTS-enriched category
      to define horizontal composition of transitions of the global RTS.
      Note that a pair of transitions (which comprise a transition of a product RTS)
      must be ``packed'' into a single transition of the RTS underlying a product object,
      before the composition operation can be applied.
    ›

    definition hcomp  (infixr "" 53)
    where "t  u 
           if V.arr t  V.arr u  Dom t = Cod u
           then MkArr (Dom u) (Cod t)
                      (RTS.Map (Comp (Dom u) (Cod u) (Cod t))
                               (RTS.Pack (Hom (Dom t) (Cod t))
                                         (Hom (Dom u) (Cod u))
                                         (Trn t, Trn u)))
                    else V.null"

    lemma arr_hcomp:
    assumes "V.arr t" and "V.arr u" and "Dom t = Cod u"
    shows "V.arr (t  u)"
    proof -
      let ?a = "Dom u" and ?b = "Cod u" and ?c = "Cod t"
      have a: "?a  Obj" and b: "?b  Obj" and c: "?c  Obj"
        using assms arr_char by auto
      interpret HOM_ab: hom_rts arr_type Obj Hom Id Comp ?a ?b
        using a b by unfold_locales auto
      interpret HOM_bc: hom_rts arr_type Obj Hom Id Comp ?b ?c
        using b c by unfold_locales auto
      interpret HOM_ac: hom_rts arr_type Obj Hom Id Comp ?a ?c
        using a c by unfold_locales auto
      interpret bcxab: extensional_rts RTS.Rts (Hom ?b ?c  Hom ?a ?b)
        using a b c by auto
      interpret BCxAB: product_rts HOMEC ?b ?c HOMEC ?a ?b ..
      interpret Pack: simulation
                        BCxAB.resid RTS.Rts (Hom ?b ?c  Hom ?a ?b)
                        RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
        using a b c RTS.simulation_Pack by blast
      let ?tu = "MkArr ?a ?c
                   (RTS.Map (Comp ?a ?b ?c)
                      (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn t, Trn u)))"
      have arr_Trn_u: "HOM_ab.arr (Trn u)"
        using assms arr_char by blast
      have arr_Trn_t: "HOM_bc.arr (Trn t)"
        using assms arr_char by simp
      have "V.arr ?tu"
      proof
        show "Dom u  Obj"
          using assms arr_char by auto
        show "Cod t  Obj"
          using assms arr_char by simp
        show "HOM_ac.arr (RTS.Map (Comp ?a ?b ?c)
                            (RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
                               (Trn t, Trn u)))"
        proof -
          have "HOM_ac.arr (RTS.Map (Comp ?a ?b ?c)
                              (RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
                                 (Trn t, Trn u)))"
          proof -
            have "RTS.in_hom (Comp (Dom u) (Cod u) (Cod t))
                             (Hom ?b ?c  Hom ?a ?b)
                             (Hom (Dom u) (Cod t))"
              using a b c Comp_in_hom by auto
            moreover have "bcxab.arr
                             (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn t, Trn u))"
              using a b c arr_Trn_t arr_Trn_u Pack.preserves_reflects_arr
              by auto
            ultimately show ?thesis
              by (metis (mono_tags, lifting) HOM_ac.arrI RTS.in_homE
                  bcxab.arrE RTS.arrD(3) simulation.preserves_con)
          qed
          thus ?thesis by simp
        qed
      qed
      thus ?thesis
        using assms hcomp_def by simp
    qed

    lemma Dom_hcomp [simp]:
    assumes "V.arr t" and "V.arr u" and "Dom t = Cod u"
    shows "Dom (t  u) = Dom u"
      using assms hcomp_def by auto

    lemma Cod_hcomp [simp]:
    assumes "V.arr t" and "V.arr u" and "Dom t = Cod u"
    shows "Cod (t  u) = Cod t"
      using assms hcomp_def by auto

    lemma Trn_hcomp [simp]:
    assumes "V.arr t" and "V.arr u" and "Dom t = Cod u"
    shows "Trn (t  u) =
           RTS.Map (Comp (Dom u) (Cod u) (Cod t))
             (RTS.Pack (Hom (Cod u) (Cod t)) (Hom (Dom u) (Cod u))
             (Trn t, Trn u))"
      using assms hcomp_def by auto

    lemma hcomp_Null [simp]:
    shows "t  Null = Null" and "Null  u = Null"
      using hcomp_def null_char by fastforce+

    sublocale H: Category.partial_magma hcomp
      using hcomp_def
      by (metis Category.partial_magma.intro V.not_arr_null)

    lemma H_null_char:
    shows "H.null = V.null"
      using hcomp_def
      by (metis H.null_eqI V.not_arr_null)

    sublocale H: partial_composition hcomp ..

    lemma H_composable_char:
    shows "t  u  V.null  V.arr t  V.arr u  Dom t = Cod u"
      using hcomp_def null_char
      by (cases t; cases u) auto

    definition horizontal_unit
    where "horizontal_unit a 
           V.arr a  Dom a = Cod a 
             (t. (V.arr t  Dom t = Cod a  t  a = t) 
             (V.arr t  Dom a = Cod t  a  t = t))"

    lemma H_ide_char:
    shows "H.ide a  horizontal_unit a"
      using H.ide_def H_composable_char H_null_char horizontal_unit_def
      by fastforce

    text‹
      Each A ∈ Obj› determines a corresponding identity for horizontal composition;
      namely, the transition of HOMEC A A› obtained by evaluating the simulation
      «Id A : One → Hom A A»› at the unique arrow @{term RTS.One.the_arr} of the underlying
      one-arrow RTS of One›.
    ›

    abbreviation mkobj
    where "mkobj A  MkArr A A (RTS.Map (Id A) RTS.One.the_arr)"

    lemma Id_yields_horiz_ide:
    assumes "A  Obj"
    shows "H.ide (mkobj A)"
    proof (unfold H.ide_def, intro allI conjI impI)
      interpret HOM_A_A: hom_rts arr_type Obj Hom Id Comp A A
        using assms by unfold_locales
      interpret Id_A: simulation RTS.Rts 𝟭 HOMEC A A RTS.Map (Id A)
        using assms Id_in_hom [of A] RTS.arrD(3) [of "Id A"] RTS.unity_agreement
        by auto
      let ?a = "mkobj A"
      have "HOM_A_A.ide (RTS.Map (Id A) RTS.One.the_arr)"
        using assms Id_A.preserves_ide RTS.One.ide_char1RTS by auto
      hence a: "V.arr ?a  Dom ?a = Cod ?a"
        using assms ide_char by auto
      show "mkobj A  mkobj A  H.null"
        by (metis Cod.simps(1) Dom.simps(1) HOM_A_A.ide_implies_arr H_null_char
            V.not_arr_null HOM_A_A.ide (RTS.Map (Id A) RTS.One.the_arr)
            arr_MkArr arr_hcomp assms)
      fix t
      show "t  ?a  H.null  t  ?a = t"
      proof -
        assume "t  ?a  H.null"
        hence t: "V.arr t  Dom t = Cod ?a"
          by (simp add: H_composable_char H_null_char)
        show "t  ?a = t"
        proof -
          interpret HOM_AB: hom_rts arr_type Obj Hom Id Comp A Cod t
            using assms t arr_char
            by unfold_locales auto
          interpret HOM_AB: simulation
                              HOMEC A (Cod t) HOMEC A (Cod t)
                              RTS.Map (Hom A (Cod t))
            using assms t arr_char RTS.arrD [of "Hom A (Cod t)"] by simp
          interpret HOM_ABxI: product_rts HOMEC A (Cod t) RTS.One.resid
            ..
          interpret HOM_ABxId_A: product_simulation
                                   HOMEC A (Cod t) RTS.Rts 𝟭
                                   HOMEC A (Cod t) HOMEC A A
                                   RTS.Map (Hom A (Cod t)) RTS.Map (Id A)
            ..
          interpret PU: inverse_simulations
                          RTS.Rts (Hom A (Cod t)  𝟭) HOM_ABxI.resid
                          RTS.Pack (Hom A (Cod t)) 𝟭
                          RTS.Unpack (Hom A (Cod t)) 𝟭
            using assms t arr_char RTS.ide_one
                  RTS.inverse_simulations_Pack_Unpack
                    [of "Hom A (Cod t)" RTS.one]
            by simp
          have "t  ?a  Null"
            using a t arr_hcomp null_char arr_char by blast
          moreover have "t  Null"
            using t null_char arr_char by blast
          moreover have "Dom t = Dom (hcomp t ?a)"
            using a t hcomp_def by fastforce
          moreover have "Cod t = Cod (hcomp t ?a)"
            using a t hcomp_def by fastforce
          moreover have "Trn t = Trn (hcomp t ?a)"
          proof -
            have "Trn (t  ?a) =
                  (RTS.Map (Comp A A (Cod t)) 
                     (RTS.Pack (Hom A (Cod t)) (Hom A A) 
                        HOM_ABxId_A.map))
                     (Trn t, RTS.One.the_arr)"
              using HOM_ABxId_A.map_simp RTS.Map_ide a arr_char t by force
            also have "... =
                  (RTS.Map (Comp A A (Cod t)) 
                     (RTS.Map (Hom A (Cod t)  Id A) 
                        RTS.Pack (Hom A (Cod t)) 𝟭))
                     (Trn t, RTS.One.the_arr)"
            proof -
              have "RTS.Map (Hom A (Cod t)  Id A) 
                      RTS.Pack (Hom A (Cod t)) 𝟭 =
                    (RTS.Pack (Hom A (Cod t)) (Hom A A) 
                       HOM_ABxId_A.map 
                         RTS.Unpack (Hom A (Cod t)) 𝟭) 
                      RTS.Pack (Hom A (Cod t)) 𝟭"
                by (metis (no_types, lifting) HOM_AB.b Id_in_hom RTS.Map_prod
                    RTS.ideD(1-3) RTS.in_homE RTS.unity_agreement assms ide_Hom)
              also have "... =
                    (RTS.Pack (Hom A (Cod t)) (Hom A A) 
                       HOM_ABxId_A.map) 
                         (RTS.Unpack (Hom A (Cod t)) 𝟭 
                            RTS.Pack (Hom A (Cod t)) 𝟭)"
                by auto
              also have "... = RTS.Pack (Hom A (Cod t)) (Hom A A) 
                                  (HOM_ABxId_A.map  I HOM_ABxI.resid)"
                using PU.inv by auto
              also have "... = RTS.Pack (Hom A (Cod t)) (Hom A A) 
                                 HOM_ABxId_A.map"
                using comp_simulation_identity
                        [of "HOM_ABxI.resid" "HOM_ABxId_A.B1xB0.resid"
                            "HOM_ABxId_A.map"]
                      HOM_ABxId_A.simulation_axioms
                by auto
              finally have "RTS.Map (Hom A (Cod t)  Id A) 
                              RTS.Pack (Hom A (Cod t)) 𝟭 =
                            RTS.Pack (Hom A (Cod t)) (Hom A A)  HOM_ABxId_A.map"
                by blast
              thus ?thesis by simp
            qed
            also have "... =
                  ((RTS.Map (Comp A A (Cod t)) 
                      RTS.Map (Hom A (Cod t)  Id A)) 
                        RTS.Pack (Hom A (Cod t)) 𝟭)
                     (Trn t, RTS.One.the_arr)"
              by auto
            also have "... =
                  (RTS.Map (Comp A A (Cod t)  (Hom A (Cod t)  Id A)) 
                     RTS.Pack (Hom A (Cod t)) 𝟭)
                     (Trn t, RTS.One.the_arr)"
              by (metis (no_types, lifting) Comp_Hom_Id HOM_AB.b RTS.CMC.arr_runit
                  RTS.Map_comp assms ide_Hom prod.sel(1-2))
            also have "... = (RTS.Map 𝗋[Hom A (Cod t)] 
                                RTS.Pack (Hom A (Cod t)) 𝟭)
                               (Trn t, RTS.One.the_arr)"
              using assms t arr_char Comp_Hom_Id
              by (simp add: RTS.runit_agreement)
            also have "... = (HOM_ABxI.P1 
                                (RTS.Unpack (Hom A (Cod t)) 𝟭 
                                   RTS.Pack (Hom A (Cod t)) 𝟭))
                               (Trn t, RTS.One.the_arr)"
              using assms t arr_char RTS.Map_runit by auto
            also have "... = HOM_ABxI.P1 (Trn t, RTS.One.the_arr)"
              using assms t arr_char PU.inv HOM_ABxI.P1.simulation_axioms
                    comp_simulation_identity
                      [of "HOM_ABxI.resid" _ "HOM_ABxI.P1"]
              by simp
            also have "... = Trn t"
              using t arr_char HOM_ABxI.P1_def HOM_ABxI.arr_char RTS.One.arr_char
              by auto
            finally show ?thesis by auto
          qed
          ultimately show "t  ?a = t"
            apply (cases t)
            by auto (metis Cod.simps(1) Dom.simps(1) Trn.elims)
        qed
      qed
      show "?a  t  H.null  ?a  t = t"
      proof -
        assume "?a  t  H.null"
        hence t: "V.arr t  Dom ?a = Cod t"
          by (simp add: H_composable_char H_null_char)
        show "?a  t = t"
        proof -
          interpret HOM_BA: hom_rts arr_type Obj Hom Id Comp Dom t A
            using assms t arr_char
            by unfold_locales auto
          interpret HOM_BA: simulation
                              HOMEC (Dom t) A HOMEC (Dom t) A
                              RTS.Map (Hom (Dom t) A)
            using assms t arr_char RTS.arrD(3) [of "Hom (Dom t) A"] by auto
          interpret IxHOM_BA: product_rts
                                RTS.Rts (RTS.dom 𝟭)
                                HOMEC (Dom t) A
            by (metis HOM_BA.small_rts_axioms Id_A.simulation_axioms RTS.ideD(2)
                RTS.ide_one product_rts.intro simulation_def small_rts_def)
          interpret Id_AxHOM_BA: product_simulation
                                   RTS.Rts (RTS.dom 𝟭) HOMEC (Dom t) A
                                   HOMEC A A HOMEC (Dom t) A
                                   RTS.Map (Id A) RTS.Map (Hom (Dom t) A)
            by (metis (mono_tags, lifting) HOM_BA.simulation_axioms
                Id_A.simulation_axioms RTS.ideD(2) RTS.ide_one product_rts.intro
                product_simulation_def simulation_def)
          interpret PU: inverse_simulations
                          RTS.Rts (RTS.dom (𝟭  Hom (Dom t) A))
                          IxHOM_BA.resid
                          RTS.Pack 𝟭 (Hom (Dom t) A)
                          RTS.Unpack 𝟭 (Hom (Dom t) A)
            using assms t arr_char RTS.ide_one
                  RTS.inverse_simulations_Pack_Unpack [of 𝟭 "Hom (Dom t) A"]
            by simp
          have "?a  t  Null"
            using a t arr_hcomp null_char arr_char by blast
          moreover have "t  Null"
            using t null_char arr_char by blast
          moreover have "Dom t = Dom (hcomp ?a t)"
            using a t hcomp_def by fastforce
          moreover have "Cod t = Cod (hcomp ?a t)"
            using a t hcomp_def by fastforce
          moreover have "Trn t = Trn (hcomp ?a t)"
          proof -
            have "Trn (?a  t) =
                  RTS.Map (Comp (Dom t) A A)
                    (RTS.Pack (Hom A A) (Hom (Dom t) A)
                       (RTS.Map (Id A) RTS.One.the_arr, Trn t))"
              using a t hcomp_def by simp
            also have "... =
                  (RTS.Map (Comp (Dom t) A A) 
                     (RTS.Pack (Hom A A) (Hom (Dom t) A) 
                        Id_AxHOM_BA.map))
                     (RTS.One.the_arr, Trn t)"
              using assms t arr_char RTS.Map_ide Id_AxHOM_BA.map_simp
                    Id_A.preserves_reflects_arr RTS.ide_one a
              by auto
            also have "... =
                  (RTS.Map (Comp (Dom t) A A) 
                     (RTS.Map (Id A  Hom (Dom t) A) 
                        RTS.Pack 𝟭 (Hom (Dom t) A)))
                     (RTS.One.the_arr, Trn t)"
            proof -
              have "RTS.Map (Id A  Hom (Dom t) A) 
                      RTS.Pack 𝟭 (Hom (Dom t) A) =
                    (RTS.Pack (Hom A A) (Hom (Dom t) A) 
                       Id_AxHOM_BA.map 
                         RTS.Unpack 𝟭 (Hom (Dom t) A)) 
                      RTS.Pack 𝟭 (Hom (Dom t) A)"
                by (metis (no_types, lifting) HOM_BA.a Id_in_hom RTS.Map_prod
                    RTS.ide_char RTS.ide_one RTS.in_homE RTS.unity_agreement
                    assms ide_Hom)
              also have "... =
                    (RTS.Pack (Hom A A) (Hom (Dom t) A) 
                       Id_AxHOM_BA.map) 
                         (RTS.Unpack 𝟭 (Hom (Dom t) A) 
                            RTS.Pack 𝟭 (Hom (Dom t) A))"
                by auto
              also have "... = (RTS.Pack (Hom A A) (Hom (Dom t) A) 
                                  Id_AxHOM_BA.map) 
                                    I IxHOM_BA.resid"
              proof -
                have "RTS.Unpack 𝟭 (Hom (Dom t) A) 
                        RTS.Pack 𝟭 (Hom (Dom t) A) =
                      I IxHOM_BA.resid"
                  using PU.inv by fastforce
                thus ?thesis by simp
              qed
              also have "... = RTS.Pack (Hom A A) (Hom (Dom t) A) 
                                  (Id_AxHOM_BA.map  I IxHOM_BA.resid)"
                by auto
              also have "... = RTS.Pack (Hom A A) (Hom (Dom t) A) 
                                 Id_AxHOM_BA.map"
                using comp_simulation_identity
                        [of "IxHOM_BA.resid" "Id_AxHOM_BA.B1xB0.resid"
                            "Id_AxHOM_BA.map"]
                      Id_AxHOM_BA.simulation_axioms
                by auto
              finally have "RTS.Map (Id A  Hom (Dom t) A) 
                              RTS.Pack 𝟭 (Hom (Dom t) A) =
                            RTS.Pack (Hom A A) (Hom (Dom t) A)  Id_AxHOM_BA.map"
                by blast
              thus ?thesis by simp
            qed
            also have "... =
                  ((RTS.Map (Comp (Dom t) A A) 
                      RTS.Map (Id A  Hom (Dom t) A)) 
                        RTS.Pack 𝟭 (Hom (Dom t) A))
                     (RTS.One.the_arr, Trn t)"
              by auto
            also have "... =
                  (RTS.Map (Comp (Dom t) A A  (Id A  Hom (Dom t) A)) 
                     RTS.Pack 𝟭 (Hom (Dom t) A))
                     (RTS.One.the_arr, Trn t)"
              using assms t Comp_Id_Hom HOM_BA.a
                    RTS.Map_comp
                      [of "Comp (Dom t) A A" "Id A  Hom (Dom t) A"]
              by auto
            also have "... = (RTS.Map 𝗅[Hom (Dom t) A] 
                                RTS.Pack 𝟭 (Hom (Dom t) A))
                                (RTS.One.the_arr, Trn t)"
              using assms t arr_char Comp_Id_Hom
              by (simp add: RTS.lunit_agreement)
            also have "... = (IxHOM_BA.P0 
                                RTS.Unpack RTS.one (Hom (Dom t) A) 
                                RTS.Pack 𝟭 (Hom (Dom t) A))
                                (RTS.One.the_arr, Trn t)"
              using assms t arr_char RTS.Map_lunit RTS.ide_one by auto
            also have "... = (IxHOM_BA.P0 
                               (RTS.Unpack 𝟭 (Hom (Dom t) A) 
                                  RTS.Pack 𝟭 (Hom (Dom t) A)))
                               (RTS.One.the_arr, Trn t)"
              by auto
            also have "... = IxHOM_BA.P0 (RTS.One.the_arr, Trn t)"
              using assms t arr_char PU.inv IxHOM_BA.P0.simulation_axioms
                    comp_simulation_identity
                      [of "IxHOM_BA.resid" _ "IxHOM_BA.P0"]
              by simp
            also have "... = Trn t"
              using t arr_char IxHOM_BA.P0_def IxHOM_BA.arr_char
                    Id_A.preserves_reflects_arr RTS.ide_one a
              by auto
            finally show ?thesis by auto
          qed
          ultimately show ?thesis
            apply (cases t)
             apply auto[1]
            by (metis Cod.simps(1) Dom.simps(1) Trn.elims)
        qed
      qed
    qed

    lemma H_ide_is_V_ide:
    assumes "H.ide a"
    shows "V.ide a"
    proof -
      have 1: "V.arr a  a = mkobj (Dom a)"
        by (metis assms Cod.simps(1) H_ide_char Id_yields_horiz_ide
            horizontal_unit_def arr_char)
      interpret HOM_AA: hom_rts arr_type Obj Hom Id Comp Dom a Dom a
        using assms 1 arr_char by unfold_locales simp
      interpret Id_A: simulation RTS.Dom 𝟭 HOMEC (Dom a) (Dom a)
                        RTS.Map (Id (Dom a))
        using 1 arr_char Id_in_hom RTS.arrD(3) RTS.ide_one by force
      have "V.ide (MkArr (Dom a) (Dom a)
                     (RTS.Map (Id (Dom a)) RTS.One.the_arr))"
      proof -
        have "Trn a = RTS.Map (Id (Dom a)) RTS.One.the_arr"
          using 1 by (metis Trn.simps(1))
        moreover have 2: "HOM_AA.ide ..."
          using Id_A.preserves_ide RTS.One.ide_char1RTS RTS.ide_one by force
        ultimately show ?thesis
          by (metis 1 Cod.simps(1) arr_char ide_char)
      qed
      thus "V.ide a"
        using 1 ide_char by metis
    qed

    lemma H_domains_char:
    shows "H.domains t = {a. V.arr t  a = mkobj (Dom t)}"
    proof
      show "{a. V.arr t  a = mkobj (Dom t)}  H.domains t"
      proof
        fix a
        assume a: "a  {a. V.arr t  a = mkobj (Dom t)}"
        have "H.ide a"
          using a arr_char Id_yields_horiz_ide by force
        thus "a  H.domains t"
          using a H.domains_def H.ide_def H_composable_char H_null_char
          by force
      qed
      show "H.domains t  {a. V.arr t  a = mkobj (Dom t)}"
      proof
        fix a
        assume a: "a  H.domains t"
        have 1: "H.ide a  hcomp t a  H.null"
          using a H.domains_def by blast
        have "a = mkobj (Dom t)"
          using a 1 H.ide_def
          by (metis (no_types, lifting) Dom.simps(1) H_composable_char
              H_null_char Id_yields_horiz_ide arr_char)
        moreover have "V.arr t"
          using 1 hcomp_def null_char H_null_char by metis
        ultimately show "a  {a. V.arr t  a = mkobj (Dom t)}"
          by blast
      qed
    qed

    lemma H_codomains_char:
    shows "H.codomains t = {a. V.arr t  a = mkobj (Cod t)}"
    proof
      show "{a. V.arr t  a = mkobj (Cod t)}  H.codomains t"
      proof
        fix a
        assume a: "a  {a. V.arr t  a = mkobj (Cod t)}"
        have "H.ide a"
          using a arr_char Id_yields_horiz_ide by force
        thus "a  H.codomains t"
          using a H.codomains_def H.ide_def H_composable_char H_null_char
          by force
      qed
      show "H.codomains t  {a. V.arr t  a = mkobj (Cod t)}"
      proof
        fix a
        assume a: "a  H.codomains t"
        have 1: "H.ide a  hcomp a t  H.null"
          using a H.codomains_def by blast
        have "a = mkobj (Cod t)"
          using a 1 H.ide_def
          by (metis (no_types, lifting) Cod.simps(1) H_composable_char
              H_null_char Id_yields_horiz_ide arr_char)
        moreover have "V.arr t"
          using 1 hcomp_def null_char H_null_char by metis
        ultimately show "a  {a. V.arr t  a = mkobj (Cod t)}"
          by blast
      qed
    qed

    lemma H_arr_char:
    shows "H.arr t  t  Null  Dom t  Obj  Cod t  Obj 
                       residuation.arr (HOMEC (Dom t) (Cod t)) (Trn t)"
    proof
      assume t: "H.arr t"
      interpret HOM: hom_rts arr_type Obj Hom Id Comp Dom t Cod t
        using t
        by unfold_locales
           (auto simp add: H.arr_def H_codomains_char H_domains_char arr_char)
      show "t  Null  Dom t  Obj  Cod t  Obj  HOM.arr (Trn t)"
        using t H.arr_def H_codomains_char H_domains_char arr_char by auto
      next
      assume t: "t  Null  Dom t  Obj  Cod t  Obj 
                 residuation.arr (HOMEC (Dom t) (Cod t)) (Trn t)"
      have "V.arr t"
        using t arr_char by blast
      thus "H.arr t"
        using t H.arr_def H_codomains_char H_domains_char arr_char
              Id_yields_horiz_ide
        by blast
    qed

    lemma H_seq_char:
    shows "H.seq t u  V.arr t  V.arr u  Dom t = Cod u"
      by (metis H_arr_char H_composable_char arr_char arr_hcomp null_char)

    sublocale H: category hcomp
    proof
      show "t u. hcomp t u  H.null  H.seq t u"
        using hcomp_def H_seq_char H_null_char null_char
        by auto argo+
      show "t. (H.domains t  {}) = (H.codomains t  {})"
        by (simp add: H_codomains_char H_domains_char)
      show "h g f. H.seq h g; H.seq (h  g) f  H.seq g f"
        using H_seq_char
        by (metis Dom.simps(1) hcomp_def)
      show "h g f. H.seq h (g  f); H.seq g f  H.seq h g"
        using H_seq_char
        by (metis Cod.simps(1) hcomp_def)
      show "g f h. H.seq g f; H.seq h g  H.seq (h  g) f"
        using H_seq_char
        by (metis Dom.simps(1) arr_hcomp hcomp_def)
      show "t u v. H.seq u v; H.seq t u  (t  u)  v = t  u  v"
      proof (intro arr_eqI)
        fix t u v
        assume tu: "H.seq t u" and uv: "H.seq u v"
        show "(t  u)  v  V.null"
          using tu uv arr_hcomp H_seq_char H_composable_char null_char by auto
        show "t  u  v  V.null"
          using tu uv arr_hcomp H_seq_char H_composable_char null_char by auto
        show "Dom ((t  u)  v) = Dom (t  u  v)"
          using tu uv arr_hcomp H_seq_char H_composable_char null_char by simp
        show "Cod ((t  u)  v) = Cod (t  u  v)"
          using tu uv arr_hcomp H_seq_char H_composable_char null_char by simp
        show "Trn ((t  u)  v) = Trn (t  u  v)"
        proof -
          let ?A = "Dom v" and ?B = "Cod v" and ?C = "Cod u" and ?D = "Cod t"
          have A: "?A  Obj" and B: "?B  Obj" and C: "?C  Obj" and D: "?D  Obj"
            using tu uv arr_char arr_char [of u] arr_char [of v] H_seq_char by blast+
          interpret AB: hom_rts arr_type Obj Hom Id Comp ?A ?B
            using A B by unfold_locales
          interpret BC: hom_rts arr_type Obj Hom Id Comp ?B ?C
            using B C by unfold_locales
          interpret CD: hom_rts arr_type Obj Hom Id Comp ?C ?D
            using C D by unfold_locales
          interpret CDxBC: product_rts HOMEC ?C ?D HOMEC ?B ?C ..
          interpret BCxAB: product_rts HOMEC ?B ?C HOMEC ?A ?B ..
          interpret CDxBC_x_AB: product_rts CDxBC.resid HOMEC ?A ?B ..
          interpret CD_x_BCxAB: product_rts HOMEC ?C ?D BCxAB.resid ..
          interpret I_AB: simulation
                            HOMEC ?A ?B HOMEC ?A ?B
                            RTS.Map (Hom ?A ?B)
            using A B by (metis RTS.arrD(3) RTS.ideD(1-3) ide_Hom)
          interpret I_BC: simulation
                            HOMEC ?B ?C HOMEC ?B ?C
                            RTS.Map (Hom ?B ?C)
            using B C by (metis RTS.arrD(3) RTS.ideD(1-3) ide_Hom)
          interpret I_CD: simulation
                            HOMEC ?C ?D HOMEC ?C ?D
                            RTS.Map (Hom ?C ?D)
            using C D by (metis RTS.arrD(3) RTS.ideD(1-3) ide_Hom)
          interpret I_CDxI_BC: product_simulation
                                 HOMEC ?C ?D HOMEC ?B ?C
                                 HOMEC ?C ?D HOMEC ?B ?C
                                 RTS.Map (Hom ?C ?D) RTS.Map (Hom ?B ?C)
            ..
          interpret PU_BC_AB: inverse_simulations
                                RTS.Dom (Hom ?B ?C  Hom ?A ?B)
                                BCxAB.resid
                                RTS.Pack (Hom ?B ?C) (Hom ?A ?B)
                                RTS.Unpack (Hom ?B ?C) (Hom ?A ?B)
            using A B C D RTS.inverse_simulations_Pack_Unpack by simp
          interpret PU_CD_BC: inverse_simulations
                                RTS.Dom (Hom ?C ?D  Hom ?B ?C)
                                CDxBC.resid
                                RTS.Pack (Hom ?C ?D) (Hom ?B ?C)
                                RTS.Unpack (Hom ?C ?D) (Hom ?B ?C)
            using A B C D RTS.inverse_simulations_Pack_Unpack by simp
          interpret bcxab: extensional_rts RTS.Dom (Hom ?B ?C  Hom ?A ?B)
            using A B C D RTS.arrD
                  RTS.ide_char [of "Hom ?B ?C  Hom ?A ?B"]
            by blast
          interpret CD_x_bcxab: product_rts
                                  HOMEC ?C ?D
                                  RTS.Dom (Hom ?B ?C  Hom ?A ?B)
             ..
          interpret cdxbc: extensional_rts RTS.Dom (Hom ?C ?D  Hom ?B ?C)
            using A B C D RTS.arrD
                  RTS.ide_char [of "Hom ?C ?D  Hom ?B ?C"]
            by blast
          interpret cdxbc_x_AB: product_rts
                                  RTS.Dom (Hom ?C ?D  Hom ?B ?C)
                                  HOMEC ?A ?B
            ..
          interpret PU_cdxbc_x_AB: inverse_simulations
                                RTS.Dom ((Hom ?C ?D  Hom ?B ?C)  Hom ?A ?B)
                                cdxbc_x_AB.resid
                                RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B)
                                RTS.Unpack
                                   (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B)
            using A B C D RTS.inverse_simulations_Pack_Unpack by auto
          interpret PU_CD_x_bcxab: inverse_simulations
                                      RTS.Dom
                                         (Hom ?C ?D  Hom ?B ?C  Hom ?A ?B)
                                      CD_x_bcxab.resid
                                      RTS.Pack
                                         (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B)
                                      RTS.Unpack
                                         (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B)
            using A B C D RTS.inverse_simulations_Pack_Unpack by auto
          interpret I_AB: identity_simulation HOMEC ?A ?B ..
          interpret U_CD_BC_x_I_AB: product_simulation
                                      RTS.Dom (Hom ?C ?D  Hom ?B ?C)
                                         HOMEC ?A ?B
                                      CDxBC.resid HOMEC ?A ?B
                                      RTS.Unpack (Hom ?C ?D) (Hom ?B ?C)
                                      I (HOMEC ?A ?B)
            ..
          interpret C_CD_BC: simulation
                               RTS.Dom (Hom ?C ?D  Hom ?B ?C)
                               HOMEC ?B ?D
                               RTS.Map (Comp ?B ?C ?D)
            using B C D Comp_in_hom [of ?B ?C ?D] arr_char
            by (metis (no_types, lifting) RTS.arrD(3) RTS.ideD(2) RTS.ide_prod
                RTS.in_homE ide_Hom prod.sel(1-2))
          interpret C_CD_BC_x_I_AB: product_simulation
                                      RTS.Dom (Hom ?C ?D  Hom ?B ?C)
                                      HOMEC ?A ?B
                                      HOMEC ?B ?D HOMEC ?A ?B
                                      RTS.Map (Comp ?B ?C ?D)
                                      RTS.Map (Hom ?A ?B)
             ..
          interpret I_CD: identity_simulation HOMEC ?C ?D ..
          interpret I_CD_x_P_BC_AB: product_simulation
                                      HOMEC ?C ?D BCxAB.resid
                                      HOMEC ?C ?D
                                      RTS.Dom (Hom ?B ?C  Hom ?A ?B)
                                      I (HOMEC ?C ?D)
                                      RTS.Pack (Hom ?B ?C) (Hom ?A ?B)
            ..
          interpret C_BC_AB: simulation
                               RTS.Dom (Hom ?B ?C  Hom ?A ?B)
                               HOMEC ?A ?C
                               RTS.Map (Comp ?A ?B ?C)
            using A B C Comp_in_hom [of ?A ?B ?C] arr_char
            by (metis (no_types, lifting) RTS.arrD(3) RTS.ideD(2) RTS.ide_prod
                RTS.in_homE ide_Hom prod.sel(1) prod.sel(2))
          interpret I_CD_x_Comp_ABC: product_simulation
                                       HOMEC ?C ?D
                                       RTS.Dom (Hom ?B ?C  Hom ?A ?B)
                                       HOMEC ?C ?D HOMEC ?A ?C
                                       RTS.Map (Hom ?C ?D)
                                       RTS.Map (Comp ?A ?B ?C)
            ..
          have "Trn ((t  u)  v) =
                (RTS.Map (Comp ?A ?B ?D)
                  (RTS.Pack (Hom ?B ?D) (Hom ?A ?B)
                    (RTS.Map (Comp ?B ?C ?D)
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u)),
                     Trn v)))"
            using tu uv H_seq_char (t  u)  v  V.null hcomp_def by auto
          also have "... =
                RTS.Map (Comp ?A ?B ?D)
                  (RTS.Pack (Hom ?B ?D) (Hom ?A ?B)
                    (RTS.Map (Comp ?B ?C ?D)
                       (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u)),
                     I (HOMEC ?A ?B) (Trn v)))"
            using H_seq_char arr_char uv by simp
          also have "... =
                RTS.Map (Comp ?A ?B ?D)
                  ((RTS.Pack (Hom ?B ?D) (Hom ?A ?B)  C_CD_BC_x_I_AB.map)
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v))"
            using A B C D RTS.Map_ide C_CD_BC_x_I_AB.map_simp H_seq_char
                  PU_CD_BC.F.preserves_reflects_arr arr_char tu uv
            by force
          also have "... =
                RTS.Map (Comp ?A ?B ?D)
                  ((RTS.Map (Comp ?B ?C ?D  Hom ?A ?B) 
                      RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v))"
          proof -
            have "RTS.Map (Comp ?B ?C ?D  Hom ?A ?B) 
                     RTS.Pack
                       (RTS.prod (Hom ?C ?D) (Hom ?B ?C)) (Hom ?A ?B) =
                  RTS.Pack (Hom ?B ?D) (Hom ?A ?B)  C_CD_BC_x_I_AB.map 
                      (RTS.Unpack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B) 
                         RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))"
              using A B C D Comp_in_hom [of ?B ?C ?D]
                    RTS.Map_prod [of "Comp ?B ?C ?D" "Hom ?A ?B"]
              by fastforce
            also have "... =
                  RTS.Pack (Hom ?B ?D) (Hom ?A ?B) 
                    (C_CD_BC_x_I_AB.map  I cdxbc_x_AB.resid)"
              using PU_cdxbc_x_AB.inv
              by auto
            also have "... = RTS.Pack (Hom ?B ?D) (Hom ?A ?B) 
                               C_CD_BC_x_I_AB.map"
              using comp_simulation_identity
                      [of cdxbc_x_AB.resid C_CD_BC_x_I_AB.B1xB0.resid
                          C_CD_BC_x_I_AB.map]
                    C_CD_BC_x_I_AB.simulation_axioms
              by auto
            finally have "RTS.Map (Comp ?B ?C ?D  Hom ?A ?B) 
                            RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B) =
                          RTS.Pack (Hom ?B ?D) (Hom ?A ?B)  C_CD_BC_x_I_AB.map"
              by blast
            thus ?thesis by simp
          qed
          also have "... =
                ((RTS.Map (Comp ?A ?B ?D) 
                    RTS.Map (Comp ?B ?C ?D  Hom ?A ?B)) 
                      RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                        (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
            by auto
          also have "... =
                (RTS.Map (Comp ?A ?B ?D  (Comp ?B ?C ?D  Hom ?A ?B)) 
                    RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
          proof -
            have "RTS.seq (Comp ?A ?B ?D) (Comp ?B ?C ?D  Hom ?A ?B)"
              using A B C D Comp_in_hom
              apply (intro RTS.seqI)
                apply auto[3]
              by (metis RTS.ide_char RTS.in_homE RTS.prod_simps(1,3) ide_Hom)+
            thus ?thesis
              using RTS.Map_comp
                      [of "Comp ?A ?B ?D" "Comp ?B ?C ?D  Hom ?A ?B"]
              by argo
          qed
          also have "... =
                (RTS.Map (Comp ?A ?C ?D  (Hom ?C ?D  Comp ?A ?B ?C) 
                            𝖺[Hom ?C ?D, Hom ?B ?C, Hom ?A ?B]) 
                    RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
            using A B C D Comp_assoc RTS.assoc_agreement by auto
          also have "... =
                ((RTS.Map (Comp ?A ?C ?D) 
                    RTS.Map ((Hom ?C ?D  Comp ?A ?B ?C) 
                               𝖺[Hom ?C ?D, Hom ?B ?C, Hom ?A ?B])) 
                    RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
          proof -
            have "RTS.seq
                    (Comp ?A ?C ?D)
                    ((Hom ?C ?D  Comp ?A ?B ?C) 
                        𝖺[Hom ?C ?D, Hom ?B ?C, Hom ?A ?B])"
              using A B C D
                    Comp_in_hom [of ?A ?C ?D] Comp_in_hom [of ?A ?B ?C]
                    RTS.assoc_in_hom
              apply (intro RTS.seqI)
                  apply auto[4]
              by fastforce
            thus ?thesis
              using RTS.Map_comp
                      [of "Comp ?A ?C ?D"
                          "(Hom ?C ?D  Comp ?A ?B ?C) 
                             𝖺[Hom ?C ?D, Hom ?B ?C, Hom ?A ?B]"]
              by argo
          qed
          also have "... =
                ((RTS.Map (Comp ?A ?C ?D) 
                   (RTS.Map (Hom ?C ?D  Comp ?A ?B ?C) 
                      RTS.Map
                        (RTS.assoc (Hom ?C ?D) (Hom ?B ?C) (Hom ?A ?B)))) 
                    RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
          proof -
            have "RTS.seq (Hom ?C ?D  Comp ?A ?B ?C)
                    𝖺[Hom (Cod u) (Cod t), Hom (Cod v) (Cod u),
                      Hom (Dom v) (Cod v)]"
              using A B C D Comp_in_hom [of ?A ?B ?C] RTS.assoc_simps(1,3)
                    RTS.arrI
              by (intro RTS.seqI) auto
            thus ?thesis
              using RTS.Map_comp
                      [of "Hom ?C ?D  Comp ?A ?B ?C"
                          "RTS.assoc (Hom ?C ?D) (Hom ?B ?C) (Hom ?A ?B)"]
              by auto
          qed
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   (RTS.Map (RTS.assoc (Hom ?C ?D) (Hom ?B ?C) (Hom ?A ?B))
                      (RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B)
                         (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u),
                          Trn v)))"
            using comp_assoc by simp
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   ((RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                       I_CD_x_P_BC_AB.map 
                         ASSOC.map
                           (HOMEC ?C ?D) (HOMEC ?B ?C) (HOMEC ?A ?B) 
                           U_CD_BC_x_I_AB.map)
                       ((RTS.Unpack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B) 
                           RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B))
                           (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u),
                            Trn v)))"
            using A B C D RTS.Map_assoc by simp
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   ((RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                       I_CD_x_P_BC_AB.map 
                         ASSOC.map
                           (HOMEC ?C ?D) (HOMEC ?B ?C) (HOMEC ?A ?B))
                      (U_CD_BC_x_I_AB.map
                         (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u),
                          Trn v)))"
          proof -
            have "RTS.Unpack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B) 
                    RTS.Pack (Hom ?C ?D  Hom ?B ?C) (Hom ?A ?B) =
                  I cdxbc_x_AB.resid" 
              using A B C D PU_cdxbc_x_AB.inv by blast
            moreover have "I cdxbc_x_AB.resid
                             (RTS.Pack (Hom ?C ?D) (Hom ?B ?C)
                                (Trn t, Trn u), Trn v) =
                           (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u),
                            Trn v)"
            proof -
              have "CDxBC.arr (Trn t, Trn u)"
                using tu uv arr_char [of t] arr_char [of u] H_seq_char by auto
              moreover have "AB.arr (Trn v)"
                using uv arr_char H_seq_char by simp
              ultimately have "cdxbc_x_AB.arr
                                 (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u),
                                  Trn v)"
                using A B C D PU_CD_BC.F.preserves_reflects_arr by fastforce
              thus ?thesis by auto
            qed
            ultimately show ?thesis by simp
          qed
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   ((RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                       I_CD_x_P_BC_AB.map 
                         ASSOC.map
                           (HOMEC ?C ?D) (HOMEC ?B ?C) (HOMEC ?A ?B))
                         ((RTS.Unpack (Hom ?C ?D) (Hom ?B ?C) 
                             RTS.Pack (Hom ?C ?D) (Hom ?B ?C))
                             (Trn t, Trn u),
                           Trn v))"
          proof -
            have "cdxbc_x_AB.arr
                    (RTS.Pack (Hom ?C ?D) (Hom ?B ?C) (Trn t, Trn u), Trn v)"
              using tu uv arr_char H_seq_char PU_CD_BC.F.preserves_reflects_arr
              by fastforce
            thus ?thesis
              using A B C D U_CD_BC_x_I_AB.map_simp by fastforce
          qed
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   ((RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                       I_CD_x_P_BC_AB.map)
                       (ASSOC.map
                          (HOMEC ?C ?D) (HOMEC ?B ?C) (HOMEC ?A ?B)
                          ((Trn t, Trn u), Trn v)))"
            using tu uv arr_char H_seq_char PU_CD_BC.inv by fastforce
          also have "... =
                (RTS.Map (Comp ?A ?C ?D) 
                   RTS.Map (Hom ?C ?D  Comp ?A ?B ?C))
                   ((RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                       I_CD_x_P_BC_AB.map)
                       (Trn t, Trn u, Trn v))"
          proof -
            interpret A: ASSOC
                           HOMEC ?C ?D HOMEC ?B ?C HOMEC ?A ?B
              ..
            have "CDxBC_x_AB.arr ((Trn t, Trn u), Trn v)"
              using tu uv arr_char H_seq_char by fastforce
            thus ?thesis
              using A.map_eq by simp
          qed
          also have "... =
                (RTS.Map (Comp ?A ?C ?D)
                  ((RTS.Map (Hom ?C ?D  Comp ?A ?B ?C) 
                     RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B))
                      (Trn t, RTS.Pack (Hom ?B ?C) (Hom ?A ?B) (Trn u, Trn v))))"
            using tu uv arr_char H_seq_char by fastforce
          also have "... =
                RTS.Map (Comp ?A ?C ?D)
                  ((RTS.Pack (Hom ?C ?D) (Hom ?A ?C)  I_CD_x_Comp_ABC.map)
                      (Trn t, RTS.Pack (Hom ?B ?C) (Hom ?A ?B) (Trn u, Trn v)))"
          proof -
            have "RTS.Map (Hom ?C ?D  Comp ?A ?B ?C) 
                    RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) =
                  (RTS.Pack (Hom ?C ?D) (Hom ?A ?C) 
                     I_CD_x_Comp_ABC.map 
                     (RTS.Unpack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) 
                        RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B)))"
              using A B C D RTS.Map_prod [of "Hom ?C ?D" "Comp ?A ?B ?C"]
                    Comp_in_hom [of ?A ?B ?C]
              by fastforce
            also have "... =
                  (RTS.Pack (Hom ?C ?D) (Hom ?A ?C) 
                     (I_CD_x_Comp_ABC.map  I CD_x_bcxab.resid))"
              using PU_CD_x_bcxab.inv by auto
            also have "... = RTS.Pack (Hom ?C ?D) (Hom ?A ?C) 
                               I_CD_x_Comp_ABC.map"
              using comp_simulation_identity
                      [of CD_x_bcxab.resid _ I_CD_x_Comp_ABC.map]
                    I_CD_x_Comp_ABC.simulation_axioms
              by simp
            finally have "RTS.Map (Hom ?C ?D  Comp ?A ?B ?C) 
                            RTS.Pack (Hom ?C ?D) (Hom ?B ?C  Hom ?A ?B) =
                          RTS.Pack (Hom ?C ?D) (Hom ?A ?C)  I_CD_x_Comp_ABC.map"
              by simp
            thus ?thesis by simp
          qed
          also have "... =
                RTS.Map (Comp ?A ?C ?D)
                  (RTS.Pack (Hom ?C ?D) (Hom ?A ?C)
                    (Trn t,
                     RTS.Map (Comp ?A ?B ?C)
                       (RTS.Pack (Hom ?B ?C) (Hom ?A ?B) (Trn u, Trn v))))"
            using A B C D tu uv arr_char H_seq_char RTS.Map_ide
                  I_CD_x_Comp_ABC.map_simp
                    [of "Trn t" "RTS.Pack (Hom ?B ?C) (Hom ?A ?B) (Trn u, Trn v)"]
            by fastforce
          also have "... = Trn (t  u  v)"
            using tu uv H_seq_char
            apply auto[1]
            using arr_hcomp hcomp_def by auto
          finally show "Trn ((t  u)  v) = Trn (t  u  v)"
            by blast
        qed
      qed
    qed

    lemma is_category:
    shows "category hcomp"
      ..

    lemma H_dom_char:
    shows "H.dom =
           (λt. if H.arr t
                then MkArr (Dom t) (Dom t)
                       (RTS.Map (Id (Dom t)) RTS.One.the_arr)
                else V.null)"
      using H_domains_char H.dom_in_domains H.has_domain_iff_arr H.dom_def
            H_null_char
      by auto

    lemma H_dom_simp:
    assumes "V.arr t"
    shows "H.dom t = MkArr (Dom t) (Dom t)
                       (RTS.Map (Id (Dom t)) RTS.One.the_arr)"
      using assms arr_char H_arr_char H_dom_char by fastforce

    lemma H_cod_char:
    shows "H.cod =
           (λt. if H.arr t
                then MkArr (Cod t) (Cod t)
                       (RTS.Map (Id (Cod t)) RTS.One.the_arr)
                else V.null)"
      using H_codomains_char H.cod_in_codomains H.has_codomain_iff_arr
            H.cod_def H_null_char
      by auto

    lemma H_cod_simp:
    assumes "V.arr t"
    shows "H.cod t = MkArr (Cod t) (Cod t)
                       (RTS.Map (Id (Cod t)) RTS.One.the_arr)"
      using assms arr_char H_arr_char H_cod_char by fastforce

    lemma con_implies_H_par:
    assumes "V.con t u"
    shows "H.par t u"
      using assms con_char V.con_implies_arr(1-2) H_arr_char
            H_dom_simp H_cod_simp
      by (simp add: arr_char con_implies_Par(1-2))

    lemma H_par_resid:
    assumes "V.con t u"
    shows "H.par t (resid t u)"
      using assms con_char V.con_implies_arr(1-2) H_arr_char
            H_dom_simp H_cod_simp
            Dom_resid Cod_resid arr_char V.arr_resid
      by (intro conjI) metis+

    lemma simulation_dom:
    shows "simulation resid resid H.dom"
      using H_dom_char arr_char H_arr_char con_char
      apply unfold_locales
        apply auto[1]
      apply (metis (no_types, lifting) Con_def H.arr_dom V.arrE)
      by (metis (no_types, lifting) H.ide_dom H_ide_is_V_ide H_par_resid
          V.ideE con_implies_H_par)

    lemma simulation_cod:
    shows "simulation resid resid H.cod"
      using H_cod_char arr_char H_arr_char con_char
      apply unfold_locales
        apply presburger
       apply (metis (no_types, lifting) H.arr_cod V.arr_def
           rts_category_of_enriched_category.ConE
           rts_category_of_enriched_category_axioms)
      by (metis (no_types, lifting) H.ide_cod H_ide_is_V_ide
          H_par_resid V.con_implies_arr(2) V.ideE con_implies_Par(2))

    sublocale dom: simulation resid resid H.dom
      using simulation_dom by blast
    sublocale cod: simulation resid resid H.cod
      using simulation_cod by blast
    sublocale RR: fibered_product_rts resid resid resid H.dom H.cod ..

    sublocale H: simulation RR.resid resid
                   λt. if RR.arr t then fst t  snd t else V.null
    proof
      let ?C = "λt. if RR.arr t then fst t  snd t else V.null"
      show "t. ¬ RR.arr t  ?C t = V.null"
        by simp
      fix t u
      assume tu: "RR.con t u"
      have arr_t: "RR.arr t"
        using tu RR.con_implies_arr by blast
      have arr_u: "RR.arr u"
        using tu RR.con_implies_arr by blast
      have t: "V.arr (fst t)  V.arr (snd t)  Dom (fst t) = Cod (snd t)"
        by (metis H_cod_simp H_dom_simp RR.arr_char arr.inject arr_t)
      have u: "V.arr (fst u)  V.arr (snd u)  Dom (fst u) = Cod (snd u)"
        using H_cod_simp H_dom_simp RR.arr_char arr_u by auto
      let ?a = "Dom (snd t)" and ?b = "Cod (snd t)" and ?c = "Cod (fst t)"
      have a: "?a  Obj" and b: "?b  Obj" and c: "?c  Obj"
        using tu RR.con_char RR.con_implies_arr ide_char arr_char by fast+
      interpret AB: hom_rts arr_type Obj Hom Id Comp ?a ?b
        using t u ide_char arr_char
        by unfold_locales auto
      interpret BC: hom_rts arr_type Obj Hom Id Comp ?b ?c
        using t u ide_char arr_char
        by unfold_locales auto
      interpret AC: hom_rts arr_type Obj Hom Id Comp ?a ?c
        using t u ide_char arr_char
        by unfold_locales auto
      interpret BCxAB: product_rts HOMEC ?b ?c HOMEC ?a ?b ..
      interpret bcxab: extensional_rts
                         RTS.Rts (RTS.dom (Hom ?b ?c  Hom ?a ?b))
        using t u ide_char arr_char by auto
      have 1: "Dom (snd u) = ?a"
        using tu RR.con_char RR.arr_char RR.con_implies_arr RR.con_sym
              H_dom_simp H_cod_simp
        by (meson con_implies_Par(1))
      have 2: "Cod (fst u) = ?c"
        using tu RR.con_char RR.arr_char RR.con_implies_arr RR.con_sym
              H_dom_simp H_cod_simp
        by (meson con_implies_Par(2))
      have 3: "Cod (snd u) = ?b"
        using tu RR.con_char RR.arr_char RR.con_implies_arr RR.con_sym
              H_dom_simp H_cod_simp
        by (meson con_implies_Par(2))
      have 4: "BCxAB.con (Trn (fst t), Trn (snd t)) (Trn (fst u), Trn (snd u))"
        using tu RR.con_char BCxAB.con_char con_char t by auto

      interpret P: simulation BCxAB.resid
                     RTS.Rts (RTS.dom (Hom ?b ?c  Hom ?a ?b)) 
                     RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
        using a b c RTS.simulation_Pack by auto
      have 5: "bcxab.con
                 (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn (fst t), Trn (snd t)))
                 (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn (fst u), Trn (snd u)))"
        using 4 P.preserves_con by simp
      interpret Comp: simulation
                        RTS.Rts (RTS.dom  (Hom ?b ?c  Hom ?a ?b))
                        HOMEC ?a ?c
                        RTS.Map (Comp ?a ?b ?c)
        using a b c Comp_in_hom arr_char
        by (metis (no_types, lifting) RTS.arrD(3) RTS.ideD(2) RTS.ide_prod
            RTS.in_homE ide_Hom prod.sel(1-2))
      show con: "?C t  ?C u"
      proof -
        have "AC.con (RTS.Map (Comp ?a ?b ?c)
                        (RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
                           (Trn (fst t), Trn (snd t))))
                     (RTS.Map (Comp ?a ?b ?c)
                        (RTS.Pack (Hom ?b ?c) (Hom ?a ?b)
                         (Trn (fst u), Trn (snd u))))"
          using 5 Comp.preserves_con by blast
        thus ?thesis
          using 1 2 3 AC.con_implies_arr(1-2) Con_def H_composable_char
                a arr_t arr_u c con_char null_char t u
          by auto
      qed
      show "?C (RR.resid t u) = resid (?C t) (?C u)"
      proof -
        have "resid (?C t) (?C u) =
              MkArr ?a ?c
                (RTS.Map (Comp ?a ?b ?c)
                  (RTS.Rts (RTS.dom (Hom ?b ?c  Hom ?a ?b))
                     (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn (fst t), Trn (snd t)))
                     (RTS.Pack (Hom ?b ?c) (Hom ?a ?b) (Trn (fst u), Trn (snd u)))))"
          using a b c t u arr_t arr_u 1 2 3 4 5 hcomp_def P.preserves_reflects_arr
                arr_char Comp.preserves_resid con con_char by force
        also have "... = ?C (RR.resid t u)"
          using tu t u a b c 1 2 3 4 RR.con_char RR.arr_resid hcomp_def
                RR.resid_def BCxAB.resid_def P.preserves_resid
          by auto
        finally show ?thesis by simp
      qed
    qed

    lemma simulation_hcomp:
    shows "simulation RR.resid resid
             (λt. if RR.arr t then fst t  snd t else V.null)"
      ..

    lemma Dom_src [simp]:
    assumes "V.arr t"
    shows "Dom (V.src t) = Dom t"
      using assms con_implies_Par(1) by simp

    lemma Dom_trg [simp]:
    assumes "V.arr t"
    shows "Dom (V.trg t) = Dom t"
      using assms V.trg_def by simp

    lemma Cod_src [simp]:
    assumes "V.arr t"
    shows "Cod (V.src t) = Cod t"
      using assms con_implies_Par(2) by simp

    lemma Cod_trg [simp]:
    assumes "V.arr t"
    shows "Cod (V.trg t) = Cod t"
      using assms V.trg_def by simp

    lemma null_coincidence [simp]:
    shows "H.null = V.null"
      using H_null_char by blast

    lemma arr_coincidence [simp]:
    shows "H.arr = V.arr"
      using H_arr_char arr_char by blast

    lemma dom_src [simp]:
    shows "H.dom (V.src t) = H.dom t"
      using H_dom_char H_arr_char arr_char null_char V.arr_src_iff_arr
      by auto

    lemma src_dom [simp]:
    shows "V.src (H.dom t) = H.dom t"
      using H_ide_is_V_ide V.src_def V.src_ide dom.extensional by auto

    lemma small_homs:
    shows "small (H.hom a b)"
    proof -
      have "¬ H.ide a  ¬ H.ide b  ?thesis"
      proof -
        assume 1: "¬ H.ide a  ¬ H.ide b"
        have "H.hom a b = {}"
          using 1 H.ide_dom H.ide_cod by blast
        thus ?thesis by auto
      qed
      moreover have "H.ide a; H.ide b  ?thesis"
      proof -
        assume a: "H.ide a" and b: "H.ide b"
        interpret Hom: hom_rts arr_type Obj Hom Id Comp Dom a Dom b
          using a b
          by (meson H.ideD(1) H_arr_char hom_rts.intro hom_rts_axioms.intro
              rts_enriched_category_axioms)
        have "bij_betw Trn (H.hom a b) (Collect Hom.arr)"
        proof (intro bij_betwI)
          show "Trn  H.hom a b  Collect Hom.arr"
            using a b H_ide_char H_arr_char ide_char arr_char
                  H_ide_is_V_ide
            by (auto simp add: H_dom_simp H_cod_simp)
          show "(λt. MkArr (Dom a) (Dom b) t)  Collect Hom.arr  H.hom a b"
            using a b H.ideD(1-2) H_cod_simp H_dom_char Hom.a Hom.b
                  arr_MkArr arr_coincidence
            by auto
          show "x. x  H.hom a b  MkArr (Dom a) (Dom b) (Trn x) = x"
            by (metis CollectD H.ide_in_hom H.seqI' H_seq_char MkArr_Trn a b)
          show "y. y  Collect Hom.arr  Trn (MkArr (Dom a) (Dom b) y) = y"
            using a b by auto
        qed
        hence "inj_on Trn (H.hom a b)  Collect Hom.arr = Trn ` H.hom a b"
          using bij_betw_imp_inj_on bij_betw_imp_surj_on by metis
        thus ?thesis
          using Hom.small small_image_iff by auto
      qed
      ultimately show ?thesis by blast
    qed

    text‹
      Note that the arrow type of the RTS-category given by the following is
      @{typ "('O, 'A) arr"}, where 'A is the type of the universe underlying the
      category RTS and 'O is the type of objects of the context RTS-enriched
      category.  If we start with an RTS-enriched category having object type 'O,
      then we construct an RTS-category having arrow type @{typ "('O, 'A) arr"},
      and then we try to go back to an RTS-enriched category, the hom-RTS's
      will have arrow type @{typ "('O, 'A) arr"}, not 'A› as required for them to
      determine objects of RTS›.  So to show that the passage between RTS-categories
      and RTS-enriched categories is an equivalence, we will need to be able to
      reduce the type of the hom-RTS's from @{typ "('O, 'A) arr"} back to 'A›.
    ›

    sublocale rts_category resid hcomp
      using null_coincidence arr_coincidence small_homs
      by unfold_locales auto

    proposition is_rts_category:
    shows "rts_category resid hcomp"
      ..

  end

subsection "The Small Case"

  text‹
    Given an RTS-enriched category, the corresponding RTS-category R› has arrows at
    a higher type than the arrow type 'A› of the base category RTS›.  In particular,
    the arrow type for this category is ('O, 'A) arr›, where 'O› is the element
    type of Obj›.  If we want to reconstruct the original RTS-enriched category up
    to isomorphism, then we need to be able to map this type back down to 'A›,
    so that we can obtain (via RTS.MkIde›) an RTS R'› with arrow type 'A›,
    which is isomorphic to the desired RTS-category R›.
    For this to be possible, clearly we need the set Obj› to be small.
    However, we also need a way to represent each element of Obj› uniquely as an
    element of 'A›.  This would be true automatically if we knew that 'A› were
    large enough to embed all small sets, but we don't want to tie the definition
    of the category RTS› itself to a particular definition of ``small''.  So, here we
    instead just directly assume the existence of an injection from Obj› to 'A›.
  ›

  locale rts_category_of_small_enriched_category =
    rts_category_of_enriched_category arr_type Obj Hom Id Comp
  for arr_type :: "'A itself"
  and Obj :: "'O set"
  and Hom :: "'O  'O  'A rtscatx.arr"
  and Id :: "'O  'A rtscatx.arr"
  and Comp :: "'O  'O  'O  'A rtscatx.arr" +
  assumes small_Obj: "small Obj"
  and inj_Obj_to_arr: "φ :: 'O  'A. inj_on φ Obj"
  begin

     text‹
       We will use R› to refer to the RTS constructed from the given enriched category.
     ›

     abbreviation R :: "('O, 'A) arr resid"
     where "R  resid"

     text‹
       The locale assumptions are sufficient to allow us to uniquely encode each element
       of @{term "Collect arr  {null}"} as single element of 'A›.
     ›

     lemma ex_arrow_injection:
     shows "i :: ('O, 'A) arr  'A. inj_on i (Collect arr  {null})"
     proof -
       obtain φ :: "'O  'A" where φ: "inj_on φ Obj"
         using inj_Obj_to_arr by blast
       let ?p = "λt. some_pair (some_pair (φ (Dom t), φ (Cod t)), Trn t)"
       have p: "inj_on ?p (Collect arr)"
         by (metis (mono_tags, lifting) CollectD φ arr_char arr_eqI
             first_conv inj_onD inj_onI null_char second_conv)
       let ?i = "λx. some_lift (if arr x then Some (?p x) else None)"
       have "inj_on ?i (Collect arr  {null})"
       proof
         fix x y
         assume x: "x  Collect arr  {null}" and y: "y  Collect arr  {null}"
         assume eq: "?i x = ?i y"
         show "x = y"
           using x y eq p inj_some_lift injD inj_on_contraD by fastforce
       qed
       thus ?thesis by auto
     qed

     lemma bij_betw_Obj_horiz_ide:
     shows "bij_betw mkobj Obj (Collect H.ide)"
       using arr_char Id_yields_horiz_ide H_ide_char horizontal_unit_def
       apply (intro bij_betwI)
          apply auto[3]
       by (metis Dom.simps(1) mem_Collect_eq)

     lemma ex_isomorphic_image_rts:
     shows "R' (UP :: 'A  ('O, 'A) arr) (DN :: ('O, 'A) arr  'A).
               small_rts R'  extensional_rts R'  inverse_simulations R R' UP DN"
     proof -
       obtain i :: "('O, 'A) arr  'A" where i: "inj_on i (Collect arr  {null})"
         using ex_arrow_injection by blast
       interpret R': inj_image_rts i R
         using i by unfold_locales
       interpret R': extensional_rts R'.resid
         using V.extensional_rts_axioms R'.preserves_extensional_rts by blast
       interpret R': small_rts R'.resid
       proof -
         have "small (Collect arr)"
         proof -
           have "small ((Collect H.ide × Collect H.ide) ×
                           (xCollect H.ide × Collect H.ide.
                                  H.hom (fst x) (snd x)))"
           proof -
             have "a b. H.ide a; H.ide b  small (H.hom a b)"
               using small_homs by auto
             moreover have "small (Collect H.ide × Collect H.ide)"
               using small_Obj bij_betw_Obj_horiz_ide
               by (metis (no_types, lifting) bij_betw_imp_surj_on replacement
                   small_Sigma)
             ultimately show ?thesis
               using small_homs by force
           qed
           moreover
           have "(λt. ((H.dom t, H.cod t), t)) 
                          Collect arr 
                            ((Collect H.ide × Collect H.ide) ×
                               (xCollect H.ide × Collect H.ide.
                                    H.hom (fst x) (snd x)))"
           proof
             fix t
             assume t: "t  Collect arr"
             have "H.dom t  Collect H.ide  H.cod t  Collect H.ide"
               using t arr_coincidence H.ide_dom H.ide_cod by simp
             moreover have "t  H.hom (H.dom t) (H.cod t)"
               using t arr_coincidence by auto
             ultimately
             show "((H.dom t, H.cod t), t) 
                      (Collect H.ide × Collect H.ide) ×
                         (xCollect H.ide × Collect H.ide. H.hom (fst x) (snd x))"
               by auto
           qed
           moreover have "inj_on (λt. ((H.dom t, H.cod t), t)) (Collect arr)"
             by (intro inj_onI) blast
           ultimately show ?thesis
             using small_image_iff
                   smaller_than_small
                     [of _ "(λt. ((H.dom t, H.cod t), t)) ` Collect arr"]
             by blast
         qed
         hence "small_rts R"
           using small_rts_def rts_axioms small_rts_axioms.intro by auto
         thus "small_rts R'.resid"
           using R'.preserves_reflects_small_rts by blast
       qed
       have "inverse_simulations R'.resid R R'.mapext R'.map'ext"
         using R'.inverse_simulations_axioms by auto
       thus ?thesis
         using R'.rts_axioms R'.extensional_rts_axioms R'.small_rts_axioms
               inverse_simulations_sym
         by meson
     qed

     text‹
       We now choose some RTS with the properties asserted by the previous lemma,
       along with the invertible simulations that relate it to @{term R}.
     ›

     definition R' :: "'A resid"
     where "R'  SOME R'. UP DN. small_rts R'  extensional_rts R' 
                                    inverse_simulations resid R' UP DN"

     definition UP :: "'A  ('O, 'A) arr"
     where "UP  SOME UP. DN. small_rts R'  extensional_rts R' 
                                 inverse_simulations resid R' UP DN"

     definition DN :: "('O, 'A) arr  'A"
     where "DN  SOME DN. small_rts R'  extensional_rts R' 
                            inverse_simulations resid R' UP DN"

     lemma R'_prop:
     shows "UP DN. small_rts R'  extensional_rts R' 
                      inverse_simulations R R' UP DN"
       unfolding R'_def
       using small_Obj ex_isomorphic_image_rts
             someI_ex
               [of "λR'. UP DN. small_rts R'  extensional_rts R' 
                                   inverse_simulations R R' UP DN"]
       by auto

     sublocale R': extensional_rts R'
       using R'_prop by simp
     sublocale R': small_rts R'
       using R'_prop by simp

     lemma extensional_rts_R':
     shows "extensional_rts R'"
       ..

     lemma small_rts_R':
     shows "small_rts R'"
       ..

     sublocale UP_DN: inverse_simulations R R' UP DN
       using small_Obj R'_prop UP_def DN_def
             someI_ex [of "λUP. DN. inverse_simulations resid R' UP DN"]
             someI_ex [of "λDN. inverse_simulations resid R' UP DN"]
       by auto

     lemma inverse_simulations_UP_DN:
     shows "inverse_simulations resid R' UP DN"
       ..

     lemma R'_src_char:
     shows "R'.src = DN  src  UP"
     proof -
       have "t. DN (UP (R'.src t)) = DN (src (UP t))"
         by (metis H.dom_null R'.con_arr_src(2) R'.ide_src R'.not_arr_null R'.src_def
             UP_DN.F.extensional UP_DN.F.preserves_con UP_DN.F.preserves_ide
             null_coincidence src_dom V.src_eqI)
       moreover have "t. DN (UP (R'.src t)) = R'.src t"
         using R'.arr_src_iff_arr R'.src_def UP_DN.inv
         by (metis (no_types, lifting) comp_apply)
       ultimately show ?thesis by auto
     qed

     lemma R'_trg_char:
     shows "R'.trg = DN  trg  UP"
     proof -
       have "t. DN (UP (R'.trg t)) = DN (trg (UP t))"
         by (metis R'.arr_trg_iff_arr UP_DN.F.extensional UP_DN.F.preserves_trg
             V.null_is_zero(2) V.trg_def)
       moreover have "t. DN (UP (R'.trg t)) = R'.trg t"
         using R'.arr_trg_iff_arr R'.trg_def UP_DN.inv
         by (metis (no_types, lifting) R'.src_def R'.src_trg comp_apply)
       ultimately show ?thesis by auto
     qed

     text‹
       We transport the horizontal composition @{term hcomp} to R'› via
       the isomorphisms @{term UP} and @{term DN}.
     ›

     abbreviation hcomp' :: "'A resid"  (infixr "⋆´" 53)
     where "t ⋆´ u  DN (UP t  UP u)"

     interpretation H': Category.partial_magma hcomp'
       by unfold_locales
          (metis H_composable_char R'.not_arr_null UP_DN.F.extensional
           UP_DN.F.preserves_reflects_arr UP_DN.G.extensional)

     lemma H'_null_char:
     shows "H'.null = DN null"
       using arr_coincidence
       by (metis H'.null_is_zero(2) R'.not_arr_null UP_DN.F.extensional
           hcomp_Null(2) null_char)

     interpretation H': partial_composition λt u. DN (hcomp (UP t) (UP u)) ..

     lemma H'_ide_char:
     shows "H'.ide t  H.ide (UP t)"
     proof
       have 1: "f. arr f; Dom f = Cod (UP t); t ⋆´ t  DN null;
                     t u. (t  u  null) = (arr t  arr u  Dom t = Cod u);
                     f. (f ⋆´ t  DN null  f ⋆´ t = f) 
                         (t ⋆´ f  DN null  t ⋆´ f = f)
                        f  UP t = f"
          by (metis (no_types, lifting) UP_DN.G.preserves_reflects_arr
              UP_DN.inv'_simp arr_hcomp)
       have 2: "f. arr f; Dom (UP t) = Cod f; t ⋆´ t  DN null;
                     t u. (t  u  null) = (arr t  arr u  Dom t = Cod u);
                     f. (f ⋆´ t  DN null  f ⋆´ t = f) 
                         (t ⋆´ f  DN null  t ⋆´ f = f)
                        UP t  f = f"
          by (metis (no_types, lifting) UP_DN.G.preserves_reflects_arr
              UP_DN.inv'_simp arr_hcomp)
       show "H'.ide t  obj (UP t)"
         unfolding H'.ide_def H.ide_def
         using H'_null_char H_composable_char
         apply auto[1]
            apply (metis UP_DN.F.preserves_reflects_arr)
           apply metis
         using 1 2 by blast+
       show "obj (UP t)  H'.ide t"
         unfolding H'.ide_def H.ide_def
         apply (auto simp add: H'_null_char H_composable_char)[1]
          apply (metis H_composable_char UP_DN.F.extensional UP_DN.inv_simp)
         by (metis H_composable_char UP_DN.F.extensional UP_DN.inv_simp)
     qed

     lemma H'_domains_char:
     shows "H'.domains t = DN ` H.domains (UP t)"
     proof -
       have "{a. H.ide (UP a)  t ⋆´ a  DN null} =
             DN ` {a. H.ide a  UP t  a  null}"
       proof
         show "{a. H.ide (UP a)  t ⋆´ a  DN null} 
               DN ` {a. H.ide a  UP t  a  null}"
         proof
           fix a
           assume a: "a  {a. H.ide (UP a)  t ⋆´ a  DN null}"
           have 1: "H.ide (UP a)  UP t  UP a  null"
             using a by auto
           moreover have "a = DN (UP a)"
             using a 1
             by (metis (no_types, opaque_lifting) H_composable_char
                 UP_DN.F.preserves_reflects_arr UP_DN.inv comp_apply)
           ultimately show "a  DN ` {a. H.ide a  UP t  a  null}" by blast
         qed
         show "DN ` {a. H.ide a  UP t  a  null} 
               {a. H.ide (UP a)  t ⋆´ a  DN null}"
         proof
           fix a
           assume a: "a  DN ` {a. H.ide a  UP t  a  null}"
           obtain UPa
           where UPa: "a = DN UPa  UPa  {a. H.ide a  UP t  a  null}"
             using a by blast
           have "UPa = UP a"
             using UPa H_composable_char UP_DN.inv' comp_apply by auto
           thus "a  {a. H.ide (UP a)  DN (UP t  UP a)  DN null}"
             using UPa null_coincidence
             by (metis (mono_tags, lifting) H.ext UP_DN.G.preserves_reflects_arr
                 arr_coincidence mem_Collect_eq V.not_arr_null)
         qed
       qed
       thus ?thesis
         unfolding H'.domains_def H.domains_def
         using H'_ide_char H'_null_char null_coincidence by simp
     qed

     lemma H'_codomains_char:
     shows "H'.codomains t = DN ` H.codomains (UP t)"
     proof -
       have "{b. H.ide (UP b)  b ⋆´ t  DN null} =
             DN ` {b. H.ide b  b  UP t  null}"
       proof
         show "{b. H.ide (UP b)  b ⋆´ t  DN null} 
               DN ` {b. H.ide b  b  UP t  null}"
         proof
           fix b
           assume b: "b  {b. H.ide (UP b)  b ⋆´ t  DN null}"
           have "DN (UP b)  DN ` {b. H.ide b  b  UP t  null}"
             using b by auto
           moreover have "DN (UP b) = b"
             using b
             by (metis (no_types, lifting) H'.ide_def H'_ide_char
                 H.comp_ide_self mem_Collect_eq)
           ultimately show "b  DN ` {b. H.ide b  b  UP t  null}" by auto
         qed
         show "DN ` {b. H.ide b  b  UP t  null} 
               {b. H.ide (UP b)  b ⋆´ t  DN null}"
         proof
           fix b
           assume b: "b  DN ` {b. H.ide b  b  UP t  null}"
           obtain UPb
           where UPb: "b = DN UPb  UPb  {b. H.ide b  b  UP t  null}"
             using b by blast
           have "UPb = UP b"
             using UPb H_composable_char UP_DN.inv' comp_apply by auto
           thus "b  {b. H.ide (UP b)  DN (UP b  UP t)  DN null}"
             using UPb null_coincidence arr_coincidence
             by (metis (mono_tags, lifting) H.ext UP_DN.G.preserves_reflects_arr
                 mem_Collect_eq V.not_arr_null)
         qed
       qed
       thus ?thesis
         unfolding H'.codomains_def H.codomains_def
         using H'_ide_char H'_null_char null_coincidence by simp
     qed

     lemma H'_arr_char:
     shows "H'.arr t = H.arr (UP t)"
       unfolding H'.arr_def H.arr_def
       using H'_domains_char H'_codomains_char by auto

     lemma H'_seq_char:
     shows "H'.seq t u  H.seq (UP t) (UP u)"
       by (simp add: H'_arr_char)

     sublocale H': category hcomp'
     proof
       show "g f. g ⋆´ f  H'.null  H'.seq g f"
         using H'_null_char H'_seq_char UP_DN.G.extensional by auto
       show "f. (H'.domains f  {}) = (H'.codomains f  {})"
         using H'_domains_char H'_codomains_char H.has_domain_iff_has_codomain
         by simp
       show "h g f. H'.seq h g; H'.seq (DN (UP h  UP g)) f  H'.seq g f"
         by (metis H'_seq_char H.match_1 UP_DN.inv'_simp arr_coincidence)
       show "h g f. H'.seq h (g ⋆´ f); H'.seq g f  H'.seq h g"
         using H'_seq_char H_seq_char by auto
       show "g f h. H'.seq g f; H'.seq h g  H'.seq (h ⋆´ g) f"
         using H'_arr_char H_seq_char by auto
       show "g f h. H'.seq g f; H'.seq h g  (h ⋆´ g) ⋆´ f = h ⋆´ g ⋆´ f"
         using H'_seq_char H.comp_assoc UP_DN.inv' by auto
     qed

     lemma hcomp'_is_category:
     shows "category hcomp'"
       ..

     lemma H'_dom_char:
     shows "H'.dom = DN  H.dom  UP"
     proof
       fix t
       show "H'.dom t = (DN  H.dom  UP) t"
       proof (cases "arr (UP t)")
         show "¬ arr (UP t)  ?thesis"
           by (metis H'.dom_def H'.domains_char H'_arr_char H'_null_char
               H.dom_null H_arr_char UP_DN.F.extensional
               UP_DN.F.preserves_reflects_arr arr_char comp_def
               null_coincidence)
         assume t: "arr (UP t)"
         have "(DN  H.dom  UP) t = DN (H.dom (UP t))"
           using t by auto
         also have "... = H'.dom t"
           using t H'_domains_char H'_arr_char arr_coincidence H.dom_in_domains
                 H.has_domain_iff_arr
           by (intro H'.dom_eqI') auto
         finally show ?thesis by auto
       qed
     qed

     lemma H'_cod_char:
     shows "H'.cod = DN  H.cod  UP"
     proof
       fix t
       show "H'.cod t = (DN  H.cod  UP) t"
       proof (cases "arr (UP t)")
         show "¬ arr (UP t)  ?thesis"
           by (metis H'.cod_def H'.codomains_char H'_arr_char H'_null_char
               H.cod_null H_arr_char UP_DN.F.extensional
               UP_DN.F.preserves_reflects_arr arr_char comp_def
               null_coincidence)
         assume t: "arr (UP t)"
         have "(DN  H.cod  UP) t = DN (H.cod (UP t))"
           using t by auto
         also have "... = H'.cod t"
           using t H'_codomains_char H'_arr_char arr_coincidence
                 H.cod_in_codomains H.has_codomain_iff_arr
           by (intro H'.cod_eqI') auto
         finally show ?thesis by auto
       qed
     qed

     lemma null'_coincidence [simp]:
     shows "H'.null = R'.null"
       by (simp add: H'_null_char UP_DN.G.extensional)

     lemma arr'_coincidence [simp]:
     shows "H'.arr = R'.arr"
       using H'_arr_char UP_DN.F.preserves_reflects_arr arr_coincidence by auto

     lemma H'_hom_char:
     shows "H'.hom a b = DN ` H.hom (UP a) (UP b)"
     proof
       show "H'.hom a b  DN ` H.hom (UP a) (UP b)"
       proof
         fix t
         assume t: "t  H'.hom a b"
         have "UP t  H.hom (UP a) (UP b)"
         proof
           have a: "V.ide (UP a)"
             using t arr'_coincidence H'_ide_char UP_DN.F.preserves_ide
             by (metis H'.arr_dom H'.dom_dom H'.ide_char' H'.in_homE
                 H_ide_is_V_ide mem_Collect_eq)
           have b: "V.ide (UP b)"
             using t arr'_coincidence H'_ide_char UP_DN.F.preserves_ide
             by (metis H'.arr_cod H'.cod_cod H'.ide_char' H'.in_homE
                 H_ide_is_V_ide mem_Collect_eq)
           show "H.in_hom (UP t) (UP a) (UP b)"
           proof
             show 1: "H.arr (UP t)"
               using t arr_coincidence arr'_coincidence
                     UP_DN.F.preserves_reflects_arr
               by auto
             show "H.dom (UP t) = UP a"
             proof -
               have 2: "DN (H.dom (UP t)) = a"
                 using t a 1 H'_dom_char by auto
               also have "... = DN (UP a)"
                 using t a UP_DN.inv
                 by (metis (no_types, lifting) UP_DN.F.preserves_reflects_arr
                     comp_apply V.ide_implies_arr)
               finally have "DN (H.dom (UP t)) = DN (UP a)" by blast
               thus ?thesis
                 by (metis 1 2 H.arr_dom_iff_arr UP_DN.inv'
                     arr_coincidence comp_apply)
             qed
             show "H.cod (UP t) = UP b"
             proof -
               have 2: "DN (H.cod (UP t)) = b"
                 using t b 1 arr_coincidence H'_cod_char by auto
               also have "... = DN (UP b)"
                 using t b UP_DN.inv
                 by (metis (no_types, lifting) UP_DN.F.preserves_reflects_arr
                     comp_apply V.ide_implies_arr)
               finally have "DN (H.cod (UP t)) = DN (UP b)" by blast
               thus ?thesis
                 by (metis 1 2 H.arr_cod_iff_arr UP_DN.inv'
                     arr_coincidence comp_apply)
             qed
           qed
         qed
         moreover have "DN (UP t) = t"
           using t UP_DN.inv
           by (metis (no_types, lifting) H'.in_homE arr'_coincidence
               comp_apply mem_Collect_eq)
         ultimately show "t  DN ` H.hom (UP a) (UP b)"
           by (simp add: rev_image_eqI)
       qed
       show "DN ` H.hom (UP a) (UP b)  H'.hom a b"
       proof
         fix t'
         assume t': "t'  DN ` H.hom (UP a) (UP b)"
         obtain t where t: "t  H.hom (UP a) (UP b)  t' = DN t"
           using t' by blast
         have "DN t  H'.hom a b"
         proof
           show "H'.in_hom (DN t) a b"
           proof
             show "H'.arr (DN t)"
               using t H'_arr_char arr_coincidence by fastforce
             show "H'.dom (DN t) = a"
               using t H'_dom_char
               by (metis (no_types, lifting) Fun.comp_def H'.ide_char'
                   H'_ide_char H.ide_dom H.in_homE H_arr_char UP_DN.inv
                   UP_DN.inv' arr'_coincidence arr_char mem_Collect_eq)
             show "H'.cod (DN t) = b"
               using t H'_cod_char
               by (metis (no_types, lifting) Fun.comp_def H'.ide_char'
                   H'_ide_char H.ide_cod H.in_homE H_arr_char
                   UP_DN.inv UP_DN.inv' arr'_coincidence arr_char
                   mem_Collect_eq)
           qed
         qed
         thus "t'  H'.hom a b"
           using t by blast
       qed
     qed

     interpretation dom': simulation R' R' H'.dom
       using H'_dom_char simulation_comp simulation_dom
             UP_DN.F.simulation_axioms UP_DN.G.simulation_axioms
       by auto

     interpretation cod': simulation R' R' H'.cod
       using H'_cod_char simulation_comp simulation_cod
             UP_DN.F.simulation_axioms UP_DN.G.simulation_axioms
       by auto

     lemma R'_con_char:
     shows "R'.con t u  V.con (UP t) (UP u)"
       by (metis UP_DN.F.preserves_con UP_DN.F.preserves_reflects_arr
           UP_DN.G.preserves_con UP_DN.inv comp_apply
           residuation.con_implies_arr(1-2) V.residuation_axioms)

     sublocale R'R': fibered_product_rts R' R' R' H'.dom H'.cod ..

     sublocale H': simulation R'R'.resid R'
                     λt. if R'R'.arr t then fst t ⋆´ snd t else R'.null
     proof
       show "t. ¬ R'R'.arr t 
                      (if R'R'.arr t then fst t ⋆´ snd t else R'.null) = R'.null"
         by auto
       fix t u
       assume tu: "R'R'.con t u"
       show 1: "R'.con (if R'R'.arr t then fst t ⋆´ snd t else R'.null)
                       (if R'R'.arr u then fst u ⋆´ snd u else R'.null)"
       proof -
         have "UP (fst t ⋆´ snd t) = UP (fst t)  UP (snd t) 
               UP (fst u ⋆´ snd u) = UP (fst u)  UP (snd u)"
           using tu arr_coincidence null_coincidence UP_DN.inv' H.ext
           apply auto[1]
           by (metis (no_types, lifting) UP_DN.F.extensional
               UP_DN.G.preserves_reflects_arr UP_DN.inv'_simp)+
         moreover have "UP (fst t)  UP (snd t)  UP (fst u)  UP (snd u)"
         proof -
           have "RR.con (UP (fst t), UP (snd t)) (UP (fst u), UP (snd u))"
             by (metis H'.seqI H'_seq_char H.seqE R'R'.arr_char R'R'.con_char
                 R'R'.residuation_axioms R'_con_char RR.con_char arr'_coincidence
                 fst_conv residuation.con_implies_arr(1-2) snd_conv tu)
           thus ?thesis
             using H.preserves_con RR.con_implies_arr(1-2) by force
         qed
         ultimately show ?thesis
           using tu
           by (simp add: R'R'.con_implies_arr(1) R'R'.con_implies_arr(2))
       qed
       show "(if R'R'.arr (R'R'.resid t u)
              then fst (R'R'.resid t u) ⋆´ snd (R'R'.resid t u)
              else R'.null) =
             R' (if R'R'.arr t then fst t ⋆´ snd t else R'.null)
                (if R'R'.arr u then fst u ⋆´ snd u else R'.null)"
       proof -
         have "fst (R'R'.resid t u) ⋆´ snd (R'R'.resid t u) =
               R' (fst t ⋆´ snd t) (fst u ⋆´ snd u)"
         proof -
           have "UP (fst (R'R'.resid t u) ⋆´ snd (R'R'.resid t u)) =
                 UP (R' (fst t ⋆´ snd t) (fst u ⋆´ snd u))"
           proof -
             have "UP (fst (R'R'.resid t u) ⋆´ snd (R'R'.resid t u)) =
                   UP (R' (fst t) (fst u) ⋆´ R' (snd t) (snd u))"
               using tu R'R'.con_char R'R'.resid_def by auto
             also have "... = UP (R' (fst t) (fst u))  UP (R' (snd t) (snd u))"
               using tu
               by (metis H.ext UP_DN.inv' arr_coincidence comp_apply
                   null_coincidence)
             also have "... = resid (UP (fst t)) (UP (fst u)) 
                                resid (UP (snd t)) (UP (snd u))"
               using R'R'.con_char UP_DN.F.preserves_resid tu by presburger
             also have "... = (UP (fst t)  UP (snd t)) \\ (UP (fst u)  UP (snd u))"
               using tu 1 H.preserves_resid H.seqE R'.con_implies_arr(1-2)
                     R'.not_arr_null R'R'.con_char R'_con_char RR.arr_char
                     RR.arr_resid_iff_con RR.con_char RR.resid_def
                     UP_DN.G.extensional
               by (metis (no_types, lifting) H'.seqI H'_arr_char H'_seq_char
                   hpar_arr_resid resid_hcomp(2))
             also have "... = UP (fst t ⋆´ snd t) \\ UP (fst u ⋆´ snd u)"
             proof -
               have "UP (fst t ⋆´ snd t) = UP (fst t)  UP (snd t) 
                     UP (fst u ⋆´ snd u) = UP (fst u)  UP (snd u)"
                 using H'.seqI R'R'.arr_char R'R'.con_implies_arr(1-2) tu by auto
               thus ?thesis
                 using tu H.ext UP_DN.inv' arr_coincidence comp_apply
                       null_coincidence
                 by auto
             qed
             also have "... = UP (R' (fst t ⋆´ snd t) (fst u ⋆´ snd u))"
               using "1" R'R'.con_implies_arr(1) R'R'.con_implies_arr(2) tu by auto
             finally show ?thesis by blast
           qed
           thus ?thesis
             by (metis (no_types, lifting) H'.seqI R'R'.arr_char R'R'.arr_resid
                 UP_DN.F.preserves_reflects_arr UP_DN.inv_simp arr'_coincidence tu)
         qed
         thus ?thesis
           using tu 1 H.preserves_resid by auto
       qed
     qed

     proposition is_locally_small_rts_category:
     shows "locally_small_rts_category R' hcomp'"
     proof
       show "H'.null = R'.null"
         by (simp add: H'_null_char UP_DN.G.extensional)
       show "H'.arr = R'.arr"
         using H'_arr_char UP_DN.F.preserves_reflects_arr arr_coincidence by auto
       show "t. R'.src (H'.dom t) = H'.dom t"
         using R'_src_char H'_dom_char R'.arr_src_iff_arr UP_DN.G.extensional
               UP_DN.G.preserves_reflects_arr
         apply auto[1]
         by (metis (no_types, lifting) R'.not_arr_null UP_DN.inv'_simp src_dom)
       show "a b. small (H'.hom a b)"
         using H'_hom_char small_homs by simp
     qed

  end

subsection "Functoriality"

  locale rts_functor_of_enriched_functor =
    universe arr_type +
    RTS: rtscat arr_type +
    A: rts_enriched_category arr_type ObjA HomA IdA CompA +
    B: rts_enriched_category arr_type ObjB HomB IdB CompB +
    EF: rts_enriched_functor
          ObjA HomA IdA CompA ObjB HomB IdB CompB Fo Fa
  for ObjA :: "'a set"
  and HomA :: "'a  'a  'A rtscatx.arr"
  and IdA :: "'a  'A rtscatx.arr"
  and CompA :: "'a  'a  'a  'A rtscatx.arr"
  and ObjB :: "'b set"
  and HomB :: "'b  'b  'A rtscatx.arr"
  and IdB :: "'b  'A rtscatx.arr"
  and CompB :: "'b  'b  'b  'A rtscatx.arr"
  and Fo :: "'a  'b"
  and Fa :: "'a  'a  'A rtscatx.arr"
  begin

    interpretation A: rts_category_of_enriched_category
                        arr_type ObjA HomA IdA CompA
      ..
    interpretation B: rts_category_of_enriched_category
                        arr_type ObjB HomB IdB CompB
      ..

    definition F
    where "F t  if residuation.arr A.resid t
                  then B.MkArr (Fo (A.Dom t)) (Fo (A.Cod t))
                               (RTS.Map (Fa (A.Dom t) (A.Cod t)) (A.Trn t))
                  else ResiduatedTransitionSystem.partial_magma.null B.resid"

    lemma preserves_arr:
    assumes "A.H.arr f"
    shows "B.H.arr (F f)"
    proof -
      let ?a = "A.Dom f"
      let ?b = "A.Cod f"
      show 1: "B.H.arr (F f)"
      proof -
        have "B.arr (F f)"
          unfolding F_def
          using assms A.arr_char B.arr_MkArr A.arr_coincidence
            B.arr_coincidence
          apply (simp, intro B.arr_MkArr)
            apply blast
           apply blast
          using EF.is_local_simulation simulation.preserves_reflects_arr
          by metis
        thus ?thesis by auto
      qed
    qed

    sublocale rts_functor A.resid A.hcomp B.resid B.hcomp F
    proof
      show "f. ¬ A.H.arr f  F f = B.H.null"
        using F_def A.arr_coincidence B.null_coincidence by simp
      show 1: "f. A.H.arr f  B.H.arr (F f)"
        using preserves_arr by simp
      fix f
      assume f: "A.H.arr f"
      have 0: "A.arr (A.MkArr (A.Dom f) (A.Dom f)
                         (RTS.Map (IdA (A.Dom f)) RTS.One.the_arr))"
        using f A.arr_char A.arr_coincidence A.Id_in_hom RTS.Map_ide
        by (metis (no_types, lifting) A.H_dom_char A.dom.preserves_reflects_arr)
      have 1: "B.arr (B.MkArr (Fo (A.Dom f)) (Fo (A.Cod f))
                        (RTS.Map (Fa (A.Dom f) (A.Cod f)) (A.Trn f)))"
        using f 1 F_def B.H_dom_char B.arr_char B.null_char B.arr_coincidence
              B.null_coincidence
        by (intro B.arr_MkArr) auto
      have 2: "A.arr (A.MkArr (A.Cod f) (A.Cod f)
                        (RTS.Map (IdA (A.Cod f)) RTS.One.the_arr))"
        using f A.arr_char A.arr_coincidence A.H.ideD(1)
              A.Id_yields_horiz_ide
        by force
      show "B.H.dom (F f) = F (A.H.dom f)"
      proof (intro B.arr_eqI)
        show "B.H.dom (F f)  B.null"
          using f 1 F_def B.H_dom_char B.null_char by auto
        show "F (A.H.dom f)  B.null"
          using f 0 F_def A.H_dom_char B.null_char by auto
        show "B.Dom (B.H.dom (F f)) = B.Dom (F (A.H.dom f))"
          using f 0 1 F_def A.H_dom_char B.H_dom_char by simp
        show "B.Cod (B.H.dom (F f)) = B.Cod (F (A.H.dom f))"
          using f 0 1 F_def A.H_dom_char B.H_dom_char by simp
        show "B.Trn (B.H.dom (F f)) = B.Trn (F (A.H.dom f))"
        proof -
          have "B.Trn (F (A.H.dom f)) =
                RTS.Map (Fa (A.Dom f) (A.Dom f))
                  (RTS.Map (IdA (A.Dom f)) RTS.One.the_arr)"
            using f 0 F_def A.H_dom_char B.H_dom_char EF.preserves_Id
                  RTS.Map_comp
            by auto
          also have "... = RTS.Map (Fa (A.Dom f) (A.Dom f)  IdA (A.Dom f))
                             RTS.One.the_arr"
            using f RTS.Map_comp A.Id_in_hom
                  EF.preserves_Hom [of "A.Dom f" "A.Dom f"]
                  EF.preserves_Obj [of "A.Dom f"] comp_apply
            apply auto[1]
            using A.arr_char [of f] by fastforce
          also have "... = RTS.Map (IdB (Fo (A.Dom f))) RTS.One.the_arr"
            using f 0 1 EF.preserves_Id A.arr_char by simp
          also have "... = B.Trn (B.H.dom (F f))"
            using f 0 1 F_def by (simp add: B.H_dom_simp B.H_cod_simp)
          finally show ?thesis by simp
        qed
      qed
      show "B.H.cod (F f) = F (A.H.cod f)"
      proof (intro B.arr_eqI)
        show "B.H.cod (F f)  B.null"
          using f 1 F_def B.H_cod_char B.null_char by auto
        show "F (A.H.cod f)  B.null"
          using f 2 F_def A.H_cod_char B.null_char by auto
        show "B.Dom (B.H.cod (F f)) = B.Dom (F (A.H.cod f))"
          using f 2 F_def A.H_cod_char B.H_cod_char B.null_char
                B.cod.extensional B.H.cod (F f)  B.null
          by fastforce
        show "B.Cod (B.H.cod (F f)) = B.Cod (F (A.H.cod f))"
          using f 2 F_def A.H_cod_char B.H_cod_char B.null_char
                B.cod.extensional B.H.cod (F f)  B.null
          by fastforce
        show "B.Trn (B.H.cod (F f)) = B.Trn (F (A.H.cod f))"
        proof -
          have "B.Trn (F (A.H.cod f)) =
                RTS.Map (Fa (A.Cod f) (A.Cod f))
                  (RTS.Map (IdA (A.Cod f)) RTS.One.the_arr)"
            using f 2 F_def A.H_cod_char B.H_cod_char EF.preserves_Id
                  RTS.Map_comp
            by auto
          also have "... =
                     RTS.Map (Fa (A.Cod f) (A.Cod f)  IdA (A.Cod f))
                       RTS.One.the_arr"
            using f 0 1 2 A.Id_in_hom
                  EF.preserves_Hom [of "A.Cod f" "A.Cod f"]
                  EF.preserves_Obj [of "A.Cod f"] comp_apply RTS.Map_comp
            apply auto[1]
            using A.arr_char [of f] by fastforce
          also have "... = RTS.Map (IdB (Fo (A.Cod f))) RTS.One.the_arr"
            using f 0 1 EF.preserves_Id A.arr_char by simp
          also have "... = B.Trn (B.H.cod (F f))"
            using f 0 1 F_def by (auto simp add: B.H_dom_simp B.H_cod_simp)
          finally show ?thesis by simp
        qed
      qed
      next
      fix f g
      assume fg: "A.H.seq g f"
      show "F (A.hcomp g f) = B.hcomp (F g) (F f)"
      proof (intro B.arr_eqI)
        show "F (A.hcomp g f)  B.null"
          using fg F_def B.null_char by auto
        have 2: "B.Dom (F g) = B.Cod (F f)"
          using fg preserves_arr F_def A.H_seq_char by auto
        show 3: "B.hcomp (F g) (F f)  B.null"
          using fg 2 preserves_arr B.null_char B.arr_hcomp [of "F g" "F f"]
                A.arr_coincidence B.arr_coincidence A.H_seq_char
                B.V.not_arr_null
          by auto
        show "B.Dom (F (A.hcomp g f)) = B.Dom (B.hcomp (F g) (F f))"
          using fg F_def "3" A.H_seq_char B.H_composable_char by auto
        show "B.Cod (F (A.hcomp g f)) = B.Cod (B.hcomp (F g) (F f))"
          using fg F_def "3" A.H_seq_char B.H_composable_char by auto
        show "B.Trn (F (A.hcomp g f)) = B.Trn (B.hcomp (F g) (F f))"
        proof -
          have "B.Trn (F (A.hcomp g f)) =
                RTS.Map (Fa (A.Dom f) (A.Cod g))
                        (RTS.Map (CompA (A.Dom f) (A.Cod f) (A.Cod g))
                                 (RTS.Pack (HomA (A.Cod f) (A.Cod g))
                                           (HomA (A.Dom f) (A.Cod f))
                                           (A.Trn g, A.Trn f)))"
            using fg F_def A.H_seq_char by auto
          also have "... = (RTS.Map (Fa (A.Dom f) (A.Cod g)) 
                              RTS.Map (CompA (A.Dom f) (A.Cod f) (A.Cod g)))
                             (RTS.Pack
                                (HomA (A.Cod f) (A.Cod g))
                                (HomA (A.Dom f) (A.Cod f))
                                (A.Trn g, A.Trn f))"
            using fg A.H_seq_char A.Comp_in_hom EF.preserves_Hom
                  RTS.Map_comp
            by auto    
          also have "... = RTS.Map (Fa (A.Dom f) (A.Cod g) 
                                      CompA (A.Dom f) (A.Cod f) (A.Cod g))
                             (RTS.Pack (HomA (A.Cod f) (A.Cod g))
                                       (HomA (A.Dom f) (A.Cod f))
                                       (A.Trn g, A.Trn f))"
            using fg A.H_seq_char comp_apply A.Comp_in_hom EF.preserves_Hom
                  RTS.Map_comp
            apply auto[1]
            by (metis (no_types, lifting) A.arr_char RTS.seqI' comp_apply)
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)) 
                                (Fa (A.Cod f) (A.Cod g)  Fa (A.Dom f) (A.Cod f)))
                             (RTS.Pack
                                (HomA (A.Cod f) (A.Cod g))
                                (HomA (A.Dom f) (A.Cod f))
                                (A.Trn g, A.Trn f))"
            using fg A.H_seq_char A.arr_char EF.preserves_Comp by auto
          also have "... = (RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g))) 
                                RTS.Map
                                  (Fa (A.Cod f) (A.Cod g)  Fa (A.Dom f) (A.Cod f)))
                             (RTS.Pack
                                (HomA (A.Cod f) (A.Cod g))
                                (HomA (A.Dom f) (A.Cod f))
                                (A.Trn g, A.Trn f))"
          proof -
            have "RTS.seq
                    (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                    (Fa (A.Cod f) (A.Cod g)  Fa (A.Dom f) (A.Cod f))"
              using fg B.Comp_in_hom EF.preserves_Obj
              by (metis A.Comp_in_hom A.H.seqE A.H_arr_char EF.preserves_Comp
                  EF.preserves_Hom RTS.arrI RTS.seqI' RTS.tensor_agreement)
            thus ?thesis
              using RTS.Map_comp
                      [of "CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g))"
                          "Fa (A.Cod f) (A.Cod g)  Fa (A.Dom f) (A.Cod f)"]
              by argo
          qed
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                             (RTS.Map
                                (Fa (A.Cod f) (A.Cod g)  Fa (A.Dom f) (A.Cod f))
                                (RTS.Pack
                                   (HomA (A.Cod f) (A.Cod g))
                                   (HomA (A.Dom f) (A.Cod f))
                                   (A.Trn g, A.Trn f)))"
            by simp
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                             ((RTS.Pack
                                 (RTS.cod (Fa (A.Cod f) (A.Cod g)))
                                 (RTS.cod (Fa (A.Dom f) (A.Cod f))) 
                                 product_simulation.map
                                   (A.HOMEC (A.Cod f) (A.Cod g))
                                   (A.HOMEC (A.Dom f) (A.Cod f))
                                   (RTS.Map (Fa (A.Cod f) (A.Cod g)))
                                   (RTS.Map (Fa (A.Dom f) (A.Cod f))) 
                                   RTS.Unpack
                                     (RTS.dom (Fa (A.Cod f) (A.Cod g)))
                                     (RTS.dom (Fa (A.Dom f) (A.Cod f))))
                                (RTS.Pack
                                   (HomA (A.Cod f) (A.Cod g))
                                   (HomA (A.Dom f) (A.Cod f))
                                   (A.Trn g, A.Trn f)))"
             using fg A.H_seq_char EF.preserves_Hom RTS.Map_prod
             by (metis (no_types, lifting) A.arr_char RTS.in_homE)
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                             (RTS.Pack
                                (HomB (Fo (A.Cod f)) (Fo (A.Cod g)))
                                (HomB (Fo (A.Dom f)) (Fo (A.Cod f)))
                                (product_simulation.map
                                   (A.HOMEC (A.Cod f) (A.Cod g))
                                   (A.HOMEC (A.Dom f) (A.Cod f))
                                   (RTS.Map (Fa (A.Cod f) (A.Cod g)))
                                   (RTS.Map (Fa (A.Dom f) (A.Cod f)))
                                   (RTS.Unpack
                                      (HomA (A.Cod f) (A.Cod g))
                                      (HomA (A.Dom f) (A.Cod f))
                                      (RTS.Pack
                                         (HomA (A.Cod f) (A.Cod g))
                                         (HomA (A.Dom f) (A.Cod f))
                                         (A.Trn g, A.Trn f)))))"
          proof -
            have "RTS.dom (Fa (A.Dom f) (A.Cod f)) =
                  HomA (A.Dom f) (A.Cod f)"
              using fg A.H_seq_char A.arr_char
                    EF.preserves_Hom [of "A.Dom f" "A.Cod f"]
              by auto
            moreover have "RTS.cod (Fa (A.Dom f) (A.Cod f)) =
                           HomB (Fo (A.Dom f)) (Fo (A.Cod f))"
              using fg A.H_seq_char A.arr_char
                    EF.preserves_Hom [of "A.Dom f" "A.Cod f"]
              by auto
            ultimately show ?thesis
              using fg A.H_seq_char A.arr_char
                    EF.preserves_Hom [of "A.Cod f" "A.Cod g"]
                    EF.preserves_Hom [of "A.Dom f" "A.Cod f"]
              by auto
          qed
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                             (RTS.Pack
                                (HomB (Fo (A.Cod f)) (Fo (A.Cod g)))
                                (HomB (Fo (A.Dom f)) (Fo (A.Cod f)))
                                (product_simulation.map
                                   (A.HOMEC (A.Cod f) (A.Cod g))
                                   (A.HOMEC (A.Dom f) (A.Cod f))
                                   (RTS.Map (Fa (A.Cod f) (A.Cod g)))
                                   (RTS.Map (Fa (A.Dom f) (A.Cod f)))
                                   (A.Trn g, A.Trn f)))"
          proof -
            interpret HOM: extensional_rts A.HOMEC (A.Cod f) (A.Cod g)
              using fg A.H_seq_char A.arr_char A.ide_Hom
              by (metis (no_types, lifting) EF.preserves_Hom RTS.arrD(1)
                  RTS.in_homE)
            interpret HOM': extensional_rts A.HOMEC (A.Dom f) (A.Cod f)
              using fg A.H_seq_char A.arr_char A.ide_Hom
              by (metis (no_types, lifting) EF.preserves_Hom RTS.arrD(1)
                  RTS.in_homE)
            interpret HOMxHOM': product_rts
                                  A.HOMEC (A.Cod f) (A.Cod g)
                                  A.HOMEC (A.Dom f) (A.Cod f)
              ..
            show ?thesis
              using A.H_arr_char A.H_seq_char fg by force
          qed
          also have "... = RTS.Map
                             (CompB (Fo (A.Dom f)) (Fo (A.Cod f)) (Fo (A.Cod g)))
                             (RTS.Pack
                                (HomB (Fo (A.Cod f)) (Fo (A.Cod g)))
                                (HomB (Fo (A.Dom f)) (Fo (A.Cod f)))
                                (RTS.Map (Fa (A.Cod f) (A.Cod g)) (A.Trn g),
                                 RTS.Map (Fa (A.Dom f) (A.Cod f)) (A.Trn f)))"
          proof -
            interpret F: simulation
                           A.HOMEC (A.Cod f) (A.Cod g)
                           B.HOMEC (Fo (A.Cod f)) (Fo (A.Cod g))
                           RTS.Map (Fa (A.Cod f) (A.Cod g))
              using fg A.H_seq_char A.arr_char EF.preserves_Hom
              by (meson EF.is_local_simulation)
            interpret F': simulation
                            A.HOMEC (A.Dom f) (A.Cod f)
                            B.HOMEC (Fo (A.Dom f)) (Fo (A.Cod f))
                            RTS.Map (Fa (A.Dom f) (A.Cod f))
              using fg A.H_seq_char A.arr_char EF.preserves_Hom
              by (meson EF.is_local_simulation)
            interpret FxF': product_simulation
                              A.HOMEC (A.Cod f) (A.Cod g)
                              A.HOMEC (A.Dom f) (A.Cod f)
                              B.HOMEC (Fo (A.Cod f)) (Fo (A.Cod g))
                              B.HOMEC (Fo (A.Dom f)) (Fo (A.Cod f))
                              RTS.Map (Fa (A.Cod f) (A.Cod g))
                              RTS.Map (Fa (A.Dom f) (A.Cod f))
              ..
            show ?thesis
              by (metis FxF'.map_simp fg A.H_seq_char A.arr_char)
          qed
          also have "... = B.Trn (B.hcomp (F g) (F f))"
            using fg 3 F_def A.H_seq_char B.Trn_hcomp B.H_composable_char
            by force
          finally show ?thesis by blast
        qed
      qed
      next
      show "t. ¬ A.arr t  F t = B.null"
        unfolding F_def by simp
      show "t u. A.V.con t u  B.V.con (F t) (F u)"
        unfolding F_def
        using A.V.con_implies_arr B.con_char EF.preserves_Obj
              EF.preserves_Hom A.arr_char A.con_char
        apply auto[1]
        apply (intro B.ConI conjI)
                  apply auto[11] (* 3 goals remain *)
        by (metis A.ConE EF.is_local_simulation
            simulation.preserves_reflects_arr simulation.preserves_con)+
      show "t u. A.V.con t u  F (A.resid t u) = B.resid (F t) (F u)"
        unfolding F_def
        using A.V.con_implies_arr B.con_char EF.preserves_Obj EF.preserves_Hom
              A.arr_char B.null_char A.con_implies_Par
        apply auto[1]
           apply (metis (mono_tags, lifting) A.ConE A.resid_ne_Null_imp_Con
             EF.is_local_simulation simulation.preserves_resid)
          apply (metis (mono_tags, lifting) F_def
            u t. A.V.con t u  B.V.con (F t) (F u))
         apply (meson A.V.arr_resid)
        using A.V.arr_resid by force
    qed

    lemma is_rts_functor:
    shows "rts_functor A.resid A.hcomp B.resid B.hcomp F"
      ..

  end

section "RTS-Categories induce RTS-Enriched Categories"

  text‹
    Here we show that an RTS-category induces a corresponding RTS-enriched category.
    In order to perform this construction, we will need to have a universe to use
    as the arrow type of the base category RTS.  In order to avoid introducing a fixed
    universe, at this point we assume one is given as a parameter.
  ›

  locale enriched_category_of_rts_category =
    universe arr_type +
    locally_small_rts_category resid hcomp
  for arr_type :: "'A itself"
  and resid :: "'A resid"  (infix "\\" 70)
  and hcomp :: "'A comp"   (infixr "" 53)
  begin

    sublocale RTS: rtscat arr_type ..

    (* TODO: The composition in RTS is more important here than composition of transitions. *)
    no_notation V.comp       (infixr "" 55)
    no_notation H.in_hom     ("«_ : _  _»")
    no_notation RTS.prod     (infixr "" 51)

    (* TODO: Why isn't other notation inherited from rtscat? *)
    notation RTS.in_hom        ("«_ : _  _»")
    notation RTS.CMC.tensor    (infixr "" 51)
    notation RTS.CMC.unity     ("𝟭")
    notation RTS.CMC.assoc     ("𝖺[_, _, _]")
    notation RTS.CMC.lunit     ("𝗅[_]")
    notation RTS.CMC.runit     ("𝗋[_]")

    abbreviation Obj
    where "Obj  Collect H.ide"

    definition Hom
    where "Hom a b 
           if a  Obj  b  Obj then RTS.mkide (HOM a b) else RTS.null"

    definition Id
    where "Id a 
            RTS.mkarr RTS.One.resid (RTS.Rts (Hom a a))
              (λt. if RTS.One.arr t
                   then a
                   else ResiduatedTransitionSystem.partial_magma.null (HOM a a))"

    definition Comp
    where "Comp a b c 
           RTS.mkarr
             (RTS.Rts (Hom b c  Hom a b))
             (RTS.Rts (Hom a c))
             (λt. (λx. fst x  snd x) (RTS.Unpack (Hom b c) (Hom a b) t))"

    lemma ide_Hom [intro, simp]:
    assumes "a  Obj" and "b  Obj"
    shows "RTS.ide (Hom a b)"
    proof -
      interpret Hom: sub_rts resid λt. H.in_hom t a b
        using assms sub_rts_HOM by blast
      interpret Hom: extensional_rts Hom.resid
        using Hom.preserves_extensional_rts V.extensional_rts_axioms by blast
      interpret Hom: small_rts Hom.resid
        using assms Hom.arr_char small_homs
        apply unfold_locales
        by (metis Collect_cong mem_Collect_eq)
      show "RTS.ide (Hom a b)"
        unfolding Hom_def
        using assms RTS.ide_mkide Hom.rts_axioms Hom.small_rts_axioms
              Hom.extensional_rts_axioms
        by auto
    qed

    (*
     * TODO: See if this can be simplified.  I have two interpretations that amount to
     * the same thing:  rts (RTS.Rts (Hom a b)) and sub_rts resid ‹λt. H.in_hom t a b›.
     * The problem is, the sub_rts facts are not accessible from the other version.
     *)

    lemma
    assumes "a  Obj" and "b  Obj"
    shows HOM_null_char: "ResiduatedTransitionSystem.partial_magma.null
                            (RTS.Rts (Hom a b)) =
                          null"
    and HOM_arr_char:
          "residuation.arr (RTS.Rts (Hom a b)) t  H.in_hom t a b"
    proof -
      interpret Hom: sub_rts resid λt. H.in_hom t a b
        using assms sub_rts_HOM by blast
      show "ResiduatedTransitionSystem.partial_magma.null
              (RTS.Rts (Hom a b)) =
            null"
        using assms Hom_def RTS.bij_mkide(3) Hom.null_char by auto
      show "residuation.arr (RTS.Rts (Hom a b)) t  H.in_hom t a b"
        unfolding Hom_def
        using assms arr_coincidence Hom.arr_char RTS.bij_mkide(3) by simp
    qed

    lemma Id_in_hom [intro]:
    assumes "a  Obj"
    shows "«Id a : 𝟭  Hom a a»"
    proof -
      interpret Hom: sub_rts resid λt. H.in_hom t a a
        using assms sub_rts_HOM by blast
      interpret Hom: extensional_rts Hom.resid
        using Hom.preserves_extensional_rts V.extensional_rts_axioms by blast
      interpret Hom: small_rts Hom.resid
        using assms Hom.arr_char small_homs
        apply unfold_locales
        by (metis Collect_cong mem_Collect_eq)
      interpret I: simulation RTS.One.resid Hom.resid
                     λt. if RTS.One.arr t then a else Hom.null
      proof
        show "t. ¬ RTS.One.arr t 
                      (if RTS.One.arr t then a else Hom.null) = Hom.null"
          by simp
        show 1: "t u. RTS.One.con t u 
                         Hom.con (if RTS.One.arr t then a else Hom.null)
                                 (if RTS.One.arr u then a else Hom.null)"
          using H.ide_in_hom Hom.arr_char RTS.One.con_implies_arr(1-2) assms
          by auto
        show "t u. RTS.One.con t u 
                       (if RTS.One.arr (t \\1 u) then a else Hom.null) =
                       Hom.resid
                         (if RTS.One.arr t then a else Hom.null)
                         (if RTS.One.arr u then a else Hom.null)"
          using H.ide_in_hom Hom.resid_def RTS.One.con_implies_arr(1-2)
                V.resid_arr_ide assms obj_implies_sta
          by force
      qed
      show "«Id a : 𝟭  Hom a a»"
      proof
        show 1: "RTS.arr (Id a)"
        proof (unfold Id_def, intro RTS.arr_mkarr)
          show "extensional_rts RTS.One.resid  small_rts RTS.One.resid"
            using RTS.One.is_extensional_rts RTS.One.small_rts_axioms by auto
          show "extensional_rts (RTS.Rts (Hom a a)) 
                  small_rts (RTS.Rts (Hom a a))"
            using assms by auto
          show "simulation (\\1) (RTS.Rts (Hom a a))
                  (λt. if RTS.One.arr t then a else Hom.null)"
            unfolding Hom_def
            using assms RTS.bij_mkide(3) I.simulation_axioms by auto
        qed
        show "RTS.dom (Id a) = 𝟭"
          using 1 Id_def by (simp add: RTS.unity_agreement)
        show "RTS.cod (Id a) = Hom a a"
          using 1 Id_def assms by force
      qed
    qed

    lemma Id_simps [simp]:
    assumes "a  Obj"
    shows "RTS.arr (Id a)"
    and "RTS.dom (Id a) = 𝟭"
    and "RTS.cod (Id a) = Hom a a"
      using assms Id_in_hom RTS.unity_agreement by auto

    lemma Comp_in_hom [intro, simp]:
    assumes "a  Obj" and "b  Obj" and "c  Obj"
    shows "«Comp a b c : Hom b c  Hom a b  Hom a c»"
    proof (unfold Comp_def, intro RTS.in_homI)
      show 0: "RTS.arr (RTS.mkarr
                        (RTS.Rts (Hom b c  Hom a b))
                        (RTS.Rts (Hom a c))
                        (λt. fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                             snd (RTS.Unpack (Hom b c) (Hom a b) t)))"
      proof (intro RTS.arr_mkarr)
        show "extensional_rts (RTS.Rts (Hom b c  Hom a b)) 
                small_rts (RTS.Rts (Hom b c  Hom a b))"
          using assms by auto
        show "extensional_rts (RTS.Rts (Hom a c)) 
                small_rts (RTS.Rts (Hom a c))"
          using assms by auto
        show "simulation (RTS.Rts (Hom b c  Hom a b)) (RTS.Rts (Hom a c))
                (λt. fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                     snd (RTS.Unpack (Hom b c) (Hom a b) t))"
        proof -
          interpret ac: extensional_rts RTS.Rts (Hom a c)
            using assms by auto
          interpret bc: extensional_rts RTS.Rts (Hom b c)
            using assms by simp
          interpret ab: extensional_rts RTS.Rts (Hom a b)
            using assms by simp
          interpret HOM_ab: sub_rts resid λt. H.in_hom t a b
            using assms sub_rts_HOM by blast
          interpret HOM_bc: sub_rts resid λt. H.in_hom t b c
            using assms sub_rts_HOM by blast
          interpret HOM_ac: sub_rts resid λt. H.in_hom t a c
            using assms sub_rts_HOM by blast
          interpret bcxab: extensional_rts RTS.Rts (Hom b c  Hom a b)
            using assms by auto
          interpret bcXab: product_rts RTS.Rts (Hom b c) RTS.Rts (Hom a b)
            ..
          interpret U: simulation
                         RTS.Rts (Hom b c  Hom a b) bcXab.resid
                         RTS.Unpack (Hom b c) (Hom a b)
            using assms RTS.simulation_Unpack by simp
          show ?thesis
          proof
            show "t. ¬ bcxab.arr t 
                           fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                             snd (RTS.Unpack (Hom b c) (Hom a b) t) =
                           ac.null"
              using assms H.null_is_zero(2) HOM_null_char U.simulation_axioms
                    simulation.extensional
              by fastforce
            fix t u
            assume tu: "bcxab.con t u"
            have 1: "HOM_ab.con = ab.con  HOM_bc.con = bc.con 
                       HOM_ac.con = ac.con"
              using assms Hom_def arr_coincidence null_coincidence
                    RTS.bij_mkide(3)
              by auto
            have 2: "H.in_hom (fst (RTS.Unpack (Hom b c) (Hom a b) t)) b c 
                     H.in_hom (snd (RTS.Unpack (Hom b c) (Hom a b) t)) a b 
                     H.in_hom (fst (RTS.Unpack (Hom b c) (Hom a b) u)) b c 
                     H.in_hom (snd (RTS.Unpack (Hom b c) (Hom a b) u)) a b"
              using assms tu bcxab.con_implies_arr Hom_def
                    U.preserves_reflects_arr bcXab.arr_char HOM_ab.arr_char
                    HOM_bc.arr_char RTS.bij_mkide(3)
              by auto
            hence 3: "H.in_hom (fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                                snd (RTS.Unpack (Hom b c) (Hom a b) t))
                        a c 
                      H.in_hom (fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                                snd (RTS.Unpack (Hom b c) (Hom a b) u))
                        a c"
              using assms arr_coincidence by blast
            have 4: "V.con (fst (RTS.Unpack (Hom b c) (Hom a b) t))
                        (fst (RTS.Unpack (Hom b c) (Hom a b) u)) 
                      V.con (snd (RTS.Unpack (Hom b c) (Hom a b) t))
                        (snd (RTS.Unpack (Hom b c) (Hom a b) u))"
              using tu 1 2 3 bcXab.con_char HOM_bc.con_char HOM_ab.con_char
                    U.preserves_con
              by auto
            hence 5: "VV.con
                        (RTS.Unpack (Hom b c) (Hom a b) t)
                        (RTS.Unpack (Hom b c) (Hom a b) u)"
              using 2 3 bcXab.con_char VV.con_char Hom_def arr_coincidence
                    null_coincidence
              by fast
            hence 6: "fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                        snd (RTS.Unpack (Hom b c) (Hom a b) t) 
                      fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                        snd (RTS.Unpack (Hom b c) (Hom a b) u)"
              using H.preserves_con VV.con_implies_arr by auto
            thus "ac.con
                    (fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) t))
                    (fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) u))"
              using 1 3 HOM_ac.con_char by simp
            show "fst (RTS.Unpack (Hom b c) (Hom a b)
                         (RTS.Rts (Hom b c  Hom a b) t u)) 
                    snd (RTS.Unpack (Hom b c) (Hom a b)
                           (RTS.Rts (Hom b c  Hom a b) t u)) =
                  RTS.Rts (Hom a c)
                    (fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) t))
                    (fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) u))"
            proof -
              have "RTS.Rts (Hom a c)
                      (fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                         snd (RTS.Unpack (Hom b c) (Hom a b) t))
                      (fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                         snd (RTS.Unpack (Hom b c) (Hom a b) u)) =
                    (fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) t)) \\
                    (fst (RTS.Unpack (Hom b c) (Hom a b) u) 
                       snd (RTS.Unpack (Hom b c) (Hom a b) u))"
                using assms 3 6 Hom_def HOM_ac.resid_def RTS.bij_mkide(3)
                by simp
              also have "... = fst (VV.resid
                                      (RTS.Unpack (Hom b c) (Hom a b) t)
                                      (RTS.Unpack (Hom b c) (Hom a b) u)) 
                                 snd (VV.resid
                                        (RTS.Unpack (Hom b c) (Hom a b) t)
                                        (RTS.Unpack (Hom b c) (Hom a b) u))"
                using 5 VV.con_implies_arr H.preserves_resid by simp
              also have "... = fst (bcXab.resid
                                     (RTS.Unpack (Hom b c) (Hom a b) t)
                                     (RTS.Unpack (Hom b c) (Hom a b) u)) 
                                 snd (bcXab.resid
                                        (RTS.Unpack (Hom b c) (Hom a b) t)
                                        (RTS.Unpack (Hom b c) (Hom a b) u))"
              proof -
                have "RTS.Rts (Hom b c)
                        (fst (RTS.Unpack (Hom b c) (Hom a b) t))
                        (fst (RTS.Unpack (Hom b c) (Hom a b) u)) =
                      fst (RTS.Unpack (Hom b c) (Hom a b) t) \\
                        fst (RTS.Unpack (Hom b c) (Hom a b) u)"
                  using 2 Hom_def RTS.bij_mkide(3)
                        HOM_bc.resid_def
                          [of "fst (RTS.Unpack (Hom b c) (Hom a b) t)"
                              "fst (RTS.Unpack (Hom b c) (Hom a b) u)"]
                  apply auto[1]
                  by auto
                moreover have "RTS.Rts (Hom a b)
                                 (snd (RTS.Unpack (Hom b c) (Hom a b) t))
                                 (snd (RTS.Unpack (Hom b c) (Hom a b) u)) =
                               snd (RTS.Unpack (Hom b c) (Hom a b) t) \\
                                 snd (RTS.Unpack (Hom b c) (Hom a b) u)"
                  using 2 Hom_def RTS.bij_mkide(3)
                        HOM_ab.resid_def
                          [of "snd (RTS.Unpack (Hom b c) (Hom a b) t)"
                              "snd (RTS.Unpack (Hom b c) (Hom a b) u)"]
                  apply auto[1]
                  by auto
                ultimately show ?thesis
                  using tu 2 4 bcXab.resid_def bcXab.con_char VV.resid_def
                        U.preserves_con
                  apply auto[1]
                  by fastforce+
              qed
              also have "... = fst (RTS.Unpack (Hom b c) (Hom a b)
                                      (RTS.Rts (Hom b c  Hom a b) t u)) 
                                 snd (RTS.Unpack (Hom b c) (Hom a b)
                                        (RTS.Rts (Hom b c  Hom a b) t u))"
                using tu U.preserves_resid by simp
              finally show ?thesis by simp
            qed
          qed
        qed
      qed
      show "RTS.dom
              (RTS.mkarr (RTS.Rts (Hom b c  Hom a b)) (RTS.Rts (Hom a c))
                         (λt. fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                                snd (RTS.Unpack (Hom b c) (Hom a b) t))) =
            Hom b c  Hom a b"
        using assms 0 by auto
      show "RTS.cod
              (RTS.mkarr (RTS.Rts (Hom b c  Hom a b)) (RTS.Rts (Hom a c))
                         (λt. fst (RTS.Unpack (Hom b c) (Hom a b) t) 
                                snd (RTS.Unpack (Hom b c) (Hom a b) t))) =
            Hom a c"
        using assms 0 by auto
    qed

    lemma Comp_simps [simp]:
    assumes "a  Obj" and "b  Obj" and "c  Obj"
    shows "RTS.arr (Comp a b c)"
    and "RTS.dom (Comp a b c) = Hom b c  Hom a b"
    and "RTS.cod (Comp a b c) = Hom a c"
      using assms Comp_in_hom RTS.in_homE by auto

    lemma Map_Comp_Pack:
    assumes "a  Obj" and "b  Obj" and "c  Obj"
    and "residuation.arr
            (product_rts.resid (RTS.Rts (Hom b c)) (RTS.Rts (Hom a b))) x"
    shows "RTS.Map (Comp a b c) (RTS.Pack (Hom b c) (Hom a b) x) =
           fst x  snd x"
      using assms Comp_def RTS.bij_mkarr(3) by simp

    sublocale rts_enriched_category arr_type Obj Hom Id Comp
    proof
      show "a b. a  Obj; b  Obj  RTS.ide (Hom a b)"
        by blast
      show "a. a  Obj  «Id a : 𝟭  Hom a a»"
        using Id_in_hom RTS.unity_agreement by auto
      show "a b c. a  Obj; b  Obj; c  Obj 
                       «Comp a b c : Hom b c  Hom a b  Hom a c»"
        using Comp_in_hom by auto

      fix a b
      assume a: "a  Obj" and b: "b  Obj"
      interpret ab: extensional_rts RTS.Rts (Hom a b)
        using a b by simp
      interpret aa: extensional_rts RTS.Rts (Hom a a)
        using a by simp
      interpret bb: extensional_rts RTS.Rts (Hom b b)
        using b by simp
      interpret abXaa: product_rts RTS.Rts (Hom a b) RTS.Rts (Hom a a) ..
      interpret bbXab: product_rts RTS.Rts (Hom b b) RTS.Rts (Hom a b) ..
      interpret ab: simulation RTS.Rts (Hom a b) RTS.Rts (Hom a b)
                      RTS.Map (Hom a b)
        using a b ide_Hom RTS.arrD
        by (metis (no_types, lifting) RTS.ide_char)
      interpret I: simulation RTS.One.resid RTS.Rts (Hom a a)
                     RTS.Map (Id a)
        using a ide_Hom Id_in_hom RTS.ide_char
        by (metis (no_types, lifting) RTS.Rts_one RTS.arrD(3) RTS.in_homE
            RTS.unity_agreement)
      interpret Ib: simulation RTS.One.resid RTS.Rts (Hom b b)
                      RTS.Map (Id b)
        using b ide_Hom Id_in_hom RTS.ide_char
        by (metis (no_types, lifting) RTS.Rts_one RTS.arrD(3) RTS.in_homE
            RTS.unity_agreement)
      interpret abXI: product_simulation
                        RTS.Rts (Hom a b) RTS.One.resid
                        RTS.Rts (Hom a b) RTS.Rts(Hom a a)
                        RTS.Map (Hom a b) RTS.Map (Id a)
        ..
      interpret IXab: product_simulation
                        RTS.One.resid RTS.Rts (Hom a b)
                        RTS.Rts (Hom b b) RTS.Rts (Hom a b)
                        RTS.Map (Id b) RTS.Map (Hom a b)
        ..
      interpret abxone: extensional_rts RTS.Rts (Hom a b  𝟭)
        using a b by auto
      interpret onexab: extensional_rts RTS.Rts (𝟭  Hom a b)
        using a b by auto
      interpret PU_abXI: inverse_simulations
                           RTS.Rts (Hom a b  𝟭) abXI.A1xA0.resid
                           RTS.Pack (Hom a b) 𝟭 RTS.Unpack (Hom a b) 𝟭
        using a b RTS.ide_one
              RTS.inverse_simulations_Pack_Unpack [of "Hom a b" 𝟭]
        by simp
      interpret PU_IXab: inverse_simulations
                           RTS.Rts (𝟭  Hom a b) IXab.A1xA0.resid
                           RTS.Pack 𝟭 (Hom a b) RTS.Unpack 𝟭 (Hom a b)
        using a b RTS.ide_one
              RTS.inverse_simulations_Pack_Unpack [of 𝟭 "Hom a b"]
        by simp
      interpret PU_abXaa: inverse_simulations
                            RTS.Rts (Hom a b  Hom a a) abXaa.resid
                            RTS.Pack (Hom a b) (Hom a a)
                            RTS.Unpack (Hom a b) (Hom a a)
        using a b RTS.ide_one
              RTS.inverse_simulations_Pack_Unpack [of "Hom a b" "Hom a a"]
        by simp
      interpret PU_bbXab: inverse_simulations
                            RTS.Rts (Hom b b  Hom a b) bbXab.resid
                            RTS.Pack (Hom b b) (Hom a b)
                            RTS.Unpack (Hom b b) (Hom a b)
        using a b RTS.ide_one
              RTS.inverse_simulations_Pack_Unpack [of "Hom b b" "Hom a b"]
        by simp

      show "Comp a a b  (Hom a b  Id a) = 𝗋[Hom a b]"
      proof (intro RTS.arr_eqI)
        show 1: "RTS.par (Comp a a b  (Hom a b  Id a)) 𝗋[Hom a b]"
          using a b Id_in_hom by fastforce+
        show "RTS.Map (Comp a a b  (Hom a b  Id a)) = RTS.Map 𝗋[Hom a b]"
        proof -
          have "RTS.Map (Comp a a b  (Hom a b  Id a)) =
                RTS.Map (Comp a a b)  RTS.Map (Hom a b  Id a)"
            using a b 1 Comp_in_hom Id_in_hom RTS.Map_comp by blast
          also have "... = (λt. fst ((RTS.Unpack (Hom a b) (Hom a a) 
                                        RTS.Pack (Hom a b) (Hom a a) 
                                           abXI.map 
                                             RTS.Unpack (Hom a b) 𝟭) t)
                                
                                snd ((RTS.Unpack (Hom a b) (Hom a a) 
                                        RTS.Pack (Hom a b) (Hom a a) 
                                          abXI.map 
                                            RTS.Unpack (Hom a b) 𝟭) t))"
            using a b ide_Hom Id_in_hom Comp_in_hom Comp_def RTS.Map_prod
                  RTS.Map_mkarr RTS.tensor_agreement RTS.bij_mkarr(3)
                  RTS.unity_agreement
            by auto
          also have "... = (λt. fst ((I abXaa.resid  abXI.map 
                                        RTS.Unpack (Hom a b) 𝟭) t) 
                                  snd ((I abXaa.resid  abXI.map 
                                          RTS.Unpack (Hom a b) 𝟭) t))"
            using PU_abXaa.inv by auto
          also have "... = RTS.Map 𝗋[Hom a b]"
          proof
            fix t
            show "fst ((I abXaa.resid  abXI.map 
                          RTS.Unpack (Hom a b) 𝟭) t) 
                    snd ((I abXaa.resid  abXI.map 
                            RTS.Unpack (Hom a b) 𝟭) t) =
                  RTS.Map 𝗋[Hom a b] t"
            proof (cases "abxone.arr t")
              show "¬ abxone.arr t  ?thesis"
              proof -
                assume t: "¬ abxone.arr t"
                have "fst ((I abXaa.resid  abXI.map 
                              RTS.Unpack (Hom a b) 𝟭) t) 
                      snd ((I abXaa.resid  abXI.map 
                              RTS.Unpack (Hom a b) 𝟭) t) =
                      null"
                  using a b t 1 PU_abXI.G.extensional abXI.extensional
                        abXI.A1xA0.P1.extensional H.null_is_zero(2)
                        HOM_null_char null_coincidence
                  by simp
                also have "... = RTS.Map 𝗋[Hom a b] t"
                proof -
                  interpret R: simulation RTS.Rts (Hom a b  𝟭)
                    RTS.Rts (Hom a b) RTS.Map 𝗋[Hom a b]
                    using a b 1 ide_Hom RTS.arrD(3)
                    by (metis (no_types, lifting) RTS.CMC.cod_runit
                        RTS.CMC.dom_runit)
                  show ?thesis
                    using a b t R.extensional HOM_null_char by simp
                qed
                finally show ?thesis by blast
              qed
              assume t: "abxone.arr t"
              have "(I abXaa.resid  abXI.map  RTS.Unpack (Hom a b) 𝟭) t =
                    (RTS.Map 𝗋[Hom a b] t, a)"
              proof -
                have "(I abXaa.resid  abXI.map  RTS.Unpack (Hom a b) 𝟭) t =
                      I abXaa.resid (abXI.map (RTS.Unpack (Hom a b) 𝟭 t))"
                  by auto
                also have "... = abXI.map (RTS.Unpack (Hom a b) 𝟭 t)"
                  using a b t abXI.preserves_reflects_arr
                        PU_abXI.G.preserves_reflects_arr
                  by simp
                also have "... = (fst (RTS.Unpack (Hom a b) 𝟭 t),
                                  RTS.Map (Id a)
                                    (snd (RTS.Unpack (Hom a b) 𝟭 t)))"
                  using a b t PU_abXI.G.preserves_reflects_arr
                        RTS.Map_ide
                        abXI.map_simp [of "fst (RTS.Unpack (Hom a b) 𝟭 t)"
                                          "snd (RTS.Unpack (Hom a b) 𝟭 t)"]
                  by auto
                also have "... = (fst (RTS.Unpack (Hom a b) 𝟭 t), a)"
                  unfolding Id_def
                  using a b t PU_abXI.G.preserves_reflects_arr
                        Id_def RTS.bij_mkarr(3) RTS.ide_one
                        RTS.One.is_extensional_rts RTS.One.small_rts_axioms
                  by auto
                also have "... = (RTS.Map 𝗋[Hom a b] t, a)"
                  using a b t RTS.runit_agreement RTS.Map_runit
                        abXI.A1xA0.P1_def RTS.unity_agreement
                        PU_abXI.G.preserves_reflects_arr
                  by auto
                finally show ?thesis by blast
              qed
              moreover have "H.in_hom (RTS.Map 𝗋[Hom a b] t) a b"
                using a b t RTS.Map_runit PU_abXI.G.preserves_reflects_arr
                      HOM_arr_char
                        [of a b "(abXI.A1xA0.P1  RTS.Unpack (Hom a b) 𝟭) t"]
                      RTS.runit_agreement RTS.unity_agreement
                by auto
              ultimately show ?thesis
                using a b H.comp_arr_dom by auto
            qed
          qed
          finally show ?thesis by blast
        qed
      qed

      show "Comp a b b  (Id b  Hom a b) = 𝗅[Hom a b]"
      proof (intro RTS.arr_eqI)
        show 1: "RTS.par (Comp a b b  (Id b  Hom a b)) 𝗅[Hom a b]"
          using a b Id_in_hom [of b] by auto
        show "RTS.Map (Comp a b b  (Id b  Hom a b)) = RTS.Map 𝗅[Hom a b]"
        proof -
          have "RTS.Map (Comp a b b  (Id b  Hom a b)) =
                RTS.Map (Comp a b b)  RTS.Map (Id b  Hom a b)"
            using a b 1 Comp_in_hom Id_in_hom RTS.Map_comp by blast
          also have "... = (λt. fst (RTS.Unpack (Hom b b) (Hom a b) t) 
                                  snd (RTS.Unpack (Hom b b) (Hom a b) t)) 
                             (RTS.Pack (Hom b b) (Hom a b) 
                                IXab.map 
                                  RTS.Unpack 𝟭 (Hom a b))"
            using a b ide_Hom Id_in_hom Comp_in_hom [of a b b]
                  Comp_def RTS.Map_prod RTS.Map_mkarr RTS.tensor_agreement
                  RTS.unity_agreement
            by auto
          also have "... = (λt. fst ((RTS.Unpack (Hom b b) (Hom a b) 
                                        RTS.Pack (Hom b b) (Hom a b) 
                                          IXab.map 
                                            RTS.Unpack 𝟭 (Hom a b)) t)
                                
                                snd ((RTS.Unpack (Hom b b) (Hom a b) 
                                        RTS.Pack (Hom b b) (Hom a b) 
                                          IXab.map 
                                            RTS.Unpack 𝟭 (Hom a b)) t))"
            by auto
          also have "... = (λt. fst ((I bbXab.resid  IXab.map 
                                        RTS.Unpack 𝟭 (Hom a b)) t) 
                                  snd ((I bbXab.resid  IXab.map 
                                          RTS.Unpack 𝟭 (Hom a b)) t))"
            using PU_bbXab.inv by auto
          also have "... = RTS.Map 𝗅[Hom a b]"
          proof
            fix t
            show "fst ((I bbXab.resid  IXab.map 
                          RTS.Unpack 𝟭 (Hom a b)) t) 
                    snd ((I bbXab.resid  IXab.map 
                            RTS.Unpack 𝟭 (Hom a b)) t) =
                  RTS.Map 𝗅[Hom a b] t"
            proof (cases "onexab.arr t")
              show "¬ onexab.arr t  ?thesis"
              proof -
                assume t: "¬ onexab.arr t"
                have "fst ((I bbXab.resid  IXab.map  RTS.Unpack 𝟭 (Hom a b)) t) 
                      snd ((I bbXab.resid  IXab.map  RTS.Unpack 𝟭 (Hom a b)) t) =
                      null"
                  using a b t 1 PU_IXab.G.extensional IXab.extensional
                        IXab.A1xA0.P0.extensional HOM_null_char
                  apply auto[1]
                  by (metis H.null_is_zero(2) null_coincidence)+
                also have "... = RTS.Map 𝗅[Hom a b] t"
                proof -
                  interpret L: simulation
                                 RTS.Rts (𝟭  Hom a b) RTS.Rts (Hom a b)
                                 RTS.Map 𝗅[Hom a b]
                    using a b t 1 RTS.arrD(3) [of "𝗅[Hom a b]"] by force
                  show ?thesis
                    using t L.extensional HOM_null_char a b by force
                qed
                finally show ?thesis by blast
              qed
              assume t: "onexab.arr t"
              have "(I bbXab.resid  IXab.map  RTS.Unpack 𝟭 (Hom a b)) t =
                    (b, RTS.Map 𝗅[Hom a b] t)"
              proof -
                have "(I bbXab.resid  IXab.map  RTS.Unpack 𝟭 (Hom a b)) t =
                      I bbXab.resid (IXab.map (RTS.Unpack 𝟭 (Hom a b) t))"
                  by auto
                also have "... = IXab.map (RTS.Unpack 𝟭 (Hom a b) t)"
                  using a b t IXab.preserves_reflects_arr PU_IXab.G.preserves_reflects_arr
                  by simp
                also have "... = (RTS.Map (Id b) (fst (RTS.Unpack 𝟭 (Hom a b) t)),
                                  snd (RTS.Unpack 𝟭 (Hom a b) t))"
                  using a b t PU_IXab.G.preserves_reflects_arr RTS.Map_ide
                        IXab.map_simp
                          [of "fst (RTS.Unpack 𝟭 (Hom a b) t)"
                              "snd (RTS.Unpack 𝟭 (Hom a b) t)"]
                  by auto
                also have "... = (b, snd (RTS.Unpack 𝟭 (Hom a b) t))"
                  unfolding Id_def
                  using a b t PU_IXab.G.preserves_reflects_arr Id_def
                        RTS.One.is_extensional_rts
                        RTS.One.small_rts_axioms RTS.bij_mkarr(3)
                  by auto
                also have "... = (b, RTS.Map 𝗅[Hom a b] t)"
                  using a b t RTS.lunit_agreement RTS.Map_lunit
                        IXab.A1xA0.P0_def RTS.unity_agreement
                        PU_IXab.G.preserves_reflects_arr
                  by auto
                finally show ?thesis by blast
              qed
              moreover have "H.in_hom (RTS.Map 𝗅[Hom a b] t) a b"
                using a b t RTS.Map_lunit
                      RTS.lunit_agreement RTS.unity_agreement
                      PU_IXab.G.preserves_reflects_arr
                      HOM_arr_char
                        [of a b "(IXab.A1xA0.P0  RTS.Unpack 𝟭 (Hom a b)) t"]
                by auto
              ultimately show ?thesis
                using a b H.comp_cod_arr by auto
            qed
          qed
          finally show ?thesis by blast
        qed
      qed
      next
      show "a b c d. a  Obj; b  Obj; c  Obj; d  Obj
                          Comp a b d  (Comp b c d  Hom a b) =
                             Comp a c d  (Hom c d  Comp a b c) 
                               𝖺[Hom c d, Hom b c, Hom a b]"
      proof -
        fix a b c d
        assume a: "a  Obj" and b: "b  Obj" and c: "c  Obj" and d: "d  Obj"
        interpret ab: extensional_rts RTS.Rts (Hom a b)
          using a b by fastforce
        interpret bc: extensional_rts RTS.Rts (Hom b c)
          using b c by fastforce
        interpret cd: extensional_rts RTS.Rts (Hom c d)
          using c d by fastforce
        interpret ac: extensional_rts RTS.Rts (Hom a c)
          using a c by fastforce
        interpret bd: extensional_rts RTS.Rts (Hom b d)
          using b d by fastforce
        interpret bcxab: extensional_rts
                           RTS.Rts (RTS.dom (Hom b c  Hom a b))
          using a b c by auto
        interpret cdxbc: rts RTS.Rts (RTS.dom (Hom c d  Hom b c))
          using b c d ide_Hom RTS.ide_char RTS.arrD extensional_rts_def
          by (metis RTS.CMC.tensor_preserves_ide)
        interpret cdxbc_x_ab:
                    rts RTS.Rts (RTS.dom ((Hom c d  Hom b c)  Hom a b))
          using a b c d extensional_rts_def by fastforce
        interpret cd_X_bcxab: product_rts
                                RTS.Rts (Hom c d)
                                RTS.Rts (RTS.dom (Hom b c  Hom a b))
          ..
        interpret cdxbc_X_ab: product_rts
                                RTS.Rts (RTS.dom (Hom c d  Hom b c))
                                RTS.Rts (Hom a b)
          ..
        interpret bcXab: product_rts RTS.Rts (Hom b c) RTS.Rts (Hom a b) ..
        interpret cdXbc: product_rts RTS.Rts (Hom c d) RTS.Rts (Hom b c) ..
        interpret cd_X_bcXab: product_rts RTS.Rts (Hom c d) bcXab.resid ..
        interpret cdXbc_X_ab: product_rts cdXbc.resid RTS.Rts (Hom a b) ..
        interpret Icd: simulation RTS.Rts (Hom c d) RTS.Rts (Hom c d)
                         RTS.Map (Hom c d)
          by (metis RTS.arrD(3) RTS.ide_char c d ide_Hom)
        interpret Iab: simulation RTS.Rts (Hom a b) RTS.Rts (Hom a b)
                         RTS.Map (Hom a b)
          by (metis RTS.arrD(3) RTS.ideD(1-3) a b ide_Hom)
        interpret Cabc: simulation
                          RTS.Rts (RTS.dom (Hom b c  Hom a b))
                          RTS.Rts (Hom a c)
                          RTS.Map (Comp a b c)
          by (metis (no_types, lifting) Comp_in_hom
              RTS.CMC.tensor_preserves_ide RTS.arrD(3) RTS.ideD(2)
              RTS.in_homE a b c ide_Hom)
        interpret Cbcd: simulation
                          RTS.Rts (RTS.dom (Hom c d  Hom b c))
                          RTS.Rts (Hom b d)
                          RTS.Map (Comp b c d)
          by (metis (no_types, lifting) Comp_in_hom
              RTS.CMC.tensor_preserves_ide RTS.arrD(3) RTS.ideD(2)
              RTS.in_homE b c d ide_Hom)
        interpret Cabd: simulation
                          RTS.Rts (RTS.dom (Hom b d  Hom a b))
                          RTS.Rts (Hom a d)
                          RTS.Map (Comp a b d)
          by (metis (no_types, lifting) Comp_in_hom
              RTS.CMC.tensor_preserves_ide RTS.arrD(3) RTS.ideD(2)
              RTS.in_homE a b d ide_Hom)
        interpret IcdXCabc: product_simulation
                             RTS.Rts (Hom c d)
                             RTS.Rts (RTS.dom (Hom b c  Hom a b))
                             RTS.Rts (Hom c d) RTS.Rts (Hom a c)
                             RTS.Map (Hom c d) RTS.Map (Comp a b c)
          ..
        interpret CbcdXIab: product_simulation
                             RTS.Rts (RTS.dom (Hom c d  Hom b c))
                             RTS.Rts (Hom a b)
                             RTS.Rts (Hom b d) RTS.Rts (Hom a b)
                             RTS.Map (Comp b c d) RTS.Map (Hom a b)
          ..
        interpret PU_bcXab: inverse_simulations
                              RTS.Rts (RTS.dom (Hom b c  Hom a b))
                              bcXab.resid
                              RTS.Pack (Hom b c) (Hom a b)
                              RTS.Unpack (Hom b c) (Hom a b)
          using a b c RTS.inverse_simulations_Pack_Unpack by simp
        interpret PU_bdXab: inverse_simulations
                              RTS.Rts (RTS.dom (Hom b d  Hom a b))
                              CbcdXIab.B1xB0.resid
                              RTS.Pack (Hom b d) (Hom a b)
                              RTS.Unpack (Hom b d) (Hom a b)
          using a b c d RTS.inverse_simulations_Pack_Unpack by simp
        interpret PU_cdXac: inverse_simulations
                              RTS.Rts (RTS.dom (Hom c d  Hom a c))
                              IcdXCabc.B1xB0.resid
                              RTS.Pack (Hom c d) (Hom a c)
                              RTS.Unpack (Hom c d) (Hom a c)
          using a c d RTS.inverse_simulations_Pack_Unpack by simp
         interpret PU_cdXbc: inverse_simulations
                              RTS.Rts (RTS.dom (Hom c d  Hom b c))
                              cdXbc.resid
                              RTS.Pack (Hom c d) (Hom b c)
                              RTS.Unpack (Hom c d) (Hom b c)
          using b c d RTS.inverse_simulations_Pack_Unpack by simp
        interpret PU_cd_X_bcxab: inverse_simulations
                                   RTS.Rts
                                      (RTS.dom (Hom c d  Hom b c  Hom a b))
                                   cd_X_bcxab.resid
                                   RTS.Pack (Hom c d) (Hom b c  Hom a b)
                                   RTS.Unpack (Hom c d) (Hom b c  Hom a b)
          using a b c d RTS.inverse_simulations_Pack_Unpack by simp
        interpret PU_cdxbc_X_ab: inverse_simulations
                                   RTS.Rts
                                      (RTS.dom ((Hom c d  Hom b c)  Hom a b))
                                   cdxbc_X_ab.resid
                                   RTS.Pack (Hom c d  Hom b c) (Hom a b)
                                   RTS.Unpack (Hom c d  Hom b c) (Hom a b)
          using a b c d RTS.inverse_simulations_Pack_Unpack by simp
        interpret Ucdxbc_X_Iab: product_simulation
                                  RTS.Rts (RTS.dom (Hom c d  Hom b c))
                                  RTS.Rts (Hom a b)
                                  cdXbc.resid RTS.Rts (Hom a b)
                                  RTS.Unpack (Hom c d) (Hom b c)
                                  RTS.Map (Hom a b)
          ..
        interpret Icd_X_Pbcxab: product_simulation
                                  RTS.Rts (Hom c d) bcXab.resid
                                  RTS.Rts (Hom c d)
                                  RTS.Rts (RTS.dom (Hom b c  Hom a b))
                                  RTS.Map (Hom c d) RTS.Pack (Hom b c) (Hom a b)
          ..
        show "Comp a b d  (Comp b c d  Hom a b) =
              Comp a c d  (Hom c d  Comp a b c)  𝖺[Hom c d, Hom b c, Hom a b]"
        proof (intro RTS.arr_eqI)
          show 1: "RTS.par (Comp a b d  (Comp b c d  Hom a b))
                           (Comp a c d  (Hom c d  Comp a b c) 
                              𝖺[Hom c d, Hom b c, Hom a b])"
            using a b c d by auto
          show "RTS.Map (Comp a b d  (Comp b c d  Hom a b)) =
                RTS.Map (Comp a c d  (Hom c d  Comp a b c) 
                           𝖺[Hom c d, Hom b c, Hom a b])"
          proof
            fix x
            show "RTS.Map (Comp a b d  (Comp b c d  Hom a b)) x =
                  RTS.Map (Comp a c d  (Hom c d  Comp a b c) 
                             𝖺[Hom c d, Hom b c, Hom a b]) x"
            proof (cases "cdxbc_x_ab.arr x")
              assume x: "¬ cdxbc_x_ab.arr x"
              show ?thesis
              proof -
                interpret L: simulation
                               RTS.Dom ((Hom c d  Hom b c)  Hom a b)
                               RTS.Rts (Hom a d)
                               RTS.Map (Comp a b d  (Comp b c d  Hom a b))
                  using a b c d 1
                        RTS.arrD(3) [of "Comp a b d  (Comp b c d  Hom a b)"]
                  by auto
                interpret R: simulation
                               RTS.Rts (RTS.dom ((Hom c d  Hom b c)  Hom a b))
                               RTS.Rts (Hom a d)
                               RTS.Map (Comp a c d  (Hom c d  Comp a b c) 
                                           𝖺[Hom c d, Hom b c, Hom a b])
                  using a b c d 1
                        RTS.arrD(3)
                          [of "Comp a c d  (Hom c d  Comp a b c) 
                                 𝖺[Hom c d, Hom b c, Hom a b]"]
                  by auto
                show ?thesis
                  using x L.extensional R.extensional by simp
              qed
              next
              assume x: "cdxbc_x_ab.arr x"
              let ?w = "RTS.Unpack (Hom c d  Hom b c) (Hom a b) x"
              let ?x = "RTS.Unpack (Hom c d) (Hom b c) (fst ?w)"
              let ?y = "snd ?w"
              have fst_x: "cd.arr (fst ?x)"
                using cdXbc.arr_char cdxbc_X_ab.arr_char x by blast
              have snd_x: "bc.arr (snd ?x)"
                using cdXbc.arr_char cdxbc_X_ab.arr_char x by blast
              have snd_w: "ab.arr (snd ?w)"
                using cdxbc_X_ab.arr_char x by blast
              show ?thesis
              proof -
                have "RTS.Map (Comp a b d  (Comp b c d  Hom a b)) x =
                      RTS.Map (Comp a b d) (RTS.Map (Comp b c d  Hom a b) x)"
                  using a b c d RTS.Map_comp by fastforce
                also have "... = RTS.Map (Comp a b d)
                                   (RTS.Pack (Hom b d) (Hom a b)
                                     (CbcdXIab.map
                                        (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)))"
                  using RTS.Map_prod a b c d by auto
                also have "... = (λx. fst x  snd x)
                                   (CbcdXIab.map
                                      (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using a b d x CbcdXIab.preserves_reflects_arr
                        PU_cdxbc_X_ab.G.preserves_reflects_arr
                        Map_Comp_Pack
                           [of a b d "CbcdXIab.map
                                        (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"]
                  by blast
                also have "... = (λx. fst x  snd x)
                                   (RTS.Map (Comp b c d)
                                      (fst
                                        (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)),
                                    snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using a b x RTS.Map_ide cdxbc_X_ab.arr_char
                        CbcdXIab.map_simp
                          [of "fst (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"
                              "snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"]
                        PU_cdxbc_X_ab.G.preserves_reflects_arr [of x]
                  by auto
                also have "... = (λx. fst x  snd x)
                                   (RTS.Map (Comp b c d)
                                      (I (RTS.Rts (RTS.dom (Hom c d  Hom b c)))
                                            (fst
                                               (RTS.Unpack
                                                  (Hom c d  Hom b c) (Hom a b) x))),
                                    snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using x cdxbc_X_ab.arr_char comp_apply
                        PU_cdxbc_X_ab.G.preserves_reflects_arr [of x]
                  by simp
                also have "... = (λx. fst x  snd x)
                                   (RTS.Map (Comp b c d)
                                      ((RTS.Pack (Hom c d) (Hom b c) 
                                          RTS.Unpack (Hom c d) (Hom b c))
                                            (fst
                                               (RTS.Unpack
                                                  (Hom c d  Hom b c) (Hom a b) x))),
                                    snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using PU_cdXbc.inv' by simp
                also have "... = (λx. fst x  snd x)
                                   (RTS.Map (Comp b c d)
                                      (RTS.Pack (Hom c d) (Hom b c)
                                         (RTS.Unpack (Hom c d) (Hom b c)
                                            (fst
                                               (RTS.Unpack
                                                  (Hom c d  Hom b c) (Hom a b) x)))),
                                    snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  by auto
                also have "... = (λx. (fst (fst x)  snd (fst x))  snd x)
                                   ((λy. (RTS.Unpack (Hom c d) (Hom b c) (fst y),
                                          snd y))
                                      (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using b c d x PU_cdxbc_X_ab.G.preserves_reflects_arr [of x]
                        cdxbc_X_ab.arr_char
                          [of "RTS.Unpack (Hom c d  Hom b c) (Hom a b) x"]
                        Map_Comp_Pack
                          [of b c d
                              "RTS.Unpack (Hom c d) (Hom b c)
                                 (fst (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"]
                  by fastforce
                finally have LHS: "RTS.Map
                                     (Comp a b d  (Comp b c d  Hom a b)) x =
                                   (λx. (fst (fst x)  snd (fst x))  snd x)
                                     ((λy. (RTS.Unpack (Hom c d) (Hom b c) (fst y),
                                            snd y))
                                        (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  by blast

                have "RTS.Map (Comp a c d  (Hom c d  Comp a b c) 
                        𝖺[Hom c d, Hom b c, Hom a b]) x =
                      RTS.Map (Comp a c d)
                        (RTS.Map (Hom c d  Comp a b c)
                           (RTS.Map 𝖺[Hom c d, Hom b c, Hom a b] x))"
                  using a b c d RTS.Map_comp by fastforce
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Map (Hom c d  Comp a b c)
                                     (RTS.Pack (Hom c d) (Hom b c  Hom a b)
                                        (product_simulation.map
                                           (RTS.Rts (Hom c d)) bcXab.resid
                                           (I (RTS.Rts (Hom c d)))
                                           (RTS.Pack (Hom b c) (Hom a b))
                                           (ASSOC.map (RTS.Rts (Hom c d))
                                                      (RTS.Rts (Hom b c))
                                                      (RTS.Rts (Hom a b))
                                              ((product_simulation.map
                                                  (RTS.Rts (Hom c d  Hom b c))
                                                  (RTS.Rts (Hom a b))
                                                  (RTS.Unpack (Hom c d) (Hom b c))
                                                  (I (RTS.Rts (Hom a b)))
                                                  (RTS.Unpack
                                                     (Hom c d  Hom b c)
                                                     (Hom a b) x)))))))"
                  using a b c d RTS.tensor_agreement RTS.Map_assoc
                  by (auto simp add: RTS.comp_arr_ide)
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Map (Hom c d  Comp a b c)
                                     (RTS.Pack (Hom c d) (Hom b c  Hom a b)
                                        (product_simulation.map
                                           (RTS.Rts (Hom c d)) bcXab.resid
                                           (I (RTS.Rts (Hom c d)))
                                           (RTS.Pack (Hom b c) (Hom a b))
                                           (ASSOC.map (RTS.Rts (Hom c d))
                                                      (RTS.Rts (Hom b c))
                                                      (RTS.Rts (Hom a b))
                                              (((λx. (RTS.Unpack
                                                        (Hom c d) (Hom b c) (fst x),
                                                      RTS.Map (Hom a b) (snd x)))
                                                  (RTS.Unpack
                                                     (Hom c d  Hom b c)
                                                     (Hom a b) x)))))))"
                  using a b c d x RTS.Map_ide
                        PU_cdxbc_X_ab.G.preserves_reflects_arr [of x]
                        cdxbc_X_ab.arr_char
                        Ucdxbc_X_Iab.map_simp
                          [of "fst (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"
                              "snd (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"]
                  by simp
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Map (Hom c d  Comp a b c)
                                     (RTS.Pack (Hom c d) (Hom b c  Hom a b)
                                        (product_simulation.map
                                           (RTS.Rts (Hom c d)) bcXab.resid
                                           (I (RTS.Rts (Hom c d)))
                                           (RTS.Pack (Hom b c) (Hom a b))
                                           (fst (RTS.Unpack (Hom c d) (Hom b c)
                                              (fst
                                                 (RTS.Unpack
                                                    (Hom c d  Hom b c) (Hom a b) x))),
                                            snd (RTS.Unpack (Hom c d) (Hom b c)
                                              (fst
                                                 (RTS.Unpack
                                                    (Hom c d  Hom b c) (Hom a b) x))),
                                            snd
                                              (RTS.Unpack
                                                 (Hom c d  Hom b c) (Hom a b) x)))))"
                proof -
                  interpret A: ASSOC RTS.Rts (Hom c d) RTS.Rts (Hom b c)
                                 RTS.Rts (Hom a b)
                    ..
                  show ?thesis
                    using a b c d x cdxbc_X_ab.arr_char cdXbc.arr_char
                          PU_cdxbc_X_ab.G.preserves_reflects_arr
                          PU_cdXbc.G.preserves_reflects_arr
                          A.map_eq RTS.Map_ide
                    by auto
                qed
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Map (Hom c d  Comp a b c)
                                     (RTS.Pack (Hom c d) (Hom b c  Hom a b)
                                       (fst ?x,
                                        RTS.Pack (Hom b c) (Hom a b)
                                          (snd ?x, snd ?w))))"
                   using c d x RTS.Map_ide Icd_X_Pbcxab.map_simp
                         cdxbc_X_ab.arr_char
                         PU_cdxbc_X_ab.G.preserves_reflects_arr [of x]
                         PU_cdXbc.G.preserves_reflects_arr
                           [of "fst (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x)"]
                   by auto
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Pack (Hom c d) (Hom a c)
                                      (IcdXCabc.map
                                         ((RTS.Unpack
                                             (Hom c d) (Hom b c  Hom a b) 
                                                RTS.Pack (Hom c d) (Hom b c  Hom a b))
                                            (fst ?x,
                                             RTS.Pack (Hom b c) (Hom a b)
                                               (snd ?x, snd ?w)))))"
                  using a b c d x RTS.Map_prod by auto
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Pack (Hom c d) (Hom a c)
                                      (IcdXCabc.map
                                         (fst ?x,
                                          RTS.Pack (Hom b c) (Hom a b)
                                            (snd ?x, snd ?w))))"
                proof - 
                  have "cd_X_bcxab.arr
                          (fst ?x, RTS.Pack (Hom b c) (Hom a b) (snd ?x, snd ?w))"
                    using fst_x snd_x snd_w PU_bcXab.F.preserves_reflects_arr
                    by fastforce
                  thus ?thesis
                    using PU_cd_X_bcxab.inv by auto
                qed
                also have "... = RTS.Map (Comp a c d)
                                   (RTS.Pack (Hom c d) (Hom a c)
                                     (RTS.Map (Hom c d) (fst ?x),
                                      RTS.Map (Comp a b c)
                                        (RTS.Pack (Hom b c) (Hom a b)
                                           (snd ?x, snd ?w))))"
                  using a b c d x fst_x snd_x snd_w
                        IcdXCabc.map_simp
                          [of "fst ?x"
                              "RTS.Pack (Hom b c) (Hom a b) (snd ?x, snd ?w)"]
                  by fastforce
                also have "... = fst ?x  (snd ?x  snd ?w)"
                proof -
                  have "ac.arr (snd ?x  snd ?w)"
                    using a b c snd_w snd_x HOM_arr_char arr_coincidence
                    by auto
                  thus ?thesis
                    using a b c d fst_x RTS.Map_ide snd_x snd_w Map_Comp_Pack
                    by auto
                qed
                also have "... = (λx. (fst (fst x)  snd (fst x))  snd x)
                                   ((λy. (RTS.Unpack (Hom c d) (Hom b c) (fst y),
                                          snd y))
                                      (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  using H.comp_assoc by simp
                finally have RHS: "RTS.Map
                                     (Comp a c d  (Hom c d  Comp a b c) 
                                        𝖺[Hom c d, Hom b c, Hom a b]) x =
                                   (λx. (fst (fst x)  snd (fst x))  snd x)
                                      ((λy. (RTS.Unpack (Hom c d) (Hom b c) (fst y),
                                             snd y))
                                         (RTS.Unpack (Hom c d  Hom b c) (Hom a b) x))"
                  by blast
                show ?thesis using LHS RHS by auto
              qed
            qed
          qed
        qed
      qed
    qed

    proposition is_rts_enriched_category:
    shows "rts_enriched_category Obj Hom Id Comp"
      ..

    lemma HOM_agreement:
    assumes "H.ide a" and "H.ide b"
    shows "HOMEC a b = HOM a b"
      using assms Hom_def RTS.bij_mkide(3) by auto

  end

subsection "Functoriality"

  text‹
    If we are to construct an enriched functor from a given RTS-functor F›, then we need
    a base category RTS that is large enough to provide objects for all the required
    hom-RTS's.  So the arrow type of this category will need to embed the arrow types
    of both the domain A› and the codomain B› RTS of the given RTS-functor F›.
    Here I have assumed that both of these arrow types are in fact the same type 'A›
    and in addition that 'A› is a universe, so that it supports the construction of the
    cartesian closed base category RTS.  At the cost of having to deal with coercions,
    we could more generally just assume injections from the arrow types of A›
    and B› into a common universe 'C›, but we haven't bothered to do that.
  ›

  locale enriched_functor_of_rts_functor =
    universe arr_type +
    RTS: rtscat arr_type +
    A: locally_small_rts_category residA compA +
    B: locally_small_rts_category residB compB +
    F: rts_functor residA compA residB compB F
  for arr_type :: "'A itself"
  and residA :: "'A resid"  (infix "\\A" 70)
  and compA :: "'A comp"    (infixr "A" 53)
  and residB :: "'A resid"  (infix "\\B" 70)
  and compB :: "'A comp"    (infixr "B" 53)
  and F :: "'A  'A"
  begin

    interpretation A: enriched_category_of_rts_category arr_type residA compA ..
    interpretation B: enriched_category_of_rts_category arr_type residB compB ..

    (*
     * TODO: I haven't assumed that the object map of an enriched functor is extensional.
     * Perhaps I should have.
     *)

    definition Fo
    where "Fo a  if A.H.ide a then F a else B.null"

    definition Fa
    where "Fa a b  if A.H.ide a  A.H.ide b
                    then RTS.mkarr (A.HOMEC a b) (B.HOMEC (Fo a) (Fo b))
                           (λt. if residuation.arr (A.HOMEC a b) t
                                then F t
                                else ResiduatedTransitionSystem.partial_magma.null
                                       (B.HOMEC (Fo a) (Fo b)))
                    else RTS.null"

    lemma sub_rts_resid_eq:
    assumes "a  A.Obj" and "b  A.Obj"
    shows "sub_rts.resid residA (λt. A.H.in_hom t a b) = A.HOMEC a b"
    and "sub_rts.resid residB (λt. B.H.in_hom t (Fo a) (Fo b)) =
         B.HOMEC (Fo a) (Fo b)"
    proof -
      have 1: "a. a  Collect A.H.ide  Fo a  Collect B.H.ide"
        unfolding Fo_def by simp
      interpret DOM: sub_rts residA λt. A.H.in_hom t a b
        using assms A.sub_rts_HOM by metis
      interpret COD: sub_rts residB λt. B.H.in_hom t (Fo a) (Fo b)
        using assms 1 B.sub_rts_HOM by metis
      show "DOM.resid = A.HOMEC a b"
        using assms DOM.resid_def A.Hom_def RTS.bij_mkide(3) by simp
      show "COD.resid = B.HOMEC (Fo a) (Fo b)"
        using assms 1 B.Hom_def COD.resid_def RTS.bij_mkide(3) by auto
    qed

    sublocale rts_enriched_functor
                Collect A.H.ide A.Hom A.Id A.Comp
                Collect B.H.ide B.Hom B.Id B.Comp
                Fo Fa
    proof
      show 1: "a. a  Collect A.H.ide  Fo a  Collect B.H.ide"
        unfolding Fo_def by simp
      show "a b. a  Collect A.H.ide  b  Collect A.H.ide  Fa a b = RTS.null"
        unfolding Fa_def by auto
      show 2: "a b. a  Collect A.H.ide; b  Collect A.H.ide 
                        «Fa a b : A.Hom a b  B.Hom (Fo a) (Fo b)»"
      proof -
        fix a b
        assume a: "a  Collect A.H.ide" and b: "b  Collect A.H.ide"
        interpret DOM: sub_rts residA λt. A.H.in_hom t a b
          using a b A.sub_rts_HOM by metis
        interpret COD: sub_rts residB λt. B.H.in_hom t (Fo a) (Fo b)
          using a b 1 B.sub_rts_HOM by metis
        interpret Fa_ab: simulation DOM.resid COD.resid
                           λt. if DOM.arr t then F t else COD.null
        proof
          show "t. ¬ DOM.arr t 
                         (if DOM.arr t then F t else COD.null) = COD.null"
            by simp
          show "t u. DOM.con t u 
                         COD.con (if DOM.arr t then F t else COD.null)
                                 (if DOM.arr u then F u else COD.null)"
            using COD.con_char DOM.arr_char DOM.con_char Fo_def a b by auto
          show "t u. DOM.con t u 
                         (if DOM.arr (DOM.resid t u) then F (DOM.resid t u)
                          else COD.null) =
                         COD.resid (if DOM.arr t then F t else COD.null)
                                   (if DOM.arr u then F u else COD.null)"
            using a b 1 Fo_def COD.con_char DOM.arr_char DOM.con_char
                  DOM.resid_def COD.resid_def DOM.resid_closed
            by auto
        qed
        show "«Fa a b : A.Hom a b  B.Hom (Fo a) (Fo b)»"
        proof
          have 2: "residuation.arr (A.HOMEC a b) = DOM.arr"
            using a b DOM.arr_char A.Hom_def RTS.bij_mkide(3) by simp
          have 3: "ResiduatedTransitionSystem.partial_magma.null
                     (B.HOMEC (Fo a) (Fo b)) =
                   COD.null"
            using a b 1 COD.null_char B.Hom_def RTS.bij_mkide(3) by auto
          show 4: "RTS.arr (Fa a b)"
          proof (intro RTS.arrIRTSC)
            show "extensional_rts DOM.resid  small_rts DOM.resid"
              using a b A.V.extensional_rts_axioms DOM.preserves_extensional_rts
                    sub_rts_resid_eq
              by auto
            show "extensional_rts COD.resid  small_rts COD.resid"
              using a b 1 B.V.extensional_rts_axioms COD.preserves_extensional_rts
                    sub_rts_resid_eq(2)
              by auto
            have "(λt. if DOM.arr t then F t
                       else ResiduatedTransitionSystem.partial_magma.null
                              (B.HOMEC (Fo a) (Fo b))) =
                  (λt. if DOM.arr t then F t else COD.null)"
              using a b 3 sub_rts_resid_eq Fa_def RTS.Map_mkarr
              by auto
            thus "Fa a b  RTS.mkarr DOM.resid COD.resid `
                             Collect (simulation DOM.resid COD.resid)"
              unfolding Fa_def
              using a b 1 3 sub_rts_resid_eq Fa_ab.simulation_axioms
                    RTS.Map_mkarr
              by auto
          qed
          show "RTS.dom (Fa a b) = A.Hom a b"
            using 4 Fa_def by fastforce
          show "RTS.cod (Fa a b) = B.Hom (Fo a) (Fo b)"
            using 4 Fo_def Fa_def by fastforce
        qed
      qed
      show "a. a  Collect A.H.ide  Fa a a  A.Id a = B.Id (Fo a)"
      proof -
        fix a
        assume a: "a  Collect A.H.ide"
        interpret HOMA: sub_rts residA λt. A.H.in_hom t a a
          using a A.sub_rts_HOM by metis
        interpret HOMB: sub_rts residB λt. B.H.in_hom t (Fo a) (Fo a)
          using a 1 B.sub_rts_HOM by metis
        have 3: "RTS.arr (Fa a a  A.Id a)"
          using a 2 A.arr_coincidence A.Id_in_hom by auto
        have 4: "Fa a a  A.Id a =
                 RTS.mkarr (A.HOMEC a a) (B.HOMEC (F a) (F a))
                   (λt. if HOMA.arr t then F t else HOMB.null) 
                 RTS.mkarr RTS.One.resid (A.HOMEC a a)
                   (λt. if RTS.One.arr t then a else HOMA.null)"
        proof -
          have "A.HOMEC a a = HOMA.resid"
            using a HOMA.resid_def A.Hom_def RTS.bij_mkide(3) by simp
          moreover have "B.HOMEC (Fo a) (Fo a) = HOMB.resid"
            using a 1 HOMB.resid_def B.Hom_def [of "Fo a" "Fo a"] RTS.bij_mkide(3)
            by simp
          ultimately show ?thesis
            unfolding Fo_def Fa_def A.Id_def B.Id_def
            using a A.arr_coincidence A.Hom_def B.Hom_def
            apply auto[1]
            using Fo_def B.HOMEC (Fo a) (Fo a) = HOMB.resid by presburger
        qed
        also have "... = RTS.mkarr RTS.One.resid (B.HOMEC (F a) (F a))
                           ((λt. if HOMA.arr t then F t else HOMB.null) 
                              (λt. if RTS.One.arr t then a else HOMA.null))"
          using a 1 3 4 RTS.comp_mkarr by auto
        also have "... = RTS.mkarr RTS.One.resid (B.HOMEC (F a) (F a))
                           (λt. if RTS.One.arr t then F a else HOMB.null)"
          (is "?LHS = ?RHS")
        proof (intro RTS.arr_eqI)
          interpret HOM_Fa_Fa: hom_rts arr_type B.Obj B.Hom B.Id B.Comp
                                 F a F a
            using a by unfold_locales auto
          have 5: "simulation RTS.One.resid (B.HOMEC (F a) (F a))
                     (λt. if RTS.One.arr t then F a else HOMB.null)"
          proof -
            have "(λt. if RTS.One.arr t then F a
                       else ResiduatedTransitionSystem.partial_magma.null
                              (B.HOM (F a) (F a))) =
                  (λt. if RTS.One.arr t then F a else HOMB.null)"
              using Fo_def a by fastforce
            thus ?thesis
              using a RTS.bij_mkide(3) B.Id_in_hom [of "F a"]
                    RTS.arrD(3) [of "B.Id (F a)"]
                    B.Id_def RTS.Map_mkarr
              by auto
          qed
          have 6: "extensional_rts (B.HOMEC (F a) (F a))"
            using a by force
          have 7: "small_rts (B.HOMEC (F a) (F a))"
            using a by force
          have 8: "RTS.arr ?LHS"
            using 3 calculation by auto
          have 9: "RTS.arr ?RHS"
            using 5 6 7 RTS.One.extensional_rts_axioms
                  RTS.One.small_rts_axioms
            by auto
          show "RTS.par ?LHS ?RHS"
            using 8 9 by auto
          show "RTS.Map ?LHS = RTS.Map ?RHS"
          proof
            fix x
            show "RTS.Map ?LHS x = RTS.Map ?RHS x"
              using a 8 9 RTS.Map_mkarr HOMA.arr_char HOMA.null_char
                    A.H.ide_in_hom
              by auto
          qed
        qed
        also have "... = B.Id (Fo a)"
          unfolding Fo_def B.Id_def
          using a by auto
        finally show "Fa a a  A.Id a = B.Id (Fo a)" by blast
      qed
      show "a b c. a  A.Obj; b  A.Obj; c  A.Obj
                        B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b) =
                           Fa a c  A.Comp a b c"
      proof -
        fix a b c
        assume a: "a  Collect A.H.ide" and b: "b  Collect A.H.ide"
        and c: "c  Collect A.H.ide"
        interpret HOMA_ab: sub_rts residA λt. A.H.in_hom t a b
          using a b A.sub_rts_HOM by metis
        interpret HOMA_ac: sub_rts residA λt. A.H.in_hom t a c
          using a c A.sub_rts_HOM by metis
        interpret HOMA_bc: sub_rts residA λt. A.H.in_hom t b c
          using b c A.sub_rts_HOM by metis
        interpret HOMB_ab: sub_rts residB λt. B.H.in_hom t (Fo a) (Fo b)
          using a b 1 B.sub_rts_HOM by metis
        interpret HOMB_ac: sub_rts residB λt. B.H.in_hom t (Fo a) (Fo c)
          using a c 1 B.sub_rts_HOM by metis
        interpret HOMB_bc: sub_rts residB λt. B.H.in_hom t (Fo b) (Fo c)
          using b c 1 B.sub_rts_HOM by metis
        interpret Fa_bc: simulation HOMA_bc.resid HOMB_bc.resid
                           RTS.Map (Fa b c)
          using b c 1 2 [of b c] A.Hom_def B.Hom_def RTS.bij_mkide(3)
                RTS.arrD(3) [of "Fa b c"]
          by auto
        interpret Fa_ab: simulation HOMA_ab.resid HOMB_ab.resid
                           RTS.Map (Fa a b)
          using a b 1 2 [of a b] A.Hom_def B.Hom_def RTS.bij_mkide(3)
                RTS.arrD(3) [of "Fa a b"]
          by auto
        interpret Fa_bc_x_Fa_ab: product_simulation
                                   HOMA_bc.resid HOMA_ab.resid
                                   HOMB_bc.resid HOMB_ab.resid
                                   RTS.Map (Fa b c) RTS.Map (Fa a b)
          ..

        interpret HOM_bc: extensional_rts A.HOMEC b c
          using b c by simp
        interpret HOM_ab: extensional_rts A.HOMEC a b
          using a b by simp
        interpret HOM_ac: extensional_rts A.HOMEC a c
          using a c by simp
        interpret HOM_bc_x_HOM_ab: product_rts
                                     A.HOMEC b c A.HOMEC a b
          ..
        interpret B_HOM_bc: extensional_rts B.HOMEC (Fo b) (Fo c)
          using b c 1 by simp
        interpret B_HOM_ab: extensional_rts B.HOMEC (Fo a) (Fo b)
          using a b 1 by simp
        interpret B_HOM_bc_x_B_HOM_ab: product_rts
                                         B.HOMEC (Fo b) (Fo c)
                                         B.HOMEC (Fo a) (Fo b)
          ..
        interpret U: simulation
                       RTS.Rts (A.Hom b c  A.Hom a b)
                       HOM_bc_x_HOM_ab.resid
                       RTS.Unpack (A.Hom b c) (A.Hom a b)
          using a b c RTS.simulation_Unpack by simp

        show "B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b) =
              Fa a c  A.Comp a b c"
        proof (intro RTS.arr_eqI)
          show 3: "RTS.par
                     (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b))
                     (Fa a c  A.Comp a b c)"
          proof (intro conjI)
            show "RTS.seq (B.Comp (Fo a) (Fo b) (Fo c)) (Fa b c  Fa a b)"
              using a b c 1 2 [of b c] 2 [of a b]
                    RTS.prod_simps [of "Fa b c" "Fa a b"]
              apply (intro RTS.seqI)
                apply auto[1]
              by fastforce+
            show "RTS.seq (Fa a c) (A.Comp a b c)"
              using a b c 1 2 A.Comp_in_hom by blast
            show "RTS.dom (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                  RTS.dom (Fa a c  A.Comp a b c)"
              using a b c 1 2 [of b c] 2 [of a b] 2 [of a c] by fastforce
            show "RTS.cod (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                  RTS.cod (Fa a c  A.Comp a b c)"
              using a b c 1 2 [of b c] 2 [of a b] 2 [of a c] by fastforce
          qed
          show "RTS.Map (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                RTS.Map (Fa a c  A.Comp a b c)"
          proof -
            have "RTS.Map (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                  RTS.Map (B.Comp (Fo a) (Fo b) (Fo c)) 
                             RTS.Map (Fa b c  Fa a b)"
              using a b c 1 2 [of b c] 2 [of a b] 2 [of a c] 3 RTS.Map_comp
              by auto
            also have "... = (λt. fst
                                    (RTS.Unpack
                                       (B.Hom (Fo b) (Fo c))
                                       (B.Hom (Fo a) (Fo b)) t) B
                                    snd
                                      (RTS.Unpack
                                         (B.Hom (Fo b) (Fo c))
                                         (B.Hom (Fo a) (Fo b)) t)) 
                               (RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b)) 
                                  Fa_bc_x_Fa_ab.map 
                                    RTS.Unpack
                                      (RTS.dom (Fa b c)) (RTS.dom (Fa a b)))"
            proof -
              have "RTS.Map (B.Comp (Fo a) (Fo b) (Fo c)) =
                    (λt. fst (RTS.Unpack
                                (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b)) t) B
                         snd (RTS.Unpack
                                (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b)) t))"
                using a b c 1 2 B.Comp_def RTS.Map_mkarr
                      B.Comp_in_hom [of "Fo a" "Fo b" "Fo c"]
                by auto
              moreover have "RTS.Map (Fa b c  Fa a b) =
                             RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b)) 
                               Fa_bc_x_Fa_ab.map 
                                 RTS.Unpack (RTS.dom (Fa b c)) (RTS.dom (Fa a b))"
              proof -
                have "RTS.Rts (RTS.dom (Fa b c)) = HOMA_bc.resid"
                  using b c 2 [of b c] sub_rts_resid_eq by auto
                moreover have "RTS.Rts (RTS.dom (Fa a b)) = HOMA_ab.resid"
                  using a b 2 [of a b] sub_rts_resid_eq by auto
                ultimately have "product_simulation.map
                        (RTS.Rts (RTS.dom (Fa b c))) (RTS.Rts (RTS.dom (Fa a b)))
                        (RTS.Map (Fa b c)) (RTS.Map (Fa a b)) =
                      Fa_bc_x_Fa_ab.map"
                  using a b c 1 2 [of b c] 2 [of a b] Fa_def RTS.dom_mkarr by auto
                thus ?thesis
                  using a b c 1 2 [of b c] 2 [of a b] A.Hom_def B.Hom_def
                        RTS.in_homE RTS.Map_prod [of "Fa b c" "Fa a b"]
                  by auto
              qed
              ultimately show ?thesis by force
            qed
            also have "... = (λt. fst
                                    (RTS.Unpack
                                       (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                                         (RTS.Pack
                                            (B.Hom (Fo b) (Fo c))
                                            (B.Hom (Fo a) (Fo b))
                                             (Fa_bc_x_Fa_ab.map
                                                (RTS.Unpack
                                                   (A.Hom b c) (A.Hom a b) t)))) B
                                    snd
                                      (RTS.Unpack
                                         (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                                          (RTS.Pack
                                             (B.Hom (Fo b) (Fo c))
                                             (B.Hom (Fo a) (Fo b))
                                             (Fa_bc_x_Fa_ab.map
                                                (RTS.Unpack
                                                   (A.Hom b c) (A.Hom a b) t)))))"
              using a b c 2 [of a b] 2 [of b c] by fastforce
            also have "... = (λt. fst (Fa_bc_x_Fa_ab.map
                                         (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                                  snd (Fa_bc_x_Fa_ab.map
                                         (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))"
            proof
              fix t
              interpret PU: inverse_simulations
                              RTS.Rts
                                 (RTS.dom
                                    (B.Hom (Fo b) (Fo c)  B.Hom (Fo a) (Fo b)))
                              product_rts.resid
                                 (B.HOMEC (Fo b) (Fo c)) (B.HOMEC (Fo a) (Fo b))
                              RTS.Pack
                                 (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                              RTS.Unpack
                                  (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                using a b c 1 RTS.inverse_simulations_Pack_Unpack by simp
              show "fst
                      (RTS.Unpack
                         (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                         (RTS.Pack (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                            (Fa_bc_x_Fa_ab.map
                               (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))) B
                             snd (RTS.Unpack
                                    (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                                    (RTS.Pack
                                       (B.Hom (Fo b) (Fo c)) (B.Hom (Fo a) (Fo b))
                                       (Fa_bc_x_Fa_ab.map
                                          (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))) =
                   fst
                     (Fa_bc_x_Fa_ab.map (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                   snd
                     (Fa_bc_x_Fa_ab.map (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
              proof (cases "U.A.arr t")
                show "¬ U.A.arr t  ?thesis"
                  using a b c sub_rts_resid_eq
                        Fa_bc_x_Fa_ab.extensional PU.F.extensional PU.G.extensional
                        U.extensional Fa_bc.extensional Fa_ab.extensional
                        PU.A.not_arr_null B_HOM_bc_x_B_HOM_ab.not_arr_null
                  by auto
                assume t: "U.A.arr t"
                show ?thesis
                  using a b c t 1 RTS.Unpack_Pack Fa_bc_x_Fa_ab.preserves_reflects_arr
                        U.preserves_reflects_arr sub_rts_resid_eq
                  by auto
              qed
            qed
            also have "... =
                       (λt. F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                            F (snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))"
            proof
              fix t
              show "fst
                      (Fa_bc_x_Fa_ab.map
                         (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                    snd
                      (Fa_bc_x_Fa_ab.map
                         (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) =
                    F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                    F (snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
              proof (cases "U.A.arr t")
                show "¬ U.A.arr t  ?thesis"
                  using a b c U.extensional Fa_bc_x_Fa_ab.extensional F.extensional
                        HOMA_bc.null_char HOMA_ab.null_char HOMB_bc.null_char
                        HOMB_ab.null_char Fa_bc.extensional Fa_ab.extensional
                        sub_rts_resid_eq HOMA_bc.not_arr_null HOMA_ab.not_arr_null
                  by auto
                assume t: "U.A.arr t"
                show ?thesis
                  using a b c t 1 Fa_bc_x_Fa_ab.map_def U.preserves_reflects_arr
                        sub_rts_resid_eq B_HOM_ab.extensional_rts_axioms
                        B_HOM_bc.extensional_rts_axioms Fa_def
                        HOM_ab.extensional_rts_axioms HOM_bc.extensional_rts_axioms
                        RTS.bij_mkarr(3)
                  by auto
              qed
            qed
            also have "... = (λt. F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                                     snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))"
            proof
              fix t
              show "F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) B
                    F (snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) =
                    F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                       snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
              proof (cases "U.A.arr t")
                show "¬ U.A.arr t  ?thesis"
                  using a b c U.extensional F.extensional A.HOM_null_char
                        A.H.extensional B.H.extensional
                        A.H.null_is_zero(2) A.null_coincidence
                        B.H.null_is_zero(2) B.null_coincidence
                  by auto
                assume t: "U.A.arr t"
                have "A.H.seq (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) 
                              (snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
                  using A.HOM_arr_char HOM_bc_x_HOM_ab.arr_char a b c t by blast
                thus ?thesis
                  using a b c t U.preserves_reflects_arr F.preserves_comp
                  by auto
              qed
            qed
            also have "... = (λt. if HOM_ac.arr t then F t
                                  else ResiduatedTransitionSystem.partial_magma.null
                                         (B.HOMEC (Fo a) (Fo c))) 
                               (λt. fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                                    snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
            proof
              fix t
              show "F (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                       snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t)) =
                    ((λt. if HOM_ac.arr t
                          then F t
                          else ResiduatedTransitionSystem.partial_magma.null
                                 (B.HOMEC (Fo a) (Fo c))) 
                      (λt. fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                           snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t)))
                         t"
              proof (cases "U.A.arr t")
                show "¬ U.A.arr t  ?thesis"
                  using a b c U.extensional F.extensional A.HOM_null_char
                        A.H.null_is_zero(2) A.null_coincidence sub_rts_resid_eq
                        HOMB_ac.null_char
                  by auto
                assume t: "U.A.arr t"
                have "HOM_ac.arr (fst (RTS.Unpack (A.Hom b c) (A.Hom a b) t) A
                                  snd (RTS.Unpack (A.Hom b c) (A.Hom a b) t))"
                  by (meson A.H.comp_in_homI A.HOM_arr_char HOM_bc_x_HOM_ab.arr_char
                      U.preserves_reflects_arr a b c t)
                thus ?thesis
                  using a b c t sub_rts_resid_eq F.preserves_reflects_arr
                  by auto
              qed
            qed
            also have "... = RTS.Map (Fa a c)  RTS.Map (A.Comp a b c)"
              using a b c Fa_def [of a c] A.Comp_def [of a b c] sub_rts_resid_eq
              apply simp
              using 1 RTS.bij_mkarr(3) by force
            also have "... = RTS.Map (Fa a c  A.Comp a b c)"
              using RTS.Map_comp
              by (simp add: RTS.par
                               (B.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b))
                               (Fa a c  A.Comp a b c))
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

  end

section "Equivalence of RTS-Enriched Categories and RTS-Categories"

  text‹
    We now extend to an equivalence the correspondence between categories enriched
    in RTS and RTS-categories.
  ›

subsection "RTS-Category to Enriched Category to RTS-Category"

  context enriched_category_of_rts_category
  begin

    interpretation RC: rts_category_of_enriched_category arr_type
                         Obj Hom Id Comp ..

    no_notation RTS.prod     (infixr "" 51)

    interpretation Trn: simulation RC.resid resid
                         λt. if RC.arr t then RC.Trn t else null
    proof
      let ?Trn = "λt. if RC.arr t then RC.Trn t else null"
      show "t. ¬ RC.arr t  ?Trn t = null"
       by simp
      fix t u
      assume tu: "RC.V.con t u"
      interpret Hom: sub_rts resid λv. H.in_hom v (RC.Dom u) (RC.Cod u)
        using sub_rts_HOM by auto
      interpret HOM: hom_rts arr_type Obj Hom Id Comp
                       RC.Dom u RC.Cod u
        using tu RC.con_char RC.arr_char RC.V.con_implies_arr
        by unfold_locales blast+
      show con: "?Trn t  ?Trn u"
      proof -
        have "HOM.con (RC.Trn t) (RC.Trn u) 
              Hom.con (RC.Trn t) (RC.Trn u)"
          using tu Hom.con_char Hom_def RC.con_char RTS.bij_mkide(3) by auto
        thus ?thesis
          using tu Hom.con_char RC.con_char RC.Con_def by auto
      qed
      show "?Trn (RC.resid t u) = ?Trn t \\ ?Trn u"
      proof -
        have "HOMEC (RC.Dom t) (RC.Cod t) (RC.Trn t) (RC.Trn u) =
              RC.Trn t \\ RC.Trn u"
          using tu con RC.con_char Hom.con_char Hom_def Hom.resid_def RC.arr_char
                RTS.bij_mkide(3)
          by auto
        thus ?thesis
          using tu con by auto
      qed
    qed

    interpretation MkArr: simulation resid RC.resid
                            λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t
                                 else RC.null
    proof
      let ?MkArr = "λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t else RC.null"
      show "t. ¬ arr t  ?MkArr t = RC.null"
        by simp
      fix t u
      assume tu: "t  u"
      interpret Hom: sub_rts resid λt. H.in_hom t (H.dom u) (H.cod u)
        using tu sub_rts_HOM [of "H.dom u" "H.cod u"] arr_coincidence V.con_implies_arr
        by auto
      show con: "RC.V.con (?MkArr t) (?MkArr u)"
        using tu V.con_implies_arr arr_coincidence RC.con_char HOM_arr_char
              con_implies_hpar Hom.con_char H.in_homI HOM_agreement
        by (unfold RC.con_char) auto
      show "?MkArr (t \\ u) = RC.resid (?MkArr t) (?MkArr u)"
        using tu con arr_coincidence con_implies_hpar RC.con_char HOM_arr_char
              con_implies_hpar Hom.con_char H.in_homI HOM_agreement Hom.resid_def
        apply auto[1]
          apply (metis VV.F.preserves_trg dom_trg V.trg_def)
        by (metis VV.G.preserves_trg cod_trg V.trg_def)
    qed

    interpretation Trn_MkArr: inverse_simulations resid RC.resid
                                λt. if RC.arr t then RC.Trn t else null
                                λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t
                                     else RC.null
    proof
      let ?Trn = "λt. if RC.arr t then RC.Trn t else null"
      let ?MkArr = "λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t else RC.null"
      show "?MkArr  ?Trn = I RC.resid"
      proof
        fix t
        show "(?MkArr  ?Trn) t = I RC.resid t"
          apply auto[1]
          by (metis RC.Cod.simps(1) RC.Dom.simps(1) RC.Trn.simps(1)
              RC.arr.simps(2) RC.arr_char RC.arr_eqI RC.null_char H.in_homE
              HOM_arr_char)
      qed
      show "?Trn  ?MkArr = I resid" by auto
    qed

    lemma inverse_simulations_Trn_MkArr:
    shows "inverse_simulations resid RC.resid
             (λt. if RC.arr t then RC.Trn t else null)
             (λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t else RC.null)"
      ..

    interpretation Trn: "functor" RC.hcomp hcomp
                           λt. if RC.arr t then RC.Trn t else null
    proof
      let ?Trn = "λt. if RC.arr t then RC.Trn t else null"
      show "f. ¬ RC.H.arr f  ?Trn f = H.null"
        using null_coincidence RC.arr_coincidence by auto
      show 1: "f. RC.H.arr f  H.arr (?Trn f)"
        using RC.arr_coincidence arr_coincidence null_coincidence Trn.extensional
        by (metis Trn.preserves_reflects_arr)
      show "f. RC.H.arr f  H.dom (?Trn f) = ?Trn (RC.H.dom f)"
      proof -
        fix t
        assume t: "RC.H.arr t"
        have 2: "RC.arr (RC.MkArr (RC.Dom t) (RC.Dom t) (RC.Dom t))"
          using t RC.arr_coincidence RC.arr_char HOM_arr_char H.ide_in_hom
          by auto
        show "H.dom (?Trn t) = ?Trn (RC.H.dom t)"
        proof (intro H.dom_eqI)
          show 3: "H.ide (?Trn (RC.H.dom t))"
            using t 2 RC.arr_coincidence Id_def RC.arr_char
                  RTS.One.arr_char RTS.One.is_extensional_rts
                  RTS.One.small_rts_axioms RTS.bij_mkarr(3)
            by (auto simp add: RC.H_dom_simp RC.H_cod_simp)
          show "H.seq (?Trn t) (?Trn (RC.H.dom t))"
            by (metis 3 H.ide_char H.seqI RC.Dom.simps(1) RC.H_dom_simp
                RC.arr_coincidence Trn.preserves_reflects_arr
                Trn_MkArr.inv_simp arr_coincidence t)
        qed
      qed
      show "f. RC.H.arr f  H.cod (?Trn f) = ?Trn (RC.H.cod f)"
      proof -
        fix t
        assume t: "RC.H.arr t"
        have 2: "RC.arr (RC.MkArr (RC.Cod t) (RC.Cod t) (RC.Cod t))"
          using t RC.arr_coincidence RC.arr_char HOM_arr_char H.ide_in_hom
          by auto
        show "H.cod (?Trn t) = ?Trn (RC.H.cod t)"
        proof (intro H.cod_eqI)
          show 3: "H.ide (?Trn (RC.H.cod t))"
            using t 2 RC.arr_coincidence Id_def RC.arr_char
                  RTS.One.arr_char RTS.One.is_extensional_rts
                  RTS.One.small_rts_axioms RTS.bij_mkarr(3)
            by (auto simp add: RC.H_dom_simp RC.H_cod_simp)
          show "H.seq (?Trn (RC.H.cod t)) (?Trn t)"
            by (metis 1 3 H.ide_char H.seqI RC.Cod.simps(1)
                RC.H_cod_simp Trn.preserves_reflects_arr
                Trn_MkArr.inv_simp arr_coincidence t)
        qed
      qed
      fix f g
      assume fg: "RC.H.seq g f"
      interpret DOM: simulation
                       HOMEC (RC.Dom f) (RC.Cod f)
                       RTS.Rts (RTS.cod (Hom (RC.Dom f) (RC.Cod f)))
                       RTS.Map (Hom (RC.Dom f) (RC.Cod f))
        using fg ide_Hom RTS.ide_char RTS.arrD
        by (metis (no_types, lifting) RC.H.seqE RC.H_arr_char)
      interpret COD: simulation HOMEC (RC.Cod f) (RC.Cod g)
                       RTS.Rts (RTS.cod (Hom (RC.Cod f) (RC.Cod g)))
                       RTS.Map (Hom (RC.Cod f) (RC.Cod g))
        using fg ide_Hom RTS.ide_char RTS.arrD
        by (metis (no_types, lifting) RC.H.seqE RC.H_arr_char)
      interpret CODxDOM: product_rts
                           HOMEC (RC.Cod f) (RC.Cod g)
                           HOMEC (RC.Dom f) (RC.Cod f)
        ..
      interpret PU: inverse_simulations 
                      RTS.Rts
                         (RTS.dom
                            (Hom (RC.Cod f) (RC.Cod g) 
                               Hom (RC.Dom f) (RC.Cod f)))
                      CODxDOM.resid
                      RTS.Pack
                         (Hom (RC.Cod f) (RC.Cod g))
                         (Hom (RC.Dom f) (RC.Cod f))
                      RTS.Unpack
                         (Hom (RC.Cod f) (RC.Cod g))
                         (Hom (RC.Dom f) (RC.Cod f))
        using fg RC.H_seq_char RC.arr_char
              RTS.inverse_simulations_Pack_Unpack
        by simp
      have 4: "COD.A.arr (RC.Trn g)  DOM.A.arr (RC.Trn f)"
        using fg RC.arr_coincidence RC.H_arr_char
        by (elim RC.H.seqE) (auto simp add: RC.H_dom_simp RC.H_cod_simp)
      have "RTS.Unpack (Hom (RC.Cod f) (RC.Cod g)) (Hom (RC.Dom f) (RC.Cod f))
              (RTS.Pack (Hom (RC.Cod f) (RC.Cod g)) (Hom (RC.Dom f) (RC.Cod f))
                 (RC.Trn g, RC.Trn f)) =
            (RC.Trn g, RC.Trn f)"
        using PU.inv 4 by auto
      moreover have "RC.arr
                       (RC.MkArr (RC.Dom f) (RC.Cod g) (RC.Trn g  RC.Trn f))"
        by (metis (no_types, lifting) 4 RC.H.seqE RC.H_arr_char RC.arr_MkArr
            H.comp_in_homI HOM_arr_char fg)
      ultimately show "?Trn (RC.hcomp g f) = hcomp (?Trn g) (?Trn f)"
        using fg RC.hcomp_def Comp_def PU.inv RC.arr_coincidence RTS.Map_mkarr
        apply auto[1]
        using RC.arr_char RTS.bij_mkarr(3) by force
    qed

    interpretation MkArr: "functor" hcomp RC.hcomp
                            λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t
                                 else RC.null
    proof
      let ?MkArr = "λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t
                        else RC.null"
      show "f. ¬ H.arr f  ?MkArr f = RC.H.null"
        using arr_coincidence RC.null_coincidence by auto
      show "f. H.arr f  RC.H.arr (?MkArr f)"
        using arr_coincidence RC.arr_coincidence
        by (metis MkArr.preserves_reflects_arr)
      have 1: "f. H.arr f  RC.arr (RC.MkArr (H.dom f) (H.cod f) f)"
        using MkArr.preserves_reflects_arr arr_coincidence H.in_homI HOM_arr_char
        by (intro RC.arr_MkArr) auto
      thus "f. H.arr f  RC.H.dom (?MkArr f) = ?MkArr (H.dom f)"
        using RC.H_dom_char Id_def RTS.One.arr_char RTS.One.is_extensional_rts
              RTS.One.small_rts_axioms RTS.bij_mkarr(3)
        by auto
      show "f. H.arr f  RC.H.cod (?MkArr f) = ?MkArr (H.cod f)"
        using 1 RC.H_cod_char Id_def RTS.One.arr_char RTS.One.is_extensional_rts
              RTS.One.small_rts_axioms RTS.bij_mkarr(3)
        by auto
      show "g f. H.seq g f 
                     ?MkArr (g  f) = RC.hcomp (?MkArr g) (?MkArr f)"
      proof -
        fix f g
        assume fg: "H.seq g f"
        interpret COD: extensional_rts RTS.Rts (Hom (H.cod f) (H.cod g))
          using fg ide_Hom [of "H.cod f" "H.cod g"] arr_coincidence
          by (metis H.ide_cod H.seqE RTS.ideDRTSC(1) mem_Collect_eq)
        interpret DOM: extensional_rts RTS.Rts (Hom (H.dom f) (H.cod f))
          using fg ide_Hom [of "H.dom f" "H.cod f"] arr_coincidence
          by (metis H.ide_dom H.seqE RTS.ideDRTSC(1) mem_Collect_eq)
        interpret CODxDOM: product_rts
                             RTS.Rts (Hom (H.cod f) (H.cod g))
                             RTS.Rts (Hom (H.dom f) (H.cod f))
          ..
        show "?MkArr (g  f) = RC.hcomp (?MkArr g) (?MkArr f)"
        proof -
          have "RC.hcomp (?MkArr g) (?MkArr f) =
                RC.MkArr (dom f) (cod g)
                  (RTS.Map (Comp (dom f) (cod f) (cod g))
                    (RTS.Pack
                       (Hom (cod f) (cod g)) (Hom (dom f) (cod f)) (g, f)))"
            using fg RC.hcomp_def [of "?MkArr g" "?MkArr f"] H.seqE by auto
          also have "... = RC.MkArr (dom f) (cod g) (g  f)"
            by (metis 1 CODxDOM.arr_char H.seqE RC.Cod.simps(1)
                RC.Dom.simps(1) RC.Trn.simps(1) RC.arr_char Map_Comp_Pack
                fg fst_conv snd_conv)
          also have "... = ?MkArr (g  f)"
            using fg by simp
          finally show ?thesis by simp
        qed
      qed
    qed

    interpretation Trn_MkArr: inverse_functors hcomp RC.hcomp
                               λt. if RC.arr t then RC.Trn t else null
                               λt. if arr t
                                    then RC.MkArr (H.dom t) (H.cod t) t
                                    else RC.null
    proof
      let ?Trn = "λt. if RC.arr t then RC.Trn t else null"
      let ?MkArr = "λt. if arr t
                        then RC.MkArr (H.dom t) (H.cod t) t
                        else RC.null"
      show "?MkArr  ?Trn = RC.H.map"
        by (auto simp add: RC.H.map_def Trn_MkArr.inv)
      show "(?Trn  ?MkArr) = H.map"
        using arr_coincidence null_coincidence H.is_extensional by auto
    qed

    lemma inverse_functors_Trn_MkArr:
    shows "inverse_functors hcomp RC.hcomp
             (λt. if RC.arr t then RC.Trn t else null)
             (λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t else RC.null)"
      ..

    proposition induces_rts_category_isomorphism:
    shows "rts_category_isomorphism resid hcomp RC.resid RC.hcomp
             (λt. if arr t then RC.MkArr (H.dom t) (H.cod t) t else RC.null)"
      using Trn_MkArr.inverse_functors_axioms
            Trn_MkArr.inverse_simulations_axioms
      by unfold_locales auto

  end

subsection "Enriched Category to RTS-Category to Enriched Category"

  context rts_category_of_small_enriched_category
  begin

    text‹
      As it is easy to get lost in the types and definitions, we begin with a road map
      of the construction to be performed.
      We are given a small RTS-enriched category (Obj, Hom, Id, Comp)› with objects at type 'O›
      and as base category the category RTS with arrow type 'A rtscat.arr›.
      From this, we constructed a ``global RTS'' R› by stitching together all of the
      RTS's underlying the hom-objects.
      We then reduced the type of R› by taking its image under an injective map on
      arrows, to obtain an isomorphic RTS R'› at arrow type 'A›.
      The smallness assumption was used for this.
      Next, we will extend R'› to a locally small RTS-category R''› (new name is used to
      avoid name clashes within sublocales) by equipping it with the horizontal composition
      @{term hcomp'} derived from the composition of the originally given enriched category.
      From R''› we then construct an RTS-enriched category (R''.Obj R''.Hom R''.Id R''.Comp)›.
    ›

    interpretation R'': locally_small_rts_category R' hcomp'
      using is_locally_small_rts_category by blast

    interpretation R'': enriched_category_of_rts_category arr_type R' hcomp'
      ..

    text‹
      Our objective is now to construct a fully faithful RTS-enriched functor (Fo, Fa)›,
      from the originally given RTS-enriched category (Obj, Hom, Id, Comp)› to the newly
      constructed RTS-category (R''.Obj R''.Hom R''.Id R''.Comp)›.
      Note that this makes sense, because, due to the type reduction from R'› to R''›,
      we have arranged for the base category of (R''.Obj R''.Hom R''.Id R''.Comp)› to be the
      same category RTS as that of the originally given (Obj, Hom, Id, Comp)›.
      The object map Fo will take a ∈ Obj :: 'O set› to
      DN (MkArr a a (RTS.Map (Id a) one)) ∈ R''.Obj :: 'A set›.
      The arrow map Fa will take each pair (a, b)› of elements of Obj› to an invertible
      arrow «Fa a b : Hom a b → R''.Hom (Fo a) (Fo b)»› of RTS.
      This arrow corresponds to the invertible simulation from HOMEC a b› to
      R''.HOMEC (Fo a) (Fo b)› that takes t ∈ Hom a b› to
      DN (MkArr a b t) ∈ R''.HOMEC (Fo a) (Fo b)›.
    ›

     abbreviation Fo :: "'O  'A"
     where "Fo  λa. DN (MkArr a a (RTS.Map (Id a) RTS.One.the_arr))"

     abbreviation Fa :: "'O  'O  'A rtscat.arr"
     where "Fa  λa b. if a  Obj  b  Obj
                       then RTS.mkarr (HOMEC a b) (R''.HOMEC (Fo a) (Fo b))
                              (λt. if residuation.arr (HOMEC a b) t
                                   then DN (MkArr a b t)
                                   else ResiduatedTransitionSystem.partial_magma.null
                                         (R''.HOMEC (Fo a) (Fo b)))
                       else RTS.null"

     lemma ide_Fo:
     assumes "a  Obj"
     shows "DN (MkArr a a (RTS.Map (Id a) RTS.One.the_arr))  Collect H'.ide"
       using H'_ide_char Id_yields_horiz_ide assms obj_implies_sta by auto

     lemma bij_Fo:
     shows "bij_betw Fo Obj R''.Obj"
     proof -
       have "bij_betw (DN  (λA. MkArr A A (RTS.Map (Id A) RTS.One.the_arr)))
               Obj (Collect H'.ide)"
       proof -
         have "bij_betw DN (Collect H.ide) (Collect H'.ide)"
           using H'_ide_char H.ideD(1) H'.ideD(1)
           by (intro bij_betwI) auto
         thus ?thesis
           using bij_betw_Obj_horiz_ide bij_betw_trans by blast
       qed
       moreover
         have "DN  (λA. MkArr A A (RTS.Map (Id A) RTS.One.the_arr)) = Fo"
         by auto
       ultimately show ?thesis by simp
     qed

     lemma Fa_in_hom [intro, simp]:
     assumes "a  Obj" and "b  Obj"
     shows "«Fa a b : Hom a b  R''.Hom (Fo a) (Fo b)»"
     proof
       show "RTS.arr (Fa a b)"
       proof -
         have "RTS.arr
                 ((RTS.mkarr (HOMEC a b) (R''.HOMEC (Fo a) (Fo b))
                     (λt. if residuation.arr (HOMEC a b) t then DN (MkArr a b t)
                          else ResiduatedTransitionSystem.partial_magma.null
                                 (R''.HOMEC (Fo a) (Fo b)))))"
         proof (intro RTS.arrIRTSC)
           interpret HOM: extensional_rts HOMEC a b
             using assms by simp
           interpret HOM': extensional_rts R''.HOMEC (Fo a) (Fo b)
             using assms R''.ide_Hom RTS.ideDRTSC RTS.arrD
             by (metis (no_types, lifting) ide_Fo)
           show "extensional_rts (HOMEC a b)  small_rts (HOMEC a b)"
             using assms by simp
           show "extensional_rts (R''.HOMEC (Fo a) (Fo b)) 
                   small_rts (R''.HOMEC (Fo a) (Fo b))"
             using assms R''.ide_Hom RTS.ideDRTSC RTS.arrD
             by (metis (no_types, lifting) ide_Fo)
           text‹
             To prove the rest we need information about R''.HOMEC (Fo a) (Fo b)›.
             Rather than just having it as an abstract RTS, we need to know that
             it is a sub-RTS of R'›, which in turn is isomorphic (via DN)
             to the ``global RTS'' R›, which has arrows of the form MkArr a b t›.
           ›
           have *: "R''.HOMEC (Fo a) (Fo b) =
                    sub_rts.resid R' (λt. H'.in_hom t (Fo a) (Fo b))"
             using assms R''.Hom_def [of "Fo a" "Fo b"] ide_Fo RTS.bij_mkide(3)
             by simp
           interpret HOM'_alt: sub_rts R' λt. H'.in_hom t (Fo a) (Fo b)
             using assms ide_Fo R''.sub_rts_HOM by metis
           have "(λt. if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                    Collect (simulation (HOMEC a b) (R''.HOMEC (Fo a) (Fo b)))"
           proof
             show "simulation (HOMEC a b) (R''.HOMEC (Fo a) (Fo b))
                     (λt. if HOM.arr t then DN (MkArr a b t) else HOM'.null)"
             proof
               show "t. ¬ HOM.arr t 
                             (if HOM.arr t then DN (MkArr a b t) else HOM'.null) =
                             HOM'.null"
                 by simp
               fix t u
               assume tu: "HOM.con t u"
               have 0: "V.con (MkArr a b t) (MkArr a b u)"
                 using tu Con_def
                 by (simp add: assms(1-2) con_char HOM.con_implies_arr(1-2))
               have 1: "R'.con (DN (MkArr a b t)) (DN (MkArr a b u))"
                 using 0 UP_DN.G.preserves_con by simp
               have 2: "HOM'_alt.con (DN (MkArr a b t)) (DN (MkArr a b u))"
               proof -
                 have "H'.in_hom (DN (MkArr a b t)) (Fo a) (Fo b)"
                 proof -
                   have "H.arr (UP (DN (MkArr a b t)))"
                     using "1" R'.con_implies_arr(1) by auto
                   thus ?thesis
                     using assms
                     by (simp add: H'.in_homI H'_cod_char H'_dom_char
                         H_cod_char H_dom_char)
                 qed
                 moreover have "H'.in_hom (DN (MkArr a b u)) (Fo a) (Fo b)"
                   by (metis (no_types, lifting) "1" H'.in_homE H'.in_homI
                       R''.con_implies_hpar calculation)
                 ultimately show ?thesis
                   using 1 HOM'_alt.con_char by blast
               qed
               show "HOM'.con (if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                              (if HOM.arr u then DN (MkArr a b u) else HOM'.null)"
                 using tu * 2 HOM.con_implies_arr by auto
               show "(if HOM.arr (HOMEC a b t u)
                      then DN (MkArr a b (HOMEC a b t u))
                      else HOM'.null) =
                     R''.HOMEC (Fo a) (Fo b)
                       (if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                       (if HOM.arr u then DN (MkArr a b u) else HOM'.null)"
               proof -
                 have "(if HOM.arr (HOMEC a b t u)
                        then DN (MkArr a b (HOMEC a b t u))
                        else HOM'.null) =
                       HOM'_alt.resid
                         (if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                         (if HOM.arr u then DN (MkArr a b u) else HOM'.null)"
                 proof -
                   have "H'.in_hom (DN (MkArr a b t)) (Fo a) (Fo b)"
                     using assms tu 2 HOM'_alt.con_char by fastforce
                   moreover have "H'.in_hom (DN (MkArr a b u)) (Fo a) (Fo b)"
                     using assms tu 2 HOM'_alt.con_char by fastforce
                   moreover have "R' (DN (MkArr a b t)) (DN (MkArr a b u)) =
                                  DN (MkArr a b (HOMEC a b t u))"
                     by (metis "0" Cod.simps(1) Dom.simps(1) Trn.simps(1)
                         UP_DN.G.preserves_resid con_char resid.simps(3))
                   ultimately show ?thesis
                     unfolding HOM'_alt.resid_def
                     using tu 1 HOM.con_implies_arr UP_DN.inv UP_DN.inv' by auto
                 qed
                 also have "... = R''.HOMEC (Fo a) (Fo b)
                                    (if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                                    (if HOM.arr u then DN (MkArr a b u) else HOM'.null)"
                   using * by simp
                 finally show ?thesis by simp
               qed
             qed
           qed
           thus "RTS.mkarr (HOMEC a b) (R''.HOMEC (Fo a) (Fo b))
                   (λt. if HOM.arr t then DN (MkArr a b t) else HOM'.null)
                    RTS.mkarr (HOMEC a b) (R''.HOMEC (Fo a) (Fo b)) `
                       Collect (simulation (HOMEC a b) (R''.HOMEC (Fo a) (Fo b)))"
             by auto
         qed
         thus ?thesis
           using assms by simp
       qed
       show "RTS.dom (Fa a b) = Hom a b"
         using assms(1-2) RTS.arr (Fa a b) by auto
       show "RTS.cod (Fa a b) = R''.Hom (Fo a) (Fo b)"
         using assms(1-2) RTS.arr (Fa a b) ide_Fo by auto
     qed

     lemma Fa_simps [simp]:
     assumes "a  Obj" and "b  Obj"
     shows "RTS.arr (Fa a b)"
     and "RTS.dom (Fa a b) = Hom a b"
     and "RTS.cod (Fa a b) = R''.Hom (Fo a) (Fo b)"
       using assms Fa_in_hom by blast+

     lemma Map_Fa_simp [simp]:
     assumes "a  Obj" and "b  Obj" and "residuation.arr (HOMEC a b) t"
     shows "RTS.Map (Fa a b) t = DN (MkArr a b t)"
       using assms RTS.bij_mkarr(3) ide_Fo by force

     interpretation Φ: rts_enriched_functor
                          Obj Hom Id Comp R''.Obj R''.Hom R''.Id R''.Comp
                          Fo Fa
     proof
       show "a. a  Obj  Fo a  R''.Obj"
         using ide_Fo by blast
       show "a b. a  Obj; b  Obj 
                      «Fa a b : Hom a b  R''.Hom (Fo a) (Fo b)»"
         using Fa_in_hom by blast
       show "a b. a  Obj  b  Obj  Fa a b = RTS.null"
         by auto
       show "a. a  Obj  Fa a a  Id a = R''.Id (Fo a)"
       proof -
         fix a
         assume a: "a  Obj"
         show "Fa a a  Id a = R''.Id (Fo a)"
         proof (intro RTS.arr_eqI)
           show 1: "RTS.par (Fa a a  Id a) (R''.Id (Fo a))"
             using a Id_in_hom R''.Id_in_hom Fa_in_hom ide_Fo RTS.in_homE
             apply (intro conjI)
                apply auto[1]
             by fastforce+
           show "RTS.Map (Fa a a  Id a) = RTS.Map (R''.Id (Fo a))"
           proof -
             interpret Map_Id_a: simulation RTS.One.resid HOMEC a a
                                   RTS.Map (Id a)
               using a Id_in_hom [of a] RTS.arrD(3) [of "Id a"] RTS.unity_agreement
               by auto
             interpret Map_Fa_aa: simulation
                                    HOMEC a a RTS.Rts (R''.Hom (Fo a) (Fo a))
                                    RTS.Map (Fa a a)
               using a Fa_in_hom [of a a] RTS.arrD(3) by fastforce
             interpret Map_Fa_aa_o_Map_Id_a: simulation
                                               RTS.One.resid
                                               RTS.Rts (R''.Hom (Fo a) (Fo a))
                                               RTS.Map (Fa a a)  RTS.Map (Id a)
               using simulation_comp Map_Id_a.simulation_axioms
                     Map_Fa_aa.simulation_axioms
               by blast
             interpret Map_R''_Id_Fo_a: simulation
                                          RTS.One.resid
                                          RTS.Rts (R''.Hom (Fo a) (Fo a))
                                          RTS.Map (R''.Id (Fo a))
               using a
               by (metis (no_types, lifting) R''.Id_in_hom RTS.Rts_one RTS.arrD(3)
                   RTS.in_homE RTS.unity_agreement ide_Fo)
             have "RTS.Map (Fa a a  Id a) = RTS.Map (Fa a a)  RTS.Map (Id a)"
               using 1 RTS.Map_comp by blast
             also have "... = RTS.Map (R''.Id (Fo a))"
               using Map_Id_a.preserves_reflects_arr Map_R''_Id_Fo_a.extensional
                     R''.Id_def RTS.One.arr_char RTS.One.is_extensional_rts
                     RTS.One.small_rts_axioms RTS.bij_mkarr(3) a ide_Fo
               by auto
             finally show ?thesis by blast
           qed
         qed
       qed
       show "a b c. a  Obj; b  Obj; c  Obj 
                        R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b) =
                        Fa a c  Comp a b c"
       proof -
         fix a b c
         assume a: "a  Obj" and b: "b  Obj" and c: "c  Obj"
         show "R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b) =
               Fa a c  Comp a b c"
         proof (intro RTS.arr_eqI)
           show 1: "RTS.par
                      (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b))
                      (Fa a c  Comp a b c)"
           proof (intro conjI)
             show 2: "RTS.seq (R''.Comp (Fo a) (Fo b) (Fo c)) (Fa b c  Fa a b)"
               using a b c Fa_in_hom ide_Fo R''.Comp_in_hom R''.Hom_def by blast
             show 3: "RTS.seq (Fa a c) (Comp a b c)"
               using a b c Fa_in_hom ide_Fo R''.Comp_in_hom R''.Hom_def by blast
             show "RTS.dom (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                   RTS.dom (Fa a c  Comp a b c)"
             proof -
               have "RTS.dom (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                     RTS.dom (Fa b c  Fa a b)"
                 using a b c 2 R''.Comp_in_hom by auto
               also have "... = Hom b c  Hom a b"
                 using a b c Fa_in_hom
                 by (meson RTS.CMC.dom_tensor)
               also have "... = RTS.dom (Fa a c  Comp a b c)"
                 using a b c 3 Comp_in_hom [of a b c] by auto
               finally show ?thesis by blast
             qed
             show "RTS.cod (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                   RTS.cod (Fa a c  Comp a b c)"
             proof -
               have "RTS.cod (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                     RTS.cod (R''.Comp (Fo a) (Fo b) (Fo c))"
                 using a b c 2 Fa_in_hom R''.Comp_in_hom by auto
               also have "... = RTS.cod (Fa a c  Comp a b c)"
                 using a b c 3 ide_Fo R''.Comp_in_hom by auto
               finally show ?thesis by blast
             qed
           qed
           show "RTS.Map (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) =
                 RTS.Map (Fa a c  Comp a b c)"
           proof
             interpret Dom_bc: extensional_rts HOMEC b c
               using b c by simp
             interpret Dom_ab: extensional_rts HOMEC a b
               using a b by simp
             interpret Dom_bc_X_Dom_ab: product_rts HOMEC b c HOMEC a b
               ..
             interpret Dom_bcxab: extensional_rts RTS.Rts (Hom b c  Hom a b)
               using a b c by simp
             have 3: "RTS.ide (RTS.dom (Fa b c))  RTS.ide (RTS.dom (Fa a b))"
               using a b c Fa_in_hom RTS.ide_dom by blast
             have 4: "RTS.ide (RTS.cod (Fa b c))  RTS.ide (RTS.cod (Fa a b))"
               using a b c Fa_in_hom RTS.ide_cod by blast
             interpret Cod_bc: extensional_rts RTS.Rts (RTS.cod (Fa b c))
               using 4 RTS.ide_char RTS.arrD RTS.arr_cod_iff_arr
               by (metis (no_types, lifting))
             interpret Cod_ab: extensional_rts RTS.Rts (RTS.cod (Fa a b))
               using 4 RTS.ide_char RTS.arrD RTS.arr_cod_iff_arr
               by (metis (no_types, lifting))
             interpret Cod_bc_X_Cod_ab: product_rts
                                          RTS.Rts (RTS.cod (Fa b c))
                                          RTS.Rts (RTS.cod (Fa a b))
               ..
             interpret Fabc: simulation HOMEC b c
                               RTS.Rts (RTS.cod (Fa b c))
                               RTS.Map (Fa b c)
               using b c Fa_in_hom [of b c] RTS.arrD(3) [of "Fa b c"] by auto
             interpret Faab: simulation HOMEC a b
                               RTS.Rts (RTS.cod (Fa a b))
                               RTS.Map (Fa a b)
               using a b Fa_in_hom [of a b] RTS.arrD(3) [of "Fa a b"] by auto
             interpret Fabc_X_Faab: product_simulation
                                     HOMEC b c HOMEC a b
                                     RTS.Rts (RTS.cod (Fa b c))
                                     RTS.Rts (RTS.cod (Fa a b))
                                     RTS.Map (Fa b c) RTS.Map (Fa a b)
               ..
             interpret U: simulation
                            RTS.Rts (Hom b c  Hom a b)
                            Dom_bc_X_Dom_ab.resid
                            RTS.Unpack (RTS.dom (Fa b c)) (RTS.dom (Fa a b))
             proof -
               have "RTS.arr (Fa b c)  RTS.arr (Fa a b)"
                 using a b c Fa_in_hom by blast
               thus "simulation
                       (RTS.Rts (Hom b c  Hom a b))
                       Dom_bc_X_Dom_ab.resid
                       (RTS.Unpack (RTS.dom (Fa b c)) (RTS.dom (Fa a b)))"
                 using a b c 1 Fa_in_hom
                       RTS.simulation_Unpack [of "Hom b c" "Hom a b"]
                 by fastforce
             qed
             fix x
             show "RTS.Map
                     (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) x =
                   RTS.Map (Fa a c  Comp a b c) x"
             proof (cases "Dom_bcxab.arr x")
               show "¬ Dom_bcxab.arr x 
                       RTS.Map
                         (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) x =
                       RTS.Map (Fa a c  Comp a b c) x"
               proof -
                 interpret LHS: simulation
                                  RTS.Rts (Hom b c  Hom a b)
                                  R''.HOMEC (Fo a) (Fo c)
                                  RTS.Map
                                     (R''.Comp (Fo a) (Fo b) (Fo c) 
                                        (Fa b c  Fa a b))
                 proof -
                   have "RTS.seq (R''.Comp (Fo a) (Fo b) (Fo c)) (Fa b c  Fa a b)"
                     using a b c 1 ide_Fo by force
                   moreover have "RTS.Dom
                                    (R''.Comp (Fo a) (Fo b) (Fo c) 
                                       (Fa b c  Fa a b)) =
                                  RTS.Rts (Hom b c  Hom a b)"
                     using a b c 1 ide_Fo R''.ide_Hom R''.Comp_in_hom
                     by (metis (no_types, lifting) Comp_in_hom RTS.dom_comp
                         RTS.in_homE)
                   moreover have "RTS.Cod
                                    (R''.Comp (Fo a) (Fo b) (Fo c) 
                                       (Fa b c  Fa a b)) =
                                  R''.HOMEC (Fo a) (Fo c)"
                     using a b c 1 ide_Fo R''.ide_Hom R''.Comp_in_hom
                     by (metis (no_types, lifting) R''.Comp_simps(3) RTS.cod_comp)
                   ultimately
                   show "simulation
                           (RTS.Rts
                              (Hom b c  Hom a b)) (R''.HOMEC (Fo a) (Fo c))
                           (RTS.Map
                              (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)))"
                     using a b c 1 ide_Fo
                           RTS.arrD(3)
                             [of "R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)"]
                     by auto
                 qed
                 interpret RHS: simulation
                                  RTS.Rts (Hom b c  Hom a b)
                                  R''.HOMEC (Fo a) (Fo c)
                                  RTS.Map (Fa a c  Comp a b c)
                 proof -
                   have "RTS.seq (Fa a c) (Comp a b c)"
                     using a b c 1 ide_Fo by force
                   moreover have "RTS.Dom (Fa a c  Comp a b c) =
                                  RTS.Rts (Hom b c  Hom a b)"
                     using a b c 1 ide_Fo R''.ide_Hom R''.Comp_in_hom
                     by (metis (no_types, lifting) Comp_in_hom RTS.dom_comp
                         RTS.in_homE)
                   moreover have "RTS.Cod (Fa a c  Comp a b c) =
                                  R''.HOMEC (Fo a) (Fo c)"
                     using a b c 1 ide_Fo R''.ide_Hom R''.Comp_in_hom
                     by (metis (no_types, lifting) R''.Comp_simps(3) RTS.cod_comp)
                  ultimately
                   show "simulation
                           (RTS.Rts
                              (Hom b c  Hom a b)) (R''.HOMEC (Fo a) (Fo c))
                           (RTS.Map (Fa a c  Comp a b c))"
                     using a b c 1 ide_Fo
                           RTS.arrD(3) [of "Fa a c  Comp a b c"]
                     by auto
                 qed
                 assume x: "¬ Dom_bcxab.arr x"
                 show "RTS.Map
                         (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) x =
                       RTS.Map (Fa a c  Comp a b c) x"
                   using x LHS.extensional RHS.extensional by presburger
               qed
               assume x: "Dom_bcxab.arr x"
               have 0: "Dom_bc_X_Dom_ab.arr (RTS.Unpack (Hom b c) (Hom a b) x)"
                 using a b c x U.preserves_reflects_arr [of x]
                       Fa_in_hom [of b c] Fa_in_hom [of a b]
                       Dom_bc_X_Dom_ab.arr_char
                 by (metis (no_types, lifting) RTS.in_homE)

               have "RTS.Map
                       (R''.Comp (Fo a) (Fo b) (Fo c)  (Fa b c  Fa a b)) x =
                     RTS.Map
                       (R''.Comp (Fo a) (Fo b) (Fo c))
                       (RTS.Map (Fa b c  Fa a b) x)"
                 using a b c 1 ide_Fo RTS.Map_comp by auto
               also have "... =
                          fst (RTS.Unpack
                                 (R''.Hom (Fo b) (Fo c)) (R''.Hom (Fo a) (Fo b))
                                    (RTS.Map (Fa b c  Fa a b) x)) ⋆´
                            snd (RTS.Unpack
                                   (R''.Hom (Fo b) (Fo c))
                                   (R''.Hom (Fo a) (Fo b))
                                   (RTS.Map (Fa b c  Fa a b) x))"
                 using a b c R''.Comp_def RTS.bij_mkarr(3)
                       a. a  Obj  Fo a  R''.Obj
                 by force
               also have "... =
                          fst (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                 (RTS.Map (Fa b c  Fa a b) x)) ⋆´
                            snd (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                   (RTS.Map (Fa b c  Fa a b) x))"
               proof -
                 have "R''.Hom (Fo b) (Fo c) = RTS.cod (Fa b c)"
                   using a b c ide_Fo Fa_in_hom R''.Hom_def by force
                 moreover have "R''.Hom (Fo a) (Fo b) = RTS.cod (Fa a b)"
                   using a b c ide_Fo Fa_in_hom R''.Hom_def by force
                 ultimately show ?thesis by argo
               qed
               also have "... =
                          fst
                            (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                               ((RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b)) 
                                   product_simulation.map
                                     (HOMEC b c) (HOMEC a b)
                                     (RTS.Map (Fa b c)) (RTS.Map (Fa a b)) 
                                       RTS.Unpack
                                         (RTS.dom (Fa b c)) (RTS.dom (Fa a b))) x)) ⋆´
                            snd
                              (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                 ((RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b)) 
                                     Fabc_X_Faab.map 
                                        RTS.Unpack
                                          (RTS.dom (Fa b c)) (RTS.dom (Fa a b))) x))"
               proof -
                 have "RTS.Map (Fa b c  Fa a b) =
                       RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b)) 
                         product_simulation.map
                           (RTS.Dom (Fa b c)) (RTS.Dom (Fa a b))
                           (RTS.Map (Fa b c)) (RTS.Map (Fa a b)) 
                              RTS.Unpack (RTS.dom (Fa b c)) (RTS.dom (Fa a b))"
                   using a b c 4 RTS.Map_prod [of "Fa b c" "Fa a b"] Fa_in_hom
                   by (metis (no_types, lifting) RTS.arr_cod_iff_arr RTS.ideD(1)
                       RTS.tensor_agreement)
                 moreover have "RTS.Dom (Fa b c) = HOMEC b c 
                                  RTS.Dom (Fa a b) = HOMEC a b"
                   using a b c Fa_in_hom [of b c] Fa_in_hom [of a b] by auto
                 ultimately show ?thesis by simp
               qed
               also have "... =
                          fst (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                 (RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                    (Fabc_X_Faab.map
                                      (RTS.Unpack (Hom b c) (Hom a b) x)))) ⋆´
                          snd (RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                (RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                    (Fabc_X_Faab.map
                                      (RTS.Unpack (Hom b c) (Hom a b) x))))"
                 using a b c Fa_in_hom [of b c] Fa_in_hom [of a b] by fastforce
               also have "... =
                          fst
                            (Fabc_X_Faab.map
                               (RTS.Unpack (Hom b c) (Hom a b) x)) ⋆´
                          snd
                            (Fabc_X_Faab.map
                               (RTS.Unpack (Hom b c) (Hom a b) x))"
               proof -
                 have 1: "RTS.ide (RTS.cod (Fa b c))  RTS.ide (RTS.cod (Fa a b))"
                   using a b c Fa_in_hom RTS.ide_cod by blast
                 interpret PU: inverse_simulations
                                 RTS.Rts (RTS.cod (Fa b c)  RTS.cod (Fa a b))
                                 Cod_bc_X_Cod_ab.resid
                                 RTS.Pack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                                 RTS.Unpack (RTS.cod (Fa b c)) (RTS.cod (Fa a b))
                   using a b c 1 Fa_in_hom [of a b] Fa_in_hom [of b c]
                         RTS.inverse_simulations_Pack_Unpack
                   by fastforce
                 show ?thesis
                 proof -
                   have "Cod_bc_X_Cod_ab.arr
                           (Fabc_X_Faab.map
                              (RTS.Unpack (Hom b c) (Hom a b) x))"
                     using a b c x U.preserves_reflects_arr
                           Fa_in_hom [of b c] Fa_in_hom [of a b]
                     by fastforce
                   thus ?thesis by simp
                 qed
               qed
               also have "... =
                          RTS.Map (Fa b c)
                            (fst (RTS.Unpack (Hom b c) (Hom a b) x)) ⋆´
                          RTS.Map
                            (Fa a b) (snd (RTS.Unpack (Hom b c) (Hom a b) x))"
                 using 0 Fabc_X_Faab.map_def by auto
               also have "... =
                          DN (MkArr b c
                                (fst (RTS.Unpack (Hom b c) (Hom a b) x))) ⋆´
                          DN (MkArr a b
                                (snd (RTS.Unpack (Hom b c) (Hom a b) x)))"
                 using a b c 0 Map_Fa_simp by auto
               also have "... =
                          DN (MkArr b c (fst (RTS.Unpack (Hom b c) (Hom a b) x)) 
                                MkArr a b (snd (RTS.Unpack (Hom b c) (Hom a b) x)))"
                 using 0 a b c arr_MkArr by force
               also have "... =
                          DN (MkArr a c
                                (RTS.Map (Comp a b c)
                                   (RTS.Pack (Hom b c) (Hom a b)
                                      (RTS.Unpack (Hom b c) (Hom a b) x))))"
                 using 0 a b c x hcomp_def
                 by (simp add: arr_MkArr) 
               also have "... = DN (MkArr a c (RTS.Map (Comp a b c) x))"
               proof -
                 interpret PU: inverse_simulations
                                 RTS.Rts (Hom b c  Hom a b)
                                 Dom_bc_X_Dom_ab.resid
                                 RTS.Pack (Hom b c) (Hom a b)
                                 RTS.Unpack (Hom b c) (Hom a b)
                   using a b c RTS.inverse_simulations_Pack_Unpack by simp
                 show ?thesis
                    using a b c x PU.inv' by simp
               qed
               also have "... = RTS.Map (Fa a c) (RTS.Map (Comp a b c) x)"
                 using a b c x Map_Fa_simp R''.HOM_null_char RTS.bij_mkarr(3)
                       UP_DN.G.extensional arr_char ide_Fo
                 by force
               also have "... = (RTS.Map (Fa a c)  RTS.Map (Comp a b c)) x"
                 by simp
               also have "... = RTS.Map (Fa a c  Comp a b c) x"
                 using a b c x Fa_in_hom [of a c] Comp_in_hom [of a b c]
                       RTS.Map_comp by fastforce
               finally show ?thesis by blast
             qed
           qed
         qed
       qed
     qed

     lemma induces_rts_enriched_functor:
     shows "rts_enriched_functor
              Obj Hom Id Comp R''.Obj R''.Hom R''.Id R''.Comp Fo Fa"
       ..

     proposition induces_fully_faithful_rts_enriched_functor:
     shows "fully_faithful_rts_enriched_functor
              Obj Hom Id Comp R''.Obj R''.Hom R''.Id R''.Comp Fo Fa"
     proof
       show "a b. a  Obj; b  Obj  RTS.iso (Fa a b)"
       proof -
         fix a b
         assume a: "a  Obj" and b: "b  Obj"
         (* TODO: Figure out how to avoid or generalize this frequently occuring fact. *)
         have *: "R''.HOMEC (Fo a) (Fo b) =
                  sub_rts.resid R' (λt. H'.in_hom t (Fo a) (Fo b))"
           using a b R''.Hom_def [of "Fo a" "Fo b"] ide_Fo RTS.bij_mkide(3) by auto
         show "RTS.iso (Fa a b)"
         proof -
           have "invertible_simulation
                   (RTS.Rts (RTS.dom (Fa a b))) (RTS.Rts (RTS.cod (Fa a b)))
                   (RTS.Map (Fa a b))"
           proof (unfold invertible_simulation_iff, intro conjI)
             interpret Fa_ab: simulation
                                RTS.Rts (RTS.dom (Fa a b))
                                RTS.Rts (RTS.cod (Fa a b))
                                RTS.Map (Fa a b)
               using a b Fa_in_hom RTS.arrD by blast
             show "simulation
                     (RTS.Rts (RTS.dom (Fa a b))) (RTS.Rts (RTS.cod (Fa a b)))
                     (RTS.Map (Fa a b))"
               using Fa_ab.simulation_axioms by simp
             show "bij_betw (RTS.Map (Fa a b))
                     (Collect (residuation.arr (RTS.Rts (RTS.dom (Fa a b)))))
                     (Collect (residuation.arr (RTS.Rts (RTS.cod (Fa a b)))))"
             proof (intro bij_betwI)
               have Dom: "RTS.Rts (RTS.dom (Fa a b)) = HOMEC a b"
                 using a b Fa_in_hom [of a b] by auto
               have Cod: "RTS.Rts (RTS.cod (Fa a b)) = R''.HOMEC (Fo a) (Fo b)"
                 using a b Fa_in_hom [of a b] by auto
               interpret DOM'_alt: sub_rts R' λt. H'.in_hom t (Fo a) (Fo b)
                 using a b ide_Fo R''.sub_rts_HOM by metis
               have Map: "RTS.Map (Fa a b) =
                          (λt. if residuation.arr (HOMEC a b) t
                               then DN (MkArr a b t)
                               else ResiduatedTransitionSystem.partial_magma.null
                                      (R''.HOMEC (Fo a) (Fo b)))"
                 using RTS.bij_mkarr(3) a b ide_Fo by auto
               show "RTS.Map (Fa a b)  Collect Fa_ab.A.arr  Collect Fa_ab.B.arr"
                 using Fa_ab.preserves_reflects_arr by blast
               let ?g = "λt. if Fa_ab.B.arr t then Trn (UP t) else Fa_ab.A.null"
               show g_mapsto: "?g  Collect Fa_ab.B.arr  Collect Fa_ab.A.arr"
               proof
                 fix t
                 assume t: "t  Collect Fa_ab.B.arr"
                 have gt: "?g t = Trn (UP t)"
                   using t by simp
                 have "arr (UP t)"
                   using a b t Cod UP_DN.F.preserves_reflects_arr
                         R''.HOM_arr_char ide_Fo
                   by fastforce
                 moreover have "Dom (UP t) = a"
                 proof -
                   have 1: "DOM'_alt.arr t"
                     using t * Cod by auto
                   have "Dom (UP t) = Dom (H.dom (UP t))"
                     using t
                     by (simp add: H_dom_char UP_DN.F.extensional)
                   also have "... = Dom (UP (H'.dom t))"
                     using t 1 H'_dom_char UP_DN.inv'_simp [of "H.dom (UP t)"]
                           DOM'_alt.arr_char DOM'_alt.inclusion
                     by auto
                   also have "... = Dom (UP (Fo a))"
                     using 1 DOM'_alt.arr_char by auto
                   also have "... = a"
                     using a Id_yields_horiz_ide
                     by (simp add: H_ide_char horizontal_unit_def)
                   finally show ?thesis by blast
                 qed
                 moreover have "Cod (UP t) = b"
                 proof -
                   have 1: "DOM'_alt.arr t"
                     using t * Cod by auto
                   have "Cod (UP t) = Cod (H.cod (UP t))"
                     using t H_cod_char
                     by (metis (no_types, lifting) Cod.simps(1) cod.extensional
                         H_cod_simp UP_DN.F.extensional UP_DN.F.preserves_reflects_arr)
                   also have "... = Cod (UP (H'.cod t))"
                     using t 1 H'_cod_char UP_DN.inv'_simp
                           DOM'_alt.arr_char DOM'_alt.inclusion
                     by auto
                   also have "... = Cod (UP (Fo b))"
                     using 1 DOM'_alt.arr_char by auto
                   also have "... = b"
                     using b Id_yields_horiz_ide
                     by (simp add: H_ide_char horizontal_unit_def)
                   finally show ?thesis by blast
                 qed
                 ultimately have "residuation.arr (HOMEC a b) (Trn (UP t))"
                   using arr_char by blast
                 thus "?g t  Collect Fa_ab.A.arr"
                   using gt Dom by simp
               qed
               show "x. x  Collect Fa_ab.A.arr  ?g (RTS.Map (Fa a b) x) = x"
               proof -
                 fix x
                 assume x: "x  Collect Fa_ab.A.arr"
                 have "?g (RTS.Map (Fa a b) x) = Trn (UP (DN (MkArr a b x)))"
                   using a b x Fa_ab.preserves_reflects_arr RTS.Map_mkarr
                   apply auto[1]
                   using Dom Map by force
                 also have "... = x"
                   using Dom a b x arr_MkArr by auto
                 finally show "?g (RTS.Map (Fa a b) x) = x" by blast
               qed
               show "y. y  Collect Fa_ab.B.arr  RTS.Map (Fa a b) (?g y) = y"
               proof -
                 fix y
                 assume y: "y  Collect Fa_ab.B.arr"
                 have "RTS.Map (Fa a b) (?g y) = DN (MkArr a b (Trn (UP y)))"
                   using a b y * DOM'_alt.null_char Map
                         UP_DN.G.extensional arr_char
                   by auto
                 also have "... = y"
                 proof -
                   have "arr (UP y)"
                     using Cod R''.HOM_arr_char a b ide_Fo y by fastforce
                   moreover have "Dom (UP y) = a"
                   proof -
                     have 1: "DOM'_alt.arr y"
                       using y * Cod by auto
                     have "Dom (UP y) = Dom (H.dom (UP y))"
                       using y
                       by (simp add: H_dom_char UP_DN.F.extensional)
                     also have "... = Dom (UP (H'.dom y))"
                       using y H'_dom_char UP_DN.inv'_simp
                       apply auto[1]
                       using 1 DOM'_alt.arr_char DOM'_alt.inclusion by force
                     also have "... = Dom (UP (Fo a))"
                       using 1 DOM'_alt.arr_char by auto
                     also have "... = a"
                       using a Id_yields_horiz_ide
                       by (simp add: H_ide_char horizontal_unit_def)
                     finally show ?thesis by blast
                   qed
                   moreover have "Cod (UP y) = b"
                   proof -
                     have 1: "DOM'_alt.arr y"
                       using y * Cod by auto
                     have "Cod (UP y) = Cod (H.cod (UP y))"
                       using y H_cod_char
                       by (metis (no_types, lifting) Cod.simps(1) cod.extensional
                           H_cod_simp UP_DN.F.extensional UP_DN.F.preserves_reflects_arr)
                     also have "... = Cod (UP (H'.cod y))"
                       using y H'_cod_char UP_DN.inv'_simp
                       apply auto[1]
                       using 1 DOM'_alt.arr_char DOM'_alt.inclusion by simp
                     also have "... = Cod (UP (Fo b))"
                       using 1 DOM'_alt.arr_char by auto
                     also have "... = b"
                       using b Id_yields_horiz_ide
                       by (simp add: H_ide_char horizontal_unit_def)
                     finally show ?thesis by blast
                   qed
                   ultimately show ?thesis
                     using a b y MkArr_Trn [of "UP y"] by simp
                 qed
                 finally show "RTS.Map (Fa a b) (?g y) = y" by blast
               qed
             qed
             show "t u. Fa_ab.B.con (RTS.Map (Fa a b) t) (RTS.Map (Fa a b) u)
                             Fa_ab.A.con t u"
             proof (intro allI impI)
               fix t u
               assume tu: "Fa_ab.B.con (RTS.Map (Fa a b) t) (RTS.Map (Fa a b) u)"
               have "R'.con (DN (MkArr a b t)) (DN (MkArr a b u))"
               proof -
                 have "Fa_ab.B.con (DN (MkArr a b t)) (DN (MkArr a b u))"
                 proof -
                   have "RTS.Map (Fa a b) t = DN (MkArr a b t)"
                     using a b R''.HOM_null_char RTS.bij_mkarr(3) UP_DN.G.extensional
                           arr_char ide_Fo
                     by force
                   moreover have "RTS.Map (Fa a b) u = DN (MkArr a b u)"
                     using a b R''.HOM_null_char RTS.bij_mkarr(3) UP_DN.G.extensional
                           arr_char ide_Fo
                     by force
                   ultimately show ?thesis
                     using tu by simp
                 qed
                 moreover have "residuation.con (R''.HOM (Fo a) (Fo b)) =
                                Fa_ab.B.con"
                   using a b ide_Fo Fa_in_hom [of a b] R''.Hom_def RTS.bij_mkide(3)
                   by auto
                 ultimately show ?thesis
                   using a b ide_Fo R''.sub_rts_HOM
                         sub_rts.con_char
                           [of R' "λt. H'.in_hom t (Fo a) (Fo b)"
                               "DN (MkArr a b t)" "DN (MkArr a b u)"]
                   by auto
               qed
               hence "V.con (MkArr a b t) (MkArr a b u)"
                 using UP_DN.G.reflects_con by auto
               thus "Fa_ab.A.con t u"
                 using a b con_char Fa_in_hom [of a b] Con_def by auto
             qed
           qed
           thus ?thesis
             using a b Fa_in_hom RTS.iso_char by blast
         qed
       qed
     qed

  end

section "RTS Determined by its Underlying Category"

  text‹
    In this section we show that the category RTS is fully determined by
    its subcategory RTS comprising the arrows that are identities for the residuation.
    Specifically, we show that there is an invertible RTS-functor from RTS
    to the RTS-category obtained from the category RTS regarded as a category
    enriched in itself.
  ›

  context rtscat
  begin

    text‹
      The following produces a stand-alone instance of the category RTS,
      independent of the current context.
      Arrows of RTS have type 'A rtscatx.arr›
      and they have the form MkArr A B F›, where A› and B› have type 'A resid›
      and F› has the type ('A, 'A) exponential_rts.arr› of an arrow of the
      exponential RTS [A, B]›).
    ›

    interpretation RTSx: rtscatx arr_type ..

    text‹
      In the current locale context, comp› is the composition for the ordinary
      category RTS.  As a cartesian closed category, this category determines
      a category enriched in itself.
    ›

    interpretation enriched_category comp Prod α ι
                     Collect ide exp ECMC.Id ECMC.Comp
      using extends_to_enriched_category by blast

    text‹
      This self-enriched category determines an RTS-category, using the general construction
      defined in @{locale rts_category_of_enriched_category}.  We will refer to this
      RTS-category as RC.
      Arrows of RC have type ('A rtscatx.arr, 'A) RC.arr› and they have the form
      RC.MkArr a b t›, where a› and b› are objects of RTS and t› is an arrow of the
      hom-RTS HOMEC a b›, which has arrow type 'A›.
    ›

    interpretation RC: rts_category_of_enriched_category
                         arr_type Collect ide exp ECMC.Id ECMC.Comp
      ..

    text‹
      We now define the mapping Φ› which we will show to be an RTS-category isomorphism
      from RC to RTS.  In order to map an arrow MkArr a b t› of RC to an arrow of RTS,
      it is necessary to use the invertible simulation RTS.Func a b› to lift the arrow
      t :: 'A› of HOMEC a b› to an arrow RTS.Func a b t :: ('A, 'A) exponential_rts.arr›
      of the exponential RTS [RTSx.Rts a, RTSx.Rts b]›.
    ›

    definition Φ :: "('A rtscatx.arr, 'A) RC.arr  'A rtscatx.arr"
    where "Φ t  if RC.arr t
                  then RTSx.MkArr
                         (RTSx.Dom (RC.Dom t)) (RTSx.Dom (RC.Cod t))
                         (Func (RC.Dom t) (RC.Cod t) (RC.Trn t))
                  else RTSx.null"

    lemma Φ_simps [simp]:
    assumes "RC.arr t"
    shows "RTSx.arr (Φ t)"
    and "RTSx.dom (Φ t) = RTSx.mkobj (RTSx.Dom (RC.Dom t))"
    and "RTSx.cod (Φ t) = RTSx.mkobj (RTSx.Dom (RC.Cod t))"
    proof -
      show 1: "RTSx.arr (Φ t)"
        unfolding Φ_def Rts_def
        using assms RTSx.null_char RC.arr_char simulation_Func
              Rts_def Func_def ideDRTSC
        apply (intro RTSx.arrI)
           apply auto[3]
        apply simp
        by (metis Rts_def simulation.preserves_reflects_arr)
      show "RTSx.dom (Φ t) = RTSx.mkobj (RTSx.Dom (RC.Dom t))"
        using assms 1 Φ_def RC.arr_char RTSx.dom_char by simp
      show "RTSx.cod (Φ t) = RTSx.mkobj (RTSx.Dom (RC.Cod t))"
        using assms 1 Φ_def RC.arr_char RTSx.cod_char by simp
    qed

    lemma Φ_in_hom [intro]:
    assumes "RC.arr t"
    shows "RTSx.H.in_hom (Φ t)
             (RTSx.mkobj
                (RTSx.Dom (RC.Dom t))) (RTSx.mkobj (RTSx.Dom (RC.Cod t)))"
      using assms by auto

    interpretation Φ: simulation RC.resid RTSx.resid Φ
    proof
      show "t. ¬ RC.arr t  Φ t = RTSx.null"
        using Φ_def by auto
      fix t u
      assume tu: "RC.V.con t u"
      have t: "RC.arr t" and u: "RC.arr u"
        using tu RC.V.con_implies_arr by auto
      have 0: "RC.Dom t = RC.Dom u  RC.Cod t = RC.Cod u"
        using RC.con_implies_Par(1-2) tu by blast
      interpret Func: simulation RC.HOMEC (RC.Dom t) (RC.Cod t)
                        exponential_rts.resid
                           (RTSx.Dom (RC.Dom t)) (RTSx.Dom (RC.Cod t))
                        Func (RC.Dom t) (RC.Cod t)
        using t simulation_Func RC.arr_char
        by (simp add: Rts_def Func_def)
      show 1: "RTSx.V.con (Φ t) (Φ u)"
        using tu RTSx.con_char RC.V.con_implies_arr RTSx.arr_char Φ_simps(1)
              RC.con_implies_Par Φ_def
        apply auto[1]
         apply metis
        by (metis Func.preserves_con RC.Con_def RC.con_char)
      show "Φ (RC.resid t u) = RTSx.resid (Φ t) (Φ u)"
        using t u tu 1 Φ_def
        apply simp
        apply (intro conjI)
                 apply (metis (no_types, lifting) Func.preserves_resid
            RC.ConE RC.con_char)
        using RTSx.con_char by auto
    qed

    text‹
      The following fact is key to showing that Φ› is functorial.
    ›

    lemma Func_Trn_obj:
    assumes "RC.obj a"
    shows "Func (RC.Dom a) (RC.Cod a) (RC.Trn a) =
           exponential_rts.MkIde (I (Rts (RC.Dom a)))"
    proof -
      have a: "ide (RC.Dom a)"
        using assms RC.H.ideD(1) RC.H_arr_char by auto

      interpret Dom: extensional_rts RTSx.Dom (RC.Dom a)
        using assms Rts_def ideDRTSC(1) RC.H.ideD(1) RC.H_arr_char by simp
      interpret I_Dom: identity_simulation RTSx.Dom (RC.Dom a) ..
      interpret Exp0: exponential_rts
                        RTSx.Dom (RC.Dom a) RTSx.Dom (RC.Dom a)
        ..
      interpret DOM: extensional_rts RC.HOMEC (RC.Dom a) (RC.Dom a)
        using assms
        by (simp add: RC.H_ide_char RC.arr_char RC.horizontal_unit_def)
      have "RC.Trn a = RC.Trn (RC.mkobj (RC.Dom a))"
        using assms RC.H.ide_char [of a] RC.arr_char [of a] RC.H_dom_char
        by force
      also have "... = Exp0.Map (RTSx.Trn (ECMC.Id (RC.Dom a))) One.the_arr"
      proof -
        have "RC.mkobj (RC.Dom a) =
              RC.MkArr (RC.Dom a) (RC.Dom a)
                (RTSx.Map (ECMC.Id (RC.Dom a)) One.the_arr)"
          using Map_def by argo
        thus ?thesis by simp
      qed
      also have "... = Exp0.Map
                         (RTSx.Trn
                            (curry CMC.unity (RC.Dom a) (RC.Dom a)
                               (CMC.lunit (RC.Dom a))))
                         One.the_arr"
        using ECMC.Id_def by (simp add: curry_def)
      also have "... = (Unfunc (RC.Dom a) (RC.Dom a) 
                          Currying.Curry
                            (Cod ι) (RTSx.Dom (RC.Dom a))
                              (RTSx.Dom (RC.Dom a))
                            (RTSx.Src (CMC.lunit (RC.Dom a)) 
                               Pack CMC.unity (RC.Dom a))
                            (RTSx.Trg (CMC.lunit (RC.Dom a)) 
                               Pack CMC.unity (RC.Dom a))
                            (RTSx.Map (CMC.lunit (RC.Dom a)) 
                               Pack CMC.unity (RC.Dom a)))
                            One.the_arr"
        using CMC.ide_unity ECMC.Id_def Pack_def RTSx.Map_curry Rts_def
              Unfunc_def a ide_iff_RTS_obj local.curry_def
        by force
      also have "... = (Unfunc (RC.Dom a) (RC.Dom a) 
                          Currying.Curry3
                            (Cod ι) (RTSx.Dom (RC.Dom a))
                              (RTSx.Dom (RC.Dom a))
                            (product_rts.P0
                               (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a))))
                            One.the_arr"
      proof -
        have "RTSx.Map (CMC.lunit (RC.Dom a)) 
                Pack CMC.unity (RC.Dom a) =
              product_rts.P0 (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a))"
        proof -
          have "RTSx.Map (CMC.lunit (RC.Dom a)) 
                  RTSx.Pack CMC.unity (RC.Dom a) =
                RTSx.Map (CMC.pr0 RTSx.one (RC.Dom a)) 
                  RTSx.Pack CMC.unity (RC.Dom a)"
            using assms CMC.lunit_eq RC.H.ide_char RC.H_arr_char unity_agreement
            by (metis (no_types, lifting) mem_Collect_eq one_def)
          also have "... =  product_rts.P0
                              (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a)) 
                             (Unpack RTSx.one (RC.Dom a) 
                                Pack CMC.unity (RC.Dom a))"
            using assms RTSx.Map_p0 RC.H.ideD(1) RC.H_arr_char pr_agreement(1)
                  ide_iff_RTS_obj
            by (auto simp add: one_def p0_def Pack_def Unpack_def)
          also have "... = product_rts.P0
                             (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a)) 
                             I (product_rts.resid
                                  (RTSx.Dom (RTSx.one)) (RTSx.Dom (RC.Dom a)))"
            using assms a one_def RTSx.obj_one ide_iff_RTS_obj ide_one
                  RTSx.Unpack_o_Pack
            by (auto simp add: one_def Pack_def Unpack_def)
          also have "... = product_rts.P0
                             (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a))"
            using assms one_def
                  comp_simulation_identity
                    [of "product_rts.resid
                           (RTSx.Dom (RTSx.one)) (RTSx.Dom (RC.Dom a))"
                        "RTSx.Dom (RC.Dom a)"
                        "product_rts.P0 (RTSx.Dom RTSx.one)
                           (RTSx.Dom (RC.Dom a))"]
            by (metis (no_types, lifting) Dom.rts_axioms Rts_def extensional_rts_def
                ideDRTSC ide_one product_rts.P0_is_simulation product_rts.intro)
          finally show ?thesis
            unfolding Pack_def by blast
        qed
        moreover have 1: "RTSx.sta (CMC.lunit (RC.Dom a))"
          using assms CMC.arr_lunit RC.H.ideD(1) RC.H_arr_char arr_iff_RTS_sta
          by force
        moreover have "RTSx.Src (CMC.lunit (RC.Dom a)) =
                 RTSx.Map (CMC.lunit (RC.Dom a))"
          using assms 1 RTSx.src_char RTSx.sta_char RTSx.Map_simps(3) RTSx.V.src_ide
          by (metis (no_types, lifting))
        moreover have "RTSx.Trg (CMC.lunit (RC.Dom a)) =
                 RTSx.Map (CMC.lunit (RC.Dom a))"
          using assms 1 RTSx.trg_char RTSx.sta_char RTSx.Map_simps(4) RTSx.V.trg_ide
          by (metis (no_types, lifting))
        ultimately show ?thesis
          by force
      qed
      also have "... = RTSx.Unfunc (RC.Dom a) (RC.Dom a)
                         (Exp0.MkIde (I (RTSx.Dom (RC.Dom a))))"
      proof -
        interpret Cod_ι: extensional_rts Cod ι
          using CMC.ide_unity extensional_rts_def by simp
        interpret C: Currying
                       Cod ι RTSx.Dom (RC.Dom a) RTSx.Dom (RC.Dom a)
          ..
        have "Currying.Curry3
                (Cod ι) (RTSx.Dom (RC.Dom a)) (RTSx.Dom (RC.Dom a))
                (product_rts.P0 (RTSx.Dom RTSx.one) (RTSx.Dom (RC.Dom a)))
                One.the_arr =
              Exp0.MkIde (I (RTSx.Dom (RC.Dom a)))"
        proof -
          interpret P: product_rts RTSx.Dom one RTSx.Dom (RC.Dom a)
            using C.AxB.product_rts_axioms Rts_def unity_agreement by argo
          have 1: "Cod_ι.arr = One.arr  Cod_ι.src = One.src  Cod_ι.trg = One.trg"
            by (simp add: unity_agreement)
          have "Cod_ι.arr One.the_arr"
            by (simp add: One.arr_char unity_agreement)
          moreover have "(λg. P.P0 (One.the_arr, g)) = I_Dom.map"
            using P.P0_def One.arr_char P.arr_char Rts_def Rts_one by auto
          ultimately show ?thesis
            using 1 One.src_char One.trg_char C.Curry_def
            by (auto simp add: one_def)
        qed
        thus ?thesis
          unfolding Unfunc_def
          using One.arr_char by auto
      qed
      finally
      have "RC.Trn a =
            RTSx.Unfunc (RC.Dom a) (RC.Dom a) (Exp0.MkIde I_Dom.map)"
        by blast
      thus ?thesis
        unfolding Rts_def
        using assms RTSx.Func_Unfunc Unfunc_def Exp0.ide_MkIde
              Exp0.ide_implies_arr I_Dom.simulation_axioms RC.H_ide_char
              RC.horizontal_unit_def a ide_iff_RTS_obj Func_def
        by auto
    qed

    lemma obj_Φ_obj:
    assumes "RC.obj a"
    shows "RTSx.obj (Φ a)"
    proof -
      interpret Dom: extensional_rts RTSx.Dom (RC.Dom a)
        using assms RC.H.ideD(1) RC.H_arr_char Rts_def ideDRTSC by force
      interpret I_Dom: identity_simulation RTSx.Dom (RC.Dom a) ..
      interpret Exp0: exponential_rts
                        RTSx.Dom (RC.Dom a) RTSx.Dom (RC.Dom a) ..
      show ?thesis 
        unfolding Φ_def
        using assms RC.H.ideD(1) Func_Trn_obj RTSx.mkobj_def Rts_def
              RTSx.obj_mkobj [of "RTSx.Dom (RC.Dom a)"]
        apply auto[1]
        by (metis (no_types, lifting) CollectD RC.H.ideD(1) RC.H_arr_char
            RC.H_ide_char RC.horizontal_unit_def Rts_def ideDRTSC)
    qed

    interpretation Φ: "functor" RC.hcomp RTSx.hcomp Φ
    proof
      fix f
      let ?a = "RC.Dom f"
      let ?b = "RC.Cod f"
      let ?A = "RTSx.Dom ?a"
      let ?B = "RTSx.Dom ?b"
      let ?ab = "RTSx.exp ?a ?b"
      show "¬ RC.H.arr f  Φ f = RTSx.H.null"
        using Φ_def by force
      show "RC.H.arr f  RTSx.H.arr (Φ f)"
        using RC.arr_coincidence RTSx.arr_coincidence Φ.preserves_reflects_arr
        by force
      show "RC.H.arr f  RTSx.dom (Φ f) = Φ (RC.dom f)"
      proof -
        assume f: "RC.H.arr f"
        have 1: "RC.Dom (RC.dom f) = ?a"
          using f RC.H.ide_dom RC.H_dom_char by simp
        have 2: "RC.Cod (RC.dom f) = ?a"
          using f RC.H.ide_dom RC.H_dom_char by simp
        have 3: "RTSx.dom (Φ f) = RTSx.mkobj ?A"
          using f by simp
        have "Φ (RC.dom f) = RTSx.mkobj ?A"
        proof -
          have "Φ (RC.dom f) =
                RTSx.MkArr
                  (RTSx.Dom (RC.Dom (RC.dom f)))
                  (RTSx.Dom (RC.Cod (RC.dom f)))
                  (RTSx.Func (RC.Dom (RC.dom f)) (RC.Cod (RC.dom f))
                     (RC.Trn (RC.dom f)))"
            unfolding Φ_def Func_def
            using f by simp
          also have "... = RTSx.MkArr ?A ?A
                             (exponential_rts.MkArr (I ?A) (I ?A) (I ?A))"
          proof -
            have "RC.obj (RC.dom f)"
              using f by simp
            thus ?thesis
              using 1 2 Func_Trn_obj [of "RC.dom f"]
              unfolding Func_def Rts_def by presburger
          qed
          also have "... = RTSx.mkobj ?A"
            unfolding RTSx.mkobj_def
            using f by blast
          finally show ?thesis by blast
        qed
        moreover have "RTSx.dom (Φ f) = RTSx.mkobj ?A"
          using f by simp
        ultimately show "RTSx.dom (Φ f) = Φ (RC.dom f)"
          by simp
      qed
      show "RC.H.arr f  RTSx.cod (Φ f) = Φ (RC.cod f)"
      proof -
        assume f: "RC.H.arr f"
        have 1: "RC.Dom (RC.cod f) = ?b"
          using f RC.H.ide_cod RC.H_cod_char by simp
        have 2: "RC.Cod (RC.cod f) = ?b"
          using f RC.H.ide_cod RC.H_cod_char by simp
        have 3: "RTSx.cod (Φ f) = RTSx.mkobj ?B"
          using f by simp
        have "Φ (RC.cod f) = RTSx.mkobj ?B"
        proof -
          have "Φ (RC.cod f) =
                RTSx.MkArr
                  (RTSx.Dom (RC.Dom (RC.cod f)))
                  (RTSx.Dom (RC.Cod (RC.cod f)))
                  (RTSx.Func (RC.Dom (RC.cod f)) (RC.Cod (RC.cod f))
                     (RC.Trn (RC.cod f)))"
            unfolding Φ_def Func_def
            using f by simp
          also have "... = RTSx.MkArr ?B ?B
                             (exponential_rts.MkArr (I ?B) (I ?B) (I ?B))"
          proof -
            have "RC.obj (RC.cod f)"
              using f by simp
            thus ?thesis
              using 1 2 Func_Trn_obj [of "RC.cod f"]
              unfolding Func_def Rts_def by presburger
          qed
          also have "... = RTSx.mkobj ?B"
            unfolding RTSx.mkobj_def
            using f by blast
          finally show ?thesis by blast
        qed
        moreover have "RTSx.cod (Φ f) = RTSx.mkobj ?B"
          using f by simp
        ultimately show "RTSx.cod (Φ f) = Φ (RC.cod f)"
          by simp
      qed
      fix g
      let ?c = "RC.Cod g"
      let ?C = "RTSx.Dom ?c"
      let ?bc = "RTSx.exp ?b ?c"
      let ?ac = "RTSx.exp ?a ?c"
      show "RC.H.seq g f  Φ (RC.hcomp g f) = RTSx.hcomp (Φ g) (Φ f)"
      proof -
        assume seq: "RC.H.seq g f"
        have 0: "RC.H.arr f  RC.H.arr g  RC.dom g = RC.cod f"
          using seq by blast
        interpret A: extensional_rts ?A
          using seq 0 RC.H_arr_char Rts_def ideDRTSC by fastforce
        interpret B: extensional_rts ?B
          using seq 0 RC.H_arr_char Rts_def ideDRTSC by fastforce
        interpret C: extensional_rts ?C
          using seq 0 RC.H_arr_char Rts_def ideDRTSC by fastforce
        interpret AB: exponential_rts ?A ?B ..
        interpret BC: exponential_rts ?B ?C ..
        interpret AC: exponential_rts ?A ?C ..
        interpret CMP: COMP ?A ?B ?C ..
        interpret ASC: ASSOC BC.resid AB.resid ?A ..
        interpret HOM_ab: extensional_rts RC.HOMEC ?a ?b
          by (meson RC.H_seq_char RC.rts_category_of_enriched_category_axioms
              ideDRTSC(1) ide_Hom rts_category_of_enriched_category.arr_char seq)
        interpret HOM_bc: extensional_rts RC.HOMEC ?b ?c
          by (meson RC.H_seq_char RC.rts_category_of_enriched_category_axioms
              ideDRTSC(1) ide_Hom rts_category_of_enriched_category.arr_char seq)
        interpret HOM_ac: extensional_rts RC.HOMEC ?a ?c
          by (meson RC.H_seq_char RC.rts_category_of_enriched_category_axioms
              ideDRTSC(1) ide_Hom rts_category_of_enriched_category.arr_char seq)
        let ?Func_ab = "RTSx.Func ?a ?b"
        let ?Func_bc = "RTSx.Func ?b ?c"
        let ?Func_ac = "RTSx.Func ?a ?c"
        interpret Func_ab: simulation RC.HOMEC ?a ?b AB.resid ?Func_ab
          using 0 simulation_Func
          by (metis (no_types, lifting) RC.H_arr_char Rts_def Func_def mem_Collect_eq)
        interpret Func_ab: simulation_between_extensional_rts
                             RC.HOMEC ?a ?b AB.resid ?Func_ab
          ..
        interpret Func_bc: simulation RC.HOMEC ?b ?c BC.resid ?Func_bc
          using 0 simulation_Func
          by (metis (no_types, lifting) RC.H_arr_char Rts_def Func_def mem_Collect_eq)
        interpret Func_bc: simulation_between_extensional_rts
                             RC.HOMEC ?b ?c BC.resid ?Func_bc
          ..
        interpret Func_ac: simulation RC.HOMEC ?a ?c AC.resid ?Func_ac
          using 0 simulation_Func
          by (metis (no_types, lifting) RC.H_arr_char Rts_def Func_def mem_Collect_eq)
        interpret Func_ac: simulation_between_extensional_rts
                             RC.HOMEC ?a ?c AC.resid ?Func_ac
          ..
        interpret Comp: Composition arr_type ?a ?b ?c
          using seq RC.arr_char RC.H_seq_char 
          by unfold_locales auto
        interpret bcXab: product_rts Comp.EXP ?b ?c Comp.EXP ?a ?b ..
        interpret Func_bc_x_Func_ab:
                    product_simulation Comp.EXP ?b ?c Comp.EXP ?a ?b
                      BC.resid AB.resid RTSx.Func ?b ?c RTSx.Func ?a ?b
          ..
        interpret Eval_BC: RTSConstructions.evaluation_map ?B ?C ..
        interpret Eval_AB: RTSConstructions.evaluation_map ?A ?B ..
        interpret I_BC: identity_simulation BC.resid ..
        interpret I_BC_x_Eval_AB: product_simulation
                                    BC.resid ASC.BxC.resid BC.resid ?B
                                    I_BC.map Eval_AB.map
          ..
        have 0: "bcXab.arr (RC.Trn g, RC.Trn f)"
          using seq bcXab.arr_char RC.H.seqE RC.H_arr_char RC.H_seq_char
          by auto
        have 1: "CMP.BCxAB.arr
                   (RTSx.Func ?b ?c (RC.Trn g), RTSx.Func ?a ?b (RC.Trn f))"
          using 0 by auto
        have "Φ (RC.hcomp g f) =
              RTSx.MkArr
                (RTSx.Dom (RC.Dom (RC.hcomp g f)))
                (RTSx.Dom (RC.Cod (RC.hcomp g f)))
                (RTSx.Func (RC.Dom (RC.hcomp g f)) (RC.Cod (RC.hcomp g f))
                   (RC.Trn (RC.hcomp g f)))"
          using seq Φ_def by (auto simp add: Func_def)
        also have "... =                                  
                   RTSx.MkArr ?A ?C
                     ((?Func_ac  AC.Map (RTSx.Trn (ECMC.Comp ?a ?b ?c)))
                         (RTSx.Pack ?bc ?ab (RC.Trn g, RC.Trn f)))"
          unfolding RC.hcomp_def
          using seq RC.H_seq_char
          by (auto simp add: Func_def Pack_def Map_def exp_def)
        also have "... =
                   RTSx.MkArr ?A ?C
                     (CMP.map
                        (Func_bc_x_Func_ab.map
                           (RTSx.Unpack ?bc ?ab
                              (RTSx.Pack ?bc ?ab (RC.Trn g, RC.Trn f)))))"
          using Comp.Func_o_Map_Comp
          by (auto simp add: Func_def Unpack_def Map_def exp_def Rts_def)
        also have "... =
                   RTSx.MkArr ?A ?C
                     (CMP.map
                        (Func_bc_x_Func_ab.map
                           (RC.Trn g, RC.Trn f)))"
          using RC.H_seq_char RC.arr_char ide_Hom seq RTSx.Unpack_Pack
          by (metis (no_types, lifting) 0 Rts_def exp_def ide_iff_RTS_obj)
        also have "... =
                   RTSx.MkArr ?A ?C
                     (CMP.map
                        (RTSx.Func ?b ?c (RC.Trn g), RTSx.Func ?a ?b (RC.Trn f)))"
          using 0 Func_bc_x_Func_ab.map_simp by fastforce
        also have "... =
                   RTSx.MkArr ?A ?C
                     (CMP.Currying.A_BC.MkArr
                        (BC.Dom (RTSx.Func ?b ?c (RC.Trn g)) 
                           BC.Dom (RTSx.Func ?a ?b (RC.Trn f)))
                        (BC.Cod (RTSx.Func ?b ?c (RC.Trn g)) 
                           BC.Cod (RTSx.Func ?a ?b (RC.Trn f)))
                        (BC.Map (RTSx.Func ?b ?c (RC.Trn g)) 
                           BC.Map (RTSx.Func ?a ?b (RC.Trn f))))"
          unfolding CMP.Currying.Curry_def
          using 0 CMP.map_eq by simp
        also have "... =
                   RTSx.MkArr ?A ?C
                     (COMP.map ?A ?B ?C
                        (RTSx.Func ?b ?c (RC.Trn g), RTSx.Func ?a ?b (RC.Trn f)))"
          unfolding CMP.Currying.Curry_def
          using 0 CMP.map_eq by simp
        also have "... = RTSx.hcomp (Φ g) (Φ f)"
          unfolding RTSx.hcomp_def
          using seq RC.H_seq_char Φ_def Φ_simps(1)
          apply (auto simp add: Func_def)[1]
          by (metis (no_types, lifting))
        finally show ?thesis by blast
      qed
    qed

    interpretation Φ: rts_functor RC.resid RC.hcomp
                         RTSx.resid RTSx.hcomp Φ
      ..

    interpretation Φ: fully_faithful_functor RC.hcomp RTSx.hcomp Φ
    proof
      fix t u
      assume par: "RC.H.par t u"
      assume eq: "Φ t = Φ u"
      show "t = u"
      proof (intro RC.arr_eqI)
        show "t  RC.null" and "u  RC.null"
          using par by auto
        show 1: "RC.Dom t = RC.Dom u" and 2: "RC.Cod t = RC.Cod u"
          using par eq Φ_def RC.H_dom_char RC.H_cod_char by auto
        show "RC.Trn t = RC.Trn u"
        proof -
          have "RC.Trn t = RTSx.Unfunc (RC.Dom t) (RC.Cod t)
                             (RTSx.Func (RC.Dom t) (RC.Cod t) (RC.Trn t))"
            using par RTSx.Unfunc_Func RC.arr_char [of t]
            apply auto[1]
            by (simp add: Rts_def exp_def ide_iff_RTS_obj)
          also have "... = RTSx.Unfunc (RC.Dom u) (RC.Cod u)
                             (RTSx.Func (RC.Dom t) (RC.Cod t) (RC.Trn t))"
            using 1 2 by auto
          also have "... = RTSx.Unfunc (RC.Dom u) (RC.Cod u)
                             (RTSx.Func (RC.Dom u) (RC.Cod u) (RC.Trn u))"
            using par eq Φ_def
            by (auto simp add: Func_def)
          also have "... = RC.Trn u"
            using par RTSx.Unfunc_Func RC.arr_char [of t] RC.arr_char [of u]
            apply auto[1]
            by (simp add: Rts_def exp_def ide_iff_RTS_obj)
          finally show "RC.Trn t = RC.Trn u" by blast
        qed
      qed
      next
      fix a b g
      assume a: "RC.obj a" and b: "RC.obj b"
      assume g: "RTSx.H.in_hom g (Φ a) (Φ b)"
      have 1: "RTSx.dom g = RC.Dom a"
        by (metis (no_types, lifting) CollectD RC.H.ide_char' RC.H_arr_char
            RC.H_ide_char RC.horizontal_unit_def RTSx.H.cod_dom RTSx.H.in_homE
            RTSx.bij_mkobj(4) Φ_simps(3) a g ide_iff_RTS_obj)
      have 2: "RTSx.cod g = RC.Dom b"
        by (metis (no_types, lifting) CollectD RC.H_ide_char RC.arr_char
            RC.horizontal_unit_def RTSx.Dom.simps(1) RTSx.H.ide_cod RTSx.H.in_homE
            Rts_def Φ_def b bij_mkide(4) g ide_iff_RTS_obj)
      interpret Dom_a: extensional_rts RTSx.Dom (RC.Dom a)
        using a Φ_def RC.H.ide_char [of a] RC.arr_char [of a] obj_Φ_obj
        by force
      interpret Dom_b: extensional_rts RTSx.Dom (RC.Dom b)
        using b Φ_def RC.H.ide_char [of b] RC.arr_char [of b] obj_Φ_obj
        by force
      interpret Exp: exponential_rts
                       RTSx.Dom (RC.Dom a) RTSx.Dom (RC.Dom b)
        ..
      interpret Unfunc: simulation
                          Exp.resid RC.HOMEC (RC.Dom a) (RC.Dom b)
                          RTSx.Unfunc (RC.Dom a) (RC.Dom b)
        by (metis 1 2 RTSx.H.arrI RTSx.H.ide_cod RTSx.H.ide_dom
            RTSx.simulation_Unfunc Rts_def exp_def g)
      let ?f = "RC.MkArr (RC.Dom a) (RC.Dom b)
                  (RTSx.Unfunc (RC.Dom a) (RC.Dom b) (RTSx.Trn g))"
      have "RC.H.in_hom ?f a b  Φ ?f = g"
      proof
        show 3: "RC.H.in_hom ?f a b"
        proof
          show 4: "RC.H.arr ?f"
            using a b g 1 2
                  RTSx.arr_char RC.arr_char Unfunc.preserves_reflects_arr
                  RC.arr_MkArr
            by (metis (no_types, lifting) RC.H.ideD(1) RC.H_arr_char
                RTSx.Dom_cod RTSx.Dom_dom RTSx.H.in_homE RTSx.arr_coincidenceCRC)
          show "RC.dom ?f = a"
            using 4 RC.H.ideD(1-2) RC.H_dom_char a by auto
          show "RC.cod ?f = b"
            using 4 RC.H.ideD(1-3) RC.H_dom_char RC.H_cod_char b by auto
        qed
        show "Φ ?f = g"
        proof -
          have "RTSx.Func (RC.Dom a) (RC.Dom b)
                  (RTSx.Unfunc (RC.Dom a) (RC.Dom b) (RTSx.Trn g)) =
                RTSx.Trn g"
            using 1 2 RTSx.Func_Unfunc
            by (metis (no_types, lifting) RTSx.Dom_cod RTSx.Dom_dom RTSx.H.in_homE
                RTSx.arr_char RTSx.arr_coincidenceCRC a b g obj_Φ_obj)
          thus ?thesis
            unfolding Φ_def
            using g 1 2 3 RTSx.arr_MkArr RTSx.arr_char [of g]
            apply (auto simp add: Func_def)[1]
            by (metis (no_types, lifting) RTSx.Dom_cod RTSx.Dom_dom RTSx.MkArr_Trn)
        qed
      qed
      thus "f. RC.H.in_hom f a b  Φ f = g" by blast
    qed

    interpretation Φ: full_embedding_functor RC.hcomp RTSx.hcomp Φ
    proof
      fix f f'
      assume f: "RC.H.arr f" and f': "RC.H.arr f'"
      assume eq: "Φ f = Φ f'"
      have "RC.H.par f f'"
        using f f' eq bij_mkide(4) RC.H_cod_char RC.H_dom_char
        apply (auto simp add: Φ_def Rts_def)[1]
        by (metis (no_types, lifting) CollectD RC.H_arr_char f f')+
      thus "f = f'"
        using Φ.is_faithful eq by blast
    qed

    interpretation Φ: invertible_functor RC.hcomp RTSx.hcomp Φ
    proof -
      have "Collect RTSx.obj  Φ ` Collect RC.obj"
      proof
        fix a
        assume a: "a  Collect RTSx.obj"
        show "a  Φ ` Collect RC.obj"
        proof
          let ?a' = "RC.mkobj a"
          show a': "?a'  Collect RC.obj"
            using a RC.Id_yields_horiz_ide ide_iff_RTS_obj by blast
          show "a = Φ ?a'"
            using a a' bij_mkide(4)
            apply (auto simp add: Φ_def)[1]
             apply (metis (no_types, lifting) RC.Cod.simps(1) RC.Dom.simps(1)
                RC.H.ide_char RC.Trn.simps(1) RTSx.Dom.simps(1) RTSx.bij_mkobj(4)
                RTSx.dom_char Φ.as_nat_trans.preserves_dom
                Φ.as_nat_trans.preserves_reflects_arr Φ_def)
            by (metis (no_types, lifting) RC.H.ide_char RC.arr_coincidence)
        qed
      qed
      thus "invertible_functor RC.hcomp RTSx.hcomp Φ"
        using Φ.is_invertible_if_surjective_on_objects(1) by blast
    qed

    interpretation Φ: invertible_simulation RC.resid RTSx.resid Φ
    proof -
      have "t u. RTSx.V.con (Φ t) (Φ u)  RC.V.con t u"
      proof -
        fix t u
        assume con: "RTSx.V.con (Φ t) (Φ u)"
        have 1: "RTSx.V.con
                   (RTSx.MkArr (RTSx.Dom (RC.Dom t)) (RTSx.Dom (RC.Cod t))
                      (RTSx.Func (RC.Dom t) (RC.Cod t) (RC.Trn t)))
                   (RTSx.MkArr (RTSx.Dom (RC.Dom u)) (RTSx.Dom (RC.Cod u))
                      (RTSx.Func (RC.Dom u) (RC.Cod u) (RC.Trn u)))"
          using con Φ_def
          unfolding Func_def
          by (metis RTSx.V.not_con_null(1) RTSx.V.not_con_null(2))
        hence "residuation.con
                 (exponential_rts.resid
                    (RTSx.Dom (RC.Dom t)) (RTSx.Dom (RC.Cod t)))
                 (RTSx.Func (RC.Dom t) (RC.Cod t) (RC.Trn t))
                 (RTSx.Func (RC.Dom u) (RC.Cod u) (RC.Trn u))"
          using RTSx.con_char by force
        hence "residuation.con (RC.HOMEC (RC.Dom t) (RC.Cod t))
                 (RTSx.Unfunc (RC.Dom t) (RC.Cod t)
                    (RTSx.Func (RC.Dom t) (RC.Cod t) (RC.Trn t)))
                 (RTSx.Unfunc (RC.Dom u) (RC.Cod u)
                    (RTSx.Func (RC.Dom u) (RC.Cod u) (RC.Trn u)))"
          using con 1 simulation.preserves_con simulation_Unfunc bij_mkide(4)
          by (metis (no_types, lifting) CollectD RC.H_arr_char RTSx.Cod.simps(1)
              RTSx.Dom.simps(1) RTSx.con_char RTSx.con_implies_par Rts_def
              Unfunc_def Φ.as_nat_trans.preserves_reflects_arr)
        hence "residuation.con (RC.HOMEC (RC.Dom t) (RC.Cod t)) 
                 (RC.Trn t) (RC.Trn u)"
          using RC.arr_char RTSx.con_char Unfunc_Func
          by (metis (no_types, lifting) CollectD RC.H_arr_char RTSx.con_implies_par
              Unfunc_def Φ.as_nat_trans.preserves_reflects_arr con Func_def)
        thus "RC.V.con t u"
          using 1 con bij_mkide(4) RC.con_char RTSx.con_char RC.arr_char
                RTSx.con_implies_par RTSx.null_char Φ.extensional Rts_def bij_mkide(4)
          apply auto[1]
          apply (intro RC.ConI conjI, auto)
          by metis+
      qed
      thus "invertible_simulation RC.resid RTSx.resid Φ"
        using Φ.is_invertible_simulation_if Φ.invertible_functor_axioms by blast
    qed

    theorem "rts_category_isomorphism RC.resid RC.hcomp
               RTSx.resid RTSx.hcomp Φ"
      ..

  end

end