diff --git a/thys/Category3/Adjunction.thy b/thys/Category3/Adjunction.thy
--- a/thys/Category3/Adjunction.thy
+++ b/thys/Category3/Adjunction.thy
@@ -1,3187 +1,3201 @@
 (*  Title:       Adjunction
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter Adjunction
 
 theory Adjunction
 imports Yoneda
 begin
 
   text\<open>
     This theory defines the notions of adjoint functor and adjunction in various
     ways and establishes their equivalence.
     The notions ``left adjoint functor'' and ``right adjoint functor'' are defined
     in terms of universal arrows.
     ``Meta-adjunctions'' are defined in terms of natural bijections between hom-sets,
     where the notion of naturality is axiomatized directly.
     ``Hom-adjunctions'' formalize the notion of adjunction in terms of natural
     isomorphisms of hom-functors.
     ``Unit-counit adjunctions'' define adjunctions in terms of functors equipped
     with unit and counit natural transformations that satisfy the usual
     ``triangle identities.''
     The \<open>adjunction\<close> locale is defined as the grand unification of all the
     definitions, and includes formulas that connect the data from each of them.
     It is shown that each of the definitions induces an interpretation of the
     \<open>adjunction\<close> locale, so that all the definitions are essentially equivalent.
     Finally, it is shown that right adjoint functors are unique up to natural
     isomorphism.
 
     The reference \cite{Wikipedia-Adjoint-Functors} was useful in constructing this theory.
 \<close>
 
   section "Left Adjoint Functor"
 
   text\<open>
     ``@{term e} is an arrow from @{term "F x"} to @{term y}.''
 \<close>
 
   locale arrow_from_functor =
     C: category C +
     D: category D +
     F: "functor" D C F
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c"
     and x :: 'd
     and y :: 'c
     and e :: 'c +
     assumes arrow: "D.ide x \<and> C.in_hom e (F x) y"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       ``@{term g} is a @{term[source=true] D}-coextension of @{term f} along @{term e}.''
 \<close>
 
     definition is_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
     where "is_coext x' f g \<equiv> \<guillemotleft>g : x' \<rightarrow>\<^sub>D x\<guillemotright> \<and> f = e \<cdot>\<^sub>C F g"
 
   end
 
   text\<open>
     ``@{term e} is a terminal arrow from @{term "F x"} to @{term y}.''
 \<close>
 
   locale terminal_arrow_from_functor =
     arrow_from_functor D C F x y e
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c"
     and x :: 'd
     and y :: 'c
     and e :: 'c +
     assumes is_terminal: "arrow_from_functor D C F x' y f \<Longrightarrow> (\<exists>!g. is_coext x' f g)"
   begin
 
     definition the_coext :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where "the_coext x' f = (THE g. is_coext x' f g)"
 
     lemma the_coext_prop:
     assumes "arrow_from_functor D C F x' y f"
     shows "\<guillemotleft>the_coext x' f : x' \<rightarrow>\<^sub>D x\<guillemotright>" and "f = e \<cdot>\<^sub>C F (the_coext x' f)"
       by (metis assms is_coext_def is_terminal the_coext_def the_equality)+
 
     lemma the_coext_unique:
     assumes "arrow_from_functor D C F x' y f" and "is_coext x' f g"
     shows "g = the_coext x' f"
       using assms is_terminal the_coext_def the_equality by metis
 
   end
 
   text\<open>
     A left adjoint functor is a functor \<open>F: D \<rightarrow> C\<close>
     that enjoys the following universal coextension property: for each object
     @{term y} of @{term C} there exists an object @{term x} of @{term D} and an
     arrow \<open>e \<in> C.hom (F x) y\<close> such that for any arrow
     \<open>f \<in> C.hom (F x') y\<close> there exists a unique \<open>g \<in> D.hom x' x\<close>
     such that @{term "f = C e (F g)"}.
 \<close>
 
   locale left_adjoint_functor =
     C: category C +
     D: category D +
     "functor" D C F
     for D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and F :: "'d \<Rightarrow> 'c" +
     assumes ex_terminal_arrow: "C.ide y \<Longrightarrow> (\<exists>x e. terminal_arrow_from_functor D C F x y e)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   section "Right Adjoint Functor"
 
   text\<open>
     ``@{term e} is an arrow from @{term x} to @{term "G y"}.''
 \<close>
 
   locale arrow_to_functor =
     C: category C +
     D: category D +
     G: "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd"
     and x :: 'd
     and y :: 'c
     and e :: 'd +
     assumes arrow: "C.ide y \<and> D.in_hom e x (G y)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       ``@{term f} is a @{term[source=true] C}-extension of @{term g} along @{term e}.''
 \<close>
 
     definition is_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c \<Rightarrow> bool"
     where "is_ext y' g f \<equiv> \<guillemotleft>f : y \<rightarrow>\<^sub>C y'\<guillemotright> \<and> g = G f \<cdot>\<^sub>D e"
 
   end
 
   text\<open>
     ``@{term e} is an initial arrow from @{term x} to @{term "G y"}.''
 \<close>
 
   locale initial_arrow_to_functor =
     arrow_to_functor C D G x y e
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd"
     and x :: 'd
     and y :: 'c
     and e :: 'd +
     assumes is_initial: "arrow_to_functor C D G x y' g \<Longrightarrow> (\<exists>!f. is_ext y' g f)"
   begin
 
     definition the_ext :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where "the_ext y' g = (THE f. is_ext y' g f)"
 
     lemma the_ext_prop:
     assumes "arrow_to_functor C D G x y' g"
     shows "\<guillemotleft>the_ext y' g : y \<rightarrow>\<^sub>C y'\<guillemotright>" and "g = G (the_ext y' g) \<cdot>\<^sub>D e"
       by (metis assms is_initial is_ext_def the_equality the_ext_def)+
 
     lemma the_ext_unique:
     assumes "arrow_to_functor C D G x y' g" and "is_ext y' g f"
     shows "f = the_ext y' g"
       using assms is_initial the_ext_def the_equality by metis
 
   end
 
   text\<open>
     A right adjoint functor is a functor \<open>G: C \<rightarrow> D\<close>
     that enjoys the following universal extension property:
     for each object @{term x} of @{term D} there exists an object @{term y} of @{term C}
     and an arrow \<open>e \<in> D.hom x (G y)\<close> such that for any arrow
     \<open>g \<in> D.hom x (G y')\<close> there exists a unique \<open>f \<in> C.hom y y'\<close>
     such that @{term "h = D e (G f)"}.
 \<close>
 
   locale right_adjoint_functor =
     C: category C +
     D: category D +
     "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and G :: "'c \<Rightarrow> 'd" +
     assumes initial_arrows_exist: "D.ide x \<Longrightarrow> (\<exists>y e. initial_arrow_to_functor C D G x y e)"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   section "Various Definitions of Adjunction"
 
   subsection "Meta-Adjunction"
 
   text\<open>
     A ``meta-adjunction'' consists of a functor \<open>F: D \<rightarrow> C\<close>,
     a functor \<open>G: C \<rightarrow> D\<close>, and for each object @{term x}
     of @{term C} and @{term y} of @{term D} a bijection between
     \<open>C.hom (F y) x\<close> to \<open>D.hom y (G x)\<close> which is natural in @{term x}
     and @{term y}.  The naturality is easy to express at the meta-level without having
     to resort to the formal baggage of ``set category,'' ``hom-functor,''
     and ``natural isomorphism,'' hence the name.
 \<close>
 
   locale meta_adjunction =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c" +
     assumes \<phi>_in_hom: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> D.in_hom (\<phi> y f) y (G x)"
     and \<psi>_in_hom: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> C.in_hom (\<psi> x g) (F y) x"
     and \<psi>_\<phi>: "\<lbrakk> D.ide y; C.in_hom f (F y) x \<rbrakk> \<Longrightarrow> \<psi> x (\<phi> y f) = f"
     and \<phi>_\<psi>: "\<lbrakk> C.ide x; D.in_hom g y (G x) \<rbrakk> \<Longrightarrow> \<phi> y (\<psi> x g) = g"
     and \<phi>_naturality: "\<lbrakk> C.in_hom f x x'; D.in_hom g y' y; C.in_hom h (F y) x \<rbrakk> \<Longrightarrow>
                          \<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
   begin
 
     notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     text\<open>
       The naturality of @{term \<psi>} is a consequence of the naturality of @{term \<phi>}
       and the other assumptions.
 \<close>
 
     lemma \<psi>_naturality:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' (G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g)"
       using f g h \<phi>_naturality \<psi>_in_hom C.ide_dom D.ide_dom D.in_homE \<phi>_\<psi> \<psi>_\<phi>
       by (metis C.comp_in_homI' F.preserves_hom C.in_homE D.in_homE)
 
     lemma respects_natural_isomorphism:
     assumes "natural_isomorphism D C F' F \<tau>" and "natural_isomorphism C D G G' \<mu>"
     shows "meta_adjunction C D F' G'
              (\<lambda>y f. \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C inverse_transformation.map D C F \<tau> y))
              (\<lambda>x g. \<psi> x ((inverse_transformation.map C D G' \<mu> x) \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))"
     proof -
       interpret \<tau>: natural_isomorphism D C F' F \<tau>
         using assms(1) by simp
       interpret \<tau>': inverse_transformation D C F' F \<tau>
         ..
       interpret \<mu>: natural_isomorphism C D G G' \<mu>
         using assms(2) by simp
       interpret \<mu>': inverse_transformation C D G G' \<mu>
         ..
       let ?\<phi>' = "\<lambda>y f. \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)"
       let ?\<psi>' = "\<lambda>x g. \<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)"
       show "meta_adjunction C D F' G' ?\<phi>' ?\<psi>'"
       proof
         show "\<And>y f x. \<lbrakk>D.ide y; \<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<guillemotleft>\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
         proof -
           fix x y f
           assume y: "D.ide y" and f: "\<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           show "\<guillemotleft>\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           proof (intro D.comp_in_homI)
             show "\<guillemotleft>\<mu> (C.cod f) : G x \<rightarrow>\<^sub>D G' x\<guillemotright>"
               using f by fastforce
             show "\<guillemotleft>\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using f y \<phi>_in_hom by auto
           qed
         qed
         show "\<And>x g y. \<lbrakk>C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
         proof -
           fix x y g
           assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           show "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           proof (intro C.comp_in_homI)
             show "\<guillemotleft>\<tau> (D.dom g) : F' y \<rightarrow>\<^sub>C F y\<guillemotright>"
               using g by fastforce
             show "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
               using x g \<psi>_in_hom by auto
           qed
         qed
         show "\<And>y f x. \<lbrakk>D.ide y; \<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                           \<Longrightarrow> \<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                                 \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                               f"
         proof -
           fix x y f
           assume y: "D.ide y" and f: "\<guillemotleft>f : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           have 1: "\<guillemotleft>\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
             using f y \<phi>_in_hom by auto
           show "\<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                   \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                 f"
           proof -
             have "\<psi> x (\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                     \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y))) =
                   \<psi> x ((\<mu>'.map x \<cdot>\<^sub>D \<mu> (C.cod f)) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C
                     \<tau> (D.dom (\<mu> (C.cod f) \<cdot>\<^sub>D \<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)))"
               using D.comp_assoc by simp
             also have "... = \<psi> x (\<phi> y (f \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>C \<tau> y"
               by (metis "1" C.arr_cod C.dom_cod C.ide_cod C.in_homE D.comp_ide_arr D.dom_comp
                   D.ide_compE D.in_homE D.inverse_arrowsE \<mu>'.inverts_components \<mu>.preserves_dom
                   \<mu>.preserves_reflects_arr category.seqI f meta_adjunction_axioms
                   meta_adjunction_def)
             also have "... = f"
               using f y \<psi>_\<phi> C.comp_assoc \<tau>'.inverts_components [of y] C.comp_arr_dom
               by fastforce
             finally show ?thesis by blast
           qed
         qed
         show "\<And>x g y. \<lbrakk>C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>\<rbrakk>
                          \<Longrightarrow> \<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                                \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                              g"
         proof -
           fix x y g
           assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G' x\<guillemotright>"
           have 1: "\<guillemotleft>\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
             using x g \<psi>_in_hom by auto
           show "\<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                   \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                 g"
           proof -
             have "\<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                     \<phi> y ((\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g)) \<cdot>\<^sub>C \<tau>'.map y) =
                   \<mu> (C.cod (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g))) \<cdot>\<^sub>D
                     \<phi> y (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g) \<cdot>\<^sub>C \<tau> (D.dom g) \<cdot>\<^sub>C \<tau>'.map y)"
               using C.comp_assoc by simp
             also have "... = \<mu> x \<cdot>\<^sub>D \<phi> y (\<psi> x (\<mu>'.map x \<cdot>\<^sub>D g))"
               using 1 C.comp_arr_dom C.comp_arr_inv' g by fastforce
             also have "... = (\<mu> x \<cdot>\<^sub>D \<mu>'.map x) \<cdot>\<^sub>D g"
               using x g \<phi>_\<psi> D.comp_assoc by auto
             also have "... = g"
               using x g \<mu>'.inverts_components [of x] D.comp_cod_arr by fastforce
             finally show ?thesis by blast
           qed
         qed
         show "\<And>f x x' g y' y h. \<lbrakk>\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>; \<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>; \<guillemotleft>h : F' y \<rightarrow>\<^sub>C x\<guillemotright>\<rbrakk>
                   \<Longrightarrow> \<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                       G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
         proof -
           fix x y x' y' f g h
           assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F' y \<rightarrow>\<^sub>C x\<guillemotright>"
           show "\<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                 G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
           proof -
             have "\<mu> (C.cod (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g)) \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y') =
                   \<mu> x' \<cdot>\<^sub>D \<phi> y' ((f \<cdot>\<^sub>C h \<cdot>\<^sub>C F' g) \<cdot>\<^sub>C \<tau>'.map y')"
               using f g h by fastforce
             also have "... = \<mu> x' \<cdot>\<^sub>D \<phi> y' (f \<cdot>\<^sub>C (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>C F g)"
               using g \<tau>'.naturality C.comp_assoc by auto
             also have "... = (\<mu> x' \<cdot>\<^sub>D G f) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>D g"
               using f g h \<phi>_naturality [of f x x' g y' y "h \<cdot>\<^sub>C \<tau>'.map y"] D.comp_assoc
               by fastforce
             also have "... = (G' f \<cdot>\<^sub>D \<mu> x) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y) \<cdot>\<^sub>D g"
               using f \<mu>.naturality by auto
             also have "... = G' f \<cdot>\<^sub>D (\<mu> (C.cod h) \<cdot>\<^sub>D \<phi> y (h \<cdot>\<^sub>C \<tau>'.map y)) \<cdot>\<^sub>D g"
               using h D.comp_assoc by auto
             finally show ?thesis by blast
           qed
         qed
       qed
     qed
 
   end
 
   subsection "Hom-Adjunction"
 
   text\<open>
     The bijection between hom-sets that defines an adjunction can be represented
     formally as a natural isomorphism of hom-functors.  However, stating the definition
     this way is more complex than was the case for \<open>meta_adjunction\<close>.
     One reason is that we need to have a ``set category'' that is suitable as
     a target category for the hom-functors, and since the arrows of the categories
     @{term C} and @{term D} will in general have distinct types, we need a set category
     that simultaneously embeds both.  Another reason is that we simply have to formally
     construct the various categories and functors required to express the definition.
 
     This is a good place to point out that I have often included more sublocales
     in a locale than are strictly required.  The main reason for this is the fact that
     the locale system in Isabelle only gives one name to each entity introduced by
     a locale: the name that it has in the first locale in which it occurs.
     This means that entities that make their first appearance deeply nested in sublocales
     will have to be referred to by long qualified names that can be difficult to
     understand, or even to discover.  To counteract this, I have typically introduced
     sublocales before the superlocales that contain them to ensure that the entities
     in the sublocales can be referred to by short meaningful (and predictable) names.
     In my opinion, though, it would be better if the locale system would make entities
     that occur in multiple locales accessible by \emph{all} possible qualified names,
     so that the most perspicuous name could be used in any particular context.
 \<close>
 
   locale hom_adjunction =
     C: category C +
     D: category D +
-    S: replete_set_category S +
+    S: set_category S setp +
     Cop: dual_category C +
     Dop: dual_category D +
     CopxC: product_category Cop.comp C +
     DopxD: product_category Dop.comp D +
     DopxC: product_category Dop.comp C +
     F: "functor" D C F +
     G: "functor" C D G +
-    HomC: hom_functor C S \<phi>C +
-    HomD: hom_functor D S \<phi>D +
+    HomC: hom_functor C S setp \<phi>C +
+    HomD: hom_functor D S setp \<phi>D +
     Fop: dual_functor Dop.comp Cop.comp F +
     FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
     DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
     Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
     Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
-    Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
-    Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
-    \<Phi>: set_valued_transformation DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> +
-    \<Psi>: set_valued_transformation DopxC.comp S Hom_DopxG.map Hom_FopxC.map \<Psi> +
+    Hom_FopxC: set_valued_functor DopxC.comp S setp Hom_FopxC.map +
+    Hom_DopxG: set_valued_functor DopxC.comp S setp Hom_DopxG.map +
+    \<Phi>: set_valued_transformation DopxC.comp S setp Hom_FopxC.map Hom_DopxG.map \<Phi> +
+    \<Psi>: set_valued_transformation DopxC.comp S setp Hom_DopxG.map Hom_FopxC.map \<Psi> +
     \<Phi>\<Psi>: inverse_transformations DopxC.comp S Hom_FopxC.map Hom_DopxG.map \<Phi> \<Psi>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and S :: "'s comp"     (infixr "\<cdot>\<^sub>S" 55)
+    and setp :: "'s set \<Rightarrow> bool"
     and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
     and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<Phi> :: "'d * 'c \<Rightarrow> 's"
     and \<Psi> :: "'d * 'c \<Rightarrow> 's"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     abbreviation \<psi>C :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
     where "\<psi>C \<equiv> HomC.\<psi>"
 
     abbreviation \<psi>D :: "'d * 'd \<Rightarrow> 's \<Rightarrow> 'd"
     where "\<psi>D \<equiv> HomD.\<psi>"
 
   end
 
   subsection "Unit/Counit Adjunction"
 
   text\<open>
     Expressed in unit/counit terms, an adjunction consists of functors
     \<open>F: D \<rightarrow> C\<close> and \<open>G: C \<rightarrow> D\<close>, equipped with natural transformations
     \<open>\<eta>: 1 \<rightarrow> GF\<close> and \<open>\<epsilon>: FG \<rightarrow> 1\<close> satisfying certain ``triangle identities''.
 \<close>
 
   locale unit_counit_adjunction =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G +
     GF: composite_functor D C D F G +
     FG: composite_functor C D C G F +
     FGF: composite_functor D C C F \<open>F o G\<close> +
     GFG: composite_functor C D D G \<open>G o F\<close> +
     \<eta>: natural_transformation D D D.map \<open>G o F\<close> \<eta> +
     \<epsilon>: natural_transformation C C \<open>F o G\<close> C.map \<epsilon> +
     F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
     \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
     \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
     G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
     \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
     G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<eta> :: "'d \<Rightarrow> 'd"
     and \<epsilon> :: "'c \<Rightarrow> 'c" +
     assumes triangle_F: "\<epsilon>FoF\<eta>.map = F"
     and triangle_G: "G\<epsilon>o\<eta>G.map = G"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   lemma unit_determines_counit:
   assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
   and "unit_counit_adjunction C D F G \<eta> \<epsilon>'"
   shows "\<epsilon> = \<epsilon>'"
   proof -
     (* IDEA:  \<epsilon>' = \<epsilon>'FG o (FG\<epsilon> o F\<eta>G) = \<epsilon>'\<epsilon> o F\<eta>G = \<epsilon>FG o (\<epsilon>'FG o F\<eta>G) = \<epsilon> *)
     interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
     interpret Adj': unit_counit_adjunction C D F G \<eta> \<epsilon>' using assms(2) by auto
     interpret FGFG: composite_functor C D C G \<open>F o G o F\<close> ..
     interpret FG\<epsilon>: natural_transformation C C \<open>(F o G) o (F o G)\<close> \<open>F o G\<close> \<open>(F o G) o \<epsilon>\<close>
       using Adj.\<epsilon>.natural_transformation_axioms Adj.FG.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
     interpret F\<eta>G: natural_transformation C C \<open>F o G\<close> \<open>F o G o F o G\<close> \<open>F o \<eta> o G\<close>
       using Adj.\<eta>.natural_transformation_axioms Adj.F\<eta>.natural_transformation_axioms
             Adj.G.as_nat_trans.natural_transformation_axioms horizontal_composite
       by blast
     interpret \<epsilon>'\<epsilon>: natural_transformation C C \<open>F o G o F o G\<close> Adj.C.map \<open>\<epsilon>' o \<epsilon>\<close>
     proof -
       have "natural_transformation C C ((F o G) o (F o G)) Adj.C.map (\<epsilon>' o \<epsilon>)"
         using Adj.\<epsilon>.natural_transformation_axioms Adj'.\<epsilon>.natural_transformation_axioms
               horizontal_composite Adj.C.is_functor comp_functor_identity
         by (metis (no_types, lifting))
       thus "natural_transformation C C (F o G o F o G) Adj.C.map (\<epsilon>' o \<epsilon>)"
         using o_assoc by metis
     qed
     interpret \<epsilon>'\<epsilon>oF\<eta>G: vertical_composite
                          C C \<open>F o G\<close> \<open>F o G o F o G\<close> Adj.C.map \<open>F o \<eta> o G\<close> \<open>\<epsilon>' o \<epsilon>\<close> ..
     have "\<epsilon>' = vertical_composite.map C C (F o Adj.G\<epsilon>o\<eta>G.map) \<epsilon>'"
       using vcomp_ide_dom [of C C "F o G" Adj.C.map \<epsilon>'] Adj.triangle_G
       by (simp add: Adj'.\<epsilon>.natural_transformation_axioms)
     also have "... = vertical_composite.map C C
                        (vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'"
       using whisker_left Adj.F.functor_axioms Adj.G\<epsilon>.natural_transformation_axioms
             Adj.\<eta>G.natural_transformation_axioms o_assoc
       by (metis (no_types, lifting))
     also have "... = vertical_composite.map C C
                        (vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
     proof -
       have "vertical_composite.map C C
               (vertical_composite.map C C (F o \<eta> o G) (F o G o \<epsilon>)) \<epsilon>'
               = vertical_composite.map C C (F o \<eta> o G)
                   (vertical_composite.map C C (F o G o \<epsilon>) \<epsilon>')"
         using vcomp_assoc
         by (metis (no_types, lifting) Adj'.\<epsilon>.natural_transformation_axioms
             FG\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms o_assoc)
       also have "... = vertical_composite.map C C (F o \<eta> o G)
                          (vertical_composite.map C C (\<epsilon>' o F o G) \<epsilon>)"
         using Adj'.\<epsilon>.natural_transformation_axioms Adj.\<epsilon>.natural_transformation_axioms
               interchange_spc [of C C "F o G" Adj.C.map \<epsilon> C "F o G" Adj.C.map \<epsilon>']
         by (metis hcomp_ide_cod hcomp_ide_dom o_assoc)
       also have "... = vertical_composite.map C C
                          (vertical_composite.map C C (F o \<eta> o G) (\<epsilon>' o F o G)) \<epsilon>"
         using vcomp_assoc
         by (metis Adj'.\<epsilon>F.natural_transformation_axioms
             Adj.G.as_nat_trans.natural_transformation_axioms
             Adj.\<epsilon>.natural_transformation_axioms F\<eta>G.natural_transformation_axioms
             horizontal_composite)
       finally show ?thesis by simp
     qed
     also have "... = vertical_composite.map C C
                        (vertical_composite.map D C (F o \<eta>) (\<epsilon>' o F) o G) \<epsilon>"
       using whisker_right Adj'.\<epsilon>F.natural_transformation_axioms
             Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
       by metis
     also have "... = \<epsilon>"
       using Adj'.triangle_F vcomp_ide_cod Adj.\<epsilon>.natural_transformation_axioms by simp
     finally show ?thesis by simp
   qed
 
   lemma counit_determines_unit:
   assumes "unit_counit_adjunction C D F G \<eta> \<epsilon>"
   and "unit_counit_adjunction C D F G \<eta>' \<epsilon>"
   shows "\<eta> = \<eta>'"
   proof -
     interpret Adj: unit_counit_adjunction C D F G \<eta> \<epsilon> using assms(1) by auto
     interpret Adj': unit_counit_adjunction C D F G \<eta>' \<epsilon> using assms(2) by auto
     interpret GFGF: composite_functor D C D F \<open>G o F o G\<close> ..
     interpret GF\<eta>: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>(G o F) o \<eta>\<close>
       using Adj.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
             Adj.GF.as_nat_trans.natural_transformation_axioms comp_functor_identity
             horizontal_composite
       by (metis (no_types, lifting))
     interpret \<eta>'GF: natural_transformation D D \<open>G o F\<close> \<open>(G o F) o (G o F)\<close> \<open>\<eta>' o (G o F)\<close>
       using Adj'.\<eta>.natural_transformation_axioms Adj.GF.functor_axioms
             Adj.GF.as_nat_trans.natural_transformation_axioms comp_identity_functor
             horizontal_composite
       by (metis (no_types, lifting))
     interpret G\<epsilon>F: natural_transformation D D \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>G o \<epsilon> o F\<close>
       using Adj.\<epsilon>.natural_transformation_axioms Adj.F.as_nat_trans.natural_transformation_axioms
             Adj.G\<epsilon>.natural_transformation_axioms horizontal_composite
       by blast
     interpret \<eta>'\<eta>: natural_transformation D D Adj.D.map \<open>G o F o G o F\<close> \<open>\<eta>' o \<eta>\<close>
     proof -
       have "natural_transformation D D Adj.D.map ((G o F) o (G o F)) (\<eta>' o \<eta>)"
         using Adj'.\<eta>.natural_transformation_axioms Adj.D.identity_functor_axioms
               Adj.\<eta>.natural_transformation_axioms horizontal_composite identity_functor.is_functor
         by fastforce
       thus "natural_transformation D D Adj.D.map (G o F o G o F) (\<eta>' o \<eta>)"
         using o_assoc by metis
     qed
     interpret G\<epsilon>Fo\<eta>'\<eta>: vertical_composite
                          D D Adj.D.map \<open>G o F o G o F\<close> \<open>G o F\<close> \<open>\<eta>' o \<eta>\<close> \<open>G o \<epsilon> o F\<close> ..
     have "\<eta>' = vertical_composite.map D D \<eta>' (G o Adj.\<epsilon>FoF\<eta>.map)"
       using vcomp_ide_cod [of D D  Adj.D.map "G o F" \<eta>'] Adj.triangle_F
       by (simp add: Adj'.\<eta>.natural_transformation_axioms)
     also have "... = vertical_composite.map D D \<eta>'
                        (vertical_composite.map D D (G o (F o \<eta>)) (G o (\<epsilon> o F)))"
       using whisker_left Adj.F\<eta>.natural_transformation_axioms Adj.G.functor_axioms
             Adj.\<epsilon>F.natural_transformation_axioms
       by fastforce
     also have "... = vertical_composite.map D D
                        (vertical_composite.map D D \<eta>' (G o (F o \<eta>))) (G o \<epsilon> o F)"
       using vcomp_assoc Adj'.\<eta>.natural_transformation_axioms
             GF\<eta>.natural_transformation_axioms G\<epsilon>F.natural_transformation_axioms o_assoc
       by (metis (no_types, lifting))
     also have "... = vertical_composite.map D D
                        (vertical_composite.map D D \<eta> (\<eta>' o G o F)) (G o \<epsilon> o F)"
         using interchange_spc [of D D Adj.D.map "G o F" \<eta> D Adj.D.map "G o F" \<eta>']
               Adj.\<eta>.natural_transformation_axioms Adj'.\<eta>.natural_transformation_axioms
         by (metis hcomp_ide_cod hcomp_ide_dom o_assoc)
     also have "... = vertical_composite.map D D \<eta>
                        (vertical_composite.map D D (\<eta>' o G o F) (G o \<epsilon> o F))"
       using vcomp_assoc
       by (metis (no_types, lifting) Adj.\<eta>.natural_transformation_axioms
           G\<epsilon>F.natural_transformation_axioms \<eta>'GF.natural_transformation_axioms o_assoc)
     also have "... = vertical_composite.map D D \<eta>
                        (vertical_composite.map C D (\<eta>' o G) (G o \<epsilon>) o F)"
       using whisker_right Adj'.\<eta>G.natural_transformation_axioms Adj.F.functor_axioms
             Adj.G\<epsilon>.natural_transformation_axioms
       by fastforce
     also have "... = \<eta>"
       using Adj'.triangle_G vcomp_ide_dom Adj.GF.functor_axioms
             Adj.\<eta>.natural_transformation_axioms
       by simp
     finally show ?thesis by simp
   qed
 
   subsection "Adjunction"
 
   text\<open>
     The grand unification of everything to do with an adjunction.
 \<close>
 
   locale adjunction =
     C: category C +
     D: category D +
-    S: replete_set_category S +
+    S: set_category S setp +
     Cop: dual_category C +
     Dop: dual_category D +
     CopxC: product_category Cop.comp C +
     DopxD: product_category Dop.comp D +
     DopxC: product_category Dop.comp C +
     idDop: identity_functor Dop.comp +
-    HomC: hom_functor C S \<phi>C +
-    HomD: hom_functor D S \<phi>D +
+    HomC: hom_functor C S setp \<phi>C +
+    HomD: hom_functor D S setp \<phi>D +
     F: left_adjoint_functor D C F +
     G: right_adjoint_functor C D G +
     GF: composite_functor D C D F G +
     FG: composite_functor C D C G F +
     FGF: composite_functor D C C F FG.map +
     GFG: composite_functor C D D G GF.map +
     Fop: dual_functor Dop.comp Cop.comp F +
     FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
     DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
     Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
     Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
-    Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
-    Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
+    Hom_FopxC: set_valued_functor DopxC.comp S setp Hom_FopxC.map +
+    Hom_DopxG: set_valued_functor DopxC.comp S setp Hom_DopxG.map +
     \<eta>: natural_transformation D D D.map GF.map \<eta> +
     \<epsilon>: natural_transformation C C FG.map C.map \<epsilon> +
     F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>\<close> +
     \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta> o G\<close> +
     \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon> o F\<close> +
     G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>\<close> +
     \<epsilon>FoF\<eta>: vertical_composite D C F FGF.map F \<open>F o \<eta>\<close> \<open>\<epsilon> o F\<close> +
     G\<epsilon>o\<eta>G: vertical_composite C D G GFG.map G \<open>\<eta> o G\<close> \<open>G o \<epsilon>\<close> +
     \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> +
     \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon> +
-    \<Phi>\<Psi>: hom_adjunction C D S \<phi>C \<phi>D F G \<Phi> \<Psi>
+    \<Phi>\<Psi>: hom_adjunction C D S setp \<phi>C \<phi>D F G \<Phi> \<Psi>
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and S :: "'s comp"     (infixr "\<cdot>\<^sub>S" 55)
+    and setp :: "'s set \<Rightarrow> bool"
     and \<phi>C :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
     and \<phi>D :: "'d * 'd \<Rightarrow> 'd \<Rightarrow> 's"
     and F :: "'d \<Rightarrow> 'c"
     and G :: "'c \<Rightarrow> 'd"
     and \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     and \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     and \<eta> :: "'d \<Rightarrow> 'd"
     and \<epsilon> :: "'c \<Rightarrow> 'c"
     and \<Phi> :: "'d * 'c \<Rightarrow> 's"
     and \<Psi> :: "'d * 'c \<Rightarrow> 's" +
     assumes \<phi>_in_terms_of_\<eta>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow> \<phi> y f = G f \<cdot>\<^sub>D \<eta> y"
     and \<psi>_in_terms_of_\<epsilon>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow> \<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g"
     and \<eta>_in_terms_of_\<phi>: "D.ide y \<Longrightarrow> \<eta> y = \<phi> y (F y)"
     and \<epsilon>_in_terms_of_\<psi>: "C.ide x \<Longrightarrow> \<epsilon> x = \<psi> x (G x)"
     and \<phi>_in_terms_of_\<Phi>: "\<lbrakk> D.ide y; \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<rbrakk> \<Longrightarrow>
                               \<phi> y f = (\<Phi>\<Psi>.\<psi>D (y, G x) o S.Fun (\<Phi> (y, x)) o \<phi>C (F y, x)) f"
     and \<psi>_in_terms_of_\<Psi>: "\<lbrakk> C.ide x; \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<rbrakk> \<Longrightarrow>
                               \<psi> x g = (\<Phi>\<Psi>.\<psi>C (F y, x) o S.Fun (\<Psi> (y, x)) o \<phi>D (y, G x)) g"
     and \<Phi>_in_terms_of_\<phi>:
            "\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
                 \<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                     (\<phi>D (y, G x) o \<phi> y o \<Phi>\<Psi>.\<psi>C (F y, x))"
     and \<Psi>_in_terms_of_\<psi>:
            "\<lbrakk> C.ide x; D.ide y \<rbrakk> \<Longrightarrow>
                 \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                     (\<phi>C (F y, x) o \<psi> x o \<Phi>\<Psi>.\<psi>D (y, G x))"
 
   section "Meta-Adjunctions Induce Unit/Counit Adjunctions"
 
   context meta_adjunction
   begin
 
     interpretation GF: composite_functor D C D F G ..
     interpretation FG: composite_functor C D C G F ..
     interpretation FGF: composite_functor D C C F FG.map ..
     interpretation GFG: composite_functor C D D G GF.map ..
 
     definition \<eta>o :: "'d \<Rightarrow> 'd"
     where "\<eta>o y = \<phi> y (F y)"
 
     lemma \<eta>o_in_hom:
     assumes "D.ide y"
     shows "\<guillemotleft>\<eta>o y : y \<rightarrow>\<^sub>D G (F y)\<guillemotright>"
       using assms D.ide_in_hom \<eta>o_def \<phi>_in_hom by force
 
     lemma \<phi>_in_terms_of_\<eta>o:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta>o y"
     proof (unfold \<eta>o_def)
       have 1: "\<guillemotleft>F y : F y \<rightarrow>\<^sub>C F y\<guillemotright>"
         using assms(1) D.ide_in_hom by blast
       hence "\<phi> y (F y) = \<phi> y (F y) \<cdot>\<^sub>D y"
         by (metis assms(1) D.in_homE \<phi>_in_hom D.comp_arr_dom)
       thus "\<phi> y f = G f \<cdot>\<^sub>D \<phi> y (F y)"
         using assms 1 D.ide_in_hom by (metis C.comp_arr_dom C.in_homE \<phi>_naturality)
     qed
 
     lemma \<phi>_F_char:
     assumes "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>"
     shows "\<phi> y' (F g) = \<eta>o y \<cdot>\<^sub>D g"
       using assms \<eta>o_def \<phi>_in_hom [of y "F y" "F y"]
             D.comp_cod_arr [of "D (\<phi> y (F y)) g" "G (F y)"]
             \<phi>_naturality [of "F y" "F y" "F y" g y' y "F y"]
       by (metis C.ide_in_hom D.arr_cod_iff_arr D.arr_dom D.cod_cod D.cod_dom D.comp_ide_arr
           D.comp_ide_self D.ide_cod D.in_homE F.as_nat_trans.is_natural_2 F.functor_axioms
           F.preserves_section_retraction \<phi>_in_hom functor.preserves_hom)
 
     interpretation \<eta>: transformation_by_components D D D.map GF.map \<eta>o
     proof
       show "\<And>a. D.ide a \<Longrightarrow> \<guillemotleft>\<eta>o a : D.map a \<rightarrow>\<^sub>D GF.map a\<guillemotright>"
         using \<eta>o_def \<phi>_in_hom D.ide_in_hom by force
       fix f
       assume f: "D.arr f"
       show "\<eta>o (D.cod f) \<cdot>\<^sub>D D.map f = GF.map f \<cdot>\<^sub>D \<eta>o (D.dom f)"
         using f \<phi>_F_char [of "D.map f" "D.dom f" "D.cod f"]
               \<phi>_in_terms_of_\<eta>o [of "D.dom f" "F f" "F (D.cod f)"]
         by force
     qed
 
     lemma \<eta>_map_simp:
     assumes "D.ide y"
     shows "\<eta>.map y = \<phi> y (F y)"
       using assms \<eta>.map_simp_ide \<eta>o_def by simp
 
     definition \<epsilon>o :: "'c \<Rightarrow> 'c"
     where "\<epsilon>o x = \<psi> x (G x)"
 
     lemma \<epsilon>o_in_hom:
     assumes "C.ide x"
     shows "\<guillemotleft>\<epsilon>o x : F (G x) \<rightarrow>\<^sub>C x\<guillemotright>"
       using assms C.ide_in_hom \<epsilon>o_def \<psi>_in_hom by force
 
     lemma \<psi>_in_terms_of_\<epsilon>o:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = \<epsilon>o x \<cdot>\<^sub>C F g"
     proof -
       have "\<epsilon>o x \<cdot>\<^sub>C F g = x \<cdot>\<^sub>C \<psi> x (G x) \<cdot>\<^sub>C F g"
         using assms \<epsilon>o_def \<psi>_in_hom [of x "G x" "G x"]
               C.comp_cod_arr [of "\<psi> x (G x) \<cdot>\<^sub>C F g" x]
         by fastforce
       also have "... = \<psi> x (G x \<cdot>\<^sub>D G x \<cdot>\<^sub>D g)"
         using assms \<psi>_naturality [of x x x g y "G x" "G x"] by force
       also have "... = \<psi> x g"
         using assms D.comp_cod_arr by fastforce
       finally show ?thesis by simp
     qed
 
     lemma \<psi>_G_char:
     assumes "\<guillemotleft>f: x \<rightarrow>\<^sub>C x'\<guillemotright>"
     shows "\<psi> x' (G f) = f \<cdot>\<^sub>C \<epsilon>o x"
     proof (unfold \<epsilon>o_def)
       have 0: "C.ide x \<and> C.ide x'" using assms by auto
       thus "\<psi> x' (G f) = f \<cdot>\<^sub>C \<psi> x (G x)"
         using 0 assms \<psi>_naturality \<psi>_in_hom [of x "G x" "G x"] G.preserves_hom \<epsilon>o_def
               \<psi>_in_terms_of_\<epsilon>o G.as_nat_trans.is_natural_1 C.ide_in_hom
         by (metis C.arrI C.in_homE)
     qed
 
     interpretation \<epsilon>: transformation_by_components C C FG.map C.map \<epsilon>o
       apply unfold_locales
       using \<epsilon>o_in_hom
        apply simp
       using \<psi>_G_char \<psi>_in_terms_of_\<epsilon>o
       by (metis C.arr_iff_in_hom C.ide_cod C.map_simp G.preserves_hom comp_apply)
 
     lemma \<epsilon>_map_simp:
     assumes "C.ide x"
     shows "\<epsilon>.map x = \<psi> x (G x)"
       using assms \<epsilon>o_def by simp
 
     interpretation FD: composite_functor D D C D.map F ..
     interpretation CF: composite_functor D C C F C.map ..
     interpretation GC: composite_functor C C D C.map G ..
     interpretation DG: composite_functor C D D G D.map ..
 
     interpretation F\<eta>: natural_transformation D C F \<open>F o G o F\<close> \<open>F o \<eta>.map\<close>
       by (metis (no_types, lifting) F.as_nat_trans.natural_transformation_axioms
           F.functor_axioms \<eta>.natural_transformation_axioms comp_functor_identity
           horizontal_composite o_assoc)
 
     interpretation \<epsilon>F: natural_transformation D C \<open>F o G o F\<close> F \<open>\<epsilon>.map o F\<close>
       using \<epsilon>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
 
     interpretation \<eta>G: natural_transformation C D G \<open>G o F o G\<close> \<open>\<eta>.map o G\<close>
       using \<eta>.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
             horizontal_composite
       by fastforce
 
     interpretation G\<epsilon>: natural_transformation C D \<open>G o F o G\<close> G \<open>G o \<epsilon>.map\<close>
       by (metis (no_types, lifting) G.as_nat_trans.natural_transformation_axioms
           G.functor_axioms \<epsilon>.natural_transformation_axioms comp_functor_identity
           horizontal_composite o_assoc)
 
     interpretation \<epsilon>FoF\<eta>: vertical_composite D C F \<open>F o G o F\<close> F \<open>F o \<eta>.map\<close> \<open>\<epsilon>.map o F\<close>
       ..
     interpretation G\<epsilon>o\<eta>G: vertical_composite C D G \<open>G o F o G\<close> G \<open>\<eta>.map o G\<close> \<open>G o \<epsilon>.map\<close>
       ..
 
     lemma unit_counit_F:
     assumes "D.ide y"
     shows "F y = \<epsilon>o (F y) \<cdot>\<^sub>C F (\<eta>o y)"
       using assms \<psi>_in_terms_of_\<epsilon>o \<eta>o_def \<psi>_\<phi> \<eta>o_in_hom F.preserves_ide C.ide_in_hom by metis
 
     lemma unit_counit_G:
     assumes "C.ide x"
     shows "G x = G (\<epsilon>o x) \<cdot>\<^sub>D \<eta>o (G x)"
       using assms \<phi>_in_terms_of_\<eta>o \<epsilon>o_def \<phi>_\<psi> \<epsilon>o_in_hom G.preserves_ide D.ide_in_hom by metis
 
     lemma induces_unit_counit_adjunction':
     shows "unit_counit_adjunction C D F G \<eta>.map \<epsilon>.map"
     proof
       show "\<epsilon>FoF\<eta>.map = F"
         using \<epsilon>FoF\<eta>.is_natural_transformation \<epsilon>FoF\<eta>.map_simp_ide unit_counit_F
               F.as_nat_trans.natural_transformation_axioms
         by (intro NaturalTransformation.eqI) auto
       show "G\<epsilon>o\<eta>G.map = G"
         using G\<epsilon>o\<eta>G.is_natural_transformation G\<epsilon>o\<eta>G.map_simp_ide unit_counit_G
               G.as_nat_trans.natural_transformation_axioms
         by (intro NaturalTransformation.eqI) auto
     qed
 
     definition \<eta> :: "'d \<Rightarrow> 'd" where "\<eta> \<equiv> \<eta>.map"
     definition \<epsilon> :: "'c \<Rightarrow> 'c" where "\<epsilon> \<equiv> \<epsilon>.map"
 
     theorem induces_unit_counit_adjunction:
     shows "unit_counit_adjunction C D F G \<eta> \<epsilon>"
       unfolding \<eta>_def \<epsilon>_def
       using induces_unit_counit_adjunction' by simp
 
     lemma \<eta>_is_natural_transformation:
     shows "natural_transformation D D D.map GF.map \<eta>"
       unfolding \<eta>_def ..
 
     lemma \<epsilon>_is_natural_transformation:
     shows "natural_transformation C C FG.map C.map \<epsilon>"
       unfolding \<epsilon>_def ..
 
     text\<open>
       From the defined @{term \<eta>} and @{term \<epsilon>} we can recover the original @{term \<phi>} and @{term \<psi>}.
 \<close>
 
     lemma \<phi>_in_terms_of_\<eta>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = G f \<cdot>\<^sub>D \<eta> y"
       using assms \<eta>_def by (simp add: \<phi>_in_terms_of_\<eta>o)
 
     lemma \<psi>_in_terms_of_\<epsilon>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = \<epsilon> x \<cdot>\<^sub>C F g"
       using assms \<epsilon>_def by (simp add: \<psi>_in_terms_of_\<epsilon>o)
 
   end
 
   section "Meta-Adjunctions Induce Left and Right Adjoint Functors"
 
   context meta_adjunction
   begin
 
     interpretation unit_counit_adjunction C D F G \<eta> \<epsilon>
       using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
 
     lemma has_terminal_arrows_from_functor:
     assumes x: "C.ide x"
     shows "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)"
     and "\<And>y' f. arrow_from_functor D C F y' x f
                    \<Longrightarrow> terminal_arrow_from_functor.the_coext D C F (G x) (\<epsilon> x) y' f = \<phi> y' f"
     proof -
       interpret \<epsilon>x: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
         using x \<epsilon>.preserves_hom G.preserves_ide by unfold_locales auto
       have 1: "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow>
                       \<epsilon>x.is_coext y' f (\<phi> y' f) \<and> (\<forall>g'. \<epsilon>x.is_coext y' f g' \<longrightarrow> g' = \<phi> y' f)"
         using x
         by (metis (full_types) \<epsilon>x.is_coext_def \<phi>_\<psi> \<psi>_in_terms_of_\<epsilon> arrow_from_functor.arrow
             \<phi>_in_hom \<psi>_\<phi>)
       interpret \<epsilon>x: terminal_arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon> x\<close>
         using 1 by unfold_locales blast
       show "terminal_arrow_from_functor D C F (G x) x (\<epsilon> x)" ..
       show "\<And>y' f. arrow_from_functor D C F y' x f \<Longrightarrow> \<epsilon>x.the_coext y' f = \<phi> y' f"
         using 1 \<epsilon>x.the_coext_def by auto
     qed
 
     lemma has_left_adjoint_functor:
     shows "left_adjoint_functor D C F"
       apply unfold_locales using has_terminal_arrows_from_functor by auto
 
     lemma has_initial_arrows_to_functor:
     assumes y: "D.ide y"
     shows "initial_arrow_to_functor C D G y (F y) (\<eta> y)"
     and "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
                   initial_arrow_to_functor.the_ext C D G (F y) (\<eta> y) x' g = \<psi> x' g"
     proof -
       interpret \<eta>y: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
         using y by unfold_locales auto
       have 1: "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow>
                          \<eta>y.is_ext x' g (\<psi> x' g) \<and> (\<forall>f'. \<eta>y.is_ext x' g f' \<longrightarrow> f' = \<psi> x' g)"
         using y
         by (metis (full_types) \<eta>y.is_ext_def \<psi>_\<phi> \<phi>_in_terms_of_\<eta> arrow_to_functor.arrow
             \<psi>_in_hom \<phi>_\<psi>)
       interpret \<eta>y: initial_arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta> y\<close>
         apply unfold_locales using 1 by blast
       show "initial_arrow_to_functor C D G y (F y) (\<eta> y)" ..
       show "\<And>x' g. arrow_to_functor C D G y x' g \<Longrightarrow> \<eta>y.the_ext x' g = \<psi> x' g"
         using 1 \<eta>y.the_ext_def by auto
     qed
 
     lemma has_right_adjoint_functor:
     shows "right_adjoint_functor C D G"
       apply unfold_locales using has_initial_arrows_to_functor by auto
 
   end
 
   section "Unit/Counit Adjunctions Induce Meta-Adjunctions"
 
   context unit_counit_adjunction
   begin
 
     definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where "\<phi> y h = G h \<cdot>\<^sub>D \<eta> y"
 
     definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where "\<psi> x h = \<epsilon> x \<cdot>\<^sub>C F h"
 
     interpretation meta_adjunction C D F G \<phi> \<psi>
     proof
       fix x :: 'c and y :: 'd and f :: 'c
       assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show 0: "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
         using f y G.preserves_hom \<eta>.preserves_hom \<phi>_def D.ide_in_hom by auto
       show "\<psi> x (\<phi> y f) = f"
       proof -
         have "\<psi> x (\<phi> y f) = (\<epsilon> x \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (\<eta> y)"
           using y f \<phi>_def \<psi>_def C.comp_assoc by auto
         also have "... = (f \<cdot>\<^sub>C \<epsilon> (F y)) \<cdot>\<^sub>C F (\<eta> y)"
           using y f \<epsilon>.naturality by auto
         also have "... = f"
           using y f \<epsilon>FoF\<eta>.map_simp_2 triangle_F C.comp_arr_dom D.ide_in_hom C.comp_assoc
           by fastforce
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and y :: 'd and g :: 'd
       assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       show "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>" using g x \<psi>_def by fastforce
       show "\<phi> y (\<psi> x g) = g"
       proof -
         have "\<phi> y (\<psi> x g) = (G (\<epsilon> x) \<cdot>\<^sub>D \<eta> (G x)) \<cdot>\<^sub>D g"
           using g x \<phi>_def \<psi>_def \<eta>.naturality [of g] D.comp_assoc by auto
         also have "... = g"
           using x g triangle_G D.comp_ide_arr G\<epsilon>o\<eta>G.map_simp_ide by auto
         finally show ?thesis by auto
       qed
       next
       fix f :: 'c and g :: 'd and h :: 'c and x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
       assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
         using \<phi>_def f g h \<eta>.naturality D.comp_assoc by fastforce
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>" ..
 
     text\<open>
       From the defined @{term \<phi>} and @{term \<psi>} we can recover the original @{term \<eta>} and @{term \<epsilon>}.
 \<close>
 
     lemma \<eta>_in_terms_of_\<phi>:
     assumes "D.ide y"
     shows "\<eta> y = \<phi> y (F y)"
       using assms \<phi>_def D.comp_cod_arr by auto
 
     lemma \<epsilon>_in_terms_of_\<psi>:
     assumes "C.ide x"
     shows "\<epsilon> x = \<psi> x (G x)"
       using assms \<psi>_def C.comp_arr_dom by auto
 
   end
 
   section "Left and Right Adjoint Functors Induce Meta-Adjunctions"
 
   text\<open>
     A left adjoint functor induces a meta-adjunction, modulo the choice of a
     right adjoint and counit.
 \<close>
 
   context left_adjoint_functor
   begin
 
     definition Go :: "'c \<Rightarrow> 'd"
     where "Go a = (SOME b. \<exists>e. terminal_arrow_from_functor D C F b a e)"
 
     definition \<epsilon>o :: "'c \<Rightarrow> 'c"
     where "\<epsilon>o a = (SOME e. terminal_arrow_from_functor D C F (Go a) a e)"
 
     lemma Go_\<epsilon>o_terminal:
     assumes "\<exists>b e. terminal_arrow_from_functor D C F b a e"
     shows "terminal_arrow_from_functor D C F (Go a) a (\<epsilon>o a)"
       using assms Go_def \<epsilon>o_def
             someI_ex [of "\<lambda>b. \<exists>e. terminal_arrow_from_functor D C F b a e"]
             someI_ex [of "\<lambda>e. terminal_arrow_from_functor D C F (Go a) a e"]
       by simp
 
     text\<open>
       The right adjoint @{term G} to @{term F} takes each arrow @{term f} of
       @{term[source=true] C} to the unique @{term[source=true] D}-coextension of
       @{term "C f (\<epsilon>o (C.dom f))"} along @{term "\<epsilon>o (C.cod f)"}.
 \<close>
 
     definition G :: "'c \<Rightarrow> 'd"
     where "G f = (if C.arr f then
                      terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
                                   (Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))
                   else D.null)"
 
     lemma G_ide:
     assumes "C.ide x"
     shows "G x = Go x"
     proof -
       interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
         using assms ex_terminal_arrow Go_\<epsilon>o_terminal by blast
       have 1: "arrow_from_functor D C F (Go x) x (\<epsilon>o x)" ..
       have "is_coext (Go x) (\<epsilon>o x) (Go x)"
         using arrow is_coext_def C.in_homE C.comp_arr_dom by auto
       hence "Go x = the_coext (Go x) (\<epsilon>o x)" using 1 the_coext_unique by blast
       moreover have "\<epsilon>o x = C x (\<epsilon>o (C.dom x))"
         using assms arrow C.comp_ide_arr C.seqI' C.ide_in_hom C.in_homE by metis
       ultimately show ?thesis using assms G_def C.cod_dom C.ide_in_hom C.in_homE by metis
     qed
 
     lemma G_is_functor:
     shows "functor C D G"
     proof
       fix f :: 'c
       assume "\<not>C.arr f"
       thus "G f = D.null" using G_def by auto
       next
       fix f :: 'c
       assume f: "C.arr f"
       let ?x = "C.dom f"
       let ?x' = "C.cod f"
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
         using f x\<epsilon>.arrow by (unfold_locales, auto)
       have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))" using f G_def by simp
       hence Gf: "\<guillemotleft>G f : Go ?x \<rightarrow>\<^sub>D Go ?x'\<guillemotright> \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
         using 1 x'\<epsilon>.the_coext_prop by simp
       show "D.arr (G f)" using Gf by auto
       show "D.dom (G f) = G ?x" using f Gf G_ide by auto
       show "D.cod (G f) = G ?x'" using f Gf G_ide by auto
       next
       fix f f' :: 'c
       assume ff': "C.arr (C f' f)"
       have f: "C.arr f" using ff' by auto
       let ?x = "C.dom f"
       let ?x' = "C.cod f"
       let ?x'' = "C.cod f'"
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> \<open>?x\<close> \<open>\<epsilon>o ?x\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> \<open>?x'\<close> \<open>\<epsilon>o ?x'\<close>
         using f ex_terminal_arrow Go_\<epsilon>o_terminal by simp
       interpret x''\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x''\<close> \<open>?x''\<close> \<open>\<epsilon>o ?x''\<close>
         using ff' ex_terminal_arrow Go_\<epsilon>o_terminal by auto
       have 1: "arrow_from_functor D C F (Go ?x) ?x' (f \<cdot>\<^sub>C \<epsilon>o ?x)"
          using f x\<epsilon>.arrow by (unfold_locales, auto)
       have 2: "arrow_from_functor D C F (Go ?x') ?x'' (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
          using ff' x'\<epsilon>.arrow by (unfold_locales, auto)
       have "G f = x'\<epsilon>.the_coext (Go ?x) (C f (\<epsilon>o ?x))"
         using f G_def by simp
       hence Gf: "D.in_hom (G f) (Go ?x) (Go ?x') \<and> f \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x' \<cdot>\<^sub>C F (G f)"
         using 1 x'\<epsilon>.the_coext_prop by simp
       have "G f' = x''\<epsilon>.the_coext (Go ?x') (f' \<cdot>\<^sub>C \<epsilon>o ?x')"
         using ff' G_def by auto
       hence Gf': "\<guillemotleft>G f' : Go (C.cod f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright> \<and> f' \<cdot>\<^sub>C \<epsilon>o ?x' = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f')"
         using 2 x''\<epsilon>.the_coext_prop by simp
       show "G (f' \<cdot>\<^sub>C f) = G f' \<cdot>\<^sub>D G f"
       proof -
         have "x''\<epsilon>.is_coext (Go ?x) ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x) (G f' \<cdot>\<^sub>D G f)"
         proof -
           have 3: "\<guillemotleft>G f' \<cdot>\<^sub>D G f : Go (C.dom f) \<rightarrow>\<^sub>D Go (C.cod f')\<guillemotright>" using 1 2 Gf Gf' by auto
           moreover have "(f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x = \<epsilon>o ?x'' \<cdot>\<^sub>C F (G f' \<cdot>\<^sub>D G f)"
             by (metis 3 C.comp_assoc D.in_homE Gf Gf' preserves_comp)
           ultimately show ?thesis using x''\<epsilon>.is_coext_def by auto
         qed
         moreover have "arrow_from_functor D C F (Go ?x) ?x'' ((f' \<cdot>\<^sub>C f) \<cdot>\<^sub>C \<epsilon>o ?x)"
            using ff' x\<epsilon>.arrow by unfold_locales blast
         ultimately show ?thesis
           using ff' G_def x''\<epsilon>.the_coext_unique C.seqE C.cod_comp C.dom_comp by auto
       qed
     qed
 
     interpretation G: "functor" C D G using G_is_functor by auto
 
     lemma G_simp:
     assumes "C.arr f"
     shows "G f = terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (\<epsilon>o (C.cod f))
                                                              (Go (C.dom f)) (f \<cdot>\<^sub>C \<epsilon>o (C.dom f))"
       using assms G_def by simp
 
     interpretation idC: identity_functor C ..
     interpretation GF: composite_functor C D C G F ..
 
     interpretation \<epsilon>: transformation_by_components C C GF.map C.map \<epsilon>o
     proof
       fix x :: 'c
       assume x: "C.ide x"
       show "\<guillemotleft>\<epsilon>o x : GF.map x \<rightarrow>\<^sub>C C.map x\<guillemotright>"
       proof -
         interpret terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
           using x Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         show ?thesis using x G_ide arrow by auto
       qed
       next
       fix f :: 'c
       assume f: "C.arr f"
       show "\<epsilon>o (C.cod f) \<cdot>\<^sub>C GF.map f = C.map f \<cdot>\<^sub>C \<epsilon>o (C.dom f)"
       proof -
         let ?x = "C.dom f"
         let ?x' = "C.cod f"
         interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x\<close> ?x \<open>\<epsilon>o ?x\<close>
           using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         interpret x'\<epsilon>: terminal_arrow_from_functor D C F \<open>Go ?x'\<close> ?x' \<open>\<epsilon>o ?x'\<close>
           using f Go_\<epsilon>o_terminal ex_terminal_arrow by simp
         have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (\<epsilon>o ?x))"
            using f x\<epsilon>.arrow by unfold_locales auto
         have "G f = x'\<epsilon>.the_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x)"
           using f G_simp by blast
         hence "x'\<epsilon>.is_coext (Go ?x) (f \<cdot>\<^sub>C \<epsilon>o ?x) (G f)"
           using 1 x'\<epsilon>.the_coext_prop x'\<epsilon>.is_coext_def by auto
         thus ?thesis
           using f x'\<epsilon>.is_coext_def by simp
       qed
     qed
 
     definition \<psi>
     where "\<psi> x h = C (\<epsilon>.map x) (F h)"
 
     lemma \<psi>_in_hom:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<guillemotleft>\<psi> x g : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       unfolding \<psi>_def using assms \<epsilon>.maps_ide_in_hom by auto
 
     lemma \<psi>_natural:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
     proof -
       have "f \<cdot>\<^sub>C \<psi> x h \<cdot>\<^sub>C F g = f \<cdot>\<^sub>C (\<epsilon>.map x \<cdot>\<^sub>C F h) \<cdot>\<^sub>C F g"
         unfolding \<psi>_def by auto
       also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F h \<cdot>\<^sub>C F g"
         using C.comp_assoc by fastforce
       also have "... = (f \<cdot>\<^sub>C \<epsilon>.map x) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
         using g h by fastforce
       also have "... = (\<epsilon>.map x' \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (h \<cdot>\<^sub>D g)"
         using f \<epsilon>.naturality by auto
       also have "... = \<epsilon>.map x' \<cdot>\<^sub>C F ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
         using f g h C.comp_assoc by fastforce
       also have "... = \<psi> x' ((G f \<cdot>\<^sub>D h) \<cdot>\<^sub>D g)"
         unfolding \<psi>_def by auto
       finally show ?thesis by auto
     qed
 
     lemma \<psi>_inverts_coext:
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "arrow_from_functor.is_coext D C F (G x) (\<epsilon>.map x) y (\<psi> x g) g"
     proof -
       interpret x\<epsilon>: arrow_from_functor D C F \<open>G x\<close> x \<open>\<epsilon>.map x\<close>
         using x \<epsilon>.maps_ide_in_hom by unfold_locales auto
       show "x\<epsilon>.is_coext y (\<psi> x g) g"
         using x g \<psi>_def x\<epsilon>.is_coext_def G_ide by blast
     qed
 
     lemma \<psi>_invertible:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<exists>!g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"
     proof
       have x: "C.ide x" using f by auto
       interpret x\<epsilon>: terminal_arrow_from_functor D C F \<open>Go x\<close> x \<open>\<epsilon>o x\<close>
         using x ex_terminal_arrow Go_\<epsilon>o_terminal by auto
       have 1: "arrow_from_functor D C F y x f"
         using y f by (unfold_locales, auto)
       let ?g = "x\<epsilon>.the_coext y f"
       have "\<psi> x ?g = f"
         using 1 x y \<psi>_def x\<epsilon>.the_coext_prop G_ide \<psi>_inverts_coext x\<epsilon>.is_coext_def by simp
       thus "\<guillemotleft>?g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x ?g = f"
         using 1 x x\<epsilon>.the_coext_prop G_ide by simp
       show "\<And>g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = f \<Longrightarrow> g' = ?g"
         using 1 x y \<psi>_inverts_coext G_ide x\<epsilon>.the_coext_unique by force
     qed
 
     definition \<phi>
     where "\<phi> y f = (THE g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G (C.cod f)\<guillemotright> \<and> \<psi> (C.cod f) g = f)"
 
     lemma \<phi>_in_hom:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
       by auto
 
     lemma \<phi>_\<psi>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<phi> y (\<psi> x g) = g"
     proof -
       have "\<phi> y (\<psi> x g) = (THE g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g)"
       proof -
         have "C.cod (\<psi> x g) = x"
           using assms \<psi>_in_hom by auto
         thus ?thesis
           using \<phi>_def by auto
       qed
       moreover have "\<exists>!g'. \<guillemotleft>g' : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g' = \<psi> x g"
         using assms \<psi>_in_hom \<psi>_invertible D.ide_dom by blast
       ultimately show "\<phi> y (\<psi> x g) = g"
         using assms(2) by auto
     qed
 
     lemma \<psi>_\<phi>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<psi> x (\<phi> y f) = f"
       using assms \<psi>_invertible \<phi>_def theI' [of "\<lambda>g. \<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright> \<and> \<psi> x g = f"]
       by auto
 
     lemma \<phi>_natural:
     assumes "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
     proof -
       have "C.ide x' \<and> D.ide y \<and> D.in_hom (\<phi> y h) y (G x)"
         using assms \<phi>_in_hom by auto
       thus ?thesis
         using assms D.comp_in_homI G.preserves_hom \<psi>_natural [of f x x' g y' y "\<phi> y h"] \<phi>_\<psi> \<psi>_\<phi>
         by auto
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>"
       using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
       by unfold_locales auto
 
   end
 
   text\<open>
     A right adjoint functor induces a meta-adjunction, modulo the choice of a
     left adjoint and unit.
 \<close>
 
   context right_adjoint_functor
   begin
 
     definition Fo :: "'d \<Rightarrow> 'c"
     where "Fo y = (SOME x. \<exists>u. initial_arrow_to_functor C D G y x u)"
 
     definition \<eta>o :: "'d \<Rightarrow> 'd"
     where "\<eta>o y = (SOME u. initial_arrow_to_functor C D G y (Fo y) u)"
 
     lemma Fo_\<eta>o_initial:
     assumes "\<exists>x u. initial_arrow_to_functor C D G y x u"
     shows "initial_arrow_to_functor C D G y (Fo y) (\<eta>o y)"
       using assms Fo_def \<eta>o_def
             someI_ex [of "\<lambda>x. \<exists>u. initial_arrow_to_functor C D G y x u"]
             someI_ex [of "\<lambda>u. initial_arrow_to_functor C D G y (Fo y) u"]
       by simp
 
     text\<open>
       The left adjoint @{term F} to @{term g} takes each arrow @{term g} of
       @{term[source=true] D} to the unique @{term[source=true] C}-extension of
       @{term "D (\<eta>o (D.cod g)) g"} along @{term "\<eta>o (D.dom g)"}.
 \<close>
 
     definition F :: "'d \<Rightarrow> 'c"
     where "F g = (if D.arr g then
                      initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
                                   (Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)
                   else C.null)"
 
     lemma F_ide:
     assumes "D.ide y"
     shows "F y = Fo y"
     proof -
       interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
         using assms initial_arrows_exist Fo_\<eta>o_initial by blast
       have 1: "arrow_to_functor C D G y (Fo y) (\<eta>o y)" ..
       have "is_ext (Fo y) (\<eta>o y) (Fo y)"
         unfolding is_ext_def using arrow D.comp_ide_arr [of "G (Fo y)" "\<eta>o y"] by force
       hence "Fo y = the_ext (Fo y) (\<eta>o y)"
         using 1 the_ext_unique by blast
       moreover have "\<eta>o y = D (\<eta>o (D.cod y)) y"
         using assms arrow D.comp_arr_ide D.comp_arr_dom by auto
       ultimately show ?thesis
         using assms F_def D.dom_cod D.in_homE D.ide_in_hom by metis
     qed
 
     lemma F_is_functor:
     shows "functor D C F"
     proof
       fix g :: 'd
       assume "\<not>D.arr g"
       thus "F g = C.null" using F_def by auto
       next
       fix g :: 'd
       assume g: "D.arr g"
       let ?y = "D.dom g"
       let ?y' = "D.cod g"
       interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       have 1: "arrow_to_functor C D G ?y (Fo ?y') (D (\<eta>o ?y') g)"
         using g y'\<eta>.arrow by unfold_locales auto
       have "F g = y\<eta>.the_ext (Fo ?y') (D (\<eta>o ?y') g)"
         using g F_def by simp
       hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
         using 1 y\<eta>.the_ext_prop by simp
       show "C.arr (F g)" using Fg by auto
       show "C.dom (F g) = F ?y" using Fg g F_ide by auto
       show "C.cod (F g) = F ?y'" using Fg g F_ide by auto
       next
       fix g :: 'd
       fix g' :: 'd
       assume g': "D.arr (D g' g)"
       have g: "D.arr g" using g' by auto
       let ?y = "D.dom g"
       let ?y' = "D.cod g"
       let ?y'' = "D.cod g'"
       interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
         using g initial_arrows_exist Fo_\<eta>o_initial by simp
       interpret y''\<eta>: initial_arrow_to_functor C D G ?y'' \<open>Fo ?y''\<close> \<open>\<eta>o ?y''\<close>
         using g' initial_arrows_exist Fo_\<eta>o_initial by auto
       have 1: "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
         using g y'\<eta>.arrow by unfold_locales auto
       have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
         using g F_def by simp
       hence Fg: "\<guillemotleft>F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y'\<guillemotright> \<and> \<eta>o ?y' \<cdot>\<^sub>D g = G (F g) \<cdot>\<^sub>D \<eta>o ?y"
         using 1 y\<eta>.the_ext_prop by simp
       have 2: "arrow_to_functor C D G ?y' (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
         using g' y''\<eta>.arrow by unfold_locales auto
       have "F g' = y'\<eta>.the_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g')"
         using g' F_def by auto
       hence Fg': "\<guillemotleft>F g' : Fo ?y' \<rightarrow>\<^sub>C Fo ?y''\<guillemotright> \<and> \<eta>o ?y'' \<cdot>\<^sub>D g' = G (F g') \<cdot>\<^sub>D \<eta>o ?y'"
         using 2 y'\<eta>.the_ext_prop by simp
       show "F (g' \<cdot>\<^sub>D g) = F g' \<cdot>\<^sub>C F g"
       proof -
         have "y\<eta>.is_ext (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g) (F g' \<cdot>\<^sub>C F g)"
         proof -
           have 3: "\<guillemotleft>F g' \<cdot>\<^sub>C F g : Fo ?y \<rightarrow>\<^sub>C Fo ?y''\<guillemotright>" using 1 2 Fg Fg' by auto
           moreover have "\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g = G (F g' \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>o ?y"
             using Fg Fg' g g' 3 y''\<eta>.arrow
             by (metis C.arrI D.comp_assoc preserves_comp)
           ultimately show ?thesis using y\<eta>.is_ext_def by auto
         qed
         moreover have "arrow_to_functor C D G ?y (Fo ?y'') (\<eta>o ?y'' \<cdot>\<^sub>D g' \<cdot>\<^sub>D g)"
           using g g' y''\<eta>.arrow by unfold_locales auto
         ultimately show ?thesis
           using g g' F_def y\<eta>.the_ext_unique D.dom_comp D.cod_comp by auto
       qed
     qed
 
     interpretation F: "functor" D C F using F_is_functor by auto
 
     lemma F_simp:
     assumes "D.arr g"
     shows "F g = initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (\<eta>o (D.dom g))
                                                         (Fo (D.cod g)) (\<eta>o (D.cod g) \<cdot>\<^sub>D g)"
       using assms F_def by simp
 
     interpretation FG: composite_functor D C D F G ..
 
     interpretation \<eta>: transformation_by_components D D D.map FG.map \<eta>o
     proof
       fix y :: 'd
       assume y: "D.ide y"
       show "\<guillemotleft>\<eta>o y : D.map y \<rightarrow>\<^sub>D FG.map y\<guillemotright>"
       proof -
         interpret initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
           using y Fo_\<eta>o_initial initial_arrows_exist by simp
         show ?thesis using y F_ide arrow by auto
       qed
       next
       fix g :: 'd
       assume g: "D.arr g"
       show "\<eta>o (D.cod g) \<cdot>\<^sub>D D.map g = FG.map g \<cdot>\<^sub>D \<eta>o (D.dom g)"
       proof -
         let ?y = "D.dom g"
         let ?y' = "D.cod g"
         interpret y\<eta>: initial_arrow_to_functor C D G ?y \<open>Fo ?y\<close> \<open>\<eta>o ?y\<close>
           using g Fo_\<eta>o_initial initial_arrows_exist by simp
         interpret y'\<eta>: initial_arrow_to_functor C D G ?y' \<open>Fo ?y'\<close> \<open>\<eta>o ?y'\<close>
           using g Fo_\<eta>o_initial initial_arrows_exist by simp
         have "arrow_to_functor C D G ?y (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
           using g y'\<eta>.arrow by unfold_locales auto
         moreover have "F g = y\<eta>.the_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g)"
           using g F_simp by blast
         ultimately have "y\<eta>.is_ext (Fo ?y') (\<eta>o ?y' \<cdot>\<^sub>D g) (F g)"
           using y\<eta>.the_ext_prop y\<eta>.is_ext_def by auto
         thus ?thesis
           using g y\<eta>.is_ext_def by simp
       qed
     qed
 
     definition \<phi>
     where "\<phi> y h = D (G h) (\<eta>.map y)"
 
     lemma \<phi>_in_hom:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<guillemotleft>\<phi> y f : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       unfolding \<phi>_def using assms \<eta>.maps_ide_in_hom by auto
 
     lemma \<phi>_natural:
     assumes f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = (G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g"
     proof -
       have "(G f \<cdot>\<^sub>D \<phi> y h) \<cdot>\<^sub>D g = (G f \<cdot>\<^sub>D G h \<cdot>\<^sub>D \<eta>.map y) \<cdot>\<^sub>D g"
         unfolding \<phi>_def by auto
       also have "... = (G f \<cdot>\<^sub>D G h) \<cdot>\<^sub>D \<eta>.map y \<cdot>\<^sub>D g"
         using D.comp_assoc by fastforce
       also have "... = G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g) \<cdot>\<^sub>D \<eta>.map y'"
         using f g h \<eta>.naturality by fastforce
       also have "... = (G (f \<cdot>\<^sub>C h) \<cdot>\<^sub>D G (F g)) \<cdot>\<^sub>D \<eta>.map y'"
         using D.comp_assoc by fastforce
       also have "... = G (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) \<cdot>\<^sub>D \<eta>.map y'"
         using f g h D.comp_assoc by fastforce
       also have "... = \<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)"
         unfolding \<phi>_def by auto
       finally show ?thesis by auto
     qed
 
     lemma \<phi>_inverts_ext:
     assumes y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "arrow_to_functor.is_ext C D G (F y) (\<eta>.map y) x (\<phi> y f) f"
     proof -
       interpret y\<eta>: arrow_to_functor C D G y \<open>F y\<close> \<open>\<eta>.map y\<close>
         using y \<eta>.maps_ide_in_hom by unfold_locales auto
       show "y\<eta>.is_ext x (\<phi> y f) f"
         using f y \<phi>_def y\<eta>.is_ext_def F_ide by blast
     qed
 
     lemma \<phi>_invertible:
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<exists>!f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"
     proof
       have y: "D.ide y" using g by auto
       interpret y\<eta>: initial_arrow_to_functor C D G y \<open>Fo y\<close> \<open>\<eta>o y\<close>
         using y initial_arrows_exist Fo_\<eta>o_initial by auto
       have 1: "arrow_to_functor C D G y x g"
         using x g by (unfold_locales, auto)
       let ?f = "y\<eta>.the_ext x g"
       have "\<phi> y ?f = g"
         using \<phi>_def y\<eta>.the_ext_prop 1 F_ide x y \<phi>_inverts_ext y\<eta>.is_ext_def by fastforce
       moreover have "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
         using 1 y y\<eta>.the_ext_prop F_ide by simp
       ultimately show "\<guillemotleft>?f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y ?f = g" by auto
       show "\<And>f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = g \<Longrightarrow> f' = ?f"
         using 1 y \<phi>_inverts_ext y\<eta>.the_ext_unique F_ide by force
     qed
 
     definition \<psi>
     where "\<psi> x g = (THE f. \<guillemotleft>f : F (D.dom g) \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> (D.dom g) f = g)"
 
     lemma \<psi>_in_hom:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "C.in_hom (\<psi> x g) (F y) x"
       using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
       by auto
 
     lemma \<psi>_\<phi>:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<psi> x (\<phi> y f) = f"
     proof -
       have "D.dom (\<phi> y f) = y" using assms \<phi>_in_hom by blast
       hence "\<psi> x (\<phi> y f) = (THE f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f)"
         using \<psi>_def by auto
       moreover have "\<exists>!f'. \<guillemotleft>f' : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f' = \<phi> y f"
         using assms \<phi>_in_hom \<phi>_invertible C.ide_cod by blast
       ultimately show ?thesis using assms(2) by auto
     qed
 
     lemma \<phi>_\<psi>:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<phi> y (\<psi> x g) = g"
       using assms \<phi>_invertible \<psi>_def theI' [of "\<lambda>f. \<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright> \<and> \<phi> y f = g"]
       by auto
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>"
       using \<phi>_in_hom \<psi>_in_hom \<phi>_\<psi> \<psi>_\<phi> \<phi>_natural D.comp_assoc
       by (unfold_locales, auto)
 
   end
 
   section "Meta-Adjunctions Induce Hom-Adjunctions"
 
   text\<open>
     To obtain a hom-adjunction from a meta-adjunction, we need to exhibit hom-functors
     from @{term C} and @{term D} to a common set category @{term S}, so it is necessary
     to apply an actual concrete construction of such a category.
     We use the replete set category generated by the disjoint sum
     @{typ "('c+'d)"} of the arrow types of @{term C} and @{term D}.
 \<close>
 
   context meta_adjunction
   begin
 
     interpretation S: replete_setcat \<open>undefined :: 'c+'d\<close> .
 
     definition inC :: "'c \<Rightarrow> ('c+'d) setcat.arr"
     where "inC \<equiv> S.UP o Inl"
 
     definition inD :: "'d \<Rightarrow> ('c+'d) setcat.arr"
     where "inD \<equiv> S.UP o Inr"
 
+    interpretation S: replete_setcat \<open>undefined :: ('c+'d)\<close> .
     interpretation Cop: dual_category C ..
     interpretation Dop: dual_category D ..
     interpretation CopxC: product_category Cop.comp C ..
     interpretation DopxD: product_category Dop.comp D ..
     interpretation DopxC: product_category Dop.comp C ..
-    interpretation HomC: hom_functor C S.comp \<open>\<lambda>_. inC\<close>
+    interpretation HomC: hom_functor C S.comp S.setp \<open>\<lambda>_. inC\<close>
     proof
       show "\<And>f. C.arr f \<Longrightarrow> inC f \<in> S.Univ"
         unfolding inC_def using S.UP_mapsto by auto
+      thus "\<And>b a. \<lbrakk>C.ide b; C.ide a\<rbrakk> \<Longrightarrow> inC ` C.hom b a \<subseteq> S.Univ"
+        by blast
       show "\<And>b a. \<lbrakk>C.ide b; C.ide a\<rbrakk> \<Longrightarrow> inj_on inC (C.hom b a)"
         unfolding inC_def
         using S.inj_UP
         by (metis injD inj_Inl inj_compose inj_on_def)
     qed
-    interpretation HomD: hom_functor D S.comp \<open>\<lambda>_. inD\<close>
+    interpretation HomD: hom_functor D S.comp S.setp \<open>\<lambda>_. inD\<close>
     proof
       show "\<And>f. D.arr f \<Longrightarrow> inD f \<in> S.Univ"
         unfolding inD_def using S.UP_mapsto by auto
+      thus "\<And>b a. \<lbrakk>D.ide b; D.ide a\<rbrakk> \<Longrightarrow> inD ` D.hom b a \<subseteq> S.Univ"
+        by blast
       show "\<And>b a. \<lbrakk>D.ide b; D.ide a\<rbrakk> \<Longrightarrow> inj_on inD (D.hom b a)"
         unfolding inD_def
         using S.inj_UP
         by (metis injD inj_Inr inj_compose inj_on_def)
     qed
     interpretation Fop: dual_functor D C F ..
     interpretation FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map ..
     interpretation DopxG: product_functor Dop.comp C Dop.comp D Dop.map G ..
     interpretation Hom_FopxC: composite_functor DopxC.comp CopxC.comp S.comp
                                                 FopxC.map HomC.map ..
     interpretation Hom_DopxG: composite_functor DopxC.comp DopxD.comp S.comp
                                                 DopxG.map HomD.map ..
 
     lemma inC_\<psi> [simp]:
     assumes "C.ide b" and "C.ide a" and "x \<in> inC ` C.hom b a"
     shows "inC (HomC.\<psi> (b, a) x) = x"
       using assms by auto
 
     lemma \<psi>_inC [simp]:
     assumes "C.arr f"
     shows "HomC.\<psi> (C.dom f, C.cod f) (inC f) = f"
       using assms HomC.\<psi>_\<phi> by blast
 
     lemma inD_\<psi> [simp]:
     assumes "D.ide b" and "D.ide a" and "x \<in> inD ` D.hom b a"
     shows "inD (HomD.\<psi> (b, a) x) = x"
       using assms by auto
 
     lemma \<psi>_inD [simp]:
     assumes "D.arr f"
     shows "HomD.\<psi> (D.dom f, D.cod f) (inD f) = f"
       using assms HomD.\<psi>_\<phi> by blast
 
     lemma Hom_FopxC_simp:
     assumes "DopxC.arr gf"
     shows "Hom_FopxC.map gf =
               S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                       (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
                       (inC \<circ> (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
                            \<circ> HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
       using assms HomC.map_def by simp
 
     lemma Hom_DopxG_simp:
     assumes "DopxC.arr gf"
     shows "Hom_DopxG.map gf =
               S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                       (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
                       (inD \<circ> (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
                            \<circ> HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
       using assms HomD.map_def by simp
                       
     definition \<Phi>o
     where "\<Phi>o yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                            (HomD.set (fst yx, G (snd yx)))
                            (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
 
     lemma \<Phi>o_in_hom:
     assumes yx: "DopxC.ide yx"
     shows "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
     proof -
       have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
         using yx HomC.map_ide by auto
       moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
         using yx HomD.map_ide by auto
       moreover have
           "\<guillemotleft>S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                     (inD \<circ> \<phi> (fst yx) \<circ> HomC.\<psi> (F (fst yx), snd yx)) :
               S.mkIde (HomC.set (F (fst yx), snd yx))
                  \<rightarrow>\<^sub>S S.mkIde (HomD.set (fst yx, G (snd yx)))\<guillemotright>"
       proof (intro S.mkArr_in_hom)
         show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
         show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
         show "inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)
                  \<in> HomC.set (F (fst yx), snd yx) \<rightarrow> HomD.set (fst yx, G (snd yx))"
         proof
           fix x
           assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
           show "(inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)) x
                   \<in> HomD.set (fst yx, G (snd yx))"
             using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"]
                   \<phi>_in_hom [of "fst yx"] HomD.\<phi>_mapsto [of "fst yx" "G (snd yx)"]
             by auto
         qed
       qed
       ultimately show ?thesis using \<Phi>o_def by auto
     qed
 
     interpretation \<Phi>: transformation_by_components
                         DopxC.comp S.comp Hom_FopxC.map Hom_DopxG.map \<Phi>o
     proof
       fix yx
       assume yx: "DopxC.ide yx"
       show "\<guillemotleft>\<Phi>o yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
         using yx \<Phi>o_in_hom by auto
       next
       fix gf
       assume gf: "DopxC.arr gf"
       show "S.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
                 = S.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))"
       proof -
         let ?g = "fst gf"
         let ?f = "snd gf"
         let ?x = "C.dom ?f"
         let ?x' = "C.cod ?f"
         let ?y = "D.cod ?g"
         let ?y' = "D.dom ?g"
         let ?Fy = "F ?y"
         let ?Fy' = "F ?y'"
         let ?Fg = "F ?g"
         let ?Gx = "G ?x"
         let ?Gx' = "G ?x'"
         let ?Gf = "G ?f"
         have 1: "S.arr (Hom_FopxC.map gf) \<and>
                  Hom_FopxC.map gf = S.mkArr (HomC.set (?Fy, ?x)) (HomC.set (?Fy', ?x'))
                                             (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))"
           using gf Hom_FopxC.preserves_arr Hom_FopxC_simp by blast
         have 2: "S.arr (\<Phi>o (DopxC.cod gf)) \<and>
                  \<Phi>o (DopxC.cod gf) = S.mkArr (HomC.set (?Fy', ?x')) (HomD.set (?y', ?Gx'))
                                              (inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))"
           using gf \<Phi>o_in_hom [of "DopxC.cod gf"] \<Phi>o_def [of "DopxC.cod gf"] \<phi>_in_hom
-                S.card_of_leq
           by auto
         have 3: "S.arr (\<Phi>o (DopxC.dom gf)) \<and>
                  \<Phi>o (DopxC.dom gf) = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y, ?Gx))
                                              (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))"
           using gf \<Phi>o_in_hom [of "DopxC.dom gf"] \<Phi>o_def [of "DopxC.dom gf"] \<phi>_in_hom
-                S.card_of_leq
           by auto
         have 4: "S.arr (Hom_DopxG.map gf) \<and>
                  Hom_DopxG.map gf = S.mkArr (HomD.set (?y, ?Gx)) (HomD.set (?y', ?Gx'))
                                             (inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))"
           using gf Hom_DopxG.preserves_arr Hom_DopxG_simp by blast
         have 5: "S.seq (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf) \<and>
                  S.comp (\<Phi>o (DopxC.cod gf)) (Hom_FopxC.map gf)
                      = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                                ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                                  o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))"
           by (metis gf 1 2 DopxC.arr_iff_in_hom DopxC.ide_cod Hom_FopxC.preserves_hom
                     S.comp_mkArr S.seqI' \<Phi>o_in_hom)
         have 6: "S.comp (Hom_DopxG.map gf) (\<Phi>o (DopxC.dom gf))
                   = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                             ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                               o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
           by (metis 3 4 S.comp_mkArr)
         have 7:
           "restrict ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                       o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))
              = restrict ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                           o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) (HomC.set (?Fy, ?x))"
         proof (intro restrict_ext)
           show "\<And>h. h \<in> HomC.set (?Fy, ?x) \<Longrightarrow>
                      ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                        o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                        = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                            o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
           proof -
             fix h
             assume h: "h \<in> HomC.set (?Fy, ?x)"
             have \<psi>h: "\<guillemotleft>HomC.\<psi> (?Fy, ?x) h : ?Fy \<rightarrow>\<^sub>C ?x\<guillemotright>"
               using gf h HomC.\<psi>_mapsto [of ?Fy ?x] CopxC.ide_char by auto
             show "((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                        o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                        = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                            o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
             proof -
               have
                 "((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                    o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x))) h
                    = inD (\<phi> ?y' (?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg))"
                 using gf \<psi>h HomC.\<phi>_mapsto HomC.\<psi>_mapsto \<phi>_in_hom
                       \<psi>_inC [of "?f \<cdot>\<^sub>C HomC.\<psi> (?Fy, ?x) h \<cdot>\<^sub>C ?Fg"]
                 by auto
               also have "... = inD (D ?Gf (D (\<phi> ?y (HomC.\<psi> (?Fy, ?x) h)) ?g))"
                 by (metis (no_types, lifting) C.arr_cod C.arr_dom_iff_arr C.arr_iff_in_hom
                     C.in_homE D.arr_cod_iff_arr D.arr_iff_in_hom F.preserves_reflects_arr
                     \<phi>_naturality \<psi>h)
               also have "... = ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                                 o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x))) h"
                 using gf \<psi>h \<phi>_in_hom by simp
               finally show ?thesis by auto
             qed
           qed
         qed
         have 8: "S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                          ((inD o \<phi> ?y' o HomC.\<psi> (?Fy', ?x'))
                            o (inC o (\<lambda>h. ?f \<cdot>\<^sub>C h \<cdot>\<^sub>C ?Fg) o HomC.\<psi> (?Fy, ?x)))
                     = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                               ((inD o (\<lambda>h. ?Gf \<cdot>\<^sub>D h \<cdot>\<^sub>D ?g) o HomD.\<psi> (?y, ?Gx))
                                 o (inD o \<phi> ?y o HomC.\<psi> (?Fy, ?x)))"
           using 5 7 by force
         show ?thesis using 5 6 8 by auto
       qed
     qed
 
     lemma \<Phi>_simp:
     assumes YX: "DopxC.ide yx"
     shows "\<Phi>.map yx =
            S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                    (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
       using YX \<Phi>o_def by simp
       
     abbreviation \<Psi>o
     where "\<Psi>o yx \<equiv> S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                             (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
 
     lemma \<Psi>o_in_hom:
     assumes yx: "DopxC.ide yx"
     shows "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
     proof -
       have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
         using yx HomC.map_ide by auto
       moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
         using yx HomD.map_ide by auto
       moreover have "\<guillemotleft>\<Psi>o yx : S.mkIde (HomD.set (fst yx, G (snd yx)))
                                  \<rightarrow>\<^sub>S S.mkIde (HomC.set (F (fst yx), snd yx))\<guillemotright>"
       proof (intro S.mkArr_in_hom)
         show "HomC.set (F (fst yx), snd yx) \<subseteq> S.Univ" using yx HomC.set_subset_Univ by simp
         show "HomD.set (fst yx, G (snd yx)) \<subseteq> S.Univ" using yx HomD.set_subset_Univ by simp
         show "inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))
                  \<in> HomD.set (fst yx, G (snd yx)) \<rightarrow> HomC.set (F (fst yx), snd yx)"
         proof
           fix x
           assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
           show "(inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))) x
                   \<in> HomC.set (F (fst yx), snd yx)"
             using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom [of "snd yx"]
                   HomC.\<phi>_mapsto [of "F (fst yx)" "snd yx"]
             by auto
         qed
       qed
       ultimately show ?thesis by auto
     qed
 
     lemma \<Phi>_inv:
     assumes yx: "DopxC.ide yx"
     shows "S.inverse_arrows (\<Phi>.map yx) (\<Psi>o yx)"
     proof -
       have 1: "\<guillemotleft>\<Phi>.map yx : Hom_FopxC.map yx \<rightarrow>\<^sub>S Hom_DopxG.map yx\<guillemotright>"
         using yx \<Phi>.preserves_hom [of yx yx yx] DopxC.ide_in_hom by blast
       have 2: "\<guillemotleft>\<Psi>o yx : Hom_DopxG.map yx \<rightarrow>\<^sub>S Hom_FopxC.map yx\<guillemotright>"
         using yx \<Psi>o_in_hom by simp
       have 3: "\<Phi>.map yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                                    (HomD.set (fst yx, G (snd yx)))
                                    (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))"
         using yx \<Phi>_simp by blast
       have antipar: "S.antipar (\<Phi>.map yx) (\<Psi>o yx)"
         using 1 2 by blast
       moreover have "S.ide (S.comp (\<Psi>o yx) (\<Phi>.map yx))"
       proof -
         have "S.comp (\<Psi>o yx) (\<Phi>.map yx) =
                   S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                           ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                             o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx)))"
           using 1 2 3 antipar S.comp_mkArr by auto
         also have
           "... = S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                          (\<lambda>x. x)"
         proof -
           have
             "S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx)) (\<lambda>x. x)
                = ..."
           proof
             show
               "S.arr (S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                      (\<lambda>x. x))"
-              using yx HomC.set_subset_Univ S.arr_mkArr by simp
+              using yx HomC.set_subset_Univ by simp
             show "\<And>x. x \<in> HomC.set (F (fst yx), snd yx) \<Longrightarrow>
                         x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                              o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
             proof -
               fix x
               assume x: "x \<in> HomC.set (F (fst yx), snd yx)"
               have "((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                              o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x
                       = inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx))
                               (inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))))"
                 by simp
               also have "... = inC (\<psi> (snd yx) (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx) x)))"
                 using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<phi>_in_hom by force
               also have "... = inC (HomC.\<psi> (F (fst yx), snd yx) x)"
                 using x yx HomC.\<psi>_mapsto [of "F (fst yx)" "snd yx"] \<psi>_\<phi> by force
               also have "... = x" using x yx inC_\<psi> by simp
               finally show "x = ((inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))
                                    o (inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))) x"
                 by auto
             qed
           qed
           thus ?thesis by auto
         qed
         also have "... = S.mkIde (HomC.set (F (fst yx), snd yx))"
           using yx S.mkIde_as_mkArr HomC.set_subset_Univ by force
         finally have
             "S.comp (\<Psi>o yx) (\<Phi>.map yx) = S.mkIde (HomC.set (F (fst yx), snd yx))"
           by auto
         thus ?thesis using yx HomC.set_subset_Univ S.ide_mkIde by simp
       qed
       moreover have "S.ide (S.comp (\<Phi>.map yx) (\<Psi>o yx))"
       proof -
         have "S.comp (\<Phi>.map yx) (\<Psi>o yx) =
                   S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                           ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                             o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx))))"
           using 1 2 3 S.comp_mkArr antipar by fastforce
         also
           have "... = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                               (\<lambda>x. x)"
         proof -
           have
             "S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx))) (\<lambda>x. x)
                 = ..."
           proof
             show
               "S.arr (S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                      (\<lambda>x. x))"
-              using yx HomD.set_subset_Univ S.arr_mkArr by simp
+              using yx HomD.set_subset_Univ by simp
             show "\<And>x. x \<in> (HomD.set (fst yx, G (snd yx))) \<Longrightarrow>
                         x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                             o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
             proof -
               fix x
               assume x: "x \<in> HomD.set (fst yx, G (snd yx))"
               have "((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                           o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x
                        = inD (\<phi> (fst yx) (HomC.\<psi> (F (fst yx), snd yx)
                             (inC (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))))"
                 by simp
               also have "... = inD (\<phi> (fst yx) (\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x)))"
               proof -
                 have "\<guillemotleft>\<psi> (snd yx) (HomD.\<psi> (fst yx, G (snd yx)) x) : F (fst yx) \<rightarrow> snd yx\<guillemotright>"
                   using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<psi>_in_hom by auto
                 thus ?thesis by simp
               qed
               also have "... = inD (HomD.\<psi> (fst yx, G (snd yx)) x)"
                 using x yx HomD.\<psi>_mapsto [of "fst yx" "G (snd yx)"] \<phi>_\<psi> by force
               also have "... = x" using x yx inD_\<psi> by simp
               finally show "x = ((inD o \<phi> (fst yx) o HomC.\<psi> (F (fst yx), snd yx))
                                    o (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))) x"
                 by auto
             qed
           qed
           thus ?thesis by auto
         qed
         also have "... = S.mkIde (HomD.set (fst yx, G (snd yx)))"
           using yx S.mkIde_as_mkArr HomD.set_subset_Univ by force
         finally have
             "S.comp (\<Phi>.map yx) (\<Psi>o yx) = S.mkIde (HomD.set (fst yx, G (snd yx)))"
           by auto
         thus ?thesis using yx HomD.set_subset_Univ S.ide_mkIde by simp
       qed
       ultimately show ?thesis by auto
     qed
 
     interpretation \<Phi>: natural_isomorphism DopxC.comp S.comp
                                           Hom_FopxC.map Hom_DopxG.map \<Phi>.map
       using \<Phi>_inv by unfold_locales blast
 
     interpretation \<Psi>: inverse_transformation DopxC.comp S.comp
                            Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
 
     interpretation \<Phi>\<Psi>: inverse_transformations DopxC.comp S.comp
                            Hom_FopxC.map Hom_DopxG.map \<Phi>.map \<Psi>.map
       using \<Psi>.inverts_components by unfold_locales simp
 
     abbreviation \<Phi> where "\<Phi> \<equiv> \<Phi>.map"
     abbreviation \<Psi> where "\<Psi> \<equiv> \<Psi>.map"
 
     abbreviation HomC where "HomC \<equiv> HomC.map"
     abbreviation \<phi>C where "\<phi>C \<equiv> \<lambda>_. inC"
     abbreviation HomD where "HomD \<equiv> HomD.map"
     abbreviation \<phi>D where "\<phi>D \<equiv> \<lambda>_. inD"
 
-    theorem induces_hom_adjunction: "hom_adjunction C D S.comp \<phi>C \<phi>D F G \<Phi> \<Psi>"
+    theorem induces_hom_adjunction: "hom_adjunction C D S.comp S.setp \<phi>C \<phi>D F G \<Phi> \<Psi>"
       using F.is_extensional by unfold_locales auto
 
     lemma \<Psi>_simp:
     assumes yx: "DopxC.ide yx"
     shows "\<Psi> yx = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                           (inC o \<psi> (snd yx) o HomD.\<psi> (fst yx, G (snd yx)))"
       using assms \<Phi>o_def \<Phi>_inv S.inverse_unique by simp
 
     text\<open>
       The original @{term \<phi>} and @{term \<psi>} can be recovered from @{term \<Phi>} and @{term \<Psi>}.
 \<close>
 
-    interpretation \<Phi>: set_valued_transformation DopxC.comp S.comp
+    interpretation \<Phi>: set_valued_transformation DopxC.comp S.comp S.setp
                                                 Hom_FopxC.map Hom_DopxG.map \<Phi>.map ..
      
-    interpretation \<Psi>: set_valued_transformation DopxC.comp S.comp
+    interpretation \<Psi>: set_valued_transformation DopxC.comp S.comp S.setp
                                                 Hom_DopxG.map Hom_FopxC.map \<Psi>.map ..
 
     lemma \<phi>_in_terms_of_\<Phi>':
     assumes y: "D.ide y" and f: "\<guillemotleft>f: F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<phi> y f = (HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f"
     proof -
       have x: "C.ide x" using f by auto
       have "(HomD.\<psi> (y, G x) o \<Phi>.FUN (y, x) o inC) f =
               HomD.\<psi> (y, G x)
                      (restrict (inD o \<phi> y o HomC.\<psi> (F y, x)) (HomC.set (F y, x)) (inC f))"
       proof -
         have "S.arr (\<Phi> (y, x))" using x y by fastforce
         thus ?thesis
           using x y \<Phi>o_def by simp
       qed
       also have "... = \<phi> y f"
         using x y f HomC.\<phi>_mapsto \<phi>_in_hom HomC.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
         by auto
       finally show ?thesis by auto
     qed
 
     lemma \<psi>_in_terms_of_\<Psi>':
     assumes x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<psi> x g = (HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g"
     proof -
       have y: "D.ide y" using g by auto
       have "(HomC.\<psi> (F y, x) o \<Psi>.FUN (y, x) o inD) g =
               HomC.\<psi> (F y, x)
                      (restrict (inC o \<psi> x o HomD.\<psi> (y, G x)) (HomD.set (y, G x)) (inD g))"
       proof -
         have "S.arr (\<Psi> (y, x))"
           using x y \<Psi>.preserves_reflects_arr [of "(y, x)"] by simp
         thus ?thesis
           using x y \<Psi>_simp by simp
       qed
       also have "... = \<psi> x g"
         using x y g HomD.\<phi>_mapsto \<psi>_in_hom HomD.\<psi>_mapsto C.ide_in_hom D.ide_in_hom
         by auto
       finally show ?thesis by auto
     qed
 
   end
 
   section "Hom-Adjunctions Induce Meta-Adjunctions"
 
   context hom_adjunction
   begin
 
     definition \<phi> :: "'d \<Rightarrow> 'c \<Rightarrow> 'd"
     where
       "\<phi> y h = (HomD.\<psi> (y, G (C.cod h)) o \<Phi>.FUN (y, C.cod h) o \<phi>C (F y, C.cod h)) h"
     
     definition \<psi> :: "'c \<Rightarrow> 'd \<Rightarrow> 'c"
     where
       "\<psi> x h = (HomC.\<psi> (F (D.dom h), x) o \<Psi>.FUN (D.dom h, x) o \<phi>D (D.dom h, G x)) h"
 
     lemma Hom_FopxC_map_simp:
     assumes "DopxC.arr gf"
     shows "Hom_FopxC.map gf =
               S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                       (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))            
                       (\<phi>C (F (D.dom (fst gf)), C.cod (snd gf))
                            o (\<lambda>h. snd gf \<cdot>\<^sub>C h \<cdot>\<^sub>C F (fst gf))
                            o HomC.\<psi> (F (D.cod (fst gf)), C.dom (snd gf)))"
       using assms HomC.map_def by simp
 
     lemma Hom_DopxG_map_simp:
     assumes "DopxC.arr gf"
     shows "Hom_DopxG.map gf =
               S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                       (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))           
                       (\<phi>D (D.dom (fst gf), G (C.cod (snd gf)))
                            o (\<lambda>h. G (snd gf) \<cdot>\<^sub>D h \<cdot>\<^sub>D fst gf)
                            o HomD.\<psi> (D.cod (fst gf), G (C.dom (snd gf))))"
       using assms HomD.map_def by simp
                       
     lemma \<Phi>_Fun_mapsto:
     assumes "D.ide y" and "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
     shows "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
     proof -
       have "S.arr (\<Phi> (y, x)) \<and> \<Phi>.DOM (y, x) = HomC.set (F y, x) \<and>
                                 \<Phi>.COD (y, x) = HomD.set (y, G x)"
         using assms HomC.set_map HomD.set_map by auto
       thus ?thesis using S.Fun_mapsto by blast
     qed
 
     lemma \<phi>_mapsto:
     assumes y: "D.ide y"
     shows "\<phi> y \<in> C.hom (F y) x \<rightarrow> D.hom y (G x)"
     proof
       fix h
       assume h: "h \<in> C.hom (F y) x"
       hence 1: " \<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>" by simp
       show "\<phi> y h \<in> D.hom y (G x)"
       proof -
         have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
           using y h 1 HomC.\<phi>_mapsto [of "F y" x] by fastforce
         hence "\<Phi>.FUN (y, x) (\<phi>C (F y, x) h) \<in> HomD.set (y, G x)"
           using h y \<Phi>_Fun_mapsto by auto
         thus ?thesis
           using y h 1 \<phi>_def HomC.\<phi>_mapsto HomD.\<psi>_mapsto [of y "G x"] by fastforce
       qed
     qed
 
     lemma \<Phi>_simp:
     assumes "D.ide y" and "C.ide x"
     shows "S.arr (\<Phi> (y, x))"
     and "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                             (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
     proof -
       show 1: "S.arr (\<Phi> (y, x))" using assms by auto
       hence "\<Phi> (y, x) = S.mkArr (\<Phi>.DOM (y, x)) (\<Phi>.COD (y, x)) (\<Phi>.FUN (y, x))"
         using S.mkArr_Fun by metis
       also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x))"
         using assms HomC.set_map HomD.set_map by fastforce
       also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
       proof (intro S.mkArr_eqI')
         show 2: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (\<Phi>.FUN (y, x)))"
           using 1 calculation by argo
         show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
                     \<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h"
         proof -
           fix h
           assume h: "h \<in> HomC.set (F y, x)"
           have "(\<phi>D (y, G x) o \<phi> y o HomC.\<psi> (F y, x)) h =
                    \<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) (\<phi>C (F y, x) (\<psi>C (F y, x) h))))"
           proof -
             have "\<guillemotleft>\<psi>C (F y, x) h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
               using assms h HomC.\<psi>_mapsto [of "F y" x] by auto
             thus ?thesis
               using h \<phi>_def by auto
           qed
           also have "... = \<phi>D (y, G x) (\<psi>D (y, G x) (\<Phi>.FUN (y, x) h))"
             using assms h HomC.\<phi>_\<psi> \<Phi>_Fun_mapsto by simp
           also have "... = \<Phi>.FUN (y, x) h"
             using assms h \<Phi>_Fun_mapsto [of y "\<psi>C (F y, x) h"] HomC.\<psi>_mapsto
                   HomD.\<phi>_\<psi> [of y "G x"] C.ide_in_hom D.ide_in_hom
-            by (meson 2 G.preserves_ide S.arr_mkArr funcset_mem)
+            by blast
           finally show "\<Phi>.FUN (y, x) h = (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) h" by auto
         qed
       qed
       finally show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                        (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
         by force
     qed
 
     lemma \<Psi>_Fun_mapsto:
     assumes "C.ide x" and "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
     shows "\<Psi>.FUN (y, x) \<in> HomD.set (y, G x) \<rightarrow> HomC.set (F y, x)"
     proof -
       have "S.arr (\<Psi> (y, x)) \<and> \<Psi>.COD (y, x) = HomC.set (F y, x) \<and>
                                 \<Psi>.DOM (y, x) = HomD.set (y, G x)"
         using assms HomC.set_map HomD.set_map by auto
       thus ?thesis using S.Fun_mapsto by fast
     qed
 
     lemma \<psi>_mapsto:
     assumes x: "C.ide x"
     shows "\<psi> x \<in> D.hom y (G x) \<rightarrow> C.hom (F y) x"
     proof
       fix h
       assume h: "h \<in> D.hom y (G x)"
       hence 1: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>" by auto
       show "\<psi> x h \<in> C.hom (F y) x"
       proof -
         have "\<Psi>.FUN (y, x) (\<phi>D (y, G x) h) \<in> HomC.set (F y, x)"
         proof -
           have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
             using x h 1 HomD.\<phi>_mapsto [of y "G x"] by fastforce
           thus ?thesis
             using h x \<Psi>_Fun_mapsto by auto
         qed
         thus ?thesis
           using x h 1 \<psi>_def HomD.\<phi>_mapsto HomC.\<psi>_mapsto [of "F y" x] by fastforce
       qed
     qed
 
     lemma \<Psi>_simp:
     assumes "D.ide y" and "C.ide x"
     shows "S.arr (\<Psi> (y, x))"
     and "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                             (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
     proof -
       show 1: "S.arr (\<Psi> (y, x))" using assms by auto
       hence "\<Psi> (y, x) = S.mkArr (\<Psi>.DOM (y, x)) (\<Psi>.COD (y, x)) (\<Psi>.FUN (y, x))"
         using S.mkArr_Fun by metis
       also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x))"
         using assms HomC.set_map HomD.set_map by auto
       also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (\<Psi>.FUN (y, x)))"
           using 1 calculation by argo
         show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
                     \<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)) h"
         proof -
           fix h
           assume h: "h \<in> HomD.set (y, G x)"
           have "(\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h =
                    \<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) (\<phi>D (y, G x) (\<psi>D (y, G x) h))))"
           proof -
             have "\<guillemotleft>\<psi>D (y, G x) h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using assms h HomD.\<psi>_mapsto [of y "G x"] by auto
             thus ?thesis
               using h \<psi>_def by auto
           qed
           also have "... = \<phi>C (F y, x) (\<psi>C (F y, x) (\<Psi>.FUN (y, x) h))"
             using assms h HomD.\<phi>_\<psi> \<Psi>_Fun_mapsto by simp
           also have "... = \<Psi>.FUN (y, x) h"
             using assms h \<Psi>_Fun_mapsto HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_\<psi> [of "F y" x]
                   C.ide_in_hom D.ide_in_hom
             by blast
           finally show "\<Psi>.FUN (y, x) h = (\<phi>C (F y, x) o \<psi> x o HomD.\<psi> (y, G x)) h" by auto
         qed
       qed
       finally show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                        (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
         by force
     qed
 
     text\<open>
       The length of the next proof stems from having to use properties of composition
       of arrows in @{term[source=true] S} to infer properties of the composition of the
       corresponding functions.
 \<close>
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
     proof
       fix y :: 'd and x :: 'c and h :: 'c
       assume y: "D.ide y" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       have x: "C.ide x" using h by auto
       show "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       proof -
         have "\<Phi>.FUN (y, x) \<in> HomC.set (F y, x) \<rightarrow> HomD.set (y, G x)"
           using y h \<Phi>_Fun_mapsto by blast
         thus ?thesis
           using x y h \<phi>_def HomD.\<psi>_mapsto [of y "G x"] HomC.\<phi>_mapsto [of "F y" x] by auto
       qed
       show "\<psi> x (\<phi> y h) = h"
       proof -
         have 0: "restrict (\<lambda>h. h) (HomC.set (F y, x))
                    = restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))"
         proof -
           have 1: "S.ide (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))"
             using x y \<Phi>\<Psi>.inv [of "(y, x)"] by auto
           hence 6: "S.seq (\<Psi> (y, x)) (\<Phi> (y, x))" by auto
           have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
                    \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                       (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
             using x y \<Phi>_simp \<Psi>_simp by force
           have 3: "S (\<Psi> (y, x)) (\<Phi> (y, x))
                     = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                               (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
           proof -
             have 4: "S.arr (\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x))" using 1 by auto
             hence "S (\<Psi> (y, x)) (\<Phi> (y, x))
                      = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                                   o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 2 S.ide_in_hom S.comp_mkArr by fastforce
             also have "... = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                      (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))"
             proof (intro S.mkArr_eqI')
               show "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                    ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                                      o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
                 using 4 calculation by simp
               show "\<And>h. h \<in> HomC.set (F y, x) \<Longrightarrow>
                           ((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
                           (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
               proof -
                 fix h
                 assume h: "h \<in> HomC.set (F y, x)"
                 hence "\<guillemotleft>\<phi> y (\<psi>C (F y, x) h) : y \<rightarrow>\<^sub>D G x\<guillemotright>"
                   using x y h HomC.\<psi>_mapsto [of "F y" x] \<phi>_mapsto by auto
                 thus "((\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))) h =
                       (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) h"
                   using x y 1 \<phi>_mapsto HomD.\<psi>_\<phi> by simp
               qed
             qed
             finally show ?thesis by simp
           qed
           moreover have "\<Psi> (y, x) \<cdot>\<^sub>S \<Phi> (y, x)
                              = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
             using 1 2 6 calculation S.mkIde_as_mkArr S.arr_mkArr S.dom_mkArr S.ideD(2)
             by metis
           ultimately have 4: "S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                       (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x))
                                 = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (\<lambda>h. h)"
             by auto
           have 5: "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                   (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
             using 1 3 6 by presburger
           hence "restrict (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (HomC.set (F y, x))
                   = S.Fun (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                          (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)))"
             by auto
           also have "... = restrict (\<lambda>h. h) (HomC.set (F y, x))"
             using 4 5 by auto
           finally show ?thesis by auto
         qed
         moreover have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
           using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
         ultimately have
             "\<phi>C (F y, x) h = (\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
           using x y h HomC.\<phi>_mapsto [of "F y" x] by fast
         hence "\<psi>C (F y, x) (\<phi>C (F y, x) h) =
                  \<psi>C (F y, x) ((\<phi>C (F y, x) o (\<psi> x o \<phi> y) o \<psi>C (F y, x)) (\<phi>C (F y, x) h))"
           by simp
         hence "h = \<psi>C (F y, x) (\<phi>C (F y, x) (\<psi> x (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h)))))"
           using x y h HomC.\<psi>_\<phi> [of "F y" x] by simp
         also have "... = \<psi> x (\<phi> y h)"
           using x y h HomC.\<psi>_\<phi> HomC.\<psi>_\<phi> \<phi>_mapsto \<psi>_mapsto
           by (metis PiE mem_Collect_eq)
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and h :: 'd and y :: 'd
       assume x: "C.ide x" and h: "\<guillemotleft>h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       have y: "D.ide y" using h by auto
       show "\<guillemotleft>\<psi> x h : F y \<rightarrow>\<^sub>C x\<guillemotright>" using x y h \<psi>_mapsto [of x y] by auto
       show "\<phi> y (\<psi> x h) = h"
       proof -
         have 0: "restrict (\<lambda>h. h) (HomD.set (y, G x))
                    = restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))"
         proof -
           have 1: "S.ide (S (\<Phi> (y, x)) (\<Psi> (y, x)))"
             using x y \<Phi>\<Psi>.inv by force
           hence 6: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" by auto
           have 2: "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)) \<and>
                    \<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                        (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
             using x h \<Phi>_simp \<Psi>_simp by auto
           have 3: "S (\<Phi> (y, x)) (\<Psi> (y, x))
                      = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
           proof -
             have 4: "S.seq (\<Phi> (y, x)) (\<Psi> (y, x))" using 1 by auto
             hence "S (\<Phi> (y, x)) (\<Psi> (y, x))
                      = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                                  o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x)))"
               using 1 2 6 S.ide_in_hom S.comp_mkArr by fastforce
             also have "... = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                      (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))"
             proof
               show "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                    ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                                      o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))))"
                 using 4 calculation by simp
               show "\<And>h. h \<in> HomD.set (y, G x) \<Longrightarrow>
                           ((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                             o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
                           (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
               proof -
                 fix h
                 assume h: "h \<in> HomD.set (y, G x)"
                 hence "\<guillemotleft>\<psi> x (\<psi>D (y, G x) h) : F y \<rightarrow>\<^sub>C x\<guillemotright>"
                   using x y HomD.\<psi>_mapsto [of y "G x"] \<psi>_mapsto by auto
                 thus "((\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))
                             o (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))) h =
                       (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) h"
                   using x y HomC.\<psi>_\<phi> by simp
               qed
             qed
             finally show ?thesis by auto
           qed
           moreover have "\<Phi> (y, x) \<cdot>\<^sub>S \<Psi> (y, x) =
                            S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
             using 1 2 6 calculation
             by (metis S.arr_mkArr S.cod_mkArr S.ide_in_hom S.mkIde_as_mkArr S.in_homE)
           ultimately have 4: "S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x))
                                 = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (\<lambda>h. h)"
             by auto
           have 5: "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
             using 1 3 by fastforce
           hence "restrict (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (HomD.set (y, G x))
                   = S.Fun (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                          (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)))"
             by auto
           also have "... = restrict (\<lambda>h. h) (HomD.set (y, G x))"
             using 4 5 by auto
           finally show ?thesis by auto
         qed
         moreover have "\<phi>D (y, G x) h \<in> HomD.set (y, G x)"
           using x y h HomD.\<phi>_mapsto [of y "G x"] by auto
         ultimately have
             "\<phi>D (y, G x) h = (\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h)"
           by fast
         hence "\<psi>D (y, G x) (\<phi>D (y, G x) h) =
                 \<psi>D (y, G x) ((\<phi>D (y, G x) o (\<phi> y o \<psi> x) o \<psi>D (y, G x)) (\<phi>D (y, G x) h))"
           by simp
         hence "h = \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi> x (\<psi>D (y, G x) (\<phi>D (y, G x) h)))))"
           using x y h HomD.\<psi>_\<phi> by simp
         also have "... = \<phi> y (\<psi> x h)"
           using x y h HomD.\<psi>_\<phi> HomD.\<psi>_\<phi> [of "\<phi> y (\<psi> x h)" y "G x"] \<phi>_mapsto \<psi>_mapsto
           by fastforce
         finally show ?thesis by auto
       qed
       next
       fix x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
       and f :: 'c and g :: 'd and h :: 'c
       assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>C x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>D y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       have x: "C.ide x" using f by auto
       have y: "D.ide y" using g by auto
       have x': "C.ide x'" using f by auto
       have y': "D.ide y'" using g by auto
       show "\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
       proof -
         have 0: "restrict ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                            o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                        (HomC.set (F y, x))
                 = restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                              o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) o \<psi>C (F y, x))
                            (HomC.set (F y, x))"
         proof -
           have 1: "S.arr (\<Phi> (y, x)) \<and>
                    \<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
                 using x y \<Phi>_simp [of y x] by auto
           have 2: "S.arr (\<Phi> (y', x')) \<and>
                    \<Phi> (y', x') = S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                         (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))"
                 using x' y' \<Phi>_simp [of y' x'] by auto
           have 3: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                   ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                     o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))
                    \<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                      = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                          (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
           proof -
             have 1: "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                            (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                   (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
             proof -
               have "S.arr (Hom_DopxG.map (g, f)) \<and>
                     Hom_DopxG.map (g, f)
                         = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                   (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
                 using f g Hom_DopxG.preserves_arr Hom_DopxG_map_simp by fastforce
               thus ?thesis
                 using 1 S.cod_mkArr S.dom_mkArr S.seqI by metis
             qed
             have "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                  (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                         (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                  (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 by (intro S.seqI', auto)
             moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                              = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                           (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x)))
                                  (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                           (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))"
               using 1 S.comp_mkArr by fastforce
             ultimately show ?thesis by auto
           qed
           moreover have
              4: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                 ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                   o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))
                  \<and> S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                            ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                              o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                      = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x')) 
                                   (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                          (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                   (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
           proof -
             have 5: "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                     (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                            (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                     (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
             proof -
               have "S.arr (Hom_FopxC.map (g, f)) \<and>
                     Hom_FopxC.map (g, f)
                           = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                     (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
                 using f g Hom_FopxC.preserves_arr Hom_FopxC_map_simp by fastforce
               thus ?thesis using 2 S.cod_mkArr S.dom_mkArr S.seqI by metis
             qed
             have "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                  (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                         (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                  (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
               using 5 by (intro S.seqI', auto)
             moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                    ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                      o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                              = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                           (\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x')))
                                  (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                           (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
               using 5 S.comp_mkArr by fastforce
             ultimately show ?thesis by argo
           qed
           moreover have 2:
               "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                        ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                          o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                   = S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                             ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                               o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))"
           proof -
             have
               "S (Hom_DopxG.map (g, f)) (\<Phi> (y, x)) = S (\<Phi> (y', x')) (Hom_FopxC.map (g, f))"
               using f g \<Phi>.is_natural_1 \<Phi>.is_natural_2 by fastforce
             moreover have "Hom_DopxG.map (g, f)
                              = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                        (\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))"
               using f g Hom_DopxG_map_simp [of "(g, f)"] by fastforce
             moreover have "Hom_FopxC.map (g, f)
                              = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                        (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"
               using f g Hom_FopxC_map_simp [of "(g, f)"] by fastforce
             ultimately show ?thesis using 1 2 3 4 by simp
           qed
           ultimately have 6: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                              ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                                o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
             by fast
           hence "restrict ((\<phi>D (y', G x') o (\<lambda>h. D (G f) (D h g)) o \<psi>D (y, G x))
                             o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x)))
                           (HomC.set (F y, x))
                   = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                   ((\<phi>D (y', G x') o (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) o \<psi>D (y, G x))
                                     o (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))))"
             by simp
           also have "... = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                        ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                          o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))))"
             using 2 by argo
           also have "... = restrict ((\<phi>D (y', G x') o \<phi> y' o \<psi>C (F y', x'))
                                       o (\<phi>C (F y', x') o (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x)))
                                     (HomC.set (F y, x))"
             using 4 S.Fun_mkArr by meson
           finally show ?thesis by auto
         qed
         hence 5: "((\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
                     \<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))) (\<phi>C (F y, x) h) =
                    (\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x')
                      \<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g)) \<circ> \<psi>C (F y, x)) (\<phi>C (F y, x) h)"
         proof -
           have "\<phi>C (F y, x) h \<in> HomC.set (F y, x)"
             using x y h HomC.\<phi>_mapsto [of "F y" x] by auto
           thus ?thesis
             using 0 h restr_eqE [of "(\<phi>D (y', G x') \<circ> (\<lambda>h. G f \<cdot>\<^sub>D h \<cdot>\<^sub>D g) \<circ> \<psi>D (y, G x))
                                       \<circ> (\<phi>D (y, G x) \<circ> \<phi> y \<circ> \<psi>C (F y, x))"
                                     "HomC.set (F y, x)"
                                     "(\<phi>D (y', G x') \<circ> \<phi> y' \<circ> \<psi>C (F y', x'))
                                        \<circ> (\<phi>C (F y', x') \<circ> (\<lambda>h. f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) o \<psi>C (F y, x))"]
             by fast
         qed
         show ?thesis
         proof -
           have "\<phi> y' (C f (C h (F g))) =
                   \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                      (C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))"
           proof -
             have "\<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                      (C f (C (\<psi>C (F y, x) (\<phi>C (F y, x) h)) (F g)))))))
                     = \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (\<psi>C (F y', x') (\<phi>C (F y', x')
                          (C f (C h (F g)))))))"
               using x y h HomC.\<psi>_\<phi> by simp
             also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (\<phi> y' (C f (C h (F g)))))"
               using f g h HomC.\<psi>_\<phi> [of "C f (C h (F g))"] by fastforce
             also have "... = \<phi> y' (C f (C h (F g)))"
             proof -
               have "\<guillemotleft>\<phi> y' (f \<cdot>\<^sub>C h \<cdot>\<^sub>C F g) : y' \<rightarrow>\<^sub>D G x'\<guillemotright>"
                 using f g h y' x' \<phi>_mapsto [of y' x'] by auto
               thus ?thesis by simp
             qed
             finally show ?thesis by auto
           qed
           also have
              "... = \<psi>D (y', G x')
                        (\<phi>D (y', G x')
                            (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
                                 \<cdot>\<^sub>D g))"
             using 5 by force
           also have "... = D (G f) (D (\<phi> y h) g)"
           proof -
             have \<phi>yh: "\<guillemotleft>\<phi> y h : y \<rightarrow>\<^sub>D G x\<guillemotright>"
               using x y h \<phi>_mapsto by auto
             have "\<psi>D (y', G x')
                      (\<phi>D (y', G x')
                          (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y (\<psi>C (F y, x) (\<phi>C (F y, x) h))))
                               \<cdot>\<^sub>D g)) =
                   \<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<psi>D (y, G x) (\<phi>D (y, G x) (\<phi> y h)) \<cdot>\<^sub>D g))"
               using x y f g h by auto
             also have "... = \<psi>D (y', G x') (\<phi>D (y', G x') (G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g))"
               using \<phi>yh x' y' f g by simp
             also have "... = G f \<cdot>\<^sub>D \<phi> y h \<cdot>\<^sub>D g"
               using \<phi>yh f g by fastforce
             finally show ?thesis by auto
           qed
           finally show ?thesis by auto
         qed
       qed
     qed
 
     theorem induces_meta_adjunction:
     shows "meta_adjunction C D F G \<phi> \<psi>" ..
 
   end
 
   section "Putting it All Together"
 
   text\<open>
     Combining the above results, an interpretation of any one of the locales:
     \<open>left_adjoint_functor\<close>, \<open>right_adjoint_functor\<close>, \<open>meta_adjunction\<close>,
     \<open>hom_adjunction\<close>, and \<open>unit_counit_adjunction\<close> extends to an interpretation
     of \<open>adjunction\<close>.
 \<close>
 
   context meta_adjunction
   begin
 
+    interpretation S: replete_setcat .
     interpretation F: left_adjoint_functor D C F using has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using has_right_adjoint_functor by auto
 
     interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<eta> \<epsilon>
       using induces_unit_counit_adjunction \<eta>_def \<epsilon>_def by auto
-    interpretation \<Phi>\<Psi>: hom_adjunction C D replete_setcat.comp \<phi>C \<phi>D F G \<Phi> \<Psi>
+    interpretation \<Phi>\<Psi>: hom_adjunction C D S.comp S.setp \<phi>C \<phi>D F G \<Phi> \<Psi>
       using induces_hom_adjunction by auto
 
     theorem induces_adjunction:
-    shows "adjunction C D replete_setcat.comp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
+    shows "adjunction C D S.comp S.setp \<phi>C \<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<Phi> \<Psi>"
       using \<epsilon>_map_simp \<eta>_map_simp \<phi>_in_terms_of_\<eta> \<phi>_in_terms_of_\<Phi>' \<psi>_in_terms_of_\<epsilon>
             \<psi>_in_terms_of_\<Psi>' \<Phi>_simp \<Psi>_simp \<eta>_def \<epsilon>_def
       by unfold_locales auto
 
   end
 
   context unit_counit_adjunction
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi> using induces_meta_adjunction by auto
 
+    interpretation S: replete_setcat .
     interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
 
-    interpretation \<Phi>\<Psi>: hom_adjunction C D replete_setcat.comp
+    interpretation \<Phi>\<Psi>: hom_adjunction C D S.comp S.setp
                           \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>
       using \<phi>\<psi>.induces_hom_adjunction by auto
 
     theorem induces_adjunction:
-    shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
+    shows "adjunction C D S.comp S.setp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<eta> \<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<epsilon>_in_terms_of_\<psi> \<eta>_in_terms_of_\<phi> \<phi>\<psi>.\<phi>_in_terms_of_\<Phi>' \<psi>_def \<phi>\<psi>.\<psi>_in_terms_of_\<Psi>'
             \<phi>\<psi>.\<Phi>_simp \<phi>\<psi>.\<Psi>_simp \<phi>_def
       by unfold_locales auto
 
   end
 
   context hom_adjunction
   begin
    
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
     interpretation F: left_adjoint_functor D C F using \<phi>\<psi>.has_left_adjoint_functor by auto
     interpretation G: right_adjoint_functor C D G using \<phi>\<psi>.has_right_adjoint_functor by auto
     interpretation \<eta>\<epsilon>: unit_counit_adjunction C D F G \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon>
       using \<phi>\<psi>.induces_unit_counit_adjunction \<phi>\<psi>.\<eta>_def \<phi>\<psi>.\<epsilon>_def by auto
 
     theorem induces_adjunction:
-    shows "adjunction C D S \<phi>C \<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<Phi> \<Psi>"
+    shows "adjunction C D S setp \<phi>C \<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<Phi> \<Psi>"
     proof
       fix x
       assume "C.ide x"
       thus "\<phi>\<psi>.\<epsilon> x = \<psi> x (G x)"
         using \<phi>\<psi>.\<epsilon>_map_simp \<phi>\<psi>.\<epsilon>_def by simp
       next
       fix y
       assume "D.ide y"
       thus "\<phi>\<psi>.\<eta> y = \<phi> y (F y)"
         using \<phi>\<psi>.\<eta>_map_simp \<phi>\<psi>.\<eta>_def by simp
       fix x y f
       assume y: "D.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>C x\<guillemotright>"
       show "\<phi> y f = G f \<cdot>\<^sub>D \<phi>\<psi>.\<eta> y"
         using y f \<phi>\<psi>.\<phi>_in_terms_of_\<eta> \<phi>\<psi>.\<eta>_def by simp
       show "\<phi> y f = (\<psi>D (y, G x) \<circ> \<Phi>.FUN (y, x) \<circ> \<phi>C (F y, x)) f"
         using y f \<phi>_def by auto
       next
       fix x y g
       assume x: "C.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>D G x\<guillemotright>"
       show "\<psi> x g = \<phi>\<psi>.\<epsilon> x \<cdot>\<^sub>C F g"
         using x g \<phi>\<psi>.\<psi>_in_terms_of_\<epsilon> \<phi>\<psi>.\<epsilon>_def by simp
       show "\<psi> x g = (\<psi>C (F y, x) \<circ> \<Psi>.FUN (y, x) \<circ> \<phi>D (y, G x)) g"
         using x g \<psi>_def by fast
       next
       fix x y
       assume x: "C.ide x" and y: "D.ide y"
       show "\<Phi> (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                (\<phi>D (y, G x) o \<phi> y o \<psi>C (F y, x))"
         using x y \<Phi>_simp by simp
       show "\<Psi> (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                 (\<phi>C (F y, x) o \<psi> x o \<psi>D (y, G x))"
         using x y \<Psi>_simp by simp
     qed
 
   end
 
   context left_adjoint_functor
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
+    interpretation S: replete_setcat .
 
     theorem induces_adjunction:
-    shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
+    shows "adjunction C D S.comp S.setp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<phi>\<psi>.induces_adjunction by auto
 
   end
 
   context right_adjoint_functor
   begin
 
     interpretation \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using induces_meta_adjunction by auto
+    interpretation S: replete_setcat .
 
     theorem induces_adjunction:
-    shows "adjunction C D replete_setcat.comp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
+    shows "adjunction C D S.comp S.setp \<phi>\<psi>.\<phi>C \<phi>\<psi>.\<phi>D F G \<phi> \<psi> \<phi>\<psi>.\<eta> \<phi>\<psi>.\<epsilon> \<phi>\<psi>.\<Phi> \<phi>\<psi>.\<Psi>"
       using \<phi>\<psi>.induces_adjunction by auto
 
   end
 
   definition adjoint_functors
   where "adjoint_functors C D F G = (\<exists>\<phi> \<psi>. meta_adjunction C D F G \<phi> \<psi>)"
 
   lemma adjoint_functors_respects_naturally_isomorphic:
   assumes "adjoint_functors C D F G"
   and "naturally_isomorphic D C F' F" and "naturally_isomorphic C D G G'"
   shows "adjoint_functors C D F' G'"
   proof -
     obtain \<phi> \<psi> where \<phi>\<psi>: "meta_adjunction C D F G \<phi> \<psi>"
       using assms(1) adjoint_functors_def by blast
     interpret \<phi>\<psi>: meta_adjunction C D F G \<phi> \<psi>
       using \<phi>\<psi> by simp
     obtain \<tau> where \<tau>: "natural_isomorphism D C F' F \<tau>"
       using assms(2) naturally_isomorphic_def by blast
     obtain \<mu> where \<mu>: "natural_isomorphism C D G G' \<mu>"
       using assms(3) naturally_isomorphic_def by blast
     show ?thesis
       using adjoint_functors_def \<tau> \<mu> \<phi>\<psi>.respects_natural_isomorphism by blast
   qed
 
   lemma left_adjoint_functor_respects_naturally_isomorphic:
   assumes "left_adjoint_functor D C F"
   and "naturally_isomorphic D C F F'"
   shows "left_adjoint_functor D C F'"
   proof -
     interpret F: left_adjoint_functor D C F
       using assms(1) by simp
     have 1: "meta_adjunction C D F F.G F.\<phi> F.\<psi>"
       using F.induces_meta_adjunction by simp
     interpret \<phi>\<psi>: meta_adjunction C D F F.G F.\<phi> F.\<psi>
       using 1 by simp
     have "adjoint_functors C D F F.G"
       using 1 adjoint_functors_def by blast
     hence 2: "adjoint_functors C D F' F.G"
       using assms(2) adjoint_functors_respects_naturally_isomorphic [of C D F F.G F' F.G]
             naturally_isomorphic_reflexive naturally_isomorphic_symmetric
             \<phi>\<psi>.G.functor_axioms
       by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D F' F.G \<phi>' \<psi>'"
       using 2 adjoint_functors_def by blast
     interpret \<phi>'\<psi>': meta_adjunction C D F' F.G \<phi>' \<psi>'
       using \<phi>'\<psi>' by simp
     show ?thesis
       using \<phi>'\<psi>'.has_left_adjoint_functor by simp
   qed
 
   lemma right_adjoint_functor_respects_naturally_isomorphic:
   assumes "right_adjoint_functor C D G"
   and "naturally_isomorphic C D G G'"
   shows "right_adjoint_functor C D G'"
   proof -
     interpret G: right_adjoint_functor C D G
       using assms(1) by simp
     have 1: "meta_adjunction C D G.F G G.\<phi> G.\<psi>"
       using G.induces_meta_adjunction by simp
     interpret \<phi>\<psi>: meta_adjunction C D G.F G G.\<phi> G.\<psi>
       using 1 by simp
     have "adjoint_functors C D G.F G"
       using 1 adjoint_functors_def by blast
     hence 2: "adjoint_functors C D G.F G'"
       using assms(2) adjoint_functors_respects_naturally_isomorphic
             naturally_isomorphic_reflexive naturally_isomorphic_symmetric
             \<phi>\<psi>.F.functor_axioms
       by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D G.F G' \<phi>' \<psi>'"
       using 2 adjoint_functors_def by blast
     interpret \<phi>'\<psi>': meta_adjunction C D G.F G' \<phi>' \<psi>'
       using \<phi>'\<psi>' by simp
     show ?thesis
       using \<phi>'\<psi>'.has_right_adjoint_functor by simp
   qed
 
   section "Inverse Functors are Adjoints"
 
   (* TODO: This really should show that inverse functors induce an adjoint equivalence. *)
 
   lemma inverse_functors_induce_meta_adjunction:
   assumes "inverse_functors C D F G"
   shows "meta_adjunction C D F G (\<lambda>x. G) (\<lambda>y. F)"
   proof -
     interpret inverse_functors C D F G using assms by auto
     interpret meta_adjunction C D F G \<open>\<lambda>x. G\<close> \<open>\<lambda>y. F\<close>
     proof -
       have 1: "\<And>y. B.arr y \<Longrightarrow> G (F y) = y"
         by (metis B.map_simp comp_apply inv)
       have 2: "\<And>x. A.arr x \<Longrightarrow> F (G x) = x"
         by (metis A.map_simp comp_apply inv')
       show "meta_adjunction C D F G (\<lambda>x. G) (\<lambda>y. F)"
       proof
         fix y f x
         assume y: "B.ide y" and f: "\<guillemotleft>f : F y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "\<guillemotleft>G f : y \<rightarrow>\<^sub>B G x\<guillemotright>"
           using y f 1 G.preserves_hom by (elim A.in_homE, auto)
         show "F (G f) = f"
           using f 2 by auto
         next
         fix x g y
         assume x: "A.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>B G x\<guillemotright>"
         show "\<guillemotleft>F g : F y \<rightarrow>\<^sub>A x\<guillemotright>"
           using x g 2 F.preserves_hom by (elim B.in_homE, auto)
         show "G (F g) = g" using g 1 A.map_def by blast
         next
         fix f x x' g y' y h
         assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>A x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>B y\<guillemotright>" and h: "\<guillemotleft>h : F y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "G (C f (C h (F g))) = D (G f) (D (G h) g)"
           using f g h 1 2 inv inv' A.map_def B.map_def by (elim A.in_homE B.in_homE, auto)
       qed
     qed
     show ?thesis ..
   qed
 
   lemma inverse_functors_are_adjoints:
   assumes "inverse_functors A B F G"
   shows "adjoint_functors A B F G"
     using assms inverse_functors_induce_meta_adjunction adjoint_functors_def by fast
 
   context inverse_functors
   begin
 
     lemma \<eta>_char:
     shows "meta_adjunction.\<eta> B F (\<lambda>x. G) = identity_functor.map B"
     proof (intro eqI)
       interpret meta_adjunction A B F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close>
         using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
-      interpret adjunction A B replete_setcat.comp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
+      interpret S: replete_setcat .
+      interpret adjunction A B S.comp S.setp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
         using induces_adjunction by force
       show "natural_transformation B B B.map GF.map \<eta>"
         using \<eta>.natural_transformation_axioms by auto
       show "natural_transformation B B B.map GF.map B.map"
         by (simp add: B.as_nat_trans.natural_transformation_axioms inv)
       show "\<And>b. B.ide b \<Longrightarrow> \<eta> b = B.map b"
         using \<eta>_in_terms_of_\<phi> \<eta>o_def \<eta>o_in_hom by fastforce
     qed
 
     lemma \<epsilon>_char:
     shows "meta_adjunction.\<epsilon> A F G (\<lambda>y. F) = identity_functor.map A"
     proof (intro eqI)
       interpret meta_adjunction A B F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close>
         using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
-      interpret adjunction A B replete_setcat.comp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
+      interpret S: replete_setcat .
+      interpret adjunction A B S.comp S.setp \<phi>C \<phi>D F G \<open>\<lambda>y. G\<close> \<open>\<lambda>x. F\<close> \<eta> \<epsilon> \<Phi> \<Psi>
         using induces_adjunction by force
       show "natural_transformation A A FG.map A.map \<epsilon>"
         using \<epsilon>.natural_transformation_axioms by auto
       show "natural_transformation A A FG.map A.map A.map"
         by (simp add: A.as_nat_trans.natural_transformation_axioms inv')
       show "\<And>a. A.ide a \<Longrightarrow> \<epsilon> a = A.map a"
         using \<epsilon>_in_terms_of_\<psi> \<epsilon>o_def \<epsilon>o_in_hom by fastforce
     qed
 
   end
 
   section "Composition of Adjunctions"
 
   locale composite_adjunction =
     A: category A +
     B: category B +
     C: category C +
     F: "functor" B A F +
     G: "functor" A B G +
     F': "functor" C B F' +
     G': "functor" B C G' +
     FG: meta_adjunction A B F G \<phi> \<psi> +
     F'G': meta_adjunction B C F' G' \<phi>' \<psi>'
   for A :: "'a comp"     (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"     (infixr "\<cdot>\<^sub>B" 55)
   and C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and F :: "'b \<Rightarrow> 'a"
   and G :: "'a \<Rightarrow> 'b"
   and F' :: "'c \<Rightarrow> 'b"
   and G' :: "'b \<Rightarrow> 'c"
   and \<phi> :: "'b \<Rightarrow> 'a \<Rightarrow> 'b"
   and \<psi> :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
   and \<phi>' :: "'c \<Rightarrow> 'b \<Rightarrow> 'c"
   and \<psi>' :: "'b \<Rightarrow> 'c \<Rightarrow> 'b"
   begin
 
-    interpretation FG: adjunction A B replete_setcat.comp
+    interpretation S: replete_setcat .
+    interpretation FG: adjunction A B S.comp S.setp
                            FG.\<phi>C FG.\<phi>D F G \<phi> \<psi> FG.\<eta> FG.\<epsilon> FG.\<Phi> FG.\<Psi>
       using FG.induces_adjunction by simp
-    interpretation F'G': adjunction B C replete_setcat.comp F'G'.\<phi>C F'G'.\<phi>D F' G' \<phi>' \<psi>'
+    interpretation F'G': adjunction B C S.comp S.setp F'G'.\<phi>C F'G'.\<phi>D F' G' \<phi>' \<psi>'
                            F'G'.\<eta> F'G'.\<epsilon> F'G'.\<Phi> F'G'.\<Psi>
       using F'G'.induces_adjunction by simp
 
     (* Notation for C.in_hom is inherited here somehow, but I don't know from where. *)
 
     lemma is_meta_adjunction:
     shows "meta_adjunction A C (F o F') (G' o G) (\<lambda>z. \<phi>' z o \<phi> (F' z)) (\<lambda>x. \<psi> x o \<psi>' (G x))"
     proof -
       interpret G'oG: composite_functor A B C G G' ..
       interpret FoF': composite_functor C B A F' F ..
       show ?thesis
       proof
         fix y f x
         assume y: "C.ide y" and f: "\<guillemotleft>f : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "\<guillemotleft>(\<phi>' y \<circ> \<phi> (F' y)) f : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
           using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom by simp
         show "(\<psi> x \<circ> \<psi>' (G x)) ((\<phi>' y \<circ> \<phi> (F' y)) f) = f"
           using y f FG.\<phi>_in_hom F'G'.\<phi>_in_hom FG.\<psi>_\<phi> F'G'.\<psi>_\<phi> by simp
         next
         fix x g y
         assume x: "A.ide x" and g: "\<guillemotleft>g : y \<rightarrow>\<^sub>C G'oG.map x\<guillemotright>"
         show "\<guillemotleft>(\<psi> x \<circ> \<psi>' (G x)) g : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
           using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom by auto
         show "(\<phi>' y \<circ> \<phi> (F' y)) ((\<psi> x \<circ> \<psi>' (G x)) g) = g"
           using x g FG.\<psi>_in_hom F'G'.\<psi>_in_hom FG.\<phi>_\<psi> F'G'.\<phi>_\<psi> by simp
         next
         fix f x x' g y' y h
         assume f: "\<guillemotleft>f : x \<rightarrow>\<^sub>A x'\<guillemotright>" and g: "\<guillemotleft>g : y' \<rightarrow>\<^sub>C y\<guillemotright>" and h: "\<guillemotleft>h : FoF'.map y \<rightarrow>\<^sub>A x\<guillemotright>"
         show "(\<phi>' y' \<circ> \<phi> (F' y')) (f \<cdot>\<^sub>A h \<cdot>\<^sub>A FoF'.map g) =
               G'oG.map f \<cdot>\<^sub>C (\<phi>' y \<circ> \<phi> (F' y)) h \<cdot>\<^sub>C g"
           using f g h FG.\<phi>_naturality [of f x x' "F' g" "F' y'" "F' y" h]
                 F'G'.\<phi>_naturality [of "G f" "G x" "G x'" g y' y "\<phi> (F' y) h"]
                 FG.\<phi>_in_hom
           by fastforce
       qed
     qed
 
     interpretation K\<eta>H: natural_transformation C C \<open>G' o F'\<close> \<open>G' o G o F o F'\<close>
                           \<open>G' o FG.\<eta> o F'\<close>
     proof -
       interpret \<eta>F': natural_transformation C B F' \<open>(G o F) o F'\<close> \<open>FG.\<eta> o F'\<close>
         using FG.\<eta>_is_natural_transformation F'.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret G'\<eta>F': natural_transformation C C \<open>G' o F'\<close> \<open>G' o (G o F o F')\<close>
                          \<open>G' o (FG.\<eta> o F')\<close>
         using \<eta>F'.natural_transformation_axioms G'.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by blast
       show "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.\<eta> o F')"
         using G'\<eta>F'.natural_transformation_axioms o_assoc by metis
     qed
     interpretation G'\<eta>F'o\<eta>': vertical_composite C C C.map \<open>G' o F'\<close> \<open>G' o G o F o F'\<close>
                              F'G'.\<eta> \<open>G' o FG.\<eta> o F'\<close> ..
 
     interpretation F\<epsilon>G: natural_transformation A A \<open>F o F' o G' o G\<close> \<open>F o G\<close>
                           \<open>F o F'G'.\<epsilon> o G\<close>
     proof -
       interpret F\<epsilon>': natural_transformation B A \<open>F o (F' o G')\<close> F \<open>F o F'G'.\<epsilon>\<close>
         using F'G'.\<epsilon>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret F\<epsilon>'G: natural_transformation A A \<open>F o (F' o G') o G\<close> \<open>F o G\<close> \<open>F o F'G'.\<epsilon> o G\<close>
         using F\<epsilon>'.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by blast
       show "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.\<epsilon> o G)"
         using F\<epsilon>'G.natural_transformation_axioms o_assoc by metis
     qed
     interpretation \<epsilon>oF\<epsilon>'G: vertical_composite A A \<open>F \<circ> F' \<circ> G' \<circ> G\<close> \<open>F o G\<close> A.map
                              \<open>F o F'G'.\<epsilon> o G\<close> FG.\<epsilon> ..
 
     interpretation meta_adjunction A C \<open>F o F'\<close> \<open>G' o G\<close>
                                    \<open>\<lambda>z. \<phi>' z o \<phi> (F' z)\<close> \<open>\<lambda>x. \<psi> x o \<psi>' (G x)\<close>
       using is_meta_adjunction by auto
-    interpretation adjunction A C replete_setcat.comp \<phi>C \<phi>D \<open>F \<circ> F'\<close> \<open>G' \<circ> G\<close>
+    interpretation S: replete_setcat .
+    interpretation adjunction A C S.comp S.setp \<phi>C \<phi>D \<open>F \<circ> F'\<close> \<open>G' \<circ> G\<close>
                      \<open>\<lambda>z. \<phi>' z \<circ> \<phi> (F' z)\<close> \<open>\<lambda>x. \<psi> x \<circ> \<psi>' (G x)\<close> \<eta> \<epsilon> \<Phi> \<Psi>
       using induces_adjunction by simp
 
     lemma \<eta>_char:
     shows "\<eta> = G'\<eta>F'o\<eta>'.map"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation C C C.map (G' o G o F o F') G'\<eta>F'o\<eta>'.map" ..
       show "natural_transformation C C C.map (G' o G o F o F') \<eta>"
         by (metis (no_types, lifting) \<eta>_is_natural_transformation o_assoc)
       fix a
       assume a: "C.ide a"
       show "\<eta> a = G'\<eta>F'o\<eta>'.map a"
         unfolding \<eta>_def
         using a G'\<eta>F'o\<eta>'.map_def FG.\<eta>.preserves_hom [of "F' a" "F' a" "F' a"]
               F'G'.\<phi>_in_terms_of_\<eta> FG.\<eta>_map_simp \<eta>_map_simp [of a] C.ide_in_hom
               F'G'.\<eta>_def FG.\<eta>_def
         by auto
     qed
 
     lemma \<epsilon>_char:
     shows "\<epsilon> = \<epsilon>oF\<epsilon>'G.map"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation A A (F o F' o G' o G) A.map \<epsilon>"
         by (metis (no_types, lifting) \<epsilon>_is_natural_transformation o_assoc)
       show "natural_transformation A A (F \<circ> F' \<circ> G' \<circ> G) A.map \<epsilon>oF\<epsilon>'G.map" ..
       fix a
       assume a: "A.ide a"
       show "\<epsilon> a = \<epsilon>oF\<epsilon>'G.map a"
       proof -
         have "\<epsilon> a = \<psi> a (\<psi>' (G a) (G' (G a)))"
           using a \<epsilon>_in_terms_of_\<psi> by simp
         also have "... = FG.\<epsilon> a \<cdot>\<^sub>A F (F'G'.\<epsilon> (G a) \<cdot>\<^sub>B F' (G' (G a)))"
           by (metis F'G'.\<epsilon>_in_terms_of_\<psi> F'G'.\<epsilon>o_def F'G'.\<epsilon>o_in_hom F'G'.\<eta>\<epsilon>.\<epsilon>_in_terms_of_\<psi>
               F'G'.\<eta>\<epsilon>.\<psi>_def FG.G\<epsilon>.natural_transformation_axioms FG.\<psi>_in_terms_of_\<epsilon> a
               functor.preserves_ide natural_transformation_def)
         also have "... = \<epsilon>oF\<epsilon>'G.map a"
           using a B.comp_arr_dom \<epsilon>oF\<epsilon>'G.map_def by simp
         finally show ?thesis by blast
       qed
     qed
 
   end
 
   section "Right Adjoints are Unique up to Natural Isomorphism"
 
   text\<open>
     As an example of the use of the of the foregoing development, we show that two right adjoints
     to the same functor are naturally isomorphic.
 \<close>
 
   theorem two_right_adjoints_naturally_isomorphic:
   assumes "adjoint_functors C D F G" and "adjoint_functors C D F G'"
   shows "naturally_isomorphic C D G G'"
   proof -
     text\<open>
       For any object @{term x} of @{term C}, we have that \<open>\<epsilon> x \<in> C.hom (F (G x)) x\<close>
       is a terminal arrow from @{term F} to @{term x}, and similarly for \<open>\<epsilon>' x\<close>.
       We may therefore obtain the unique coextension \<open>\<tau> x \<in> D.hom (G x) (G' x)\<close>
       of \<open>\<epsilon> x\<close> along \<open>\<epsilon>' x\<close>.
       An explicit formula for \<open>\<tau> x\<close> is \<open>D (G' (\<epsilon> x)) (\<eta>' (G x))\<close>.
       Similarly, we obtain \<open>\<tau>' x = D (G (\<epsilon>' x)) (\<eta> (G' x)) \<in> D.hom (G' x) (G x)\<close>.
       We show these are the components of inverse natural transformations between
       @{term G} and @{term G'}.
 \<close>
     obtain \<phi> \<psi> where \<phi>\<psi>: "meta_adjunction C D F G \<phi> \<psi>"
       using assms adjoint_functors_def by blast
     obtain \<phi>' \<psi>' where \<phi>'\<psi>': "meta_adjunction C D F G' \<phi>' \<psi>'"
       using assms adjoint_functors_def by blast
     interpret Adj: meta_adjunction C D F G \<phi> \<psi> using \<phi>\<psi> by auto
-    interpret Adj: adjunction C D replete_setcat.comp Adj.\<phi>C Adj.\<phi>D
+    interpret S: replete_setcat .
+    interpret Adj: adjunction C D S.comp S.setp Adj.\<phi>C Adj.\<phi>D
                               F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
       using Adj.induces_adjunction by auto
     interpret Adj': meta_adjunction C D F G' \<phi>' \<psi>' using \<phi>'\<psi>' by auto
-    interpret Adj': adjunction C D replete_setcat.comp Adj'.\<phi>C Adj'.\<phi>D
+    interpret Adj': adjunction C D S.comp S.setp Adj'.\<phi>C Adj'.\<phi>D
                                F G' \<phi>' \<psi>' Adj'.\<eta> Adj'.\<epsilon> Adj'.\<Phi> Adj'.\<Psi>
       using Adj'.induces_adjunction by auto
     write C (infixr "\<cdot>\<^sub>C" 55)
     write D (infixr "\<cdot>\<^sub>D" 55)
     write Adj.C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     write Adj.D.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
     let ?\<tau>o = "\<lambda>a. G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
     interpret \<tau>: transformation_by_components C D G G' ?\<tau>o
     proof
       show "\<And>a. Adj.C.ide a \<Longrightarrow> \<guillemotleft>G' (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G a) : G a \<rightarrow>\<^sub>D G' a\<guillemotright>"
         by fastforce
       show "\<And>f. Adj.C.arr f \<Longrightarrow>
                    (G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
                    G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
       proof -
         fix f
         assume f: "Adj.C.arr f"
         let ?x = "Adj.C.dom f"
         let ?x' = "Adj.C.cod f"
         have "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
               G' (Adj.\<epsilon> (Adj.C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj'.\<eta>.naturality [of "G f"] Adj.D.comp_assoc by simp
         also have "... = G' (f \<cdot>\<^sub>C Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj.\<epsilon>.naturality by simp
         also have "... = G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           using f Adj.D.comp_assoc by simp
         finally show "(G' (Adj.\<epsilon> (Adj.C.cod f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.cod f))) \<cdot>\<^sub>D G f =
                       G' f \<cdot>\<^sub>D G' (Adj.\<epsilon> (Adj.C.dom f)) \<cdot>\<^sub>D Adj'.\<eta> (G (Adj.C.dom f))"
           by auto
       qed
     qed
     interpret natural_isomorphism C D G G' \<tau>.map
     proof
       fix a
       assume a: "Adj.C.ide a"
       show "Adj.D.iso (\<tau>.map a)"
       proof
         show "Adj.D.inverse_arrows (\<tau>.map a) (\<phi> (G' a) (Adj'.\<epsilon> a))"
         proof
           text\<open>
             The proof that the two composites are identities is a modest diagram chase.
             This is a good example of the inference rules for the \<open>category\<close>,
             \<open>functor\<close>, and \<open>natural_transformation\<close> locales in action.
             Isabelle is able to use the single hypothesis that \<open>a\<close> is an identity to
             implicitly fill in all the details that the various quantities are in fact arrows
             and that the indicated composites are all well-defined, as well as to apply
             associativity of composition.  In most cases, this is done by auto or simp without
             even mentioning any of the rules that are used.
 $$\xymatrix{
         {G' a} \ar[dd]_{\eta'(G'a)} \ar[rr]^{\tau' a} \ar[dr]_{\eta(G'a)}
            && {G a} \ar[rr]^{\tau a} \ar[dr]_{\eta'(Ga)} && {G' a}                     \\
         & {GFG'a} \rrtwocell\omit{\omit(2)} \ar[ur]_{G(\epsilon' a)} \ar[dr]_{\eta'(GFG'a)}
            && {G'FGa} \drtwocell\omit{\omit(3)} \ar[ur]_{G'(\epsilon a)} &            \\
         {G'FG'a} \urtwocell\omit{\omit(1)} \ar[rr]_{G'F\eta(G'a)} \ar@/_8ex/[rrrr]_{G'FG'a}
            && {G'FGFG'a} \dtwocell\omit{\omit(4)} \ar[ru]_{G'FG(\epsilon' a)} \ar[rr]_{G'(\epsilon(FG'a))}
            && {G'FG'a} \ar[uu]_{G'(\epsilon' a)}                                       \\
            &&&&
 }$$
 \<close>
           show "Adj.D.ide (\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a))"
           proof -
             have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) = G' a"
             proof -
               have "\<tau>.map a \<cdot>\<^sub>D \<phi> (G' a) (Adj'.\<epsilon> a) =
                     G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (Adj'.\<eta> (G a) \<cdot>\<^sub>D G (Adj'.\<epsilon> a)) \<cdot>\<^sub>D Adj.\<eta> (G' a)"
                 using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<phi>_in_terms_of_\<eta>
                       Adj'.\<epsilon>.preserves_hom [of a a a] Adj.C.ide_in_hom Adj.D.comp_assoc
                       Adj.\<epsilon>_def Adj.\<eta>_def
                 by simp
               also have "... = G' (Adj.\<epsilon> a) \<cdot>\<^sub>D (G' (F (G (Adj'.\<epsilon> a))) \<cdot>\<^sub>D Adj'.\<eta> (G (F (G' a)))) \<cdot>\<^sub>D
                                Adj.\<eta> (G' a)"
                 using a Adj'.\<eta>.naturality [of "G (Adj'.\<epsilon> a)"] by auto
               also have "... = (G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a)))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) \<cdot>\<^sub>D
                                Adj'.\<eta> (G' a)"
                 using a Adj'.\<eta>.naturality [of "Adj.\<eta> (G' a)"] Adj.D.comp_assoc by auto
               also have
                   "... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a)))) \<cdot>\<^sub>D
                          Adj'.\<eta> (G' a)"
               proof -
                 have
                    "G' (Adj.\<epsilon> a) \<cdot>\<^sub>D G' (F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D G' (Adj.\<epsilon> (F (G' a)))"
                 proof -
                   have "G' (Adj.\<epsilon> a \<cdot>\<^sub>C F (G (Adj'.\<epsilon> a))) = G' (Adj'.\<epsilon> a \<cdot>\<^sub>C Adj.\<epsilon> (F (G' a)))"
                     using a Adj.\<epsilon>.naturality [of "Adj'.\<epsilon> a"] by auto
                   thus ?thesis using a by force
                 qed
                 thus ?thesis using Adj.D.comp_assoc by auto
               qed
               also have "... = G' (Adj'.\<epsilon> a) \<cdot>\<^sub>D Adj'.\<eta> (G' a)"
               proof -
                 have "G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (F (G' a))"
                 proof -
                   have
                       "G' (Adj.\<epsilon> (F (G' a))) \<cdot>\<^sub>D G' (F (Adj.\<eta> (G' a))) = G' (Adj.\<epsilon>FoF\<eta>.map (G' a))"
                     using a Adj.\<epsilon>FoF\<eta>.map_simp_1 by auto
                   moreover have "Adj.\<epsilon>FoF\<eta>.map (G' a) = F (G' a)"
                     using a by (simp add: Adj.\<eta>\<epsilon>.triangle_F)
                   ultimately show ?thesis by auto
                 qed
                 thus ?thesis
                   using a Adj.D.comp_cod_arr [of "Adj'.\<eta> (G' a)"] by auto
               qed
               also have "... = G' a"
                 using a Adj'.\<eta>\<epsilon>.triangle_G Adj'.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
               finally show ?thesis by auto
             qed
             thus ?thesis using a by simp
           qed
           show "Adj.D.ide (\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a)"
           proof -
             have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a = G a"
             proof -
               have "\<phi> (G' a) (Adj'.\<epsilon> a) \<cdot>\<^sub>D \<tau>.map a =
                     G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (Adj.\<eta> (G' a) \<cdot>\<^sub>D G' (Adj.\<epsilon> a)) \<cdot>\<^sub>D Adj'.\<eta> (G a)"
                 using a \<tau>.map_simp_ide Adj.\<phi>_in_terms_of_\<eta> Adj'.\<epsilon>.preserves_hom [of a a a]
                       Adj.C.ide_in_hom Adj.D.comp_assoc Adj.\<eta>_def
                 by auto
               also have
                 "... = G (Adj'.\<epsilon> a) \<cdot>\<^sub>D (G (F (G' (Adj.\<epsilon> a))) \<cdot>\<^sub>D Adj.\<eta> (G' (F (G a)))) \<cdot>\<^sub>D
                        Adj'.\<eta> (G a)"
                 using a Adj.\<eta>.naturality [of "G' (Adj.\<epsilon> a)"] by auto
               also have
                 "... = (G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a)))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) \<cdot>\<^sub>D
                        Adj.\<eta> (G a)"
                 using a Adj.\<eta>.naturality [of "Adj'.\<eta> (G a)"] Adj.D.comp_assoc by auto
               also have
                 "... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D (G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a)))) \<cdot>\<^sub>D
                        Adj.\<eta> (G a)"
               proof -
                 have "G (Adj'.\<epsilon> a) \<cdot>\<^sub>D G (F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a) \<cdot>\<^sub>D G (Adj'.\<epsilon> (F (G a)))"
                 proof -
                   have "G (Adj'.\<epsilon> a \<cdot>\<^sub>C F (G' (Adj.\<epsilon> a))) = G (Adj.\<epsilon> a \<cdot>\<^sub>C Adj'.\<epsilon> (F (G a)))"
                     using a Adj'.\<epsilon>.naturality [of "Adj.\<epsilon> a"] by auto
                   thus ?thesis using a by force
                 qed
                 thus ?thesis using Adj.D.comp_assoc by auto
               qed
               also have "... = G (Adj.\<epsilon> a) \<cdot>\<^sub>D Adj.\<eta> (G a)"
               proof -
                 have "G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (F (G a))"
                 proof -
                   have
                     "G (Adj'.\<epsilon> (F (G a))) \<cdot>\<^sub>D G (F (Adj'.\<eta> (G a))) = G (Adj'.\<epsilon>FoF\<eta>.map (G a))"
                     using a Adj'.\<epsilon>FoF\<eta>.map_simp_1 [of "G a"] by auto
                   moreover have "Adj'.\<epsilon>FoF\<eta>.map (G a) = F (G a)"
                     using a by (simp add: Adj'.\<eta>\<epsilon>.triangle_F)
                   ultimately show ?thesis by auto
                 qed
                 thus ?thesis
                   using a Adj.D.comp_cod_arr by auto
               qed
               also have "... = G a"
                 using a Adj.\<eta>\<epsilon>.triangle_G Adj.G\<epsilon>o\<eta>G.map_simp_1 [of a] by auto
               finally show ?thesis by auto
             qed
             thus ?thesis using a by auto
           qed
         qed
       qed
     qed
     have "natural_isomorphism C D G G' \<tau>.map" ..
     thus "naturally_isomorphic C D G G'"
       using naturally_isomorphic_def by blast
   qed
 
 end
diff --git a/thys/Category3/EquivalenceOfCategories.thy b/thys/Category3/EquivalenceOfCategories.thy
--- a/thys/Category3/EquivalenceOfCategories.thy
+++ b/thys/Category3/EquivalenceOfCategories.thy
@@ -1,913 +1,914 @@
 (*  Title:       EquivalenceOfCategories
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Equivalence of Categories"
 
 text \<open>
   In this chapter we define the notions of equivalence and adjoint equivalence of categories
   and establish some properties of functors that are part of an equivalence.
 \<close>
 
 theory EquivalenceOfCategories
 imports Adjunction
 begin
 
   locale equivalence_of_categories =
     C: category C +
     D: category D +
     F: "functor" D C F +
     G: "functor" C D G +
     \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
     \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and F :: "'d \<Rightarrow> 'c"
   and G :: "'c \<Rightarrow> 'd"
   and \<eta> :: "'d \<Rightarrow> 'd"
   and \<epsilon> :: "'c \<Rightarrow> 'c"
   begin
 
     notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     lemma C_arr_expansion:
     assumes "C.arr f"
     shows "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f"
     and "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
     proof -
       have \<epsilon>_dom: "C.inverse_arrows (\<epsilon> (C.dom f)) (C.inv (\<epsilon> (C.dom f)))"
         using assms C.inv_is_inverse by auto
       have \<epsilon>_cod: "C.inverse_arrows (\<epsilon> (C.cod f)) (C.inv (\<epsilon> (C.cod f)))"
         using assms C.inv_is_inverse by auto
       have "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) =
             (\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
         using C.comp_assoc by force
       also have 1: "... = (f \<cdot>\<^sub>C \<epsilon> (C.dom f)) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f))"
         using assms \<epsilon>.naturality by simp
       also have 2: "... = f"
         using assms \<epsilon>_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
       finally show "\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f) \<cdot>\<^sub>C C.inv (\<epsilon> (C.dom f)) = f" by blast
       show "C.inv (\<epsilon> (C.cod f)) \<cdot>\<^sub>C f \<cdot>\<^sub>C \<epsilon> (C.dom f) = F (G f)"
         using assms 1 2 \<epsilon>_dom \<epsilon>_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
         by metis
     qed
 
     lemma G_is_faithful:
     shows "faithful_functor C D G"
     proof
       fix f f'
       assume par: "C.par f f'" and eq: "G f = G f'"
       show "f = f'"
       proof -
         have "C.inv (\<epsilon> (C.cod f)) \<in> C.hom (C.cod f) (F (G (C.cod f))) \<and>
               C.iso (C.inv (\<epsilon> (C.cod f)))"
           using par by auto
         moreover have 1: "\<epsilon> (C.dom f) \<in> C.hom (F (G (C.dom f))) (C.dom f) \<and>
                           C.iso (\<epsilon> (C.dom f))"
           using par by auto
         ultimately have 2: "f \<cdot>\<^sub>C \<epsilon> (C.dom f) = f' \<cdot>\<^sub>C \<epsilon> (C.dom f)"
           using par C_arr_expansion eq C.iso_is_section C.section_is_mono
           by (metis C_arr_expansion(1) eq)
         show ?thesis
         proof -
           have "C.epi (\<epsilon> (C.dom f))"
             using 1 par C.iso_is_retraction C.retraction_is_epi by blast
           thus ?thesis using 2 par by auto
         qed
       qed
     qed
 
     lemma G_is_essentially_surjective:
     shows "essentially_surjective_functor C D G"
     proof
       fix b
       assume b: "D.ide b"
       have "C.ide (F b) \<and> D.isomorphic (G (F b)) b"
       proof
         show "C.ide (F b)" using b by simp
         show "D.isomorphic (G (F b)) b"
         proof (unfold D.isomorphic_def)
           have "\<guillemotleft>D.inv (\<eta> b) : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso (D.inv (\<eta> b))"
             using b by auto
           thus "\<exists>f. \<guillemotleft>f : G (F b) \<rightarrow>\<^sub>D b\<guillemotright> \<and> D.iso f" by blast
         qed
       qed
       thus "\<exists>a. C.ide a \<and> D.isomorphic (G a) b"
         by blast
     qed
 
     interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
     interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
     interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
 
     lemma F_is_faithful:
     shows "faithful_functor D C F"
       using GF.G_is_faithful by simp
 
     lemma F_is_essentially_surjective:
     shows "essentially_surjective_functor D C F"
       using GF.G_is_essentially_surjective by simp
 
     lemma G_is_full:
     shows "full_functor C D G"
     proof
       fix a a' g
       assume a: "C.ide a" and a': "C.ide a'"
       assume g: "\<guillemotleft>g : G a \<rightarrow>\<^sub>D G a'\<guillemotright>"
       show "\<exists>f. \<guillemotleft>f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G f = g"
       proof
         have \<epsilon>a: "C.inverse_arrows (\<epsilon> a) (C.inv (\<epsilon> a))"
           using a C.inv_is_inverse by auto
         have \<epsilon>a': "C.inverse_arrows (\<epsilon> a') (C.inv (\<epsilon> a'))"
           using a' C.inv_is_inverse by auto
         let ?f = "\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a)"
         have f: "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright>"
           using a a' g \<epsilon>a \<epsilon>a' \<epsilon>.preserves_hom [of a' a' a'] \<epsilon>_inv.preserves_hom [of a a a]
           by fastforce
         moreover have "G ?f = g"
         proof -
           interpret F: faithful_functor D C F
             using F_is_faithful by auto
           have "F (G ?f) = F g"
           proof -
             have "F (G ?f) = C.inv (\<epsilon> a') \<cdot>\<^sub>C ?f \<cdot>\<^sub>C \<epsilon> a"
               using f C_arr_expansion(2) [of "?f"] by auto
             also have "... = (C.inv (\<epsilon> a') \<cdot>\<^sub>C \<epsilon> a') \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a) \<cdot>\<^sub>C \<epsilon> a"
               using a a' f g C.comp_assoc by fastforce
             also have "... = F g"
               using a a' g \<epsilon>a \<epsilon>a' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
             finally show ?thesis by blast
           qed
           moreover have "D.par (G (\<epsilon> a' \<cdot>\<^sub>C F g \<cdot>\<^sub>C C.inv (\<epsilon> a))) g"
             using f g by fastforce
           ultimately show ?thesis using f g F.is_faithful by blast
         qed
         ultimately show "\<guillemotleft>?f : a \<rightarrow>\<^sub>C a'\<guillemotright> \<and> G ?f = g" by blast
       qed
     qed
 
   end
 
   (* I'm not sure why I had to close and re-open the context here in order to
    * get the G_is_full fact in the interpretation GF. *)
 
   context equivalence_of_categories
   begin
 
     interpretation \<epsilon>_inv: inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
     interpretation \<eta>_inv: inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
     interpretation GF: equivalence_of_categories D C G F \<epsilon>_inv.map \<eta>_inv.map ..
 
     lemma F_is_full:
     shows "full_functor D C F"
       using GF.G_is_full by simp
 
   end
 
   text \<open>
     Traditionally the term "equivalence of categories" is also used for a functor
     that is part of an equivalence of categories.  However, it seems best to use
     that term for a situation in which all of the structure of an equivalence is
     explicitly given, and to have a different term for one of the functors involved.
 \<close>
 
   locale equivalence_functor =
     C: category C +
     D: category D +
     "functor" C D G
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and G :: "'c \<Rightarrow> 'd" +
   assumes induces_equivalence: "\<exists>F \<eta> \<epsilon>. equivalence_of_categories C D F G \<eta> \<epsilon>"
   begin
 
     notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
   end
 
   sublocale equivalence_of_categories \<subseteq> equivalence_functor C D G
     using equivalence_of_categories_axioms by (unfold_locales, blast)
 
   text \<open>
     An equivalence functor is fully faithful and essentially surjective.
 \<close>
 
   sublocale equivalence_functor \<subseteq> fully_faithful_functor C D G
   proof -
     obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
       using induces_equivalence by blast
     interpret equivalence_of_categories C D F G \<eta> \<epsilon>
       using 1 by auto
     show "fully_faithful_functor C D G"
       using G_is_full G_is_faithful fully_faithful_functor.intro by auto
   qed
 
   sublocale equivalence_functor \<subseteq> essentially_surjective_functor C D G
   proof -
     obtain F \<eta> \<epsilon> where 1: "equivalence_of_categories C D F G \<eta> \<epsilon>"
       using induces_equivalence by blast
     interpret equivalence_of_categories C D F G \<eta> \<epsilon>
       using 1 by auto
     show "essentially_surjective_functor C D G"
       using G_is_essentially_surjective by auto
   qed
 
   lemma (in inverse_functors) induce_equivalence:
   shows "equivalence_of_categories A B F G B.map A.map"
     using inv inv' A.is_extensional B.is_extensional B.comp_arr_dom B.comp_cod_arr
           A.comp_arr_dom A.comp_cod_arr
     by unfold_locales auto
 
   lemma (in invertible_functor) is_equivalence:
   shows "equivalence_functor A B G"
     using equivalence_functor_axioms.intro equivalence_functor_def equivalence_of_categories_def
           induce_equivalence
     by blast
 
   lemma (in identity_functor) is_equivalence:
   shows "equivalence_functor C C map"
   proof -
     interpret inverse_functors C C map map
       using map_def by unfold_locales auto
     interpret invertible_functor C C map
       using inverse_functors_axioms
       by unfold_locales blast
     show ?thesis
       using is_equivalence by blast
   qed
 
   text \<open>
     A special case of an equivalence functor is an endofunctor \<open>F\<close> equipped with
     a natural isomorphism from \<open>F\<close> to the identity functor.
 \<close>
 
   context endofunctor
   begin
 
     lemma isomorphic_to_identity_is_equivalence:
     assumes "natural_isomorphism A A F A.map \<phi>"
     shows "equivalence_functor A A F"
     proof -
       interpret \<phi>: natural_isomorphism A A F A.map \<phi>
          using assms by auto
       interpret \<phi>': inverse_transformation A A F A.map \<phi> ..
       interpret F\<phi>': natural_isomorphism A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
       proof -
         interpret F\<phi>': natural_transformation A A F \<open>F o F\<close> \<open>F o \<phi>'.map\<close>
           using \<phi>'.natural_transformation_axioms functor_axioms
                 horizontal_composite [of A A A.map F \<phi>'.map A F F F]
           by simp
         show "natural_isomorphism A A F (F o F) (F o \<phi>'.map)"
           apply unfold_locales
           using \<phi>'.components_are_iso by fastforce
       qed
       interpret F\<phi>'o\<phi>': vertical_composite A A A.map F \<open>F o F\<close> \<phi>'.map \<open>F o \<phi>'.map\<close> ..
       interpret F\<phi>'o\<phi>': natural_isomorphism A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map
         using \<phi>'.natural_isomorphism_axioms F\<phi>'.natural_isomorphism_axioms
               natural_isomorphisms_compose
         by fast
       interpret inv_F\<phi>'o\<phi>': inverse_transformation A A A.map \<open>F o F\<close> F\<phi>'o\<phi>'.map ..
       interpret F: equivalence_of_categories A A F F F\<phi>'o\<phi>'.map inv_F\<phi>'o\<phi>'.map ..
       show ?thesis ..
     qed
 
   end
 
   text \<open>
     An adjoint equivalence is an equivalence of categories that is also an adjunction.
 \<close>
 
   locale adjoint_equivalence =
     unit_counit_adjunction C D F G \<eta> \<epsilon> +
     \<eta>: natural_isomorphism D D D.map "G o F" \<eta> +
     \<epsilon>: natural_isomorphism C C "F o G" C.map \<epsilon>
   for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
   and F :: "'d \<Rightarrow> 'c"
   and G :: "'c \<Rightarrow> 'd"
   and \<eta> :: "'d \<Rightarrow> 'd"
   and \<epsilon> :: "'c \<Rightarrow> 'c"
 
   text \<open>
     An adjoint equivalence is clearly an equivalence of categories.
 \<close>
 
   sublocale adjoint_equivalence \<subseteq> equivalence_of_categories ..
 
   context adjoint_equivalence
   begin
 
     text \<open>
       The triangle identities for an adjunction reduce to inverse relations when
       \<open>\<eta>\<close> and \<open>\<epsilon>\<close> are natural isomorphisms.
 \<close>
 
     lemma triangle_G':
     assumes "C.ide a"
     shows "D.inverse_arrows (\<eta> (G a)) (G (\<epsilon> a))"
     proof
       show "D.ide (G (\<epsilon> a) \<cdot>\<^sub>D \<eta> (G a))"
         using assms triangle_G G\<epsilon>o\<eta>G.map_simp_ide by fastforce
       thus "D.ide (\<eta> (G a) \<cdot>\<^sub>D G (\<epsilon> a))"
         using assms D.section_retraction_of_iso [of "G (\<epsilon> a)" "\<eta> (G a)"] by auto
     qed
 
     lemma triangle_F':
     assumes "D.ide b"
     shows "C.inverse_arrows (F (\<eta> b)) (\<epsilon> (F b))"
     proof
      show "C.ide (\<epsilon> (F b) \<cdot>\<^sub>C F (\<eta> b))"
         using assms triangle_F \<epsilon>FoF\<eta>.map_simp_ide by auto
       thus "C.ide (F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b))"
         using assms C.section_retraction_of_iso [of "\<epsilon> (F b)" "F (\<eta> b)"] by auto
     qed
 
     text \<open>
       An adjoint equivalence can be dualized by interchanging the two functors and inverting
       the natural isomorphisms.  This is somewhat awkward to prove, but probably useful to have
       done it once and for all.
 \<close>
 
     lemma dual_equivalence:
     assumes "adjoint_equivalence C D F G \<eta> \<epsilon>"
     shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) \<epsilon>)
                                        (inverse_transformation.map D D (G o F) \<eta>)"
     proof -
       interpret adjoint_equivalence C D F G \<eta> \<epsilon> using assms by auto
       interpret \<epsilon>': inverse_transformation C C \<open>F o G\<close> C.map \<epsilon> ..
       interpret \<eta>': inverse_transformation D D D.map \<open>G o F\<close> \<eta> ..
       interpret G\<epsilon>': natural_transformation C D G \<open>G o F o G\<close> \<open>G o \<epsilon>'.map\<close>
       proof -
         have "natural_transformation C D G (G o (F o G)) (G o \<epsilon>'.map)"
           using G.as_nat_trans.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
                 horizontal_composite
           by fastforce
         thus "natural_transformation C D G (G o F o G) (G o \<epsilon>'.map)"
           using o_assoc by metis
       qed
       interpret \<eta>'G: natural_transformation C D \<open>G o F o G\<close> G \<open>\<eta>'.map o G\<close>
         using \<eta>'.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret \<epsilon>'F: natural_transformation D C F \<open>F o G o F\<close> \<open>\<epsilon>'.map o F\<close>
         using \<epsilon>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite
         by fastforce
       interpret F\<eta>': natural_transformation D C \<open>F o G o F\<close> F \<open>F o \<eta>'.map\<close>
       proof -
         have "natural_transformation D C (F o (G o F)) F (F o \<eta>'.map)"
           using \<eta>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
                 horizontal_composite
           by fastforce
         thus "natural_transformation D C (F o G o F) F (F o \<eta>'.map)"
           using o_assoc by metis
       qed
       interpret F\<eta>'o\<epsilon>'F: vertical_composite D C F \<open>(F o G) o F\<close> F \<open>\<epsilon>'.map o F\<close> \<open>F o \<eta>'.map\<close> ..
       interpret \<eta>'GoG\<epsilon>': vertical_composite C D G \<open>G o F o G\<close> G \<open>G o \<epsilon>'.map\<close> \<open>\<eta>'.map o G\<close> ..
       show ?thesis
       proof
         show "\<eta>'GoG\<epsilon>'.map = G"
         proof (intro NaturalTransformation.eqI)
           show "natural_transformation C D G G G"
             using G.as_nat_trans.natural_transformation_axioms by auto
           show "natural_transformation C D G G \<eta>'GoG\<epsilon>'.map"
             using \<eta>'GoG\<epsilon>'.natural_transformation_axioms by auto
           show "\<And>a. C.ide a \<Longrightarrow> \<eta>'GoG\<epsilon>'.map a = G a"
           proof -
             fix a
             assume a: "C.ide a"
             show "\<eta>'GoG\<epsilon>'.map a = G a"
               using a \<eta>'GoG\<epsilon>'.map_simp_ide triangle_G' G.preserves_ide
                     \<eta>'.inverts_components \<epsilon>'.inverts_components
                     D.inverse_unique G.preserves_inverse_arrows G\<epsilon>o\<eta>G.map_simp_ide
                     D.inverse_arrows_sym triangle_G
               by (metis o_apply)
           qed
         qed
         show "F\<eta>'o\<epsilon>'F.map = F"
         proof (intro NaturalTransformation.eqI)
           show "natural_transformation D C F F F"
             using F.as_nat_trans.natural_transformation_axioms by auto
           show "natural_transformation D C F F F\<eta>'o\<epsilon>'F.map"
             using F\<eta>'o\<epsilon>'F.natural_transformation_axioms by auto
           show "\<And>b. D.ide b \<Longrightarrow> F\<eta>'o\<epsilon>'F.map b = F b"
           proof -
             fix b
             assume b: "D.ide b"
             show "F\<eta>'o\<epsilon>'F.map b = F b"
               using b F\<eta>'o\<epsilon>'F.map_simp_ide \<epsilon>FoF\<eta>.map_simp_ide triangle_F triangle_F'
                     \<eta>'.inverts_components \<epsilon>'.inverts_components F.preserves_ide
                     C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
               by (metis o_apply)
           qed
         qed
       qed
     qed
 
   end
 
   text \<open>
     Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
     To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
     we first show that a fully faithful and essentially surjective functor is a left adjoint
     functor, and then we show that if the left adjoint in a unit-counit adjunction is
     fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
     hence the adjunction is in fact an adjoint equivalence.
 \<close>
 
   locale fully_faithful_and_essentially_surjective_functor =
     C: category C +
     D: category D +
     fully_faithful_functor C D F +
     essentially_surjective_functor C D F
     for C :: "'c comp"     (infixr "\<cdot>\<^sub>C" 55)
     and D :: "'d comp"     (infixr "\<cdot>\<^sub>D" 55)
     and F :: "'c \<Rightarrow> 'd"
   begin
 
     notation C.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
     notation D.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>D _\<guillemotright>")
 
     lemma is_left_adjoint_functor:
     shows "left_adjoint_functor C D F"
     proof
       fix y
       assume y: "D.ide y"
       let ?x = "SOME x. C.ide x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>D y\<guillemotright>)"
       let ?e = "SOME e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"
       have "\<exists>x e. D.iso e \<and> terminal_arrow_from_functor C D F x y e"
       proof -
         have "\<exists>x. D.iso ?e \<and> terminal_arrow_from_functor C D F x y ?e"
         proof -
           have x: "C.ide ?x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>)"
             using y essentially_surjective
                   someI_ex [of "\<lambda>x. C.ide x \<and> (\<exists>e. D.iso e \<and> \<guillemotleft>e : F x \<rightarrow>\<^sub>D y\<guillemotright>)"]
             by blast
           hence e: "D.iso ?e \<and> \<guillemotleft>?e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"
             using someI_ex [of "\<lambda>e. D.iso e \<and> \<guillemotleft>e : F ?x \<rightarrow>\<^sub>D y\<guillemotright>"] by blast
           interpret arrow_from_functor C D F ?x y ?e
             using x e by (unfold_locales, simp)
           interpret terminal_arrow_from_functor C D F ?x y ?e
           proof
             fix x' f
             assume 1: "arrow_from_functor C D F x' y f"
             interpret f: arrow_from_functor C D F x' y f
               using 1 by simp
             have f: "\<guillemotleft>f: F x' \<rightarrow>\<^sub>D y\<guillemotright>"
               by (meson f.arrow)
             show "\<exists>!g. is_coext x' f g"
             proof
               let ?g = "SOME g. \<guillemotleft>g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F g = D.inv ?e \<cdot>\<^sub>D f"
               have g: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F ?g = D.inv ?e \<cdot>\<^sub>D f"
                 using f e x f.arrow is_full D.comp_in_homI D.inv_in_hom
                       someI_ex [of "\<lambda>g. \<guillemotleft>g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> F g = D.inv ?e \<cdot>\<^sub>D f"]
                 by auto
               show 1: "is_coext x' f ?g"
               proof -
                 have "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright>"
                   using g by simp
                 moreover have "?e \<cdot>\<^sub>D F ?g = f"
                 proof -
                   have "?e \<cdot>\<^sub>D F ?g = ?e \<cdot>\<^sub>D D.inv ?e \<cdot>\<^sub>D f"
                     using g by simp
                   also have "... = (?e \<cdot>\<^sub>D D.inv ?e) \<cdot>\<^sub>D f"
                     using e f D.inv_in_hom by (metis D.comp_assoc)
                   also have "... = f"
                   proof -
                     have "?e \<cdot>\<^sub>D D.inv ?e = y"
                       using e D.comp_arr_inv D.inv_is_inverse by auto
                     thus ?thesis
                       using f D.comp_cod_arr by auto
                   qed
                   finally show ?thesis by blast
                 qed
                 ultimately show ?thesis
                   unfolding is_coext_def by simp
               qed
               show "\<And>g'. is_coext x' f g' \<Longrightarrow> g' = ?g"
               proof -
                 fix g'
                 assume g': "is_coext x' f g'"
                 have 2: "\<guillemotleft>g' : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>D F g' = f" using g' is_coext_def by simp
                 have 3: "\<guillemotleft>?g : x' \<rightarrow>\<^sub>C ?x\<guillemotright> \<and> ?e \<cdot>\<^sub>D F ?g = f" using 1 is_coext_def by simp
                 have "F g' = F ?g"
                   using e f 2 3 D.iso_is_section D.section_is_mono D.monoE D.arrI
                   by (metis (no_types, lifting) D.arrI)
                 moreover have "C.par g' ?g"
                   using 2 3 by fastforce
                 ultimately show "g' = ?g"
                   using is_faithful [of g' ?g] by simp
               qed
             qed
           qed
           show ?thesis
             using e terminal_arrow_from_functor_axioms by auto
         qed
         thus ?thesis by auto
       qed
       thus "\<exists>x e. terminal_arrow_from_functor C D F x y e" by blast
     qed
 
     lemma extends_to_adjoint_equivalence:
     shows "\<exists>G \<eta> \<epsilon>. adjoint_equivalence C D G F \<eta> \<epsilon>"
     proof -
       interpret left_adjoint_functor C D F
         using is_left_adjoint_functor by blast
       interpret Adj: meta_adjunction D C F G \<phi> \<psi>
         using induces_meta_adjunction by simp
-      interpret Adj: adjunction D C replete_setcat.comp
+      interpret S: replete_setcat .
+      interpret Adj: adjunction D C S.comp S.setp
                        Adj.\<phi>C Adj.\<phi>D F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
         using induces_adjunction by simp
       interpret equivalence_of_categories D C F G Adj.\<eta> Adj.\<epsilon>
       proof
         show 1: "\<And>a. D.ide a \<Longrightarrow> D.iso (Adj.\<epsilon> a)"
         proof -
           fix a
           assume a: "D.ide a"
           interpret \<epsilon>a: terminal_arrow_from_functor C D F \<open>G a\<close> a \<open>Adj.\<epsilon> a\<close>
             using a Adj.has_terminal_arrows_from_functor [of a] by blast
           have "D.retraction (Adj.\<epsilon> a)"
           proof -
             obtain b \<phi> where \<phi>: "C.ide b \<and> D.iso \<phi> \<and> \<guillemotleft>\<phi>: F b \<rightarrow>\<^sub>D a\<guillemotright>"
               using a essentially_surjective by blast
             interpret \<phi>: arrow_from_functor C D F b a \<phi>
               using \<phi> by (unfold_locales, simp)
             let ?g = "\<epsilon>a.the_coext b \<phi>"
             have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>C G a\<guillemotright> \<and> Adj.\<epsilon> a \<cdot>\<^sub>D F ?g = \<phi>"
               using \<phi>.arrow_from_functor_axioms \<epsilon>a.the_coext_prop [of b \<phi>] by simp
             have "a = (Adj.\<epsilon> a \<cdot>\<^sub>D F ?g) \<cdot>\<^sub>D D.inv \<phi>"
               using a 1 \<phi> D.comp_cod_arr Adj.\<epsilon>.preserves_hom D.invert_side_of_triangle(2)
                by auto
             also have "... = Adj.\<epsilon> a \<cdot>\<^sub>D F ?g \<cdot>\<^sub>D D.inv \<phi>"
               using a 1 \<phi> D.inv_in_hom Adj.\<epsilon>.preserves_hom [of a a a] D.comp_assoc
               by blast
             finally have "\<exists>f. D.ide (Adj.\<epsilon> a \<cdot>\<^sub>D f)"
               using a by metis
             thus ?thesis
               unfolding D.retraction_def by blast
           qed
           moreover have "D.mono (Adj.\<epsilon> a)"
           proof
             show "D.arr (Adj.\<epsilon> a)"
               using a by simp
             show "\<And>f f'. D.seq (Adj.\<epsilon> a) f \<and> D.seq (Adj.\<epsilon> a) f' \<and> Adj.\<epsilon> a \<cdot>\<^sub>D f = Adj.\<epsilon> a \<cdot>\<^sub>D f'
                             \<Longrightarrow> f = f'"
             proof -
               fix f f'
               assume ff': "D.seq (Adj.\<epsilon> a) f \<and> D.seq (Adj.\<epsilon> a) f' \<and> Adj.\<epsilon> a \<cdot>\<^sub>D f = Adj.\<epsilon> a \<cdot>\<^sub>D f'"
               have f: "\<guillemotleft>f : D.dom f \<rightarrow>\<^sub>D F (G a)\<guillemotright>"
                 using a ff' Adj.\<epsilon>.preserves_hom [of a a a] by fastforce
               have f': "\<guillemotleft>f' : D.dom f' \<rightarrow>\<^sub>D F (G a)\<guillemotright>"
                 using a ff' Adj.\<epsilon>.preserves_hom [of a a a] by fastforce
               have par: "D.par f f'"
                 using f f' ff' D.dom_comp [of "Adj.\<epsilon> a" f] by force
               obtain b' \<phi> where \<phi>: "C.ide b' \<and> D.iso \<phi> \<and> \<guillemotleft>\<phi>: F b' \<rightarrow>\<^sub>D D.dom f\<guillemotright>"
                 using par essentially_surjective D.ide_dom [of f] by blast
               have 1: "Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi> = Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>"
                 using ff' \<phi> par D.comp_assoc by metis
               obtain g where g: "\<guillemotleft>g : b' \<rightarrow>\<^sub>C G a\<guillemotright> \<and> F g = f \<cdot>\<^sub>D \<phi>"
                 using a f \<phi> is_full [of "G a" b' "f \<cdot>\<^sub>D \<phi>"] by auto
               obtain g' where g': "\<guillemotleft>g' : b' \<rightarrow>\<^sub>C G a\<guillemotright> \<and> F g' = f' \<cdot>\<^sub>D \<phi>"
                 using a f' par \<phi> is_full [of "G a" b' "f' \<cdot>\<^sub>D \<phi>"] by auto
               interpret f\<phi>: arrow_from_functor C D F b' a \<open>Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi>\<close>
                 using a \<phi> f Adj.\<epsilon>.preserves_hom
                 by (unfold_locales, fastforce)
               interpret f'\<phi>: arrow_from_functor C D F b' a \<open>Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>\<close>
                 using a \<phi> f' par Adj.\<epsilon>.preserves_hom
                 by (unfold_locales, fastforce)
               have "\<epsilon>a.is_coext b' (Adj.\<epsilon> a \<cdot>\<^sub>D f \<cdot>\<^sub>D \<phi>) g"
                 unfolding \<epsilon>a.is_coext_def using g 1 by auto
               moreover have "\<epsilon>a.is_coext b' (Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>) g'"
                 unfolding \<epsilon>a.is_coext_def using g' 1 by auto
               ultimately have "g = g'"
                 using 1 f\<phi>.arrow_from_functor_axioms f'\<phi>.arrow_from_functor_axioms
                       \<epsilon>a.the_coext_unique \<epsilon>a.the_coext_unique [of b' "Adj.\<epsilon> a \<cdot>\<^sub>D f' \<cdot>\<^sub>D \<phi>" g']
                 by auto
               hence "f \<cdot>\<^sub>D \<phi> = f' \<cdot>\<^sub>D \<phi>"
                 using g g' is_faithful by argo
               thus "f = f'"
                 using \<phi> f f' par D.iso_is_retraction D.retraction_is_epi D.epiE [of \<phi> f f']
                 by auto
             qed
           qed
           ultimately show "D.iso (Adj.\<epsilon> a)"
             using D.iso_iff_mono_and_retraction by simp
         qed
         interpret \<epsilon>: natural_isomorphism D D \<open>F o G\<close> D.map Adj.\<epsilon>
           using 1 by (unfold_locales, auto)
         interpret \<epsilon>F: natural_isomorphism C D \<open>F o G o F\<close> F \<open>Adj.\<epsilon> o F\<close>
           using \<epsilon>.components_are_iso by (unfold_locales, simp)
         show "\<And>a. C.ide a \<Longrightarrow> C.iso (Adj.\<eta> a)"
         proof -
           fix a
           assume a: "C.ide a"
           have "D.inverse_arrows ((Adj.\<epsilon> o F) a) ((F o Adj.\<eta>) a)"
             using a \<epsilon>.components_are_iso Adj.\<eta>\<epsilon>.triangle_F Adj.\<epsilon>FoF\<eta>.map_simp_ide
                   D.section_retraction_of_iso
             by simp
           hence "D.iso ((F o Adj.\<eta>) a)"
             by blast
           thus "C.iso (Adj.\<eta> a)"
             using a reflects_iso [of "Adj.\<eta> a"] by fastforce
         qed
       qed
       (*
        * Uggh, I should have started with "right_adjoint_functor D C G" so that the
        * following would come out right.  Instead, another step is needed to dualize.
        * TODO: Maybe re-work this later.
        *)
       interpret adjoint_equivalence D C F G Adj.\<eta> Adj.\<epsilon> ..
       interpret \<epsilon>': inverse_transformation D D \<open>F o G\<close> D.map Adj.\<epsilon> ..
       interpret \<eta>': inverse_transformation C C C.map \<open>G o F\<close> Adj.\<eta> ..
       interpret E: adjoint_equivalence C D G F \<epsilon>'.map \<eta>'.map
         using adjoint_equivalence_axioms dual_equivalence by blast
       show ?thesis
         using E.adjoint_equivalence_axioms by auto
     qed
 
     lemma is_right_adjoint_functor:
     shows "right_adjoint_functor C D F"
     proof -
       obtain G \<eta> \<epsilon> where E: "adjoint_equivalence C D G F \<eta> \<epsilon>"
         using extends_to_adjoint_equivalence by auto
       interpret E: adjoint_equivalence C D G F \<eta> \<epsilon>
         using E by simp
       interpret Adj: meta_adjunction C D G F E.\<phi> E.\<psi>
         using E.induces_meta_adjunction by simp
       show ?thesis
         using Adj.has_right_adjoint_functor by simp
     qed
 
     lemma is_equivalence_functor:
     shows "equivalence_functor C D F"
     proof
       obtain G \<eta> \<epsilon> where E: "adjoint_equivalence C D G F \<eta> \<epsilon>"
         using extends_to_adjoint_equivalence by auto
       interpret E: adjoint_equivalence C D G F \<eta> \<epsilon>
         using E by simp
       have "equivalence_of_categories C D G F \<eta> \<epsilon>" ..
       thus "\<exists>G \<eta> \<epsilon>. equivalence_of_categories C D G F \<eta> \<epsilon>" by blast
     qed
 
     sublocale equivalence_functor C D F
       using is_equivalence_functor by blast
 
   end
 
   context equivalence_of_categories
   begin
 
     text \<open>
       The following development shows that an equivalence of categories can
       be refined to an adjoint equivalence by replacing just the counit.
     \<close>
 
     abbreviation \<epsilon>'
     where "\<epsilon>' a \<equiv> \<epsilon> a \<cdot>\<^sub>C F (D.inv (\<eta> (G a))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G a)))"
 
     interpretation \<epsilon>': transformation_by_components C C \<open>F \<circ> G\<close> C.map \<epsilon>'
     proof
       show "\<And>a. C.ide a \<Longrightarrow> \<guillemotleft>\<epsilon>' a : (F \<circ> G) a \<rightarrow>\<^sub>C C.map a\<guillemotright>"
         using \<eta>.components_are_iso \<epsilon>.components_are_iso by simp
       fix f
       assume f: "C.arr f"
       show "\<epsilon>' (C.cod f) \<cdot>\<^sub>C (F \<circ> G) f = C.map f \<cdot>\<^sub>C \<epsilon>' (C.dom f)"
       proof -
         have "\<epsilon>' (C.cod f) \<cdot>\<^sub>C (F \<circ> G) f =
               \<epsilon> (C.cod f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (C.cod f)))) \<cdot>\<^sub>C F (G f)"
           using f C.comp_assoc by simp
         also have "... = \<epsilon> (C.cod f) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C
                            F (G (F (G f)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (C.dom f))))"
           using f \<epsilon>.inv_naturality [of "F (G f)"] C.comp_assoc by simp
         also have "... = (\<epsilon> (C.cod f) \<cdot>\<^sub>C F (G f)) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f)))) \<cdot>\<^sub>C
                            C.inv (\<epsilon> (F (G (C.dom f))))"
         proof -
           have "F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C F (G (F (G f))) =
                 F (G f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f))))"
           proof -
             have "F (D.inv (\<eta> (G (C.cod f)))) \<cdot>\<^sub>C F (G (F (G f))) =
                   F (D.inv (\<eta> (G (C.cod f))) \<cdot>\<^sub>D G (F (G f)))"
               using f by simp
             also have "... = F (G f \<cdot>\<^sub>D D.inv (\<eta> (G (C.dom f))))"
               using f \<eta>.inv_naturality [of "G f"] by simp
             also have "... = F (G f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f))))"
               using f by simp
             finally show ?thesis by blast
           qed
           thus ?thesis
             using C.comp_assoc by simp
         qed
         also have "... = C.map f \<cdot>\<^sub>C \<epsilon> (C.dom f) \<cdot>\<^sub>C F (D.inv (\<eta> (G (C.dom f)))) \<cdot>\<^sub>C
                            C.inv (\<epsilon> (F (G (C.dom f))))"
           using f \<epsilon>.naturality C.comp_assoc by simp
         finally show ?thesis by blast
       qed
     qed
 
     interpretation \<epsilon>': natural_isomorphism C C \<open>F \<circ> G\<close> C.map \<epsilon>'.map
     proof
       show "\<And>a. C.ide a \<Longrightarrow> C.iso (\<epsilon>'.map a)"
         unfolding \<epsilon>'.map_def
         using \<eta>.components_are_iso \<epsilon>.components_are_iso
         apply simp
         by (intro C.isos_compose) auto
     qed
 
     lemma F\<eta>_inverse:
     assumes "D.ide b"
     shows "F (\<eta> (G (F b))) = F (G (F (\<eta> b)))"
     and "F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b) = \<epsilon> (F (G (F b))) \<cdot>\<^sub>C F (\<eta> (G (F b)))"
     and "C.inverse_arrows (F (\<eta> b)) (\<epsilon>' (F b))"
     and "F (\<eta> b) = C.inv (\<epsilon>' (F b))"
     and "C.inv (F (\<eta> b)) = \<epsilon>' (F b)"
     proof -
       let ?\<epsilon>' = "\<lambda>a. \<epsilon> a \<cdot>\<^sub>C F (D.inv (\<eta> (G a))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G a)))"
       show 1: "F (\<eta> (G (F b))) = F (G (F (\<eta> b)))"
       proof -
         have "F (\<eta> (G (F b))) \<cdot>\<^sub>C F (\<eta> b) = F (G (F (\<eta> b))) \<cdot>\<^sub>C F (\<eta> b)"
         proof -
           have "F (\<eta> (G (F b))) \<cdot>\<^sub>C F (\<eta> b) = F (\<eta> (G (F b)) \<cdot>\<^sub>D \<eta> b)"
             using assms by simp
           also have "... = F (G (F (\<eta> b)) \<cdot>\<^sub>D \<eta> b)"
             using assms \<eta>.naturality [of "\<eta> b"] by simp
           also have "... = F (G (F (\<eta> b))) \<cdot>\<^sub>C F (\<eta> b)"
             using assms by simp
           finally show ?thesis by blast
         qed
         thus ?thesis
           using assms \<eta>.components_are_iso C.iso_cancel_right by simp
       qed
       show "F (\<eta> b) \<cdot>\<^sub>C \<epsilon> (F b) = \<epsilon> (F (G (F b))) \<cdot>\<^sub>C F (\<eta> (G (F b)))"
         using assms 1 \<epsilon>.naturality [of "F (\<eta> b)"] by simp
       show 2: "C.inverse_arrows (F (\<eta> b)) (?\<epsilon>' (F b))"
       proof
         show 3: "C.ide (?\<epsilon>' (F b) \<cdot>\<^sub>C F (\<eta> b))"
         proof -
           have "?\<epsilon>' (F b) \<cdot>\<^sub>C F (\<eta> b) =
                 \<epsilon> (F b) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"
             using C.comp_assoc by simp
           also have "... = \<epsilon> (F b) \<cdot>\<^sub>C (F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C F (G (F (\<eta> b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F b))"
             using assms \<epsilon>.naturality [of "F (\<eta> b)"] \<epsilon>.components_are_iso C.comp_assoc
                   C.invert_opposite_sides_of_square
                     [of "\<epsilon> (F (G (F b)))" "F (G (F (\<eta> b)))" "F (\<eta> b)" "\<epsilon> (F b)"]
             by simp
           also have "... = \<epsilon> (F b) \<cdot>\<^sub>C C.inv (\<epsilon> (F b))"
           proof -
             have "F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C F (G (F (\<eta> b))) = F (G (F b))"
               using assms 1 D.comp_inv_arr' \<eta>.components_are_iso
               by (metis D.ideD(1) D.ideD(2) F.preserves_comp
                   F.preserves_ide G.preserves_ide \<eta>.preserves_dom D.map_simp)
             moreover have "F (G (F b)) \<cdot>\<^sub>C C.inv (\<epsilon> (F b)) = C.inv (\<epsilon> (F b))"
               using assms D.comp_cod_arr \<epsilon>.components_are_iso C.inv_in_hom [of "\<epsilon> (F b)"]
               by (metis C.comp_ide_arr C_arr_expansion(1) D.ide_char F.preserves_arr
                   F.preserves_dom F.preserves_ide G.preserves_ide C.seqE)
             ultimately show ?thesis by simp
           qed
           also have "... = F b"
             using assms \<epsilon>.components_are_iso C.comp_arr_inv' by simp
           finally have "(\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b) = F b"
             by blast
           thus ?thesis
             using assms by simp
         qed
         show "C.ide (F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b))"
         proof -
           have "(F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b)) \<cdot>\<^sub>C F (\<eta> b) = F (G (F b)) \<cdot>\<^sub>C F (\<eta> b)"
           proof -
             have "(F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b)) \<cdot>\<^sub>C F (\<eta> b) =
                   F (\<eta> b) \<cdot>\<^sub>C (\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"
               using C.comp_assoc by simp
             also have "... = F (\<eta> b)"
               using assms 3
                     C.comp_arr_dom
                       [of "F (\<eta> b)" "(\<epsilon> (F b) \<cdot>\<^sub>C F (D.inv (\<eta> (G (F b)))) \<cdot>\<^sub>C
                                        C.inv (\<epsilon> (F (G (F b))))) \<cdot>\<^sub>C F (\<eta> b)"]
               by auto
             also have "... = F (G (F b)) \<cdot>\<^sub>C F (\<eta> b)"
               using assms C.comp_cod_arr by simp
             finally show ?thesis by blast
           qed
           hence "F (\<eta> b) \<cdot>\<^sub>C ?\<epsilon>' (F b) = F (G (F b))"
             using assms C.iso_cancel_right by simp
           thus ?thesis
             using assms by simp
         qed
       qed
       show "C.inv (F (\<eta> b)) = ?\<epsilon>' (F b)"
         using assms 2 C.inverse_unique by simp
       show "F (\<eta> b) = C.inv (?\<epsilon>' (F b))"
       proof -
         have "C.inverse_arrows (?\<epsilon>' (F b)) (F (\<eta> b))"
           using assms 2 by auto
         thus ?thesis
           using assms C.inverse_unique by simp
       qed
     qed
 
     interpretation FoGoF: composite_functor D C C F \<open>F o G\<close> ..
     interpretation GoFoG: composite_functor C D D G \<open>G o F\<close> ..
 
     interpretation natural_transformation D C F FoGoF.map \<open>F \<circ> \<eta>\<close>
     proof -
       have "F \<circ> D.map = F"
         using hcomp_ide_dom F.as_nat_trans.natural_transformation_axioms by blast
       moreover have "F o (G o F) = FoGoF.map"
         by auto
       ultimately show "natural_transformation D C F FoGoF.map (F \<circ> \<eta>)"
         using \<eta>.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
               horizontal_composite [of D D D.map "G o F" \<eta> C F F F]
         by simp
     qed
 
     interpretation natural_transformation C D G GoFoG.map \<open>\<eta> \<circ> G\<close>
       using \<eta>.natural_transformation_axioms G.as_nat_trans.natural_transformation_axioms
             horizontal_composite [of C D G G G ]
       by fastforce
 
     interpretation natural_transformation D C FoGoF.map F \<open>\<epsilon>'.map \<circ> F\<close>
       using \<epsilon>'.natural_transformation_axioms F.as_nat_trans.natural_transformation_axioms
             horizontal_composite [of D C F F F]
       by fastforce
 
     interpretation natural_transformation C D GoFoG.map G \<open>G \<circ> \<epsilon>'.map\<close>
     proof -
       have "G o C.map = G"
         using hcomp_ide_dom G.as_nat_trans.natural_transformation_axioms by blast
       moreover have "G o (F o G) = GoFoG.map"
         by auto
       ultimately show "natural_transformation C D GoFoG.map G (G \<circ> \<epsilon>'.map)"
         using G.as_nat_trans.natural_transformation_axioms \<epsilon>'.natural_transformation_axioms
               horizontal_composite [of C C "F o G" C.map \<epsilon>'.map D G G G]
         by simp
     qed
 
     interpretation \<epsilon>'F_F\<eta>: vertical_composite D C F FoGoF.map F \<open>F \<circ> \<eta>\<close> \<open>\<epsilon>'.map \<circ> F\<close> ..
     interpretation G\<epsilon>'_\<eta>G: vertical_composite C D G GoFoG.map G \<open>\<eta> o G\<close> \<open>G o \<epsilon>'.map\<close> ..
 
     interpretation \<eta>\<epsilon>': unit_counit_adjunction C D F G \<eta> \<epsilon>'.map
     proof
       show 1: "\<epsilon>'F_F\<eta>.map = F"
       proof
         fix g
         show "\<epsilon>'F_F\<eta>.map g = F g"
         proof (cases "D.arr g")
           show "\<not> D.arr g \<Longrightarrow> \<epsilon>'F_F\<eta>.map g = F g"
             using \<epsilon>'F_F\<eta>.is_extensional F.is_extensional by simp
           assume g: "D.arr g"
           have "\<epsilon>'F_F\<eta>.map g = \<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> g)"
             using g \<epsilon>'F_F\<eta>.map_def by simp
           also have "... = \<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> (D.cod g) \<cdot>\<^sub>D g)"
             using g \<eta>.is_natural_2 by simp
           also have "... = (\<epsilon>' (F (D.cod g)) \<cdot>\<^sub>C F (\<eta> (D.cod g))) \<cdot>\<^sub>C F g"
             using g C.comp_assoc by simp
           also have "... = F (D.cod g) \<cdot>\<^sub>C F g"
             using g F\<eta>_inverse(3) [of "D.cod g"] by fastforce
           also have "... = F g"
             using g C.comp_cod_arr by simp
           finally show "\<epsilon>'F_F\<eta>.map g = F g" by blast
         qed
       qed
       show "G\<epsilon>'_\<eta>G.map = G"
       proof
         fix f
         show "G\<epsilon>'_\<eta>G.map f = G f"
         proof (cases "C.arr f")
           show "\<not> C.arr f \<Longrightarrow> G\<epsilon>'_\<eta>G.map f = G f"
             using G\<epsilon>'_\<eta>G.is_extensional G.is_extensional by simp
           assume f: "C.arr f"
           have "F (G\<epsilon>'_\<eta>G.map f) = F (G (\<epsilon>' (C.cod f)) \<cdot>\<^sub>D \<eta> (G f))"
             using f G\<epsilon>'_\<eta>G.map_def D.comp_assoc by simp
           also have "... = F (G (\<epsilon>' (C.cod f)) \<cdot>\<^sub>D \<eta> (G (C.cod f)) \<cdot>\<^sub>D G f)"
             using f \<eta>.is_natural_2 [of "G f"] by simp
           also have "... = F (G (\<epsilon>' (C.cod f))) \<cdot>\<^sub>C F (\<eta> (G (C.cod f))) \<cdot>\<^sub>C F (G f)"
             using f by simp
           also have "... = (F (G (\<epsilon>' (C.cod f))) \<cdot>\<^sub>C C.inv (\<epsilon>' (F (G (C.cod f))))) \<cdot>\<^sub>C F (G f)"
             using f F\<eta>_inverse(4) C.comp_assoc by simp
           also have "... = (C.inv (\<epsilon>' (C.cod f)) \<cdot>\<^sub>C \<epsilon>' (C.cod f)) \<cdot>\<^sub>C F (G f)"
             using f \<epsilon>'.inv_naturality [of "\<epsilon>' (C.cod f)"] by simp
           also have "... = F (G (C.cod f)) \<cdot>\<^sub>C F (G f)"
             using f C.comp_inv_arr' [of "\<epsilon>' (C.cod f)"] \<epsilon>'.components_are_iso by simp
           also have "... = F (G f)"
             using f C.comp_cod_arr by simp
           finally have "F (G\<epsilon>'_\<eta>G.map f) = F (G f)" by blast
           moreover have "D.par (G\<epsilon>'_\<eta>G.map f) (G f)"
             using f by simp
           ultimately show "G\<epsilon>'_\<eta>G.map f = G f"
             using f F_is_faithful
             by (simp add: faithful_functor_axioms_def faithful_functor_def)
         qed
       qed
     qed
 
     interpretation \<eta>\<epsilon>': adjoint_equivalence C D F G \<eta> \<epsilon>'.map ..
 
     lemma refines_to_adjoint_equivalence:
     shows "adjoint_equivalence C D F G \<eta> \<epsilon>'.map"
       ..
 
   end
 
 end
diff --git a/thys/Category3/HFSetCat.thy b/thys/Category3/HFSetCat.thy
--- a/thys/Category3/HFSetCat.thy
+++ b/thys/Category3/HFSetCat.thy
@@ -1,2224 +1,2259 @@
 (*  Title:       HFSetCat
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "The Category of Hereditarily Finite Sets"
 
 theory HFSetCat
 imports CategoryWithFiniteLimits CartesianClosedCategory HereditarilyFinite.HF
 begin
 
   text\<open>
     This theory constructs a category whose objects are in bijective correspondence with
     the hereditarily finite sets and whose arrows correspond to the functions between such
     sets.  We show that this category is cartesian closed and has finite limits.
     Note that up to this point we have not constructed any other interpretation for the
     @{locale cartesian_closed_category} locale, but it is important to have one to ensure
     that the locale assumptions are consistent.
   \<close>
 
   section "Preliminaries"
 
   text\<open>
     We begin with some preliminary definitions and facts about hereditarily finite sets,
     which are better targeted toward what we are trying to do here than what already exists
     in @{theory HereditarilyFinite.HF}.
   \<close>
 
   text\<open>
     The following defines when a hereditarily finite set \<open>F\<close> represents a function from
     a hereditarily finite set \<open>B\<close> to a hereditarily finite set \<open>C\<close>.  Specifically, \<open>F\<close>
     must be a relation from \<open>B\<close> to \<open>C\<close>, whose domain is \<open>B\<close>, whose range is contained in \<open>C\<close>,
     and which is single-valued on its domain.
   \<close>
 
   definition hfun
   where "hfun B C F \<equiv> F \<le> B * C \<and> hfunction F \<and> hdomain F = B \<and> hrange F \<le> C"
 
   lemma hfunI [intro]:
   assumes "F \<le> A * B"
   and "\<And>X. X \<^bold>\<in> A \<Longrightarrow> \<exists>!Y. \<langle>X, Y\<rangle> \<^bold>\<in> F"
   and "\<And>X Y. \<langle>X, Y\<rangle> \<^bold>\<in> F \<Longrightarrow> Y \<^bold>\<in> B"
   shows "hfun A B F"
     unfolding hfun_def
     using assms hfunction_def hrelation_def is_hpair_def hrange_def hconverse_def hdomain_def
     apply (intro conjI)
     apply auto
     by fast
 
   lemma hfunE [elim]:
   assumes "hfun B C F"
   and "(\<And>Y. Y \<^bold>\<in> B \<Longrightarrow> (\<exists>!Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F) \<and> (\<forall>Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F \<longrightarrow> Z \<^bold>\<in> C)) \<Longrightarrow> T"
   shows T
   proof -
     have "\<And>Y. Y \<^bold>\<in> B \<Longrightarrow> (\<exists>!Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F) \<and> (\<forall>Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F \<longrightarrow> Z \<^bold>\<in> C)"
     proof (intro allI impI conjI)
       fix Y
       assume Y: "Y \<^bold>\<in> B"
       show "\<exists>!Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F"
       proof -
         have "\<exists>Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F"
           using assms Y hfun_def hdomain_def by auto
         moreover have "\<And>Z Z'. \<lbrakk> \<langle>Y, Z\<rangle> \<^bold>\<in> F; \<langle>Y, Z'\<rangle> \<^bold>\<in> F \<rbrakk> \<Longrightarrow> Z = Z'"
           using assms hfun_def hfunction_def by simp
         ultimately show ?thesis by blast
       qed
       show "\<And>Z. \<langle>Y, Z\<rangle> \<^bold>\<in> F \<Longrightarrow> Z \<^bold>\<in> C"
         using assms Y hfun_def by auto
     qed
     thus ?thesis
       using assms(2) by simp
   qed
 
   text\<open>
     The hereditarily finite set \<open>hexp B C\<close> represents the collection of all functions
     from \<open>B\<close> to \<open>C\<close>.
   \<close>
 
   definition hexp
   where "hexp B C = \<lbrace>F \<^bold>\<in> HPow (B * C). hfun B C F\<rbrace>"
 
   lemma hfun_in_hexp:
   assumes "hfun B C F"
   shows "F \<^bold>\<in> hexp B C"
     using assms by (simp add: hexp_def hfun_def)
 
   text\<open>
     The function \<open>happ\<close> applies a function \<open>F\<close> from \<open>B\<close> to \<open>C\<close> to an element of \<open>B\<close>,
     yielding an element of \<open>C\<close>.
   \<close>
 
   abbreviation happ
   where "happ \<equiv> app"
 
   lemma happ_mapsto:
   assumes "F \<^bold>\<in> hexp B C" and "Y \<^bold>\<in> B"
   shows "happ F Y \<^bold>\<in> C" and "happ F Y \<^bold>\<in> hrange F"
   proof -
     show "happ F Y \<^bold>\<in> C"
       using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
     show "happ F Y \<^bold>\<in> hrange F"
     proof -
       have "\<langle>Y, happ F Y\<rangle> \<^bold>\<in> F"
         using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
       thus ?thesis
         using hdomain_def hrange_def hconverse_def by auto
     qed
   qed
 
   lemma happ_expansion:
   assumes "hfun B C F"
   shows "F = \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>"
   proof
     fix XY
     show "XY \<^bold>\<in> F \<longleftrightarrow> XY \<^bold>\<in> \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>"
     proof
       show "XY \<^bold>\<in> F \<Longrightarrow> XY \<^bold>\<in> \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>"
       proof -
         assume XY: "XY \<^bold>\<in> F"
         have "XY \<^bold>\<in> B * C"
           using assms XY hfun_def by auto
         moreover have "hsnd XY = happ F (hfst XY)"
           using assms XY hfunE app_def [of F "hfst XY"] the1_equality [of "\<lambda>y. \<langle>hfst XY, y\<rangle> \<^bold>\<in> F"]
                 calculation
           by auto
         ultimately show "XY \<^bold>\<in> \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>" by simp
       qed
       show "XY \<^bold>\<in> \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace> \<Longrightarrow> XY \<^bold>\<in> F"
       proof -
         assume XY: "XY \<^bold>\<in> \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>"
         show "XY \<^bold>\<in> F"
           using assms XY app_def [of F "hfst XY"] the1_equality [of "\<lambda>y. \<langle>hfst XY, y\<rangle> \<^bold>\<in> F"]
           by fastforce
       qed
     qed
   qed
 
   text\<open>
     Function \<open>hlam\<close> takes a function \<open>F\<close> from \<open>A * B\<close> to \<open>C\<close> to a function \<open>hlam F\<close>
     from \<open>A\<close> to \<open>hexp B C\<close>.
   \<close>
 
   definition hlam
   where "hlam A B C F =
          \<lbrace>XG \<^bold>\<in> A * hexp B C.
             \<forall>YZ. YZ \<^bold>\<in> hsnd XG \<longleftrightarrow> is_hpair YZ \<and> \<langle>\<langle>hfst XG, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
 
   lemma hfun_hlam:
   assumes "hfun (A * B) C F"
   shows "hfun A (hexp B C) (hlam A B C F)"
   proof
     show "hlam A B C F \<le> A * hexp B C"
       using assms hlam_def by auto
     show "\<And>X. X \<^bold>\<in> A \<Longrightarrow> \<exists>!Y. \<langle>X, Y\<rangle> \<^bold>\<in> hlam A B C F"
     proof
       fix X
       assume X: "X \<^bold>\<in> A"
       let ?G = "\<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
       have 1: "?G \<^bold>\<in> hexp B C"
         using assms X hexp_def by fastforce
       show "\<langle>X, ?G\<rangle> \<^bold>\<in> hlam A B C F"
         using assms X 1 is_hpair_def hfun_def hlam_def by auto
       fix Y
       assume XY: "\<langle>X, Y\<rangle> \<^bold>\<in> hlam A B C F"
       show "Y = ?G"
         using assms X XY hlam_def hexp_def by fastforce
     qed
     show "\<And>X Y. \<langle>X, Y\<rangle> \<^bold>\<in> hlam A B C F \<Longrightarrow> Y \<^bold>\<in> hexp B C"
       using assms hlam_def hexp_def by simp
   qed
 
   lemma happ_hlam:
   assumes "X \<^bold>\<in> A" and "hfun (A * B) C F"
   shows "\<exists>!G. \<langle>X, G\<rangle> \<^bold>\<in> hlam A B C F"
   and "happ (hlam A B C F) X = (THE G. \<langle>X, G\<rangle> \<^bold>\<in> hlam A B C F)"
   and "happ (hlam A B C F) X = \<lbrace>yz \<^bold>\<in> B * C. \<langle>\<langle>X, hfst yz\<rangle>, hsnd yz\<rangle> \<^bold>\<in> F\<rbrace>"
   and "Y \<^bold>\<in> B \<Longrightarrow> happ (happ (hlam A B C F) X) Y = happ F \<langle>X, Y\<rangle>"
   proof -
     show 1: "\<exists>!G. \<langle>X, G\<rangle> \<^bold>\<in> hlam A B C F"
       using assms(1,2) hfun_hlam hfunE
       by (metis (full_types))
     show 2: "happ (hlam A B C F) X = (THE G. \<langle>X, G\<rangle> \<^bold>\<in> hlam A B C F)"
       using assms app_def by simp
     show "happ (happ (hlam A B C F) X) Y = happ F \<langle>X, Y\<rangle>"
     proof -
       have 3: "\<langle>X, happ (hlam A B C F) X\<rangle> \<^bold>\<in> hlam A B C F"
         using assms(1) 1 2 theI' [of "\<lambda>G. \<langle>X, G\<rangle> \<^bold>\<in> hlam A B C F"] by simp
       hence "\<exists>!Z. happ (happ (hlam A B C F) X) = Z"
         by simp
       moreover have "happ (happ (hlam A B C F) X) Y = happ F \<langle>X, Y\<rangle>"
         using assms(1-2) 3 hlam_def is_hpair_def app_def by simp
       ultimately show ?thesis by simp
     qed
     show "happ (hlam A B C F) X = \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
     proof -
       let ?G = "\<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
       have 4: "hfun B C ?G"
       proof
         show "\<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace> \<le> B * C"
           using assms by auto
         show "\<And>Y. Y \<^bold>\<in> B \<Longrightarrow> \<exists>!Z. \<langle>Y, Z\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
         proof -
           fix Y
           assume Y: "Y \<^bold>\<in> B"
           have XY: "\<langle>X, Y\<rangle> \<^bold>\<in> A * B"
             using assms Y by simp
           hence 1: "\<exists>!Z. \<langle>\<langle>X, Y\<rangle>, Z\<rangle> \<^bold>\<in> F"
             using assms XY hfunE [of "A * B" C F] by metis
           obtain Z where Z: "\<langle>\<langle>X, Y\<rangle>, Z\<rangle> \<^bold>\<in> F"
             using 1 by auto
           have "\<exists>Z. \<langle>Y, Z\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
           proof -
             have "\<langle>Y, Z\<rangle> \<^bold>\<in> B * C"
               using assms Y Z by blast
             moreover have "\<langle>\<langle>X, hfst \<langle>Y, Z\<rangle>\<rangle>, hsnd \<langle>Y, Z\<rangle>\<rangle> \<^bold>\<in> F"
               using assms Y Z by simp
             ultimately show ?thesis by auto
           qed
           moreover have "\<And>Z Z'. \<lbrakk>\<langle>Y, Z\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>;
                                  \<langle>Y, Z'\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>\<rbrakk> \<Longrightarrow> Z = Z'"
             using assms Y by auto
           ultimately show "\<exists>!Z. \<langle>Y, Z\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace>"
             by auto
         qed
         show "\<And>Y Z. \<langle>Y, Z\<rangle> \<^bold>\<in> \<lbrace>YZ \<^bold>\<in> B * C. \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F\<rbrace> \<Longrightarrow> Z \<^bold>\<in> C"
           using assms by simp
       qed
       have "\<langle>X, ?G\<rangle> \<^bold>\<in> hlam A B C F"
       proof -
         have "\<langle>X, ?G\<rangle> \<^bold>\<in> A * hexp B C"
           using assms 4
           by (simp add: hfun_in_hexp)
         moreover have "\<forall>YZ. YZ \<^bold>\<in> ?G \<longleftrightarrow> is_hpair YZ \<and> \<langle>\<langle>X, hfst YZ\<rangle>, hsnd YZ\<rangle> \<^bold>\<in> F"
           using assms 1 is_hpair_def hfun_def by auto
         ultimately show ?thesis
           using assms 1 hlam_def by simp
       qed
       thus "happ (hlam A B C F) X = ?G"
         using assms 2 4 app_equality hfun_def hfun_hlam by auto
     qed
   qed
 
   section "Construction of the Category"
 
   locale hfsetcat
   begin
 
     text\<open>
-      We construct the category of hereditarily finite sets and function simply by applying
+      We construct the category of hereditarily finite sets and functions simply by applying
       the generic ``set category'' construction, using the hereditarily finite sets as the
       universe, and constraining the collections of such sets that determine objects of the
-      category to those having cardinality less than that of the natural numbers;
-      \emph{i.e.}~to those that are finite.
+      category to those that are finite.
     \<close>
 
-    interpretation setcat \<open>undefined :: hf\<close> natLeq
-      using Field_natLeq natLeq_Card_order
-      by unfold_locales auto
+    interpretation setcat \<open>undefined :: hf\<close> finite
+      using finite_subset
+      by unfold_locales blast+
+
+    lemma set_ide_char:
+    shows "A \<in> set ` Collect ide \<longleftrightarrow> A \<subseteq> Univ \<and> finite A"
+    proof
+      assume A: "A \<in> set ` Collect ide"
+      show "A \<subseteq> Univ \<and> finite A"
+      proof
+        show "A \<subseteq> Univ"
+          using A setp_set' by auto
+        obtain a where a: "ide a \<and> A = set a"
+          using A by blast
+        have "finite (elem_of ` set a)"
+          using a setp_set_ide by blast
+        moreover have "inj_on elem_of (set a)"
+        proof -
+          have "inj_on elem_of Univ"
+            using bij_elem_of bij_betw_imp_inj_on by auto
+          moreover have "set a \<subseteq> Univ"
+            using a setp_set' [of a] by blast
+          ultimately show ?thesis
+            using inj_on_subset by auto
+        qed
+        ultimately show "finite A"
+          using a A finite_imageD [of elem_of "set a"] by blast
+      qed
+      next
+      assume A: "A \<subseteq> Univ \<and> finite A"
+      have "ide (mkIde A)"
+        using A ide_mkIde by simp
+      moreover have "set (mkIde A) = A"
+        using A finite_imp_setp set_mkIde by presburger
+      ultimately show "A \<in> set ` Collect ide" by blast
+    qed
+
+    lemma set_ideD:
+    assumes "ide a"
+    shows "set a \<subseteq> Univ" and "finite (set a)"
+      using assms set_ide_char by auto
+
+    lemma ide_mkIdeI [intro]:
+    assumes "A \<subseteq> Univ" and "finite A"
+    shows "ide (mkIde A)" and "set (mkIde A) = A"
+      using assms ide_mkIde set_mkIde by auto
 
     interpretation category_with_terminal_object comp
       using terminal_unity by unfold_locales auto
 
     text\<open>
       We verify that the objects of HF are indeed in bijective correspondence with the
       hereditarily finite sets.
     \<close>
 
     definition ide_to_hf
-    where "ide_to_hf a = HF (DOWN ` set a)"
+    where "ide_to_hf a = HF (elem_of ` set a)"
 
     definition hf_to_ide
-    where "hf_to_ide x = mkIde (UP ` hfset x)"
+    where "hf_to_ide x = mkIde (arr_of ` hfset x)"
 
     lemma ide_to_hf_mapsto:
     shows "ide_to_hf \<in> Collect ide \<rightarrow> UNIV"
       by simp
 
     lemma hf_to_ide_mapsto:
     shows "hf_to_ide \<in> UNIV \<rightarrow> Collect ide"
     proof
       fix x :: hf
-      have "finite (UP ` hfset x)"
+      have "finite (arr_of ` hfset x)"
         by simp
-      moreover have "UP ` hfset x \<subseteq> Univ"
-        by (metis (mono_tags, lifting) UNIV_I bij_UP bij_betw_def imageE image_eqI subsetI)
-      ultimately have "ide (mkIde (UP ` hfset x))"
-        using ide_mkIde_finite by simp
+      moreover have "arr_of ` hfset x \<subseteq> Univ"
+        by (metis (mono_tags, lifting) UNIV_I bij_arr_of bij_betw_def imageE image_eqI subsetI)
+      ultimately have "ide (mkIde (arr_of ` hfset x))"
+        using finite_imp_setp ide_mkIde by presburger
       thus "hf_to_ide x \<in> Collect ide"
         using hf_to_ide_def by simp
     qed
 
     lemma hf_to_ide_ide_to_hf:
     assumes "a \<in> Collect ide"
     shows "hf_to_ide (ide_to_hf a) = a"
     proof -
-      have "hf_to_ide (ide_to_hf a) = mkIde (UP ` hfset (HF (DOWN ` set a)))"
+      have "hf_to_ide (ide_to_hf a) = mkIde (arr_of ` hfset (HF (elem_of ` set a)))"
         using hf_to_ide_def ide_to_hf_def by simp
       also have "... = a"
       proof -
-        have "mkIde (UP ` hfset (HF (DOWN ` set a))) = mkIde (UP ` DOWN ` set a)"
+        have "mkIde (arr_of ` hfset (HF (elem_of ` set a))) = mkIde (arr_of ` elem_of ` set a)"
         proof -
           have "finite (set a)"
-            using assms set_card finite_iff_ordLess_natLeq by auto
-          hence "finite (DOWN ` set a)"
+            using assms set_ide_char by blast
+          hence "finite (elem_of ` set a)"
             by simp
-          hence "hfset (HF (DOWN ` set a)) = DOWN ` set a"
-            using hfset_HF [of "DOWN ` set a"] by simp
+          hence "hfset (HF (elem_of ` set a)) = elem_of ` set a"
+            using hfset_HF [of "elem_of ` set a"] by simp
           thus ?thesis by simp
         qed
         also have "... = a"
         proof -
           have "set a \<subseteq> Univ"
-            using assms set_subset_Univ ide_char by blast
-          hence "\<And>x. x \<in> set a \<Longrightarrow> UP (DOWN x) = x"
+            using assms set_ide_char by blast
+          hence "\<And>x. x \<in> set a \<Longrightarrow> arr_of (elem_of x) = x"
             using assms by auto
-          hence "UP ` DOWN ` set a = set a"
+          hence "arr_of ` elem_of ` set a = set a"
             by force
           thus ?thesis
             using assms ide_char mkIde_set by simp
         qed
         finally show ?thesis by blast
       qed
       finally show "hf_to_ide (ide_to_hf a) = a" by blast
     qed
 
     lemma ide_to_hf_hf_to_ide:
     assumes "x \<in> UNIV"
     shows "ide_to_hf (hf_to_ide x) = x"
     proof -
-      have "HF (DOWN ` set (mkIde (UP ` hfset x))) = x"
+      have "HF (elem_of ` set (mkIde (arr_of ` hfset x))) = x"
       proof -
-        have "HF (DOWN ` set (mkIde (UP ` hfset x))) = HF (DOWN ` UP ` hfset x)"
-        proof -
-          have "|UP ` hfset x| <o natLeq"
-            using assms finite_iff_ordLess_natLeq finite_hfset by blast
-          thus ?thesis
-            using assms set_mkIde [of "UP ` hfset x"] UP_mapsto mkIde_def by auto
-        qed
+        have "HF (elem_of ` set (mkIde (arr_of ` hfset x))) = HF (elem_of ` arr_of ` hfset x)"
+          using assms set_mkIde [of "arr_of ` hfset x"] arr_of_mapsto mkIde_def by auto
         also have "... = HF (hfset x)"
         proof -
-          have "\<And>A. DOWN ` UP ` A = A"
-            using DOWN_UP by force
+          have "\<And>A. elem_of ` arr_of ` A = A"
+            using elem_of_arr_of by force
           thus ?thesis by metis
         qed
         also have "... = x" by simp
         finally show ?thesis by blast
       qed
       thus ?thesis
         using assms ide_to_hf_def hf_to_ide_def by simp
     qed
 
     lemma bij_betw_ide_hf_set:
     shows "bij_betw ide_to_hf (Collect ide) (UNIV :: hf set)"
       using ide_to_hf_mapsto hf_to_ide_mapsto ide_to_hf_hf_to_ide hf_to_ide_ide_to_hf
       by (intro bij_betwI) auto
 
     lemma ide_implies_finite_set:
     assumes "ide a"
     shows "finite (set a)" and "finite (hom unity a)"
     proof -
       show 1: "finite (set a)"
-        using assms ide_char set_card finite_iff_ordLess_natLeq by blast
+        using assms set_ide_char by blast
       show "finite (hom unity a)"
-      proof -
-        have "|hom unity a| =o |set a|"
-          using assms bij_betw_points_and_set card_of_ordIsoI by auto
-        thus ?thesis
-          using 1 by simp
-      qed
+        using assms 1 bij_betw_points_and_set finite_imageD inj_img set_def by auto
     qed
 
     text\<open>
       We establish the connection between the membership relation defined for hereditarily
       finite sets and the corresponding membership relation associated with the set category.
     \<close>
 
-    lemma UP_membI [intro]:
+    lemma arr_of_membI [intro]:
     assumes "x \<^bold>\<in> ide_to_hf a"
-    shows "UP x \<in> set a"
+    shows "arr_of x \<in> set a"
     proof -
-      let ?X = "inv_into (set a) DOWN x"
-      have "x = DOWN ?X \<and> ?X \<in> set a"
+      let ?X = "inv_into (set a) elem_of x"
+      have "x = elem_of ?X \<and> ?X \<in> set a"
         using assms
         by (simp add: f_inv_into_f ide_to_hf_def inv_into_into)
       thus ?thesis
-        by (metis (no_types, lifting) UP_DOWN elem_set_implies_incl_in incl_in_def
-            set_subset_Univ subsetD)
+        by (metis (no_types, lifting) arr_of_elem_of elem_set_implies_incl_in
+            elem_set_implies_set_eq_singleton incl_in_def mem_Collect_eq terminal_char2)
     qed
 
-    lemma DOWN_membI [intro]:
+    lemma elem_of_membI [intro]:
     assumes "ide a" and "x \<in> set a"
-    shows "DOWN x \<^bold>\<in> ide_to_hf a"
+    shows "elem_of x \<^bold>\<in> ide_to_hf a"
     proof -
-      have "finite (DOWN ` set a)"
+      have "finite (elem_of ` set a)"
         using assms ide_implies_finite_set [of a] by simp
-      hence "DOWN x \<in> hfset (ide_to_hf a)"
-        using assms ide_to_hf_def hfset_HF [of "DOWN ` set a"] by simp
+      hence "elem_of x \<in> hfset (ide_to_hf a)"
+        using assms ide_to_hf_def hfset_HF [of "elem_of ` set a"] by simp
       thus ?thesis
         using hmem_def by blast
     qed
 
     text\<open>
       We show that each hom-set \<open>hom a b\<close> is in bijective correspondence with
       the elements of the hereditarily finite set \<open>hfun (ide_to_hf a) (ide_to_hf b)\<close>.
     \<close>
 
     definition arr_to_hfun
     where "arr_to_hfun f = \<lbrace>XY \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f).
-                              hsnd XY = DOWN (Fun f (UP (hfst XY)))\<rbrace>"
+                              hsnd XY = elem_of (Fun f (arr_of (hfst XY)))\<rbrace>"
 
     definition hfun_to_arr
     where "hfun_to_arr B C F =
-           mkArr (UP ` hfset B) (UP ` hfset C) (\<lambda>x. UP (happ F (DOWN x)))"
+           mkArr (arr_of ` hfset B) (arr_of ` hfset C) (\<lambda>x. arr_of (happ F (elem_of x)))"
 
     lemma hfun_arr_to_hfun:
     assumes "arr f"
     shows "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
     proof
       show "arr_to_hfun f \<le> ide_to_hf (dom f) * ide_to_hf (cod f)"
         using assms arr_to_hfun_def by auto
       show "\<And>X. X \<^bold>\<in> ide_to_hf (dom f) \<Longrightarrow> \<exists>!Y. \<langle>X, Y\<rangle> \<^bold>\<in> arr_to_hfun f"
       proof
         fix X
         assume X: "X \<^bold>\<in> ide_to_hf (dom f)"
-        show "\<langle>X, DOWN (Fun f (UP X))\<rangle> \<^bold>\<in> arr_to_hfun f"
+        show "\<langle>X, elem_of (Fun f (arr_of X))\<rangle> \<^bold>\<in> arr_to_hfun f"
         proof -
-          have "\<langle>X, DOWN (Fun f (UP X))\<rangle> \<^bold>\<in> \<lbrace>XY \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f).
-                     hsnd XY = DOWN (Fun f (UP (hfst XY)))\<rbrace>"
+          have "\<langle>X, elem_of (Fun f (arr_of X))\<rangle> \<^bold>\<in> \<lbrace>XY \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f).
+                     hsnd XY = elem_of (Fun f (arr_of (hfst XY)))\<rbrace>"
           proof -
-            have "hsnd \<langle>X, DOWN (Fun f (UP X))\<rangle> =
-                  DOWN (Fun f (UP (hfst \<langle>X, DOWN (Fun f (UP X))\<rangle>)))"
+            have "hsnd \<langle>X, elem_of (Fun f (arr_of X))\<rangle> =
+                  elem_of (Fun f (arr_of (hfst \<langle>X, elem_of (Fun f (arr_of X))\<rangle>)))"
               using assms X by simp
-            moreover have "\<langle>X, DOWN (Fun f (UP X))\<rangle> \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f)"
+            moreover have "\<langle>X, elem_of (Fun f (arr_of X))\<rangle> \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f)"
             proof -
-              have "DOWN (Fun f (UP X)) \<^bold>\<in> ide_to_hf (cod f)"
-              proof (intro DOWN_membI)
+              have "elem_of (Fun f (arr_of X)) \<^bold>\<in> ide_to_hf (cod f)"
+              proof (intro elem_of_membI)
                 show "ide (cod f)"
                   using assms ide_cod by simp
-                show "Fun f (UP X) \<in> Cod f"
-                  using assms X Fun_mapsto UP_membI by auto
+                show "Fun f (arr_of X) \<in> Cod f"
+                  using assms X Fun_mapsto arr_of_membI by auto
               qed
               thus ?thesis
                 using X by simp
             qed
             ultimately show ?thesis by simp
           qed
           thus ?thesis
             using arr_to_hfun_def by simp
         qed
         fix Y
         assume XY: "\<langle>X, Y\<rangle> \<^bold>\<in> arr_to_hfun f"
-        show "Y = DOWN (Fun f (UP X))"
+        show "Y = elem_of (Fun f (arr_of X))"
           using assms X XY arr_to_hfun_def by auto
       qed
       show "\<And>X Y. \<langle>X, Y\<rangle> \<^bold>\<in> arr_to_hfun f \<Longrightarrow> Y \<^bold>\<in> ide_to_hf (cod f)"
         using assms arr_to_hfun_def ide_to_hf_def
               \<open>arr_to_hfun f \<le> ide_to_hf (dom f) * ide_to_hf (cod f)\<close>
         by blast
     qed
 
     lemma arr_to_hfun_in_hexp:
     assumes "arr f"
     shows "arr_to_hfun f \<^bold>\<in> hexp (ide_to_hf (dom f)) (ide_to_hf (cod f))"
       using assms arr_to_hfun_def hfun_arr_to_hfun hexp_def by auto
 
     lemma hfun_to_arr_in_hom:
     assumes "hfun B C F"
     shows "\<guillemotleft>hfun_to_arr B C F : hf_to_ide B \<rightarrow> hf_to_ide C\<guillemotright>"
     proof
-      let ?f = "mkArr (UP ` hfset B) (UP ` hfset C) (\<lambda>x. UP (happ F (DOWN x)))"
+      let ?f = "mkArr (arr_of ` hfset B) (arr_of ` hfset C) (\<lambda>x. arr_of (happ F (elem_of x)))"
       have 0: "arr ?f"
       proof -
-        have "UP ` hfset B \<subseteq> Univ \<and> UP ` hfset C \<subseteq> Univ"
-          using UP_mapsto by auto
-        moreover have "(\<lambda>x. UP (happ F (DOWN x))) \<in> UP ` hfset B \<rightarrow> UP ` hfset C"
+        have "arr_of ` hfset B \<subseteq> Univ \<and> arr_of ` hfset C \<subseteq> Univ"
+          using arr_of_mapsto by auto
+        moreover have "(\<lambda>x. arr_of (happ F (elem_of x))) \<in> arr_of ` hfset B \<rightarrow> arr_of ` hfset C"
         proof
           fix x
-          assume x: "x \<in> UP ` hfset B"
-          have "happ F (DOWN x) \<in> hfset C"
+          assume x: "x \<in> arr_of ` hfset B"
+          have "happ F (elem_of x) \<in> hfset C"
             using assms x happ_mapsto hfun_in_hexp
-            by (metis DOWN_UP HF_hfset finite_hfset hmem_HF_iff imageE)
-          thus "UP (happ F (DOWN x)) \<in> UP ` hfset C"
+            by (metis elem_of_arr_of HF_hfset finite_hfset hmem_HF_iff imageE)
+          thus "arr_of (happ F (elem_of x)) \<in> arr_of ` hfset C"
             by simp
         qed
         ultimately show ?thesis
           using arr_mkArr
           by (meson finite_hfset finite_iff_ordLess_natLeq finite_imageI)
       qed
       show 1: "arr (hfun_to_arr B C F)"
         using 0 hfun_to_arr_def by simp
       show "dom (hfun_to_arr B C F) = hf_to_ide B"
         using 1 hfun_to_arr_def hf_to_ide_def dom_mkArr by auto
       show "cod (hfun_to_arr B C F) = hf_to_ide C"
         using 1 hfun_to_arr_def hf_to_ide_def cod_mkArr by auto
     qed
 
     text\<open>
       The comprehension notation from @{theory HereditarilyFinite.HF} interferes in an
       unfortunate way with the restriction notation from @{theory "HOL-Library.FuncSet"},
       making it impossible to use both in the present context.
     \<close>
 
     lemma Fun_char:
     assumes "arr f"
-    shows "Fun f = restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
+    shows "Fun f = restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f)"
     proof
       fix x
-      show "Fun f x = restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
+      show "Fun f x = restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f) x"
       proof (cases "x \<in> Dom f")
         show "x \<notin> Dom f \<Longrightarrow> ?thesis"
           using assms Fun_mapsto Fun_def restrict_apply by simp
         show "x \<in> Dom f \<Longrightarrow> ?thesis"
         proof -
           assume x: "x \<in> Dom f"
           have 1: "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
             using assms app_def arr_to_hfun_def hfun_arr_to_hfun
-                  the1_equality [of "\<lambda>y. \<langle>DOWN x, y\<rangle> \<^bold>\<in> arr_to_hfun f" "DOWN (Fun f x)"]
+                  the1_equality [of "\<lambda>y. \<langle>elem_of x, y\<rangle> \<^bold>\<in> arr_to_hfun f" "elem_of (Fun f x)"]
             by simp
-          have 2: "\<exists>!Y. \<langle>DOWN x, Y\<rangle> \<^bold>\<in> arr_to_hfun f"
-            using assms x 1 hfunE DOWN_membI ide_dom
+          have 2: "\<exists>!Y. \<langle>elem_of x, Y\<rangle> \<^bold>\<in> arr_to_hfun f"
+            using assms x 1 hfunE elem_of_membI ide_dom
             by (metis (no_types, lifting))
-          have "Fun f x = UP (DOWN (Fun f x))"
+          have "Fun f x = arr_of (elem_of (Fun f x))"
           proof -
             have "Fun f x \<in> Univ"
-              using assms x ide_cod Fun_mapsto [of f] set_subset_Univ by auto
+              using assms x ide_cod Fun_mapsto [of f] set_ide_char by blast
             thus ?thesis
-              using UP_DOWN by simp
+              using arr_of_elem_of by simp
           qed
-          also have "... = UP (happ (arr_to_hfun f) (DOWN x))"
+          also have "... = arr_of (happ (arr_to_hfun f) (elem_of x))"
           proof -
-            have "\<langle>DOWN x, DOWN (Fun f x)\<rangle> \<^bold>\<in> arr_to_hfun f"
-              using assms x 2 ide_dom arr_to_hfun_def set_subset_Univ UP_DOWN
-              by (metis (mono_tags, lifting) HCollectE hfst_conv hsnd_conv subsetD)
-            moreover have "\<langle>DOWN x, happ (arr_to_hfun f) (DOWN x)\<rangle> \<^bold>\<in> arr_to_hfun f"
+            have "\<langle>elem_of x, elem_of (Fun f x)\<rangle> \<^bold>\<in> arr_to_hfun f"
+            proof -
+              have "\<langle>elem_of x, elem_of (Fun f x)\<rangle> \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod f)"
+                using assms x ide_dom ide_cod Fun_mapsto by fast
+              moreover have "elem_of (Fun f x) = elem_of (Fun f (arr_of (elem_of x)))"
+                by (metis (no_types, lifting) arr_of_elem_of setp_set_ide assms ide_dom subsetD x)
+              ultimately show ?thesis
+                using arr_to_hfun_def by auto
+            qed
+            moreover have "\<langle>elem_of x, happ (arr_to_hfun f) (elem_of x)\<rangle> \<^bold>\<in> arr_to_hfun f"
               using assms x 1 2 app_equality hfun_def by blast
             ultimately show ?thesis
               using 2 by fastforce
           qed
-          also have "... = restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
+          also have "... = restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f) x"
             using assms x ide_dom by auto
           finally show ?thesis by simp
         qed
       qed
     qed
 
     lemma Fun_hfun_to_arr:
     assumes "hfun B C F"
-    shows "Fun (hfun_to_arr B C F) = restrict (\<lambda>x. UP (happ F (DOWN x))) (UP ` hfset B)"
+    shows "Fun (hfun_to_arr B C F) = restrict (\<lambda>x. arr_of (happ F (elem_of x))) (arr_of ` hfset B)"
     proof -
       have "arr (hfun_to_arr B C F)"
         using assms hfun_to_arr_in_hom by blast
-      hence "arr (mkArr (UP ` hfset B) (UP ` hfset C) (\<lambda>x. UP (happ F (DOWN x))))"
+      hence "arr (mkArr (arr_of ` hfset B) (arr_of ` hfset C) (\<lambda>x. arr_of (happ F (elem_of x))))"
         using hfun_to_arr_def by simp
       thus ?thesis
         using assms hfun_to_arr_def Fun_mkArr by simp
     qed
 
-    lemma UP_img_hfset_ide_to_hf:
+    lemma arr_of_img_hfset_ide_to_hf:
     assumes "ide a"
-    shows "UP ` hfset (ide_to_hf a) = set a"
+    shows "arr_of ` hfset (ide_to_hf a) = set a"
     proof -
-      have "UP ` hfset (ide_to_hf a) = UP ` hfset (HF (DOWN ` set a))"
+      have "arr_of ` hfset (ide_to_hf a) = arr_of ` hfset (HF (elem_of ` set a))"
         using ide_to_hf_def by simp
-      also have "... = UP ` DOWN ` set a"
+      also have "... = arr_of ` elem_of ` set a"
         using assms ide_implies_finite_set(1) ide_char by auto
       also have "... = set a"
       proof -
-        have "\<And>x. x \<in> set a \<Longrightarrow> UP (DOWN x) = x"
-          using assms ide_char
-          by (metis (no_types, lifting) UP_DOWN set_subset_Univ subsetD)
+        have "\<And>x. x \<in> set a \<Longrightarrow> arr_of (elem_of x) = x"
+          using assms ide_char arr_of_elem_of setp_set_ide by blast
         thus ?thesis by force
       qed
       finally show ?thesis by blast
     qed
 
     lemma hfun_to_arr_arr_to_hfun:
     assumes "arr f"
     shows "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) = f"
     proof -
       have 0: "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) =
-               mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
-                     (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x)))"
+               mkArr (arr_of ` hfset (ide_to_hf (dom f))) (arr_of ` hfset (ide_to_hf (cod f)))
+                     (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x)))"
         unfolding hfun_to_arr_def by blast
       also have "... = mkArr (Dom f) (Cod f)
-                             (restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f))"
+                             (restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f))"
       proof (intro mkArr_eqI)
-        show 1: "UP ` hfset (ide_to_hf (dom f)) = Dom f"
-          using assms UP_img_hfset_ide_to_hf ide_dom by simp
-        show 2: "UP ` hfset (ide_to_hf (cod f)) = Cod f"
-          using assms UP_img_hfset_ide_to_hf ide_cod by simp
-        show "arr (mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
-                         (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))))"
+        show 1: "arr_of ` hfset (ide_to_hf (dom f)) = Dom f"
+          using assms arr_of_img_hfset_ide_to_hf ide_dom by simp
+        show 2: "arr_of ` hfset (ide_to_hf (cod f)) = Cod f"
+          using assms arr_of_img_hfset_ide_to_hf ide_cod by simp
+        show "arr (mkArr (arr_of ` hfset (ide_to_hf (dom f))) (arr_of ` hfset (ide_to_hf (cod f)))
+                         (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))))"
           using 0 1 2
           by (metis (no_types, lifting) arrI assms hfun_arr_to_hfun hfun_to_arr_in_hom)
-        show "\<And>x. x \<in> UP ` hfset (ide_to_hf (dom f)) \<Longrightarrow>
-                     UP (happ (arr_to_hfun f) (DOWN x)) =
-                     restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
+        show "\<And>x. x \<in> arr_of ` hfset (ide_to_hf (dom f)) \<Longrightarrow>
+                     arr_of (happ (arr_to_hfun f) (elem_of x)) =
+                     restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f) x"
           using assms 1 by simp
       qed
       also have "... = mkArr (Dom f) (Cod f) (Fun f)"
         using assms Fun_char mkArr_eqI by simp
       also have "... = f"
         using assms mkArr_Fun by blast
       finally show ?thesis by simp
     qed
 
     lemma arr_to_hfun_hfun_to_arr:
     assumes "hfun B C F"
     shows "arr_to_hfun (hfun_to_arr B C F) = F"
     proof -
       have "arr_to_hfun (hfun_to_arr B C F) =
             \<lbrace>XY \<^bold>\<in> ide_to_hf (dom (hfun_to_arr B C F)) * ide_to_hf (cod (hfun_to_arr B C F)).
-               hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))\<rbrace>"
+               hsnd XY = elem_of (Fun (hfun_to_arr B C F) (arr_of (hfst XY)))\<rbrace>"
         unfolding arr_to_hfun_def by blast
       also have
-          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
-                    hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))\<rbrace>"
+          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)).
+                    hsnd XY = elem_of (Fun (hfun_to_arr B C F) (arr_of (hfst XY)))\<rbrace>"
         using assms hfun_to_arr_in_hom [of B C F] hf_to_ide_def
         by (metis (no_types, lifting) in_homE)
       also have
-          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
-                    hsnd XY = DOWN (restrict (\<lambda>x. UP (happ F (DOWN x))) (UP ` hfset B)
-                                   (UP (hfst XY)))\<rbrace>"
+          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)).
+                    hsnd XY = elem_of (restrict (\<lambda>x. arr_of (happ F (elem_of x))) (arr_of ` hfset B)
+                                   (arr_of (hfst XY)))\<rbrace>"
         using assms Fun_hfun_to_arr by simp
       also have
-          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
-                    hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY)))))\<rbrace>"
+          "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)).
+                    hsnd XY = elem_of (arr_of (happ F (elem_of (arr_of (hfst XY)))))\<rbrace>"
       proof -
         have
-          1: "\<And>XY. XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))
-                     \<Longrightarrow> UP (hfst XY) \<in> UP ` hfset B"
+          1: "\<And>XY. XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C))
+                     \<Longrightarrow> arr_of (hfst XY) \<in> arr_of ` hfset B"
         proof -
           fix XY
           assume
-            XY: "XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))"
-          have "hfst XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B))"
+            XY: "XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C))"
+          have "hfst XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B))"
             using XY by auto
-          thus "UP (hfst XY) \<in> UP ` hfset B"
-            using assms UP_membI [of "hfst XY" "mkIde (UP ` hfset B)"] set_mkIde
+          thus "arr_of (hfst XY) \<in> arr_of ` hfset B"
+            using assms arr_of_membI [of "hfst XY" "mkIde (arr_of ` hfset B)"] set_mkIde
             by (metis (mono_tags, lifting) arrI arr_mkArr hfun_to_arr_def hfun_to_arr_in_hom)
         qed
         show ?thesis
         proof -
           have
-            "\<And>XY. (XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) \<and>
-                     hsnd XY = DOWN (restrict (\<lambda>x. UP (happ F (DOWN x))) (UP ` hfset B)
-                                       (UP (hfst XY))))
+            "\<And>XY. (XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)) \<and>
+                     hsnd XY = elem_of (restrict (\<lambda>x. arr_of (happ F (elem_of x))) (arr_of ` hfset B)
+                                       (arr_of (hfst XY))))
                    \<longleftrightarrow>
-                   (XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) \<and>
-                     hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY))))))"
+                   (XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)) \<and>
+                     hsnd XY = elem_of (arr_of (happ F (elem_of (arr_of (hfst XY))))))"
             using 1 by auto
           thus ?thesis by blast
         qed
       qed
       also have
-        "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
+        "... = \<lbrace>XY \<^bold>\<in> ide_to_hf (mkIde (arr_of ` hfset B)) * ide_to_hf (mkIde (arr_of ` hfset C)).
                   hsnd XY = happ F (hfst XY)\<rbrace>"
         by simp
       also have "... = \<lbrace>XY \<^bold>\<in> B * C. hsnd XY = happ F (hfst XY)\<rbrace>"
         using assms hf_to_ide_def ide_to_hf_hf_to_ide by force
       also have "... = F"
         using assms happ_expansion by simp
       finally show ?thesis by simp
     qed
 
     lemma bij_betw_hom_hfun:
     assumes "ide a" and "ide b"
     shows "bij_betw arr_to_hfun (hom a b) {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
     proof (intro bij_betwI)
       show "arr_to_hfun \<in> hom a b \<rightarrow> {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
         using assms arr_to_hfun_in_hexp hexp_def hfun_arr_to_hfun by blast
       show "hfun_to_arr (ide_to_hf a) (ide_to_hf b)
               \<in> {F. hfun (ide_to_hf a) (ide_to_hf b) F} \<rightarrow> hom a b"
         using assms hfun_to_arr_in_hom
         by (metis (no_types, lifting) Pi_I hf_to_ide_ide_to_hf mem_Collect_eq)
       show "\<And>x. x \<in> hom a b \<Longrightarrow> hfun_to_arr (ide_to_hf a) (ide_to_hf b) (arr_to_hfun x) = x"
         using assms hfun_to_arr_arr_to_hfun by blast
       show "\<And>y. y \<in> {F. hfun (ide_to_hf a) (ide_to_hf b) F} \<Longrightarrow>
                   arr_to_hfun (hfun_to_arr (ide_to_hf a) (ide_to_hf b) y) = y"
         using assms arr_to_hfun_hfun_to_arr by simp
     qed
 
     text\<open>
       We next relate composition of arrows in the category to the corresponding operation
       on hereditarily finite sets.
     \<close>
 
     definition hcomp
     where "hcomp G F =
            \<lbrace>XZ \<^bold>\<in> hdomain F * hrange G. hsnd XZ = happ G (happ F (hfst XZ))\<rbrace>"
 
     lemma hfun_hcomp:
     assumes "hfun A B F" and "hfun B C G"
     shows "hfun A C (hcomp G F)"
     proof
       show "hcomp G F \<le> A * C"
         using assms hcomp_def hfun_def by auto
       show "\<And>X. X \<^bold>\<in> A \<Longrightarrow> \<exists>!Y. \<langle>X, Y\<rangle> \<^bold>\<in> hcomp G F"
       proof
         fix X
         assume X: "X \<^bold>\<in> A"
         show "\<langle>X, happ G (happ F X)\<rangle> \<^bold>\<in> hcomp G F"
           unfolding hcomp_def
           using assms X hfunE happ_mapsto hfun_in_hexp
           by (metis (mono_tags, lifting) HCollect_iff hfst_conv hfun_def hsnd_conv timesI)
         show "\<And>X Y. \<lbrakk>X \<^bold>\<in> A; \<langle>X, Y\<rangle> \<^bold>\<in> hcomp G F\<rbrakk> \<Longrightarrow> Y = happ G (happ F X)"
           unfolding hcomp_def by simp
       qed
       show "\<And>X Y. \<langle>X, Y\<rangle> \<^bold>\<in> hcomp G F \<Longrightarrow> Y \<^bold>\<in> C"
         unfolding hcomp_def
         using assms hfunE happ_mapsto hfun_in_hexp
         by (metis HCollectE hfun_def hsubsetCE timesD2)
     qed
 
     lemma arr_to_hfun_comp:
     assumes "seq g f"
     shows "arr_to_hfun (comp g f) = hcomp (arr_to_hfun g) (arr_to_hfun f)"
     proof -
       have 1: "hdomain (arr_to_hfun f) = ide_to_hf (dom f)"
         using assms hfun_arr_to_hfun hfun_def by blast
       have "arr_to_hfun (comp g f) =
             \<lbrace>XZ \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod g).
-               hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))\<rbrace>"
+               hsnd XZ = elem_of (Fun (comp g f) (arr_of (hfst XZ)))\<rbrace>"
         unfolding arr_to_hfun_def comp_def
         using assms by fastforce
       also have "... = \<lbrace>XZ \<^bold>\<in> hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
                           hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))\<rbrace>"
       proof
         fix XZ
         have "hfst XZ \<^bold>\<in> hdomain (arr_to_hfun f)
                  \<Longrightarrow> hsnd XZ \<^bold>\<in> ide_to_hf (cod g) \<and>
-                       hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
+                       hsnd XZ = elem_of (Fun (comp g f) (arr_of (hfst XZ)))
                       \<longleftrightarrow>
                      hsnd XZ \<^bold>\<in> hrange (arr_to_hfun g) \<and>
                        hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
         proof
           assume XZ: "hfst XZ \<^bold>\<in> hdomain (arr_to_hfun f)"
-          have 2: "UP (hfst XZ) \<in> Dom f"
-            using XZ 1 hfsetcat.UP_membI by auto
-          have 3: "UP (happ (arr_to_hfun f) (hfst XZ)) \<in> Dom g"
+          have 2: "arr_of (hfst XZ) \<in> Dom f"
+            using XZ 1 hfsetcat.arr_of_membI by auto
+          have 3: "arr_of (happ (arr_to_hfun f) (hfst XZ)) \<in> Dom g"
             using assms XZ 2
-            by (metis (no_types, lifting) "1" happ_mapsto(1) hfsetcat.UP_membI
+            by (metis (no_types, lifting) "1" happ_mapsto(1) hfsetcat.arr_of_membI
                 arr_to_hfun_in_hexp seqE)
-          have 4: "DOWN (Fun (comp g f) (UP (hfst XZ))) =
+          have 4: "elem_of (Fun (comp g f) (arr_of (hfst XZ))) =
                    happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
           proof -
-            have "DOWN (Fun (comp g f) (UP (hfst XZ))) =
-                  DOWN (restrict (Fun g o Fun f) (Dom f) (UP (hfst XZ)))"
+            have "elem_of (Fun (comp g f) (arr_of (hfst XZ))) =
+                  elem_of (restrict (Fun g o Fun f) (Dom f) (arr_of (hfst XZ)))"
               using assms Fun_comp Fun_char by simp
-            also have "... = DOWN ((Fun g o Fun f) (UP (hfst XZ)))"
+            also have "... = elem_of ((Fun g o Fun f) (arr_of (hfst XZ)))"
               using XZ 2 by auto
-            also have "... = DOWN (Fun g (Fun f (UP (hfst XZ))))"
+            also have "... = elem_of (Fun g (Fun f (arr_of (hfst XZ))))"
               by simp
             also have
-              "... = DOWN (Fun g (restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)
-                                           (UP (hfst XZ))))"
+              "... = elem_of (Fun g (restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f)
+                                           (arr_of (hfst XZ))))"
             proof -
-              have "Fun f = restrict (\<lambda>x. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
+              have "Fun f = restrict (\<lambda>x. arr_of (happ (arr_to_hfun f) (elem_of x))) (Dom f)"
                 using assms Fun_char [of f] by blast
               thus ?thesis by simp
             qed
-            also have "... = DOWN (Fun g (UP (happ (arr_to_hfun f) (hfst XZ))))"
+            also have "... = elem_of (Fun g (arr_of (happ (arr_to_hfun f) (hfst XZ))))"
               using 2 by simp
-            also have "... = DOWN (restrict (\<lambda>x. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)
-                                            (UP (happ (arr_to_hfun f) (hfst XZ))))"
+            also have "... = elem_of (restrict (\<lambda>x. arr_of (happ (arr_to_hfun g) (elem_of x))) (Dom g)
+                                            (arr_of (happ (arr_to_hfun f) (hfst XZ))))"
             proof -
-              have "Fun g = restrict (\<lambda>x. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)"
+              have "Fun g = restrict (\<lambda>x. arr_of (happ (arr_to_hfun g) (elem_of x))) (Dom g)"
                 using assms Fun_char [of g] by blast
               thus ?thesis by simp
             qed
             also have "... = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
               using 3 by simp
             finally show ?thesis by blast
           qed
-          have 5: "DOWN (Fun (comp g f) (UP (hfst XZ))) \<^bold>\<in> hrange (arr_to_hfun g)"
+          have 5: "elem_of (Fun (comp g f) (arr_of (hfst XZ))) \<^bold>\<in> hrange (arr_to_hfun g)"
           proof -
             have "happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ)) \<^bold>\<in> hrange (arr_to_hfun g)"
               using assms 1 3 XZ hfun_arr_to_hfun happ_mapsto arr_to_hfun_in_hexp arr_to_hfun_def
               by (metis (no_types, lifting) seqE)
             thus ?thesis
               using XZ 4 by simp
           qed
           show "hsnd XZ \<^bold>\<in> ide_to_hf (cod g) \<and>
-                  hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
+                  hsnd XZ = elem_of (Fun (comp g f) (arr_of (hfst XZ)))
                           \<Longrightarrow>
                 hsnd XZ \<^bold>\<in> hrange (arr_to_hfun g) \<and>
                   hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
             using XZ 4 5 by simp
           show "hsnd XZ \<^bold>\<in> hrange (arr_to_hfun g) \<and>
                   hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))
                           \<Longrightarrow>
                 hsnd XZ \<^bold>\<in> ide_to_hf (cod g) \<and>
-                  hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))"
+                  hsnd XZ = elem_of (Fun (comp g f) (arr_of (hfst XZ)))"
             using assms XZ 1 4
             by (metis (no_types, lifting) arr_to_hfun_in_hexp happ_mapsto(1) seqE)
         qed
         thus "XZ \<^bold>\<in> \<lbrace>XZ \<^bold>\<in> ide_to_hf (dom f) * ide_to_hf (cod g).
-                      hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))\<rbrace>
+                      hsnd XZ = elem_of (Fun (comp g f) (arr_of (hfst XZ)))\<rbrace>
                 \<longleftrightarrow>
               XZ \<^bold>\<in> \<lbrace>XZ \<^bold>\<in> hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
                       hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))\<rbrace>"
           using 1 is_hpair_def by auto
       qed
       also have "... = hcomp (arr_to_hfun g) (arr_to_hfun f)"
         using assms arr_to_hfun_def hcomp_def by simp
       finally show ?thesis by simp
     qed
 
     lemma hfun_to_arr_hcomp:
     assumes "hfun A B F" and "hfun B C G"
     shows "hfun_to_arr A C (hcomp G F) = comp (hfun_to_arr B C G) (hfun_to_arr A B F)"
     proof -
       have 1: "arr_to_hfun (hfun_to_arr A C (hcomp G F)) =
                arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F))"
       proof -
         have "arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F)) =
               hcomp (arr_to_hfun (hfun_to_arr B C G)) (arr_to_hfun (hfun_to_arr A B F))"
           using assms arr_to_hfun_comp hfun_to_arr_in_hom by blast
         also have "... = hcomp G F"
           using assms by (simp add: arr_to_hfun_hfun_to_arr)
         also have "... = arr_to_hfun (hfun_to_arr A C (hcomp G F))"
         proof -
           have "hfun A C (hcomp G F)"
             using assms hfun_hcomp by simp
           thus ?thesis
             by (simp add: arr_to_hfun_hfun_to_arr)
         qed
         finally show ?thesis by simp
       qed
       show ?thesis
       proof -
         have "hfun_to_arr A C (hcomp G F) \<in> hom (hf_to_ide A) (hf_to_ide C)"
           using assms hfun_hcomp hf_to_ide_def hfun_to_arr_in_hom by auto
         moreover have "comp (hfun_to_arr B C G) (hfun_to_arr A B F)
                           \<in> hom (hf_to_ide A) (hf_to_ide C)"
           using assms hfun_to_arr_in_hom hf_to_ide_def
           by (metis (no_types, lifting) comp_in_homI mem_Collect_eq)
         moreover have "inj_on arr_to_hfun (hom (hf_to_ide A) (hf_to_ide C))"
         proof -
           have "ide (hf_to_ide A) \<and> ide (hf_to_ide C)"
             using assms hf_to_ide_mapsto by auto
           thus ?thesis
             using bij_betw_hom_hfun [of "hf_to_ide A" "hf_to_ide C"] bij_betw_imp_inj_on
             by auto
         qed
         ultimately show ?thesis
           using 1 inj_on_def [of arr_to_hfun "hom (hf_to_ide A) (hf_to_ide C)"] by simp
       qed
     qed
 
     section "Binary Products"
 
     text\<open>
       The category of hereditarily finite sets has binary products,
       given by cartesian product of sets in the usual way.
     \<close>
 
     definition prod
     where "prod a b = hf_to_ide (ide_to_hf a * ide_to_hf b)"
 
     definition pr0
     where "pr0 a b = (if ide a \<and> ide b then
-                         mkArr (set (prod a b)) (set b) (\<lambda>x. UP (hsnd (DOWN x)))
+                         mkArr (set (prod a b)) (set b) (\<lambda>x. arr_of (hsnd (elem_of x)))
                       else null)"
 
     definition pr1
     where "pr1 a b = (if ide a \<and> ide b then
-                         mkArr (set (prod a b)) (set a) (\<lambda>x. UP (hfst (DOWN x)))
+                         mkArr (set (prod a b)) (set a) (\<lambda>x. arr_of (hfst (elem_of x)))
                       else null)"
 
     definition tuple
     where "tuple f g = mkArr (set (dom f)) (set (prod (cod f) (cod g)))
-                             (\<lambda>x. UP (hpair (DOWN (Fun f x)) (DOWN (Fun g x))))"
+                             (\<lambda>x. arr_of (hpair (elem_of (Fun f x)) (elem_of (Fun g x))))"
 
     lemma ide_prod:
     assumes "ide a" and "ide b"
     shows "ide (prod a b)"
       using assms prod_def hf_to_ide_mapsto ide_to_hf_mapsto by auto
 
     lemma pr1_in_hom [intro]:
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>pr1 a b : prod a b \<rightarrow> a\<guillemotright>"
     proof
       show 0: "arr (pr1 a b)"
       proof -
-        have "set (prod a b) \<subseteq> Univ"
-          using assms ide_prod ide_char set_subset_Univ by blast
-        moreover have "set a \<subseteq> Univ"
-          using assms ide_char set_subset_Univ by blast
-        moreover have "(\<lambda>x. UP (hfst (DOWN x))) \<in> set (prod a b) \<rightarrow> set a"
+        have "set (prod a b) \<subseteq> Univ \<and> finite (set (prod a b))"
+          using assms ide_implies_finite_set(1) set_ideD(1) ide_prod by presburger
+        moreover have "set a \<subseteq> Univ \<and> finite (set a)"
+          using assms ide_char set_ide_char by blast
+        moreover have "(\<lambda>x. arr_of (hfst (elem_of x))) \<in> set (prod a b) \<rightarrow> set a"
         proof (unfold prod_def)
-          show "(\<lambda>x. UP (hfst (DOWN x))) \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b)) \<rightarrow> set a"
+          show "(\<lambda>x. arr_of (hfst (elem_of x))) \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b)) \<rightarrow> set a"
           proof
             fix x
               assume x: "x \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
-              have "DOWN x \<in> hfset (ide_to_hf a * ide_to_hf b)"
+              have "elem_of x \<in> hfset (ide_to_hf a * ide_to_hf b)"
                 using assms ide_char x
-                by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
+                by (metis (no_types, lifting) prod_def elem_of_membI HF_hfset UNIV_I hmem_HF_iff
                     ide_prod ide_to_hf_hf_to_ide)
-              hence "hfst (DOWN x) \<^bold>\<in> ide_to_hf a"
+              hence "hfst (elem_of x) \<^bold>\<in> ide_to_hf a"
                 by (metis HF_hfset finite_hfset hfst_conv hmem_HF_iff timesE)
-              thus "UP (hfst (DOWN x)) \<in> set a"
-                using UP_membI by simp
+              thus "arr_of (hfst (elem_of x)) \<in> set a"
+                using arr_of_membI by simp
           qed
         qed
         ultimately show ?thesis
           unfolding pr1_def
-          using assms arr_mkArr ide_prod set_card by presburger
+          using assms arr_mkArr finite_imp_setp by presburger
       qed
       show "dom (pr1 a b) = prod a b"
         using assms 0 ide_char ide_prod dom_mkArr
         by (metis (no_types, lifting) mkIde_set pr1_def)
       show "cod (pr1 a b) = a"
         using assms 0 ide_char ide_prod cod_mkArr
         by (metis (no_types, lifting) mkIde_set pr1_def)
     qed
 
     lemma pr1_simps [simp]:
     assumes "ide a" and "ide b"
     shows "arr (pr1 a b)" and "dom (pr1 a b) = prod a b" and "cod (pr1 a b) = a"
       using assms pr1_in_hom by blast+
 
     lemma pr0_in_hom [intro]:
     assumes "ide a" and "ide b"
     shows "\<guillemotleft>pr0 a b : prod a b \<rightarrow> b\<guillemotright>"
     proof
       show 0: "arr (pr0 a b)"
       proof -
-        have "set (prod a b) \<subseteq> Univ"
-          using assms ide_prod ide_char set_subset_Univ by blast
-        moreover have "set b \<subseteq> Univ"
-          using assms ide_char set_subset_Univ by blast
-        moreover have "(\<lambda>x. UP (hsnd (DOWN x))) \<in> set (prod a b) \<rightarrow> set b"
+        have "set (prod a b) \<subseteq> Univ \<and> finite (set (prod a b))"
+          using setp_set_ide assms ide_implies_finite_set(1) ide_prod by presburger
+        moreover have "set b \<subseteq> Univ \<and> finite (set b)"
+          using assms ide_char set_ide_char by blast
+        moreover have "(\<lambda>x. arr_of (hsnd (elem_of x))) \<in> set (prod a b) \<rightarrow> set b"
         proof (unfold prod_def)
-          show "(\<lambda>x. UP (hsnd (DOWN x))) \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b)) \<rightarrow> set b"
+          show "(\<lambda>x. arr_of (hsnd (elem_of x))) \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b)) \<rightarrow> set b"
           proof
             fix x
               assume x: "x \<in> set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
-              have "DOWN x \<in> hfset (ide_to_hf a * ide_to_hf b)"
+              have "elem_of x \<in> hfset (ide_to_hf a * ide_to_hf b)"
                 using assms ide_char x
-                by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
+                by (metis (no_types, lifting) prod_def elem_of_membI HF_hfset UNIV_I hmem_HF_iff
                     ide_prod ide_to_hf_hf_to_ide)
-              hence "hsnd (DOWN x) \<^bold>\<in> ide_to_hf b"
+              hence "hsnd (elem_of x) \<^bold>\<in> ide_to_hf b"
                 by (metis HF_hfset finite_hfset hsnd_conv hmem_HF_iff timesE)
-              thus "UP (hsnd (DOWN x)) \<in> set b"
-                using UP_membI by simp
+              thus "arr_of (hsnd (elem_of x)) \<in> set b"
+                using arr_of_membI by simp
           qed
         qed
         ultimately show ?thesis
           unfolding pr0_def
-          using assms arr_mkArr ide_prod set_card by presburger
+          using assms arr_mkArr finite_imp_setp by presburger
       qed
       show "dom (pr0 a b) = prod a b"
         using assms 0 ide_char ide_prod dom_mkArr
         by (metis (no_types, lifting) mkIde_set pr0_def)
       show "cod (pr0 a b) = b"
         using assms 0 ide_char ide_prod cod_mkArr
         by (metis (no_types, lifting) mkIde_set pr0_def)
     qed
 
     lemma pr0_simps [simp]:
     assumes "ide a" and "ide b"
     shows "arr (pr0 a b)" and "dom (pr0 a b) = prod a b" and "cod (pr0 a b) = b"
       using assms pr0_in_hom by blast+
 
-    lemma UP_tuple_DOWN_membI:
+    lemma arr_of_tuple_elem_of_membI:
     assumes "span f g" and "x \<in> Dom f"
-    shows "UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle> \<in> set (prod (cod f) (cod g))"
+    shows "arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle> \<in> set (prod (cod f) (cod g))"
     proof -
       have "Fun f x \<in> set (cod f)"
         using assms Fun_mapsto by blast
       moreover have "Fun g x \<in> set (cod g)"
         using assms Fun_mapsto by auto
-      ultimately have "\<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>
+      ultimately have "\<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>
                           \<^bold>\<in> ide_to_hf (cod f) * ide_to_hf (cod g)"
         using assms ide_cod by auto
       moreover have "set (prod (cod f) (cod g)) \<subseteq> Univ"
-        using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
+        using setp_set_ide assms(1) ide_cod ide_prod by presburger
       ultimately show ?thesis
-        using prod_def UP_membI ide_to_hf_hf_to_ide by auto
+        using prod_def arr_of_membI ide_to_hf_hf_to_ide by auto
     qed
 
     lemma tuple_in_hom [intro]:
     assumes "span f g"
     shows "\<guillemotleft>tuple f g : dom f \<rightarrow> prod (cod f) (cod g)\<guillemotright>"
     proof
       show 1: "arr (tuple f g)"
       proof -
-        have "Dom f \<subseteq> Univ"
-          using assms set_subset_Univ ide_dom by blast
-        moreover have "set (prod (cod f) (cod g)) \<subseteq> Univ"
-          using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
-        moreover have "(\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>)
+        have "Dom f \<subseteq> Univ \<and> finite (Dom f)"
+          using assms set_ideD(1) ide_dom ide_implies_finite_set(1) by presburger
+        moreover have "set (prod (cod f) (cod g)) \<subseteq> Univ \<and> finite (set (prod (cod f) (cod g)))"
+          using assms set_ideD(1) ide_cod ide_prod ide_implies_finite_set(1) by presburger
+        moreover have "(\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>)
                           \<in> Dom f \<rightarrow> set (prod (cod f) (cod g))"
-          using assms UP_tuple_DOWN_membI by simp
+          using assms arr_of_tuple_elem_of_membI by simp
         ultimately show ?thesis
-          using assms ide_prod tuple_def arr_mkArr set_card ide_dom ide_cod by simp
+          using assms ide_prod tuple_def arr_mkArr ide_dom ide_cod by simp
       qed
       show "dom (tuple f g) = dom f"
         using assms 1 dom_mkArr ide_dom mkIde_set tuple_def by auto
       show "cod (tuple f g) = prod (cod f) (cod g)"
         using assms 1 cod_mkArr ide_cod mkIde_set tuple_def ide_prod by auto
     qed
 
     lemma tuple_simps [simp]:
     assumes "span f g"
     shows "arr (tuple f g)" and "dom (tuple f g) = dom f"
     and "cod (tuple f g) = prod (cod f) (cod g)"
       using assms tuple_in_hom by blast+
 
     lemma Fun_pr1:
     assumes "ide a" and "ide b"
-    shows "Fun (pr1 a b) = restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod a b))"
+    shows "Fun (pr1 a b) = restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod a b))"
       using assms pr1_def Fun_mkArr arr_char pr1_simps(1) by presburger
 
     lemma Fun_pr0:
     assumes "ide a" and "ide b"
-    shows "Fun (pr0 a b) = restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod a b))"
+    shows "Fun (pr0 a b) = restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod a b))"
       using assms pr0_def Fun_mkArr arr_char pr0_simps(1) by presburger
 
     lemma Fun_tuple:
     assumes "span f g"
-    shows "Fun (tuple f g) = restrict (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>) (Dom f)"
+    shows "Fun (tuple f g) = restrict (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>) (Dom f)"
     proof -
       have "arr (tuple f g)"
         using assms tuple_in_hom by blast
       thus ?thesis
         using assms tuple_def Fun_mkArr by simp
     qed
 
     lemma pr1_tuple:
     assumes "span f g"
     shows "comp (pr1 (cod f) (cod g)) (tuple f g) = f"
     proof (intro arr_eqI)
       have pr1: "\<guillemotleft>pr1 (cod f) (cod g) : prod (cod f) (cod g) \<rightarrow> cod f\<guillemotright>"
         using assms ide_cod by blast
       have tuple: "\<guillemotleft>tuple f g : dom f \<rightarrow> prod (cod f) (cod g)\<guillemotright>"
         using assms by blast
       show par: "par (comp (pr1 (cod f) (cod g)) (tuple f g)) f"
         using assms pr1_in_hom tuple_in_hom
         by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
       show "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) = Fun f"
       proof -
         have seq: "seq (pr1 (cod f) (cod g)) (tuple f g)"
           using par by blast
         have "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) =
               restrict (Fun (pr1 (cod f) (cod g)) \<circ> Fun (tuple f g)) (Dom (tuple f g))"
           using pr1 tuple seq Fun_comp by simp
         also have "... = restrict
                            (Fun (mkArr (set (prod (cod f) (cod g))) (Cod f)
-                                       (\<lambda>x. UP (hfst (DOWN x)))) \<circ>
+                                       (\<lambda>x. arr_of (hfst (elem_of x)))) \<circ>
                             Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
-                                       (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>)))
+                                       (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>)))
                            (Dom (tuple f g))"
           unfolding pr1_def tuple_def
           using assms ide_cod by presburger
         also have
           "... = restrict
-                   (restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod (cod f) (cod g))) o
-                      restrict (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>) (Dom f))
+                   (restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod (cod f) (cod g))) o
+                      restrict (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>) (Dom f))
                    (Dom f)"
         proof -
-          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod f) (\<lambda>x. UP (hfst (DOWN x)))) =
-                restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod (cod f) (cod g)))"
+          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod f) (\<lambda>x. arr_of (hfst (elem_of x)))) =
+                restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod (cod f) (cod g)))"
             using assms Fun_mkArr ide_prod pr1
             by (metis (no_types, lifting) arrI ide_cod pr1_def)
           moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
-                                    (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>)) =
-                         restrict (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>) (Dom f)"
+                                    (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>)) =
+                         restrict (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>) (Dom f)"
             using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
           ultimately show ?thesis
             using assms tuple_simps(2) by simp
         qed
         also have
           "... = restrict
-                   ((\<lambda>x. UP (hfst (DOWN x))) o (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+                   ((\<lambda>x. arr_of (hfst (elem_of x))) o (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                    (Dom f)"
-          using assms tuple tuple_def UP_tuple_DOWN_membI by auto
+          using assms tuple tuple_def arr_of_tuple_elem_of_membI by auto
         also have "... = restrict (Fun f) (Dom f)"
         proof
           fix x
-          have "restrict ((\<lambda>x. UP (hfst (DOWN x))) o (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+          have "restrict ((\<lambda>x. arr_of (hfst (elem_of x))) o (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                          (Dom f) x =
-                restrict (\<lambda>x. UP (DOWN (Fun f x))) (Dom f) x"
+                restrict (\<lambda>x. arr_of (elem_of (Fun f x))) (Dom f) x"
             by simp
           also have "... = restrict (Fun f) (Dom f) x"
           proof (cases "x \<in> Dom f")
             show "x \<notin> Dom f \<Longrightarrow> ?thesis" by simp
             assume x: "x \<in> Dom f"
             have "Fun f x \<in> Cod f"
               using assms x Fun_mapsto arr_char by blast
             moreover have "Cod f \<subseteq> Univ"
-              using assms pr1 ide_cod set_subset_Univ by simp
+              using setp_set_ide assms ide_cod by blast
             ultimately show ?thesis
-              using assms UP_DOWN Fun_mapsto by auto
+              using assms arr_of_elem_of Fun_mapsto by auto
           qed
-          finally show "restrict ((\<lambda>x. UP (hfst (DOWN x))) \<circ>
-                                    (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+          finally show "restrict ((\<lambda>x. arr_of (hfst (elem_of x))) \<circ>
+                                    (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                                  (Dom f) x =
                         restrict (Fun f) (Dom f) x"
             by blast
         qed
         also have "... = Fun f"
           using assms par Fun_mapsto Fun_mkArr mkArr_Fun
           by (metis (no_types, lifting))
         finally show ?thesis by blast
       qed
     qed
 
     lemma pr0_tuple:
     assumes "span f g"
     shows "comp (pr0 (cod f) (cod g)) (tuple f g) = g"
     proof (intro arr_eqI)
       have pr0: "\<guillemotleft>pr0 (cod f) (cod g) : prod (cod f) (cod g) \<rightarrow> cod g\<guillemotright>"
         using assms ide_cod by blast
       have tuple: "\<guillemotleft>tuple f g : dom f \<rightarrow> prod (cod f) (cod g)\<guillemotright>"
         using assms by blast
       show par: "par (comp (pr0 (cod f) (cod g)) (tuple f g)) g"
         using assms pr0_in_hom tuple_in_hom
         by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
       show "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) = Fun g"
       proof -
         have seq: "seq (pr0 (cod f) (cod g)) (tuple f g)"
           using par by blast
         have "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) =
               restrict (Fun (pr0 (cod f) (cod g)) \<circ> Fun (tuple f g)) (Dom (tuple f g))"
           using pr0 tuple seq Fun_comp by simp
         also have
           "... = restrict
                    (Fun (mkArr (set (prod (cod f) (cod g))) (Cod g)
-                               (\<lambda>x. UP (hsnd (DOWN x)))) \<circ>
+                               (\<lambda>x. arr_of (hsnd (elem_of x)))) \<circ>
                     Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
-                               (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>)))
+                               (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>)))
                    (Dom (tuple f g))"
           unfolding pr0_def tuple_def
           using assms ide_cod by presburger
         also have "... = restrict
-                           (restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g))) o
-                            restrict (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>) (Dom g))
+                           (restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod (cod f) (cod g))) o
+                            restrict (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>) (Dom g))
                            (Dom g)"
         proof -
-          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod g) (\<lambda>x. UP (hsnd (DOWN x)))) =
-                restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g)))"
+          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod g) (\<lambda>x. arr_of (hsnd (elem_of x)))) =
+                restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod (cod f) (cod g)))"
             using assms Fun_mkArr ide_prod arrI
             by (metis (no_types, lifting) ide_cod pr0 pr0_def)
           moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
-                                    (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>)) =
-                         restrict (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>) (Dom f)"
+                                    (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>)) =
+                         restrict (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>) (Dom f)"
             using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
           ultimately show ?thesis
             using assms tuple_simps(2) by simp
         qed
         also have "... = restrict
-                           ((\<lambda>x. UP (hsnd (DOWN x))) o (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+                           ((\<lambda>x. arr_of (hsnd (elem_of x))) o (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                            (Dom g)"
-          using assms tuple tuple_def UP_tuple_DOWN_membI by auto
+          using assms tuple tuple_def arr_of_tuple_elem_of_membI by auto
         also have "... = restrict (Fun g) (Dom g)"
         proof
           fix x
-          have "restrict ((\<lambda>x. UP (hsnd (DOWN x)))
-                            o (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+          have "restrict ((\<lambda>x. arr_of (hsnd (elem_of x)))
+                            o (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                          (Dom g) x =
-                restrict (\<lambda>x. UP (DOWN (Fun g x))) (Dom g) x"
+                restrict (\<lambda>x. arr_of (elem_of (Fun g x))) (Dom g) x"
             by simp
           also have "... = restrict (Fun g) (Dom g) x"
           proof (cases "x \<in> Dom g")
             show "x \<notin> Dom g \<Longrightarrow> ?thesis" by simp
             assume x: "x \<in> Dom g"
             have "Fun g x \<in> Cod g"
               using assms x Fun_mapsto arr_char by blast
             moreover have "Cod g \<subseteq> Univ"
-              using assms pr0 ide_cod set_subset_Univ by simp
+              using assms set_ideD(1) ide_cod by blast
             ultimately show ?thesis
-              using assms UP_DOWN Fun_mapsto by auto
+              using assms arr_of_elem_of Fun_mapsto by auto
           qed
-          finally show "restrict ((\<lambda>x. UP (hsnd (DOWN x))) \<circ>
-                                    (\<lambda>x. UP \<langle>DOWN (Fun f x), DOWN (Fun g x)\<rangle>))
+          finally show "restrict ((\<lambda>x. arr_of (hsnd (elem_of x))) \<circ>
+                                    (\<lambda>x. arr_of \<langle>elem_of (Fun f x), elem_of (Fun g x)\<rangle>))
                                  (Dom g) x =
                         restrict (Fun g) (Dom g) x"
             by blast
         qed
         also have "... = Fun g"
           using assms par Fun_mapsto Fun_mkArr mkArr_Fun
           by (metis (no_types, lifting))
         finally show ?thesis by blast
       qed
     qed
 
     lemma tuple_pr:
     assumes "ide a" and "ide b" and "\<guillemotleft>h : dom h \<rightarrow> prod a b\<guillemotright>"
     shows "tuple (comp (pr1 a b) h) (comp (pr0 a b) h) = h"
     proof (intro arr_eqI)
       have pr0: "\<guillemotleft>pr0 a b : prod a b \<rightarrow> b\<guillemotright>"
         using assms pr0_in_hom ide_cod by blast
       have pr1: "\<guillemotleft>pr1 a b : prod a b \<rightarrow> a\<guillemotright>"
         using assms pr1_in_hom ide_cod by blast
       have tuple: "\<guillemotleft>tuple (comp (pr1 a b) h) (comp (pr0 a b) h) : dom h \<rightarrow> prod a b\<guillemotright>"
         using assms pr0 pr1
         by (metis (no_types, lifting) cod_comp dom_comp pr0_simps(3) pr1_simps(3)
             seqI' tuple_in_hom)
       show par: "par (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) h"
         using assms tuple by (metis (no_types, lifting) in_homE)
       show "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) = Fun h"
       proof -
         have 1: "Fun (comp (pr1 a b) h) =
-                 restrict (restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod a b)) \<circ> Fun h) (Dom h)"
+                 restrict (restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod a b)) \<circ> Fun h) (Dom h)"
           using assms pr1 Fun_comp Fun_pr1 seqI' by auto
         have 2: "Fun (comp (pr0 a b) h) =
-                 restrict (restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod a b)) \<circ> Fun h) (Dom h)"
+                 restrict (restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod a b)) \<circ> Fun h) (Dom h)"
           using assms pr0 Fun_comp Fun_pr0 seqI' by auto
         have "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) =
-              restrict (\<lambda>x. UP \<langle>DOWN (restrict
-                                       (restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod a b)) \<circ> Fun h)
+              restrict (\<lambda>x. arr_of \<langle>elem_of (restrict
+                                       (restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod a b)) \<circ> Fun h)
                                                  (Dom h) x),
-                                DOWN (restrict
-                                       (restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod a b)) \<circ> Fun h)
+                                elem_of (restrict
+                                       (restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod a b)) \<circ> Fun h)
                                                  (Dom h) x)\<rangle>)
                        (Dom h)"
         proof -
           have "Dom (comp (pr1 a b) h) = Dom h"
             using assms pr1_in_hom
             by (metis (no_types, lifting) in_homE dom_comp seqI)
           moreover have "arr (mkArr (Dom (comp (pr1 a b) h))
                              (set (prod (cod (comp (pr1 a b) h)) (cod (comp (pr0 a b) h))))
-                             (\<lambda>x. UP \<langle>DOWN (Fun (comp (pr1 a b) h) x),
-                                      DOWN (Fun (comp (pr0 a b) h) x)\<rangle>))"
+                             (\<lambda>x. arr_of \<langle>elem_of (Fun (comp (pr1 a b) h) x),
+                                      elem_of (Fun (comp (pr0 a b) h) x)\<rangle>))"
             using tuple unfolding tuple_def by blast
           ultimately show ?thesis
             using 1 2 tuple tuple_def
                   Fun_mkArr [of "Dom (comp (pr1 a b) h)"
                                  "set (prod (cod (comp (pr1 a b) h))
                                             (cod (comp (pr0 a b) h)))"
-                                 "\<lambda>x. UP \<langle>DOWN (Fun (comp (pr1 a b) h) x),
-                                          DOWN (Fun (comp (pr0 a b) h) x)\<rangle>"]
+                                 "\<lambda>x. arr_of \<langle>elem_of (Fun (comp (pr1 a b) h) x),
+                                          elem_of (Fun (comp (pr0 a b) h) x)\<rangle>"]
             by simp
         qed
         also have "... = Fun h"
         proof
           let ?f = "..."
           fix x
           show "?f x = Fun h x"
           proof -
             have "x \<notin> Dom h \<Longrightarrow> ?f x = Fun h x"
             proof -
               assume x: "x \<notin> Dom h"
               have "restrict ?f (Dom h) x = undefined"
                 using assms x restrict_apply by auto
               also have "... = Fun h x"
               proof -
                 have "arr h"
                   using assms by blast
                 thus ?thesis
                   using assms x Fun_mapsto [of h] extensional_arb [of "Fun h" "Dom h" x]
                   by simp
               qed
               finally show ?thesis by auto
             qed
             moreover have "x \<in> Dom h \<Longrightarrow> ?f x = Fun h x"
             proof -
               assume x: "x \<in> Dom h"
               have 1: "Fun h x \<in> set (prod a b)"
               proof -
                 have "Fun h x \<in> Cod h"
                   using assms x Fun_mapsto [of h] by blast
                 moreover have "Cod h = set (prod a b)"
                   using assms ide_prod
                   by (metis (no_types, lifting) in_homE)
                 ultimately show ?thesis by fast
               qed
-              have "?f x = UP \<langle>hfst (DOWN (Fun h x)), hsnd (DOWN (Fun h x))\<rangle>"
+              have "?f x = arr_of \<langle>hfst (elem_of (Fun h x)), hsnd (elem_of (Fun h x))\<rangle>"
                 using x 1 by simp
-              also have "... = UP (DOWN (Fun h x))"
+              also have "... = arr_of (elem_of (Fun h x))"
               proof -
-                have "DOWN (Fun h x) \<^bold>\<in> ide_to_hf a * ide_to_hf b"
+                have "elem_of (Fun h x) \<^bold>\<in> ide_to_hf a * ide_to_hf b"
                   using assms x 1 par
-                  by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I ide_prod
+                  by (metis (no_types, lifting) prod_def elem_of_membI UNIV_I ide_prod
                       ide_to_hf_hf_to_ide)
                 thus ?thesis
                   using x is_hpair_def by auto
               qed
               also have "... = Fun h x"
-                using assms 1 ide_prod set_subset_Univ UP_DOWN
-                by (meson subsetD)
+                using 1 arr_of_elem_of assms set_ideD(1) ide_prod by blast
               finally show ?thesis by blast
             qed
             ultimately show ?thesis by blast
           qed
         qed
         finally show ?thesis by blast
       qed
     qed
 
     interpretation HF': elementary_category_with_binary_products comp pr0 pr1
     proof
       show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> span (pr1 a b) (pr0 a b)"
         using pr0_simps(1) pr0_simps(2) pr1_simps(1) pr1_simps(2) by auto
       show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> cod (pr0 a b) = b"
         using pr0_simps(1-3) by blast
       show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> cod (pr1 a b) = a"
         using pr1_simps(1-3) by blast
       show "\<And>f g. span f g \<Longrightarrow>
                     \<exists>!l. comp (pr1 (cod f) (cod g)) l = f \<and> comp (pr0 (cod f) (cod g)) l = g"
       proof
         fix f g
         assume fg: "span f g"
         show "comp (pr1 (cod f) (cod g)) (tuple f g) = f \<and>
               comp (pr0 (cod f) (cod g)) (tuple f g) = g"
           using fg pr0_simps pr1_simps tuple_simps pr0_tuple pr1_tuple by presburger
         show "\<And>l. \<lbrakk>comp (pr1 (cod f) (cod g)) l = f \<and> comp (pr0 (cod f) (cod g)) l = g\<rbrakk>
                       \<Longrightarrow> l = tuple f g "
         proof -
           fix l
           assume l: "comp (pr1 (cod f) (cod g)) l = f \<and> comp (pr0 (cod f) (cod g)) l = g"
           show "l = tuple f g"
             using fg l tuple_pr
             by (metis (no_types, lifting) arr_iff_in_hom ide_cod seqE pr0_simps(2))
         qed
       qed
       show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> pr0 a b = null"
         using pr0_def by auto
       show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> pr1 a b = null"
         using pr1_def by auto
     qed
 
     text\<open>
       For reasons of economy of locale parameters, the notion \<open>prod\<close> is a defined notion
       of the @{locale elementary_category_with_binary_products} locale.
       However, we need to be able to relate this notion to that of cartesian product of
       hereditarily finite sets, which we have already used to give a definition of \<open>prod\<close>.
       The locale assumptions for @{locale elementary_cartesian_closed_category} refer
       specifically to \<open>HF'.prod\<close>, even though in the end the notion itself does not depend
       on that choice.  To be able to show that the locale assumptions of
       @{locale elementary_cartesian_closed_category} are satisfied, we need to use a choice
       of products that we can relate to the cartesian product of hereditarily
       finite sets.  We therefore need to show that our previously defined \<open>prod\<close> coincides
       (on objects) with the one defined in the @{locale elementary_category_with_binary_products} locale;
       \emph{i.e.}~\<open>HF'.prod\<close>.  Note that the latter is defined for all arrows,
       not just identity arrows, so we need to use that for the subsequent definitions and proofs.
     \<close>
 
     lemma prod_ide_eq:
     assumes "ide a" and "ide b"
     shows "prod a b = HF'.prod a b"
       using assms prod_def HF'.pr_simps(2) HF'.prod_def pr0_simps(2) by presburger
 
     lemma tuple_span_eq:
     assumes "span f g"
     shows "tuple f g = HF'.tuple f g"
       using assms tuple_def HF'.tuple_def
       by (metis (no_types, lifting) HF'.tuple_eqI pr0_tuple pr1_tuple)
 
     section "Exponentials"
 
     text\<open>
       We now turn our attention to exponentials.
     \<close>
 
     definition exp
     where "exp b c = hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
 
     definition eval
     where "eval b c = mkArr (set (HF'.prod (exp b c) b)) (set c)
-                            (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))"
+                            (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))"
 
     definition \<Lambda>
     where "\<Lambda> a b c f = mkArr (set a) (set (exp b c))
-                             (\<lambda>x. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+                             (\<lambda>x. arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                  (arr_to_hfun f))
-                                           (DOWN x)))"
+                                           (elem_of x)))"
 
     lemma ide_exp:
     assumes "ide b" and "ide c"
     shows "ide (exp b c)"
       using assms exp_def hf_to_ide_mapsto ide_to_hf_mapsto by auto
 
     lemma hfset_ide_to_hf:
     assumes "ide a"
-    shows "hfset (ide_to_hf a) = DOWN ` set a"
+    shows "hfset (ide_to_hf a) = elem_of ` set a"
       using assms ide_to_hf_def ide_implies_finite_set(1) by auto
 
     lemma eval_in_hom [intro]:
     assumes "ide b" and "ide c"
     shows "in_hom (eval b c) (HF'.prod (exp b c) b) c"
     proof
       show 1: "arr (eval b c)"
       proof (unfold eval_def arr_mkArr, intro conjI)
         show "set (HF'.prod (exp b c) b) \<subseteq> Univ"
-          using assms ide_char HF'.ide_prod ide_exp set_subset_Univ by simp
+          using HF'.ide_prod assms set_ideD(1) ide_exp by presburger
         show "set c \<subseteq> Univ"
-          using assms ide_char set_subset_Univ by simp
-        show "(\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
+          using assms set_ideD(1) by blast
+        show "(\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
                  \<in> set (HF'.prod (exp b c) b) \<rightarrow> set c"
         proof
           fix x
           assume "x \<in> set (HF'.prod (exp b c) b)"
           hence x: "x \<in> set (prod (exp b c) b)"
             using assms prod_ide_eq ide_exp by auto
-          show "UP (happ (hfst (DOWN x)) (hsnd (DOWN x))) \<in> set c"
-          proof (intro UP_membI)
-            show "happ (hfst (DOWN x)) (hsnd (DOWN x)) \<^bold>\<in> ide_to_hf c"
+          show "arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))) \<in> set c"
+          proof (intro arr_of_membI)
+            show "happ (hfst (elem_of x)) (hsnd (elem_of x)) \<^bold>\<in> ide_to_hf c"
             proof -
-              have 1: "DOWN x \<^bold>\<in> ide_to_hf (exp b c) * ide_to_hf b"
+              have 1: "elem_of x \<^bold>\<in> ide_to_hf (exp b c) * ide_to_hf b"
               proof -
-                have "DOWN x \<^bold>\<in> ide_to_hf (prod (exp b c) b)"
-                  using assms x DOWN_membI ide_prod ide_exp by simp
+                have "elem_of x \<^bold>\<in> ide_to_hf (prod (exp b c) b)"
+                  using assms x elem_of_membI ide_prod ide_exp by simp
                 thus ?thesis
                   using assms x prod_def ide_to_hf_hf_to_ide by auto
               qed
-              have "hfst (DOWN x) \<^bold>\<in> hexp (ide_to_hf b) (ide_to_hf c)"
+              have "hfst (elem_of x) \<^bold>\<in> hexp (ide_to_hf b) (ide_to_hf c)"
                 using assms 1 x exp_def ide_to_hf_hf_to_ide by auto
-              moreover have "hsnd (DOWN x) \<^bold>\<in> ide_to_hf b"
+              moreover have "hsnd (elem_of x) \<^bold>\<in> ide_to_hf b"
                 using assms 1 by auto
               ultimately show ?thesis
-                using happ_mapsto [of "hfst (DOWN x)" "ide_to_hf b" "ide_to_hf c"
-                                      "hsnd (DOWN x)"]
+                using happ_mapsto [of "hfst (elem_of x)" "ide_to_hf b" "ide_to_hf c"
+                                      "hsnd (elem_of x)"]
                 by simp
             qed
           qed
         qed
-        show "|set (HF'.prod (exp b c) b)| <o natLeq"
-          using assms ide_exp HF'.ide_prod set_card by auto
-        show "|set c| <o natLeq"
-          using assms set_card by auto
+        show "finite (elem_of ` set (HF'.prod (exp b c) b))"
+          using HF'.ide_prod setp_set_ide assms ide_exp by presburger
+        show "finite (elem_of ` set c)"
+          using setp_set_ide assms(2) by blast
       qed
       show "dom (eval b c) = HF'.prod (exp b c) b"
         using assms 1 ide_char HF'.ide_prod ide_exp dom_mkArr eval_def
         by (metis (no_types, lifting) mkIde_set)
       show "cod (eval b c) = c"
         using assms 1 ide_char cod_mkArr eval_def
         by (metis (no_types, lifting) mkIde_set)
     qed
 
     lemma eval_simps [simp]:
     assumes "ide b" and "ide c"
     shows "arr (eval b c)"
     and "dom (eval b c) = HF'.prod (exp b c) b"
     and "cod (eval b c) = c"
       using assms eval_in_hom by blast+
 
     lemma hlam_arr_to_hfun_in_hexp:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom f (prod a b) c"
     shows "hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f)
              \<^bold>\<in> hexp (ide_to_hf a) (ide_to_hf (exp b c))"
       using assms hfun_in_hexp hfun_hlam
       by (metis (no_types, lifting) prod_def HCollect_iff in_homE UNIV_I
           arr_to_hfun_in_hexp exp_def hexp_def ide_to_hf_hf_to_ide)
 
     lemma lam_in_hom [intro]:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom f (prod a b) c"
     shows "in_hom (\<Lambda> a b c f) a (exp b c)"
     proof
       show 1: "arr (\<Lambda> a b c f)"
       proof (unfold \<Lambda>_def arr_mkArr, intro conjI)
         show "set a \<subseteq> Univ"
-          using assms(1) set_subset_Univ ide_char by blast
+          using assms(1) set_ideD(1) by blast
         show "set (exp b c) \<subseteq> Univ"
-          using assms(2-3) set_subset_Univ ide_exp ide_char by simp
-        show "|set a| <o natLeq"
-          using assms(1) set_card by simp
-        show "|set (exp b c)| <o natLeq"
-          using assms(2-3) set_card ide_exp by auto
-        show "(\<lambda>x. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
-                            (DOWN x)))
+          using assms(2-3) set_ideD(1) ide_exp ide_char by blast
+        show "finite (elem_of ` set a)"
+          using assms(1) set_ideD(1) setp_set_ide by presburger
+        show "finite (elem_of ` set (exp b c))"
+          using assms(2-3) set_ideD(1) setp_set_ide ide_exp by presburger
+        show "(\<lambda>x. arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
+                            (elem_of x)))
                  \<in> set a \<rightarrow> set (exp b c)"
         proof
           fix x
           assume x: "x \<in> set a"
-          show "UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
-                         (DOWN x))
+          show "arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
+                         (elem_of x))
                      \<in> set (exp b c)"
-            using assms x hlam_arr_to_hfun_in_hexp ide_to_hf_def DOWN_membI happ_mapsto
-                  UP_membI
+            using assms x hlam_arr_to_hfun_in_hexp ide_to_hf_def elem_of_membI happ_mapsto
+                  arr_of_membI
             by meson
         qed
       qed
       show "dom (\<Lambda> a b c f) = a"
         using assms(1) 1 \<Lambda>_def ide_char dom_mkArr mkIde_set by auto
       show "cod (\<Lambda> a b c f) = exp b c"
         using assms(2-3) 1 \<Lambda>_def cod_mkArr ide_exp mkIde_set by auto
     qed
 
     lemma lam_simps [simp]:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom f (prod a b) c"
     shows "arr (\<Lambda> a b c f)"
     and "dom (\<Lambda> a b c f) = a"
     and "cod (\<Lambda> a b c f) = exp b c"
       using assms lam_in_hom by blast+
 
     lemma Fun_lam:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom f (prod a b) c"
     shows "Fun (\<Lambda> a b c f) =
-           restrict (\<lambda>x. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
-                                  (DOWN x)))
+           restrict (\<lambda>x. arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
+                                  (elem_of x)))
                     (set a)"
       using assms arr_char lam_simps(1) \<Lambda>_def Fun_mkArr by simp
 
     lemma Fun_eval:
     assumes "ide b" and "ide c"
-    shows "Fun (eval b c) = restrict (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
+    shows "Fun (eval b c) = restrict (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
                                      (set (HF'.prod (exp b c) b))"
       using assms arr_char eval_simps(1) eval_def Fun_mkArr by force
 
     lemma Fun_prod:
     assumes "arr f" and "arr g" and "x \<in> set (prod (dom f) (dom g))"
-    shows "Fun (HF'.prod f g) x = UP \<langle>DOWN (Fun f (UP (hfst (DOWN x)))),
-                                     DOWN (Fun g (UP (hsnd (DOWN x))))\<rangle>"
+    shows "Fun (HF'.prod f g) x = arr_of \<langle>elem_of (Fun f (arr_of (hfst (elem_of x)))),
+                                     elem_of (Fun g (arr_of (hsnd (elem_of x))))\<rangle>"
     proof -
       have 1: "span (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
         using assms
         by (metis (no_types, lifting) HF'.prod_def HF'.prod_simps(1) HF'.tuple_ext not_arr_null)
       have 2: "Dom (comp f (pr1 (dom f) (dom g))) = set (prod (dom f) (dom g))"
         using assms
         by (metis (mono_tags, lifting) 1 dom_comp ide_dom pr0_simps(2))
       have 3: "Dom (comp g (pr0 (dom f) (dom g))) = set (prod (dom f) (dom g))"
         using assms 1 2 by force
       have "Fun (HF'.prod f g) x =
             Fun (HF'.tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))) x"
         using assms(3) HF'.prod_def by simp
-      also have "... = restrict (\<lambda>x. UP \<langle>DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
-                                         DOWN (Fun (comp g (pr0 (dom f) (dom g))) x)\<rangle>)
+      also have "... = restrict (\<lambda>x. arr_of \<langle>elem_of (Fun (comp f (pr1 (dom f) (dom g))) x),
+                                         elem_of (Fun (comp g (pr0 (dom f) (dom g))) x)\<rangle>)
                                 (Dom (comp f (pr1 (dom f) (dom g))))
                                 x"
         using assms 1 tuple_span_eq Fun_tuple by simp
-      also have "... = UP \<langle>DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
-                           DOWN (Fun (comp g (pr0 (dom f) (dom g))) x)\<rangle>"
+      also have "... = arr_of \<langle>elem_of (Fun (comp f (pr1 (dom f) (dom g))) x),
+                           elem_of (Fun (comp g (pr0 (dom f) (dom g))) x)\<rangle>"
         using assms(3) 2 by simp
-      also have "... = UP \<langle>DOWN (Fun f (UP (hfst (DOWN x)))),
-                           DOWN (Fun g (UP (hsnd (DOWN x))))\<rangle>"
+      also have "... = arr_of \<langle>elem_of (Fun f (arr_of (hfst (elem_of x)))),
+                           elem_of (Fun g (arr_of (hsnd (elem_of x))))\<rangle>"
       proof -
-        have "Fun (comp f (pr1 (dom f) (dom g))) x = Fun f (UP (hfst (DOWN x)))"
+        have "Fun (comp f (pr1 (dom f) (dom g))) x = Fun f (arr_of (hfst (elem_of x)))"
         proof -
           (* TODO: Figure out what is making this proof so "stiff". *)
           have 4: "seq f (pr1 (dom f) (dom g))"
             using assms 1 by blast
           have "Fun (comp f (pr1 (dom f) (dom g))) x =
                 restrict (Fun f \<circ> Fun (pr1 (dom f) (dom g))) (Dom (pr1 (dom f) (dom g))) x"
             using assms 1 Fun_comp [of f "pr1 (dom f) (dom g)"]
             by (metis (no_types, lifting))
           also have "... = (Fun f \<circ> Fun (pr1 (dom f) (dom g))) x"
           proof -
             have "x \<in> Dom (pr1 (dom f) (dom g))"
               using assms 1 2 4
               by (metis (no_types, lifting) dom_comp)
             thus ?thesis by simp
           qed
           also have "... = Fun f (Fun (pr1 (dom f) (dom g)) x)"
             by simp
-          also have "... = Fun f (UP (hfst (DOWN x)))"
+          also have "... = Fun f (arr_of (hfst (elem_of x)))"
             using assms 1 Fun_pr1 [of "dom f" "dom g"] ide_dom by simp
           finally show ?thesis by blast
         qed
         moreover
-        have "Fun (comp g (pr0 (dom f) (dom g))) x = Fun g (UP (hsnd (DOWN x)))"
+        have "Fun (comp g (pr0 (dom f) (dom g))) x = Fun g (arr_of (hsnd (elem_of x)))"
         proof -
           have 4: "seq g (pr0 (dom f) (dom g))"
             using assms 1 by blast
           have "Fun (comp g (pr0 (dom f) (dom g))) x =
                 restrict (Fun g \<circ> Fun (pr0 (dom f) (dom g))) (Dom (pr0 (dom f) (dom g))) x"
             using assms 1 Fun_comp [of g "pr0 (dom f) (dom g)"]
             by (metis (no_types, lifting))
           also have "... = (Fun g \<circ> Fun (pr0 (dom f) (dom g))) x"
           proof -
             have "x \<in> Dom (pr0 (dom f) (dom g))"
               using assms 1 2 4
               by (metis (no_types, lifting) dom_comp)
             thus ?thesis by simp
           qed
           also have "... = Fun g (Fun (pr0 (dom f) (dom g)) x)"
             by simp
-          also have "... = Fun g (UP (hsnd (DOWN x)))"
+          also have "... = Fun g (arr_of (hsnd (elem_of x)))"
             using assms 1 Fun_pr0 [of "dom f" "dom g"] ide_dom by simp
           finally show ?thesis by blast
         qed
         ultimately show ?thesis by simp
       qed
       finally show ?thesis by simp
     qed
 
     lemma prod_in_terms_of_tuple:
     assumes "arr f" and "arr g"
     shows "HF'.prod f g =
            tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
       using assms HF'.prod_def tuple_span_eq
       by (metis (no_types, lifting) HF'.prod_simps(1) HF'.tuple_ext not_arr_null)
 
     lemma eval_prod_lam:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom g (prod a b) c"
     shows "comp (eval b c) (HF'.prod (\<Lambda> a b c g) b) = g"
     proof -
       have ide_dom_lam: "ide (dom (\<Lambda> a b c g))"
         using assms lam_in_hom [of a b c g] ide_dom by blast
       have ide_dom_b: "ide (dom b)"
         using assms ide_dom ideD(1) by blast
       define \<Lambda>_pr1 where "\<Lambda>_pr1 = comp (\<Lambda> a b c g) (pr1 (dom (\<Lambda> a b c g)) (dom b))"
       define b_pr0 where "b_pr0 = comp b (pr0 (dom (\<Lambda> a b c g)) (dom b))"
       have lam_pr1: "in_hom \<Lambda>_pr1 (prod a b) (exp b c)"
       proof (unfold \<Lambda>_pr1_def, intro comp_in_homI)
         show "in_hom (pr1 (dom (\<Lambda> a b c g)) (dom b)) (prod a b) a"
           using assms ide_dom_lam ide_dom_b ideD(2) lam_simps(2) pr1_in_hom by auto
         show "in_hom (\<Lambda> a b c g) a (exp b c)"
           using assms lam_in_hom by simp
       qed
       have b_pr0: "in_hom b_pr0 (prod a b) b"
         using assms b_pr0_def
         by (metis (no_types, lifting) HF'.arr_pr0_iff HF'.cod_pr0 comp_in_homI'
             ideD(1-3) lam_simps(2) pr0_simps(2))
       have 1: "span \<Lambda>_pr1 b_pr0"
         using lam_pr1 b_pr0
         by (metis (no_types, lifting) in_homE)
       have tuple: "in_hom (tuple \<Lambda>_pr1 b_pr0) (prod a b) (prod (exp b c) b)"
         using 1 lam_pr1 b_pr0 tuple_in_hom [of \<Lambda>_pr1 b_pr0]
         by (metis (mono_tags, lifting) in_homE)
       define \<Lambda>_pr1' where "\<Lambda>_pr1' = comp (\<Lambda> a b c g) (pr1 a b)"
       define b_pr0' where "b_pr0' = pr0 a b"
       have lam_pr1_eq: "\<Lambda>_pr1 = \<Lambda>_pr1'"
         using assms \<Lambda>_pr1_def \<Lambda>_pr1'_def ideD(2) lam_simps(2) by auto
       have b_pr0_eq: "b_pr0 = b_pr0'"
         using assms b_pr0_def b_pr0'_def b_pr0 comp_ide_arr
         by (metis (no_types, lifting) ideD(2) in_homE lam_simps(2))
-      have Fun_pr0: "Fun (pr0 a b) = restrict (\<lambda>x. UP (hsnd (DOWN x))) (set (prod a b))"
+      have Fun_pr0: "Fun (pr0 a b) = restrict (\<lambda>x. arr_of (hsnd (elem_of x))) (set (prod a b))"
         using assms Fun_pr0 by simp
       have Fun_lam_pr1: "Fun \<Lambda>_pr1 =
                          restrict (Fun (\<Lambda> a b c g) o
-                                   restrict (\<lambda>x. UP (hfst (DOWN x))) (set (prod a b)))
+                                   restrict (\<lambda>x. arr_of (hfst (elem_of x))) (set (prod a b)))
                                   (set (prod a b))"
         using assms 1 Fun_comp Fun_pr1 lam_pr1_eq \<Lambda>_pr1'_def
         by (metis (no_types, lifting) pr1_simps(2))
       have "comp (eval b c) (HF'.prod (\<Lambda> a b c g) b) = comp (eval b c) (tuple \<Lambda>_pr1 b_pr0)"
         using assms \<Lambda>_pr1_def b_pr0_def 1 prod_in_terms_of_tuple ideD(1) lam_simps(1)
         by presburger
       also have 5: "... = comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')"
         using lam_pr1_eq b_pr0_eq by simp
       also have "... = g"
       proof (intro arr_eqI)
         have 2: "arr (comp (eval b c) (tuple \<Lambda>_pr1 b_pr0))"
           using assms tuple arr_char
           by (metis (no_types, lifting) in_homE seqI eval_simps(1-2) ide_exp prod_ide_eq)
         have 3: "arr g"
           using assms by blast
         have tuple': "in_hom (tuple \<Lambda>_pr1' b_pr0') (prod a b) (prod (exp b c) b)"
           using tuple lam_pr1_eq b_pr0_eq by blast
         have 4: "Dom g = set (prod a b)"
           using assms
           by (metis (no_types, lifting) in_homE)
         show par: "par (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) g"
           using assms tuple' 2 3 5
           by (metis (no_types, lifting) cod_comp dom_comp in_homE eval_simps(3))
         show "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) = Fun g"
         proof
           fix x
           have "x \<notin> set (prod a b) \<Longrightarrow> Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x = Fun g x"
           proof -
             have 5: "Fun g \<in> extensional (Dom g)"
               using assms 3 Fun_mapsto by simp
             moreover have "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) \<in> extensional (Dom g)"
               using 5 par Fun_mapsto by (metis (no_types, lifting) Int_iff)
             ultimately show "x \<notin> set (prod a b) \<Longrightarrow>
                              Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x = Fun g x"
               using 4 extensional_arb [of "Fun g" "Dom g" x]
                     extensional_arb [of "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0'))" "Dom g" x]
               by force
           qed
           moreover have "x \<in> set (prod a b) \<Longrightarrow>
                            Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x = Fun g x"
           proof -
             assume x: "x \<in> set (prod a b)"
             have 6: "Dom (tuple \<Lambda>_pr1' b_pr0') = set (prod a b)"
               using assms 4 tuple' par
               by (metis (no_types, lifting) in_homE)
             have "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x =
                   Fun (eval b c) (Fun (tuple \<Lambda>_pr1' b_pr0') x)"
             proof -
               have "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x =
                     (Fun (eval b c) \<circ> Fun (tuple \<Lambda>_pr1' b_pr0')) x"
                 using assms par x 6 Fun_comp [of "eval b c" "tuple \<Lambda>_pr1' b_pr0'"] by auto
               also have "... = Fun (eval b c) (Fun (tuple \<Lambda>_pr1' b_pr0') x)"
                 by simp
               finally show ?thesis by blast
             qed
-            also have "... = restrict (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
+            also have "... = restrict (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
                                       (set (HF'.prod (exp b c) b))
                                       (Fun (tuple \<Lambda>_pr1' b_pr0') x)"
               using assms Fun_eval by simp
-            also have "... = (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
+            also have "... = (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
                                (Fun (tuple \<Lambda>_pr1' b_pr0') x)"
             proof -
               have "Fun (tuple \<Lambda>_pr1' b_pr0') x \<in> set (HF'.prod (exp b c) b)"
               proof -
                 have "x \<in> Dom (tuple \<Lambda>_pr1' b_pr0')"
                   using x 6 by blast
                 moreover have "Cod (tuple \<Lambda>_pr1' b_pr0') = set (HF'.prod (exp b c) b)"
                   by (metis (no_types, lifting) in_homE assms(2-3) ide_exp
                       prod_ide_eq tuple')
                 moreover have "arr (tuple \<Lambda>_pr1' b_pr0')"
                   using tuple' by blast
                 ultimately show ?thesis
                   using tuple' Fun_mapsto [of "tuple \<Lambda>_pr1' b_pr0'"] by auto
               qed
               thus ?thesis
                 using restrict_apply by simp
             qed
-            also have "... = (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
-                               (UP \<langle>DOWN (Fun \<Lambda>_pr1' x), DOWN (Fun b_pr0' x)\<rangle>)"
+            also have "... = (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
+                               (arr_of \<langle>elem_of (Fun \<Lambda>_pr1' x), elem_of (Fun b_pr0' x)\<rangle>)"
             proof -
               have 7: "Dom \<Lambda>_pr1' = set (prod a b)"
                 using assms
                 by (metis (no_types, lifting) 1 comp_ide_arr ideD(2)
                     b_pr0_def lam_pr1_eq lam_simps(2) pr0_simps(2))
               moreover have "span \<Lambda>_pr1' b_pr0'"
                 using assms 1 b_pr0_eq lam_pr1_eq by auto
               moreover have "x \<in> Dom \<Lambda>_pr1'"
                 using x 7 by simp
               ultimately have "Fun (tuple \<Lambda>_pr1' b_pr0') x =
-                               UP \<langle>DOWN (Fun \<Lambda>_pr1' x), DOWN (Fun b_pr0' x)\<rangle>"
+                               arr_of \<langle>elem_of (Fun \<Lambda>_pr1' x), elem_of (Fun b_pr0' x)\<rangle>"
                 using assms x restrict_apply Fun_tuple by simp
               thus ?thesis by simp
             qed
-            also have "... = UP (happ (DOWN (Fun \<Lambda>_pr1' x)) (DOWN (Fun b_pr0' x)))"
+            also have "... = arr_of (happ (elem_of (Fun \<Lambda>_pr1' x)) (elem_of (Fun b_pr0' x)))"
               using assms by simp
-            also have "... = UP (happ (DOWN (UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
+            also have "... = arr_of (happ (elem_of (arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b)
                                                             (ide_to_hf c) (arr_to_hfun g))
-                                      (hfst (DOWN x)))))
-                                      (DOWN (UP (hsnd (DOWN x)))))"
+                                      (hfst (elem_of x)))))
+                                      (elem_of (arr_of (hsnd (elem_of x)))))"
             proof -
-              have "Fun b_pr0' x = UP (hsnd (DOWN x))"
+              have "Fun b_pr0' x = arr_of (hsnd (elem_of x))"
                 using assms x Fun_pr0 b_pr0'_def by simp
               moreover have "Fun \<Lambda>_pr1' x =
-                             UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+                             arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                             (arr_to_hfun g))
-                                      (hfst (DOWN x)))"
+                                      (hfst (elem_of x)))"
               proof -
                 have "Fun \<Lambda>_pr1' x =
                       restrict (Fun (\<Lambda> a b c g) o Fun (pr1 a b)) (Dom (pr1 a b)) x"
                   using assms x Fun_pr1 Fun_comp lam_pr1_eq Fun_lam_pr1 pr1_simps(1-2)
                   by presburger
                 also have "... = Fun (\<Lambda> a b c g) (Fun (pr1 a b) x)"
                   using assms x restrict_apply Fun_lam_pr1 Fun_pr1 calculation lam_pr1_eq
                   by auto
-                also have "... = restrict (\<lambda>x. UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
+                also have "... = restrict (\<lambda>x. arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b)
                                                               (ide_to_hf c) (arr_to_hfun g))
-                                          (DOWN x)))
+                                          (elem_of x)))
                                           (set a)
                                           (Fun (pr1 a b) x)"
                   using assms x Fun_lam by simp
-                also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+                also have "... = arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                 (arr_to_hfun g))
-                                          (DOWN (Fun (pr1 a b) x)))"
+                                          (elem_of (Fun (pr1 a b) x)))"
                 proof -
                   have "Fun (pr1 a b) x \<in> set a"
                   proof -
                     have "x \<in> Dom (pr1 a b)"
                       using assms x pr1_simps(1-2) by auto
                     moreover have "Cod (pr1 a b) = set a"
                       using assms HF'.cod_pr1 pr1_simps(1) by auto
                     moreover have "arr (pr1 a b)"
                       using assms arr_char by blast
                     ultimately show ?thesis
                       using Fun_mapsto [of "pr1 a b"] by auto
                   qed
                   thus ?thesis
                     using restrict_apply by simp
                 qed
-                also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+                also have "... = arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                 (arr_to_hfun g))
-                                          (hfst (DOWN x)))"
+                                          (hfst (elem_of x)))"
                   using assms x Fun_pr1 Fun_lam [of a b c g] by simp
                 finally show ?thesis by simp
               qed
               ultimately show ?thesis by simp
             qed
-            also have "... = UP (happ (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+            also have "... = arr_of (happ (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                   (arr_to_hfun g))
-                                            (hfst (DOWN x)))
-                                      (hsnd (DOWN x)))"
+                                            (hfst (elem_of x)))
+                                      (hsnd (elem_of x)))"
               by simp
-            also have "... = UP (happ (arr_to_hfun g) (DOWN x))"
+            also have "... = arr_of (happ (arr_to_hfun g) (elem_of x))"
               using assms x happ_hlam
-              by (metis (no_types, lifting) prod_def DOWN_membI HCollect_iff ide_dom
+              by (metis (no_types, lifting) prod_def elem_of_membI HCollect_iff ide_dom
                   in_homE UNIV_I arr_to_hfun_in_hexp hexp_def hfst_conv hsnd_conv
                   ide_to_hf_hf_to_ide timesE)
             also have "... = Fun g x"
               using assms x 3 4 Fun_char [of g] restrict_apply [of "Fun g" "Dom g" x]
               by simp
             finally show ?thesis by simp
           qed
           ultimately show "Fun (comp (eval b c) (tuple \<Lambda>_pr1' b_pr0')) x = Fun g x"
             by auto
         qed
       qed
       finally show ?thesis by simp
     qed
 
     lemma lam_eval_prod:
     assumes "ide a" and "ide b" and "ide c"
     and "in_hom h a (exp b c)"
     shows "\<Lambda> a b c (comp (eval b c) (HF'.prod h b)) = h"
     proof (intro arr_eqI)
       have 0: "in_hom (comp (eval b c) (HF'.prod h b)) (prod a b) c"
       proof
         show "in_hom (HF'.prod h b) (prod a b) (HF'.prod (exp b c) b)"
         proof
           show 1: "arr (HF'.prod h b)"
             using assms HF'.prod_in_hom'
             by (metis (no_types, lifting) ideD(1) in_homE)
           show "dom (HF'.prod h b) = prod a b"
             using assms 1
             by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE prod_ide_eq)
           show "cod (HF'.prod h b) = HF'.prod (exp b c) b"
             using assms 1
             by (metis (no_types, lifting) HF'.prod_simps(3) ideD(1,3) in_homE)
         qed
         show "in_hom (eval b c) (HF'.prod (exp b c) b) c"
           using assms by blast
       qed
       have 1: "in_hom (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) a (exp b c)"
         using assms 0 by blast
       have 2: "Fun (comp (eval b c) (HF'.prod h b)) =
                restrict (Fun (eval b c) \<circ> Fun (HF'.prod h b))
                         (set (HF'.prod a b))"
       proof -
         have "seq (eval b c) (HF'.prod h b)"
           using assms 1
           by (metis (no_types, lifting) 0 in_homE)
         moreover have "Dom (HF'.prod h b) = set (HF'.prod a b)"
           using assms
           by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE)
         ultimately show ?thesis
           using assms Fun_comp [of "eval b c" "HF'.prod h b"] by simp
       qed
       show par: "par (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) h"
         using assms 1
         by (metis (no_types, lifting) in_homE)
       show "Fun (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) = Fun h"
       proof
         fix x
         show "Fun (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
         proof -
           have "x \<notin> set a \<Longrightarrow> ?thesis"
             using assms 1 Fun_mapsto
                   extensional_arb [of "Fun h" "set a" x]
                   extensional_arb [of "Fun (\<Lambda> a b c (comp (eval b c) (HF'.prod h b)))"
                                       "set a" x]
             by (metis (no_types, lifting) 0 Int_iff lam_simps(2) par)
           moreover have "x \<in> set a \<Longrightarrow> ?thesis"
           proof -
             assume x: "x \<in> set a"
             have 3: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
               using assms 0 in_homE prod_ide_eq by auto
             have 4: "cod (comp (eval b c) (HF'.prod h b)) = c"
               using assms 0 by blast
             have 5: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
               using assms 3
               by (metis (mono_tags, lifting))
             have 6: "cod (comp (eval b c) (HF'.prod h b)) = c"
               using assms 4 by (metis (no_types, lifting))
             have 7: "arr_to_hfun (comp (eval b c) (HF'.prod h b)) =
                      \<lbrace>xy \<^bold>\<in> ide_to_hf (HF'.prod a b) * ide_to_hf c.
-                        hsnd xy = DOWN (Fun (comp (eval b c) (HF'.prod h b)) (UP (hfst xy)))\<rbrace>"
+                        hsnd xy = elem_of (Fun (comp (eval b c) (HF'.prod h b)) (arr_of (hfst xy)))\<rbrace>"
               unfolding arr_to_hfun_def
               using 2 5 6 by metis
             have "Fun (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) x =
-                  UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
+                  arr_of (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                  (arr_to_hfun (comp (eval b c) (HF'.prod h b))))
-                           (DOWN x))"
+                           (elem_of x))"
               using assms 0 x Fun_lam by auto
-            also have "... = UP \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                                   \<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle>
+            also have "... = arr_of \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
+                                   \<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle>
                                       \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))\<rbrace>"
             proof -
               have "seq (eval b c) (HF'.prod h b)"
                 using assms 0 by blast
               moreover have "ide_to_hf (dom (comp (eval b c) (HF'.prod h b))) =
                              ide_to_hf a * ide_to_hf b"
                 using assms 1 3
                 by (metis (no_types, lifting) prod_def UNIV_I ide_to_hf_hf_to_ide prod_ide_eq)
               moreover have "ide_to_hf (cod (comp (eval b c) (HF'.prod h b))) = ide_to_hf c"
                 using assms 2 4 by auto
               ultimately show ?thesis
-                using assms 0 x happ_hlam(3) DOWN_membI
+                using assms 0 x happ_hlam(3) elem_of_membI
                       hfun_arr_to_hfun [of "comp (eval b c) (HF'.prod h b)"]
                 by simp
             qed
-            also have "... = UP \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                                       (UP \<langle>DOWN x, hfst yz\<rangle>))\<rbrace>"
+            also have "... = arr_of \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
+                                   hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                                       (arr_of \<langle>elem_of x, hfst yz\<rangle>))\<rbrace>"
             proof -
               have "\<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                       \<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle>
+                       \<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle>
                           \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))\<rbrace> =
                     \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                                       (UP \<langle>DOWN x, hfst yz\<rangle>))\<rbrace>"
+                                   hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                                       (arr_of \<langle>elem_of x, hfst yz\<rangle>))\<rbrace>"
               proof
                 fix yz
                 show "yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                                   \<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle>
+                                   \<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle>
                                       \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))\<rbrace> \<longleftrightarrow>
                       yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                                     (UP \<langle>DOWN x, hfst yz\<rangle>))\<rbrace>"
+                                   hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                                     (arr_of \<langle>elem_of x, hfst yz\<rangle>))\<rbrace>"
                 proof -
                   have "yz \<^bold>\<in> ide_to_hf b * ide_to_hf c \<Longrightarrow>
-                        \<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle> \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))
-                          \<longleftrightarrow> hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                                     (UP \<langle>DOWN x, hfst yz\<rangle>))"
+                        \<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle> \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))
+                          \<longleftrightarrow> hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                                     (arr_of \<langle>elem_of x, hfst yz\<rangle>))"
                   proof -
                     assume yz: "yz \<^bold>\<in> ide_to_hf b * ide_to_hf c"
-                    have "\<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle>
+                    have "\<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle>
                              \<^bold>\<in> arr_to_hfun (comp (eval b c) (HF'.prod h b))
                             \<longleftrightarrow>
-                          \<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle> \<^bold>\<in> ide_to_hf (HF'.prod a b) * ide_to_hf c \<and>
-                          hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                         (UP \<langle>DOWN x, hfst yz\<rangle>))"
+                          \<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle> \<^bold>\<in> ide_to_hf (HF'.prod a b) * ide_to_hf c \<and>
+                          hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                         (arr_of \<langle>elem_of x, hfst yz\<rangle>))"
                       using 7 by auto
-                    moreover have "\<langle>\<langle>DOWN x, hfst yz\<rangle>, hsnd yz\<rangle>
+                    moreover have "\<langle>\<langle>elem_of x, hfst yz\<rangle>, hsnd yz\<rangle>
                                       \<^bold>\<in> ide_to_hf (prod a b) * ide_to_hf c"
                     proof -
-                      have "\<langle>DOWN x, hfst yz\<rangle> \<^bold>\<in> ide_to_hf (HF'.prod a b)"
+                      have "\<langle>elem_of x, hfst yz\<rangle> \<^bold>\<in> ide_to_hf (HF'.prod a b)"
                         using assms x yz
-                        by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
+                        by (metis (no_types, lifting) prod_def elem_of_membI UNIV_I hfst_conv
                             ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                       thus ?thesis
                         using yz assms(1-2) prod_ide_eq by auto
                     qed
                     ultimately show ?thesis
                       using assms(1-2) prod_ide_eq by auto
                   qed
                   thus ?thesis by auto
                 qed
               qed
               thus ?thesis by simp
             qed
-            also have "... = UP \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+            also have "... = arr_of \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
             proof -
               have "\<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c.
-                       hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                               (UP \<langle>DOWN x, hfst yz\<rangle>))\<rbrace> =
-                    \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+                       hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                               (arr_of \<langle>elem_of x, hfst yz\<rangle>))\<rbrace> =
+                    \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
               proof -
                 have "\<And>yz. yz \<^bold>\<in> ide_to_hf b * ide_to_hf c \<Longrightarrow>
-                             hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                            (UP \<langle>DOWN x, hfst yz\<rangle>))
+                             hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                            (arr_of \<langle>elem_of x, hfst yz\<rangle>))
                                \<longleftrightarrow>
-                             yz \<^bold>\<in> DOWN (Fun h x)"
+                             yz \<^bold>\<in> elem_of (Fun h x)"
                 proof -
                   fix yz
                   assume yz: "yz \<^bold>\<in> ide_to_hf b * ide_to_hf c"
-                  have 7: "UP \<langle>DOWN x, hfst yz\<rangle> \<in> set (HF'.prod a b)"
-                    using assms x yz UP_membI
-                    by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
+                  have 7: "arr_of \<langle>elem_of x, hfst yz\<rangle> \<in> set (HF'.prod a b)"
+                    using assms x yz arr_of_membI
+                    by (metis (no_types, lifting) prod_def elem_of_membI UNIV_I hfst_conv
                         ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                   have 8: "Fun h x \<in> set (exp b c)"
                   proof -
                     have "Fun h x \<in> Cod h"
                       using assms x Fun_mapsto by blast
                     moreover have "Cod h = set (exp b c)"
                       using assms 0 lam_simps(3) par by auto
                     ultimately show ?thesis by blast
                   qed
-                  show "hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                            (UP \<langle>DOWN x, hfst yz\<rangle>))
+                  show "hsnd yz = elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                            (arr_of \<langle>elem_of x, hfst yz\<rangle>))
                            \<longleftrightarrow>
-                        yz \<^bold>\<in> DOWN (Fun h x)"
+                        yz \<^bold>\<in> elem_of (Fun h x)"
                   proof -
-                    have "Fun (comp (eval b c) (HF'.prod h b)) (UP \<langle>DOWN x, hfst yz\<rangle>) =
-                            UP (happ (DOWN (Fun h x)) (hfst yz))"
+                    have "Fun (comp (eval b c) (HF'.prod h b)) (arr_of \<langle>elem_of x, hfst yz\<rangle>) =
+                            arr_of (happ (elem_of (Fun h x)) (hfst yz))"
                     proof -
-                      have "Fun (comp (eval b c) (HF'.prod h b)) (UP \<langle>DOWN x, hfst yz\<rangle>) =
+                      have "Fun (comp (eval b c) (HF'.prod h b)) (arr_of \<langle>elem_of x, hfst yz\<rangle>) =
                             restrict (Fun (eval b c) \<circ> Fun (HF'.prod h b))
                                      (set (HF'.prod a b))
-                                     (UP \<langle>DOWN x, hfst yz\<rangle>)"
+                                     (arr_of \<langle>elem_of x, hfst yz\<rangle>)"
                         using assms x yz 2 by simp
                       also have "... = Fun (eval b c)
-                                               (Fun (HF'.prod h b) (UP \<langle>DOWN x, hfst yz\<rangle>))"
+                                               (Fun (HF'.prod h b) (arr_of \<langle>elem_of x, hfst yz\<rangle>))"
                         using 7 by simp
                       also have "... = Fun (eval b c)
-                                               (UP \<langle>DOWN (Fun h x),
-                                                    DOWN (Fun b (UP (hfst yz)))\<rangle>)"
+                                               (arr_of \<langle>elem_of (Fun h x),
+                                                    elem_of (Fun b (arr_of (hfst yz)))\<rangle>)"
                       proof -
-                        have "Fun (HF'.prod h b) (UP \<langle>DOWN x, hfst yz\<rangle>) =
-                           UP \<langle>DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))\<rangle>"
+                        have "Fun (HF'.prod h b) (arr_of \<langle>elem_of x, hfst yz\<rangle>) =
+                           arr_of \<langle>elem_of (Fun h x), elem_of (Fun b (arr_of (hfst yz)))\<rangle>"
                         proof -
-                          have "Fun (HF'.prod h b) (UP \<langle>DOWN x, hfst yz\<rangle>) =
-                                UP \<langle>DOWN (Fun h (UP (hfst (DOWN (UP \<langle>DOWN x, hfst yz\<rangle>))))),
-                                    DOWN (Fun b (UP (hsnd (DOWN (UP \<langle>DOWN x, hfst yz\<rangle>)))))\<rangle>"
+                          have "Fun (HF'.prod h b) (arr_of \<langle>elem_of x, hfst yz\<rangle>) =
+                                arr_of \<langle>elem_of (Fun h (arr_of (hfst (elem_of (arr_of \<langle>elem_of x, hfst yz\<rangle>))))),
+                                    elem_of (Fun b (arr_of (hsnd (elem_of (arr_of \<langle>elem_of x, hfst yz\<rangle>)))))\<rangle>"
                           proof -
-                            have "UP \<langle>DOWN x, hfst yz\<rangle> \<in> set (prod (dom h) (dom b))"
+                            have "arr_of \<langle>elem_of x, hfst yz\<rangle> \<in> set (prod (dom h) (dom b))"
                               using assms x yz 7
                               by (metis (no_types, lifting) ideD(2) in_homE prod_ide_eq)
                             thus ?thesis
                               using assms x yz Fun_prod ideD(1) by blast
                           qed
-                          also have "... = UP \<langle>DOWN (Fun h (UP (DOWN x))),
-                                               DOWN (Fun b (UP (hfst yz)))\<rangle>"
+                          also have "... = arr_of \<langle>elem_of (Fun h (arr_of (elem_of x))),
+                                               elem_of (Fun b (arr_of (hfst yz)))\<rangle>"
                             using assms x yz by simp
-                          also have "... = UP \<langle>DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))\<rangle>"
-                            using assms(1) set_subset_Univ x by force
+                          also have "... = arr_of \<langle>elem_of (Fun h x), elem_of (Fun b (arr_of (hfst yz)))\<rangle>"
+                            using assms(1) set_ideD(1) x by force
                           finally show ?thesis by simp
                         qed
                         thus ?thesis by simp
                       qed
-                      also have "... = Fun (eval b c) (UP \<langle>DOWN (Fun h x), hfst yz\<rangle>)"
-                        using assms x yz Fun_ide ide_char UP_membI by auto
-                      also have "... = restrict (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
+                      also have "... = Fun (eval b c) (arr_of \<langle>elem_of (Fun h x), hfst yz\<rangle>)"
+                        using assms x yz Fun_ide ide_char arr_of_membI by auto
+                      also have "... = restrict (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
                                                 (set (HF'.prod (exp b c) b))
-                                                (UP \<langle>DOWN (Fun h x), hfst yz\<rangle>)"
+                                                (arr_of \<langle>elem_of (Fun h x), hfst yz\<rangle>)"
                         using assms Fun_eval [of b c] by simp
-                      also have "... = (\<lambda>x. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
-                                         (UP \<langle>DOWN (Fun h x), hfst yz\<rangle>)"
+                      also have "... = (\<lambda>x. arr_of (happ (hfst (elem_of x)) (hsnd (elem_of x))))
+                                         (arr_of \<langle>elem_of (Fun h x), hfst yz\<rangle>)"
                       proof -
-                        have "UP \<langle>DOWN (Fun h x), hfst yz\<rangle>
+                        have "arr_of \<langle>elem_of (Fun h x), hfst yz\<rangle>
                                  \<in> set (HF'.prod (exp b c) b)"
                         proof -
                           have 1: "ide_to_hf (HF'.prod (exp b c) b) =
-                                   HF (DOWN ` set (HF'.prod (exp b c) b))"
+                                   HF (elem_of ` set (HF'.prod (exp b c) b))"
                             unfolding ide_to_hf_def by blast
-                          have "\<langle>DOWN (Fun h x), hfst yz\<rangle>
-                                  \<^bold>\<in> HF (DOWN ` set (HF'.prod (exp b c) b))"
+                          have "\<langle>elem_of (Fun h x), hfst yz\<rangle>
+                                  \<^bold>\<in> HF (elem_of ` set (HF'.prod (exp b c) b))"
                             using assms x yz 1 8 Fun_mapsto [of h]
-                            by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I
+                            by (metis (no_types, lifting) prod_def elem_of_membI UNIV_I
                                 hfst_conv ide_exp ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                           thus ?thesis
-                            using assms x yz 1 UP_membI [of "\<langle>DOWN (Fun h x), hfst yz\<rangle>"]
+                            using assms x yz 1 arr_of_membI [of "\<langle>elem_of (Fun h x), hfst yz\<rangle>"]
                             by auto
                         qed
                         thus ?thesis by simp
                       qed
-                      also have "... = UP (happ (DOWN (Fun h x)) (hfst yz))"
+                      also have "... = arr_of (happ (elem_of (Fun h x)) (hfst yz))"
                         by simp
                       finally show ?thesis by simp
                     qed
-                    hence 9: "DOWN (Fun (comp (eval b c) (HF'.prod h b))
-                                        (UP \<langle>DOWN x, hfst yz\<rangle>)) =
-                              happ (DOWN (Fun h x)) (hfst yz)"
+                    hence 9: "elem_of (Fun (comp (eval b c) (HF'.prod h b))
+                                        (arr_of \<langle>elem_of x, hfst yz\<rangle>)) =
+                              happ (elem_of (Fun h x)) (hfst yz)"
                       by simp
                     show ?thesis
                     proof -
-                      have "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
-                              \<longleftrightarrow> yz \<^bold>\<in> DOWN (Fun h x)"
+                      have "hsnd yz = happ (elem_of (Fun h x)) (hfst yz)
+                              \<longleftrightarrow> yz \<^bold>\<in> elem_of (Fun h x)"
                       proof
-                        have 10: "\<exists>!z. \<langle>hfst yz, z\<rangle> \<^bold>\<in> DOWN (Fun h x)"
+                        have 10: "\<exists>!z. \<langle>hfst yz, z\<rangle> \<^bold>\<in> elem_of (Fun h x)"
                         proof -
-                          have "hfun (ide_to_hf b) (ide_to_hf c) (DOWN (Fun h x))"
+                          have "hfun (ide_to_hf b) (ide_to_hf c) (elem_of (Fun h x))"
                             using assms x 8
-                            by (metis (no_types, lifting) DOWN_membI HCollect_iff UNIV_I
+                            by (metis (no_types, lifting) elem_of_membI HCollect_iff UNIV_I
                                 exp_def hexp_def ide_exp ide_to_hf_hf_to_ide)
                           thus ?thesis
                             using assms yz
-                                  hfunE [of "ide_to_hf b" "ide_to_hf c" "DOWN (Fun h x)"]
+                                  hfunE [of "ide_to_hf b" "ide_to_hf c" "elem_of (Fun h x)"]
                             by (metis (no_types, lifting) hfst_conv timesE)
                         qed
-                        show "yz \<^bold>\<in> DOWN (Fun h x)
-                                \<Longrightarrow> hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
+                        show "yz \<^bold>\<in> elem_of (Fun h x)
+                                \<Longrightarrow> hsnd yz = happ (elem_of (Fun h x)) (hfst yz)"
                         proof -
-                          assume yz1: "yz \<^bold>\<in> DOWN (Fun h x)"
-                          show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
+                          assume yz1: "yz \<^bold>\<in> elem_of (Fun h x)"
+                          show "hsnd yz = happ (elem_of (Fun h x)) (hfst yz)"
                             unfolding app_def
                             using assms x yz yz1 10 hfun_arr_to_hfun arr_to_hfun_def
                                   the1_equality
-                                    [of "\<lambda>y. \<langle>hfst yz, y\<rangle> \<^bold>\<in> DOWN (Fun h x)" "hsnd yz"]
+                                    [of "\<lambda>y. \<langle>hfst yz, y\<rangle> \<^bold>\<in> elem_of (Fun h x)" "hsnd yz"]
                             by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
                         qed
-                        show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
-                                \<Longrightarrow> yz \<^bold>\<in> DOWN (Fun h x)"
+                        show "hsnd yz = happ (elem_of (Fun h x)) (hfst yz)
+                                \<Longrightarrow> yz \<^bold>\<in> elem_of (Fun h x)"
                           unfolding app_def
                           using assms x yz 10
-                                theI' [of "\<lambda>y. \<langle>hfst yz, y\<rangle> \<^bold>\<in> DOWN (Fun h x)"]
+                                theI' [of "\<lambda>y. \<langle>hfst yz, y\<rangle> \<^bold>\<in> elem_of (Fun h x)"]
                           by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
                       qed
                       thus ?thesis
                         using 9 by simp
                     qed
                   qed
                 qed
                 thus ?thesis by blast
               qed
               thus ?thesis by simp
             qed
             also have "... = Fun h x"
             proof -
-              have H: "Fun h x = restrict (\<lambda>x. UP (happ (arr_to_hfun h) (DOWN x))) (Dom h) x"
+              have H: "Fun h x = restrict (\<lambda>x. arr_of (happ (arr_to_hfun h) (elem_of x))) (Dom h) x"
               proof -
                 have "arr h"
                   using assms by blast
                 thus ?thesis
                   using assms x Fun_char by simp
               qed
-              also have "... = UP (happ (arr_to_hfun h) (DOWN x))"
+              also have "... = arr_of (happ (arr_to_hfun h) (elem_of x))"
                 using assms x par
                 by (metis (no_types, lifting) 0 lam_simps(2) restrict_apply)
-              also have "... = UP (THE g. \<langle>DOWN x, g\<rangle> \<^bold>\<in> arr_to_hfun h)"
+              also have "... = arr_of (THE g. \<langle>elem_of x, g\<rangle> \<^bold>\<in> arr_to_hfun h)"
                 using app_def by simp
-              also have "... = UP \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+              also have "... = arr_of \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
               proof -
-                have ex_un_g: "\<exists>!g. \<langle>DOWN x, g\<rangle> \<^bold>\<in> arr_to_hfun h"
+                have ex_un_g: "\<exists>!g. \<langle>elem_of x, g\<rangle> \<^bold>\<in> arr_to_hfun h"
                   using assms x arr_to_hfun_def hfun_arr_to_hfun
                         hfunE [of "ide_to_hf a" "ide_to_hf (exp b c)" "arr_to_hfun h"]
-                  by (metis (no_types, lifting) DOWN_membI in_homE)
+                  by (metis (no_types, lifting) elem_of_membI in_homE)
                 moreover have
-                   "\<langle>DOWN x, \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>\<rangle>
+                   "\<langle>elem_of x, \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>\<rangle>
                        \<^bold>\<in> arr_to_hfun h"
                 proof -
-                  have "DOWN (Fun h x) =
-                        \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+                  have "elem_of (Fun h x) =
+                        \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
                   proof
                     fix yz
-                    show "yz \<^bold>\<in> DOWN (Fun h x) \<longleftrightarrow>
-                          yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+                    show "yz \<^bold>\<in> elem_of (Fun h x) \<longleftrightarrow>
+                          yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
                     proof
-                      show "yz \<^bold>\<in> DOWN (Fun h x)
-                              \<Longrightarrow> yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>"
+                      show "yz \<^bold>\<in> elem_of (Fun h x)
+                              \<Longrightarrow> yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>"
                       proof -
-                        assume yz: "yz \<^bold>\<in> DOWN (Fun h x)"
+                        assume yz: "yz \<^bold>\<in> elem_of (Fun h x)"
                         have "yz \<^bold>\<in> ide_to_hf b * ide_to_hf c"
                         proof -
-                          have "DOWN (Fun h x) \<^bold>\<in> hexp (ide_to_hf b) (ide_to_hf c)"
+                          have "elem_of (Fun h x) \<^bold>\<in> hexp (ide_to_hf b) (ide_to_hf c)"
                           proof -
                             have "ide (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                               using assms exp_def ide_exp by auto
                             moreover have
                               "Fun h x \<in> set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                             proof -
                               have "Fun h x \<in> Cod h"
                                 using assms x Fun_mapsto by blast
                               moreover have
                                 "Cod h = set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                                 using assms 0 exp_def lam_simps(3) par by auto
                               ultimately show ?thesis by blast
                             qed
                             ultimately show ?thesis
-                              using DOWN_membI [of "hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
+                              using elem_of_membI [of "hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
                                                    "Fun h x"]
                               by (simp add: ide_to_hf_hf_to_ide)
                           qed
                           thus ?thesis
                             using assms yz hexp_def by auto
                         qed
                         thus ?thesis
                           using assms x yz by blast
                       qed
-                      show "yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> DOWN (Fun h x)\<rbrace>
-                              \<Longrightarrow> yz \<^bold>\<in> DOWN (Fun h x)"
+                      show "yz \<^bold>\<in> \<lbrace>yz \<^bold>\<in> ide_to_hf b * ide_to_hf c. yz \<^bold>\<in> elem_of (Fun h x)\<rbrace>
+                              \<Longrightarrow> yz \<^bold>\<in> elem_of (Fun h x)"
                         using assms by simp
                     qed
                   qed
-                  moreover have "UP (DOWN x) = x"
-                    using assms x ide_char set_subset_Univ UP_DOWN
-                    by (meson subsetD)
+                  moreover have "arr_of (elem_of x) = x"
+                    using arr_of_elem_of assms(1) set_ideD(1) x by blast
                   ultimately show ?thesis
                     using assms x arr_to_hfun_def ex_un_g by auto
                 qed
                 ultimately show ?thesis
-                  using assms x theI' [of "\<lambda>g. \<langle>DOWN x, g\<rangle> \<^bold>\<in> arr_to_hfun h"]
+                  using assms x theI' [of "\<lambda>g. \<langle>elem_of x, g\<rangle> \<^bold>\<in> arr_to_hfun h"]
                   by fastforce
               qed
               finally show ?thesis
                 using assms x by simp
             qed
             finally show ?thesis by simp
           qed
           ultimately show "Fun (\<Lambda> a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
             by blast
         qed
       qed
     qed
 
     section "The Main Results"
 
     interpretation cartesian_closed_category comp
     proof -
       interpret elementary_cartesian_closed_category comp pr0 pr1
                        some_terminal trm exp eval \<Lambda>
         using ide_exp eval_in_hom lam_in_hom prod_ide_eq eval_prod_lam lam_eval_prod
         by unfold_locales auto
       show "cartesian_closed_category comp"
         using is_cartesian_closed_category by simp
     qed
 
     theorem is_cartesian_closed_category:
     shows "cartesian_closed_category comp"
       ..
 
     theorem is_category_with_finite_limits:
     shows "category_with_finite_limits comp"
     proof
       fix J :: "'j comp"
       assume J: "category J"
       interpret J: category J
         using J by simp
       assume finite: "finite (Collect J.arr)"
       have "has_products (Collect J.ide)"
       proof -
         have "Collect J.ide \<noteq> UNIV"
           using J.not_arr_null by blast
         moreover have "finite (Collect J.ide)"
         proof -
           have "Collect J.ide \<subseteq> Collect J.arr"
             by auto
           thus ?thesis
             using finite J.ideD(1) finite_subset by blast
         qed
         ultimately show ?thesis
           using finite has_finite_products' by simp
       qed
       moreover have "has_products (Collect J.arr)"
       proof -
         have "Collect J.arr \<noteq> UNIV"
           using J.not_arr_null by blast
         thus ?thesis
           using finite has_finite_products' by simp
       qed
       ultimately show "has_limits_of_shape J"
         using J.category_axioms has_limits_if_has_products [of J] by simp
     qed
 
   end
 
 end
 
diff --git a/thys/Category3/Limit.thy b/thys/Category3/Limit.thy
--- a/thys/Category3/Limit.thy
+++ b/thys/Category3/Limit.thy
@@ -1,6208 +1,6271 @@
 (*  Title:       Limit
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter Limit
 
 theory Limit
 imports FreeCategory DiscreteCategory Adjunction
 begin
 
   text\<open>
     This theory defines the notion of limit in terms of diagrams and cones and relates
     it to the concept of a representation of a functor.  The diagonal functor associated
     with a diagram shape @{term J} is defined and it is shown that a right adjoint to
     the diagonal functor gives limits of shape @{term J} and that a category has limits
     of shape @{term J} if and only if the diagonal functor is a left adjoint functor.
     Products and equalizers are defined as special cases of limits, and it is shown
     that a category with equalizers has limits of shape @{term J} if it has products
     indexed by the sets of objects and arrows of @{term J}.
     The existence of limits in a set category is investigated, and it is shown that
     every set category has equalizers and that a set category @{term S} has @{term I}-indexed
     products if and only if the universe of @{term S} ``admits @{term I}-indexed tupling.''
     The existence of limits in functor categories is also developed, showing that
     limits in functor categories are ``determined pointwise'' and that a functor category
     @{term "[A, B]"} has limits of shape @{term J} if @{term B} does.
     Finally, it is shown that the Yoneda functor preserves limits.
 
     This theory concerns itself only with limits; I have made no attempt to consider colimits.
     Although it would be possible to rework the entire development in dual form,
     it is possible that there is a more efficient way to dualize at least parts of it without
     repeating all the work.  This is something that deserves further thought.
 \<close>
 
   section "Representations of Functors"
 
   text\<open>
     A representation of a contravariant functor \<open>F: Cop \<rightarrow> S\<close>, where @{term S}
-    is a replete set category that is the target of a hom-functor for @{term C}, consists of
+    is a set category that is the target of a hom-functor for @{term C}, consists of
     an object @{term a} of @{term C} and a natural isomorphism @{term "\<Phi>: Y a \<rightarrow> F"},
     where \<open>Y: C \<rightarrow> [Cop, S]\<close> is the Yoneda functor.
 \<close>
 
   locale representation_of_functor =
     C: category C +
     Cop: dual_category C +
-    S: replete_set_category S +
+    S: set_category S setp +
     F: "functor" Cop.comp S F +
-    Hom: hom_functor C S \<phi> +
-    Ya: yoneda_functor_fixed_object C S \<phi> a +
+    Hom: hom_functor C S setp \<phi> +
+    Ya: yoneda_functor_fixed_object C S setp \<phi> a +
     natural_isomorphism Cop.comp S \<open>Ya.Y a\<close> F \<Phi>
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   and \<Phi> :: "'c \<Rightarrow> 's"
   begin
 
      abbreviation Y where "Y \<equiv> Ya.Y"
      abbreviation \<psi> where "\<psi> \<equiv> Hom.\<psi>"
 
   end
 
   text\<open>
     Two representations of the same functor are uniquely isomorphic.
 \<close>
 
   locale two_representations_one_functor =
     C: category C +
     Cop: dual_category C +
-    S: replete_set_category S +
-    F: set_valued_functor Cop.comp S F +
-    yoneda_functor C S \<phi> +
-    Ya: yoneda_functor_fixed_object C S \<phi> a +
-    Ya': yoneda_functor_fixed_object C S \<phi> a' +
-    \<Phi>: representation_of_functor C S \<phi> F a \<Phi> +
-    \<Phi>': representation_of_functor C S \<phi> F a' \<Phi>'
+    S: set_category S setp +
+    F: set_valued_functor Cop.comp S setp F +
+    yoneda_functor C S setp \<phi> +
+    Ya: yoneda_functor_fixed_object C S setp \<phi> a +
+    Ya': yoneda_functor_fixed_object C S setp \<phi> a' +
+    \<Phi>: representation_of_functor C S setp \<phi> F a \<Phi> +
+    \<Phi>': representation_of_functor C S setp \<phi> F a' \<Phi>'
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and F :: "'c \<Rightarrow> 's"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and a :: 'c
   and \<Phi> :: "'c \<Rightarrow> 's"
   and a' :: 'c
   and \<Phi>' :: "'c \<Rightarrow> 's"
   begin
 
     interpretation \<Psi>: inverse_transformation Cop.comp S \<open>Y a\<close> F \<Phi> ..
     interpretation \<Psi>': inverse_transformation Cop.comp S \<open>Y a'\<close> F \<Phi>' ..
     interpretation \<Phi>\<Psi>': vertical_composite Cop.comp S \<open>Y a\<close> F \<open>Y a'\<close> \<Phi> \<Psi>'.map ..
     interpretation \<Phi>'\<Psi>: vertical_composite Cop.comp S \<open>Y a'\<close> F \<open>Y a\<close> \<Phi>' \<Psi>.map ..
 
     lemma are_uniquely_isomorphic:
       shows "\<exists>!\<phi>. \<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> C.iso \<phi> \<and> map \<phi> = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
     proof -
       interpret \<Phi>\<Psi>': natural_isomorphism Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<Phi>\<Psi>'.map
         using \<Phi>.natural_isomorphism_axioms \<Psi>'.natural_isomorphism_axioms
               natural_isomorphisms_compose
         by blast
       interpret \<Phi>'\<Psi>: natural_isomorphism Cop.comp S \<open>Y a'\<close> \<open>Y a\<close> \<Phi>'\<Psi>.map
         using \<Phi>'.natural_isomorphism_axioms \<Psi>.natural_isomorphism_axioms
               natural_isomorphisms_compose
         by blast
       interpret \<Phi>\<Psi>'_\<Phi>'\<Psi>: inverse_transformations Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<Phi>\<Psi>'.map \<Phi>'\<Psi>.map
       proof
         fix x
         assume X: "Cop.ide x"
         show "S.inverse_arrows (\<Phi>\<Psi>'.map x) (\<Phi>'\<Psi>.map x)"
           using S.inverse_arrows_compose S.inverse_arrows_sym X \<Phi>'\<Psi>.map_simp_ide
                 \<Phi>\<Psi>'.map_simp_ide \<Psi>'.inverts_components \<Psi>.inverts_components
           by force
       qed
       have "Cop_S.inverse_arrows (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)
                                  (Cop_S.MkArr (Y a') (Y a) \<Phi>'\<Psi>.map)"
       proof -
         have Ya: "functor Cop.comp S (Y a)" ..
         have Ya': "functor Cop.comp S (Y a')" ..
         have \<Phi>\<Psi>': "natural_transformation Cop.comp S (Y a) (Y a') \<Phi>\<Psi>'.map" ..
         have \<Phi>'\<Psi>: "natural_transformation Cop.comp S (Y a') (Y a) \<Phi>'\<Psi>.map" ..
         show ?thesis
           by (metis (no_types, lifting) Cop_S.arr_MkArr Cop_S.comp_MkArr Cop_S.ide_MkIde
               Cop_S.inverse_arrows_def Ya'.functor_axioms Ya.functor_axioms
               \<Phi>'\<Psi>.natural_transformation_axioms \<Phi>\<Psi>'.natural_transformation_axioms
               \<Phi>\<Psi>'_\<Phi>'\<Psi>.inverse_transformations_axioms inverse_transformations_inverse(1-2)
               mem_Collect_eq)
       qed
       hence 3: "Cop_S.iso (Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map)" using Cop_S.isoI by blast
       hence "\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> map f = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
         using Ya.ide_a Ya'.ide_a is_full Y_def Cop_S.iso_is_arr full_functor.is_full
               Cop_S.MkArr_in_hom \<Phi>\<Psi>'.natural_transformation_axioms preserves_ide
         by force
       from this obtain \<phi>
         where \<phi>: "\<guillemotleft>\<phi> : a \<rightarrow> a'\<guillemotright> \<and> map \<phi> = Cop_S.MkArr (Y a) (Y a') \<Phi>\<Psi>'.map"
         by blast
       show ?thesis
         by (metis 3 C.in_homE \<phi> is_faithful reflects_iso)
     qed
 
   end
 
   section "Diagrams and Cones"
 
   text\<open>
     A \emph{diagram} in a category @{term C} is a functor \<open>D: J \<rightarrow> C\<close>.
     We refer to the category @{term J} as the diagram \emph{shape}.
     Note that in the usual expositions of category theory that use set theory
     as their foundations, the shape @{term J} of a diagram is required to be
     a ``small'' category, where smallness means that the collection of objects
     of @{term J}, as well as each of the ``homs,'' is a set.
     However, in HOL there is no class of all sets, so it is not meaningful
     to speak of @{term J} as ``small'' in any kind of absolute sense.
     There is likely a meaningful notion of smallness of @{term J}
     \emph{relative to} @{term C} (the result below that states that a set
     category has @{term I}-indexed products if and only if its universe
     ``admits @{term I}-indexed tuples'' is suggestive of how this might
     be defined), but I haven't fully explored this idea at present.
 \<close>
 
   locale diagram =
     C: category C +
     J: category J +
     "functor" J C D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   begin
 
     notation J.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
 
   end
  
   lemma comp_diagram_functor:
   assumes "diagram J C D" and "functor J' J F"
   shows "diagram J' C (D o F)"
     by (meson assms(1) assms(2) diagram_def functor.axioms(1) functor_comp)
     
   text\<open>
     A \emph{cone} over a diagram \<open>D: J \<rightarrow> C\<close> is a natural transformation
     from a constant functor to @{term D}.  The value of the constant functor is
     the \emph{apex} of the cone.
 \<close>
 
   locale cone =
     C: category C +
     J: category J +
     D: diagram J C D +
     A: constant_functor J C a +
     natural_transformation J C A.map D \<chi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and a :: 'c
   and \<chi> :: "'j \<Rightarrow> 'c"
   begin
 
     lemma ide_apex:
     shows "C.ide a"
       using A.value_is_ide by auto
 
     lemma component_in_hom:
     assumes "J.arr j"
     shows "\<guillemotleft>\<chi> j : a \<rightarrow> D (J.cod j)\<guillemotright>"
       using assms by auto
 
   end
 
   text\<open>
     A cone over diagram @{term D} is transformed into a cone over diagram @{term "D o F"}
     by pre-composing with @{term F}.
 \<close>
 
   lemma comp_cone_functor:
   assumes "cone J C D a \<chi>" and "functor J' J F"
   shows "cone J' C (D o F) a (\<chi> o F)"
   proof -
     interpret \<chi>: cone J C D a \<chi> using assms(1) by auto
     interpret F: "functor" J' J F using assms(2) by auto
     interpret A': constant_functor J' C a
       using \<chi>.A.value_is_ide by unfold_locales auto
     have 1: "\<chi>.A.map o F = A'.map"
       using \<chi>.A.map_def A'.map_def \<chi>.J.not_arr_null by auto
     interpret \<chi>': natural_transformation J' C A'.map \<open>D o F\<close> \<open>\<chi> o F\<close>
       using 1 horizontal_composite F.as_nat_trans.natural_transformation_axioms
             \<chi>.natural_transformation_axioms
       by fastforce
     show "cone J' C (D o F) a (\<chi> o F)" ..
   qed
 
   text\<open>
     A cone over diagram @{term D} can be transformed into a cone over a diagram @{term D'}
     by post-composing with a natural transformation from @{term D} to @{term D'}.
 \<close>
 
   lemma vcomp_transformation_cone:
   assumes "cone J C D a \<chi>"
   and "natural_transformation J C D D' \<tau>"
   shows "cone J C D' a (vertical_composite.map J C \<chi> \<tau>)"
     by (meson assms cone.axioms(4-5) cone.intro diagram.intro natural_transformation.axioms(1-4)
               vertical_composite.intro vertical_composite.is_natural_transformation)
 
   context "functor"
   begin
 
     lemma preserves_diagrams:
     fixes J :: "'j comp"
     assumes "diagram J A D"
     shows "diagram J B (F o D)"
       by (meson assms diagram_def functor_axioms functor_comp functor_def)
 
     lemma preserves_cones:
     fixes J :: "'j comp"
     assumes "cone J A D a \<chi>"
     shows "cone J B (F o D) (F a) (F o \<chi>)"
     proof -
       interpret \<chi>: cone J A D a \<chi> using assms by auto
       interpret Fa: constant_functor J B \<open>F a\<close>
         using \<chi>.ide_apex by unfold_locales auto
       have 1: "F o \<chi>.A.map = Fa.map"
       proof
         fix f
         show "(F \<circ> \<chi>.A.map) f = Fa.map f"
           using is_extensional Fa.is_extensional \<chi>.A.is_extensional
           by (cases "\<chi>.J.arr f", simp_all)
       qed
       interpret \<chi>': natural_transformation J B Fa.map \<open>F o D\<close> \<open>F o \<chi>\<close>
         using 1 horizontal_composite \<chi>.natural_transformation_axioms
               as_nat_trans.natural_transformation_axioms
         by fastforce
       show "cone J B (F o D) (F a) (F o \<chi>)" ..
     qed
 
   end
 
   context diagram
   begin
 
     abbreviation cone
     where "cone a \<chi> \<equiv> Limit.cone J C D a \<chi>"
 
     abbreviation cones :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) set"
     where "cones a \<equiv> { \<chi>. cone a \<chi> }"
 
     text\<open>
       An arrow @{term "f \<in> C.hom a' a"} induces by composition a transformation from
       cones with apex @{term a} to cones with apex @{term a'}.  This transformation
       is functorial in @{term f}.
 \<close>
 
     abbreviation cones_map :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> ('j \<Rightarrow> 'c)"
     where "cones_map f \<equiv> (\<lambda>\<chi> \<in> cones (C.cod f). \<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null)"
 
     lemma cones_map_mapsto:
     assumes "C.arr f"
     shows "cones_map f \<in>
              extensional (cones (C.cod f)) \<inter> (cones (C.cod f) \<rightarrow> cones (C.dom f))"
     proof
       show "cones_map f \<in> extensional (cones (C.cod f))" by blast
       show "cones_map f \<in> cones (C.cod f) \<rightarrow> cones (C.dom f)"
       proof
         fix \<chi>
         assume "\<chi> \<in> cones (C.cod f)"
         hence \<chi>: "cone (C.cod f) \<chi>" by auto
         interpret \<chi>: cone J C D \<open>C.cod f\<close> \<chi> using \<chi> by auto
         interpret B: constant_functor J C \<open>C.dom f\<close>
           using assms by unfold_locales auto
         have "cone (C.dom f) (\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null)"
           using assms B.value_is_ide \<chi>.is_natural_1 \<chi>.is_natural_2
           apply (unfold_locales, auto)
           using \<chi>.is_natural_1
            apply (metis C.comp_assoc)
           using \<chi>.is_natural_2 C.comp_arr_dom
           by (metis J.arr_cod_iff_arr J.cod_cod C.comp_assoc)
         thus "(\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null) \<in> cones (C.dom f)" by auto
       qed
     qed
 
     lemma cones_map_ide:
     assumes "\<chi> \<in> cones a"
     shows "cones_map a \<chi> = \<chi>"
     proof -
       interpret \<chi>: cone J C D a \<chi> using assms by auto
       show ?thesis
       proof
         fix j
         show "cones_map a \<chi> j = \<chi> j"
           using assms \<chi>.A.value_is_ide \<chi>.preserves_hom C.comp_arr_dom \<chi>.is_extensional
           by (cases "J.arr j", auto)
       qed
     qed
 
     lemma cones_map_comp:
     assumes "C.seq f g"
     shows "cones_map (f \<cdot> g) = restrict (cones_map g o cones_map f) (cones (C.cod f))"
     proof (intro restr_eqI)
       show "cones (C.cod (f \<cdot> g)) = cones (C.cod f)" using assms by simp
       show "\<And>\<chi>. \<chi> \<in> cones (C.cod (f \<cdot> g)) \<Longrightarrow>
                   (\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null) = (cones_map g o cones_map f) \<chi>"
       proof -
         fix \<chi>
         assume \<chi>: "\<chi> \<in> cones (C.cod (f \<cdot> g))"
         show "(\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null) = (cones_map g o cones_map f) \<chi>"
         proof -
           have "((cones_map g) o (cones_map f)) \<chi> = cones_map g (cones_map f \<chi>)"
             by force
           also have "... = (\<lambda>j. if J.arr j then
                               (\<lambda>j. if J.arr j then \<chi> j \<cdot> f else C.null) j \<cdot> g else C.null)"
           proof
             fix j
             have "cone (C.dom f) (cones_map f \<chi>)"
               using assms \<chi> cones_map_mapsto by (elim C.seqE, force)
             thus "cones_map g (cones_map f \<chi>) j =
                   (if J.arr j then C (if J.arr j then \<chi> j \<cdot> f else C.null) g else C.null)"
               using \<chi> assms by auto
           qed
           also have "... = (\<lambda>j. if J.arr j then \<chi> j \<cdot> f \<cdot> g else C.null)"
             using C.comp_assoc by fastforce
           finally show ?thesis by auto
         qed
       qed
     qed
 
   end
 
   text\<open>
     Changing the apex of a cone by pre-composing with an arrow @{term f} commutes
     with changing the diagram of a cone by post-composing with a natural transformation.
 \<close>
 
   lemma cones_map_vcomp:
   assumes "diagram J C D" and "diagram J C D'"
   and "natural_transformation J C D D' \<tau>"
   and "cone J C D a \<chi>"
   and f: "partial_magma.in_hom C f a' a"
   shows "diagram.cones_map J C D' f (vertical_composite.map J C \<chi> \<tau>)
            = vertical_composite.map J C (diagram.cones_map J C D f \<chi>) \<tau>"
   proof -
     interpret D: diagram J C D using assms(1) by auto
     interpret D': diagram J C D' using assms(2) by auto
     interpret \<tau>: natural_transformation J C D D' \<tau> using assms(3) by auto
     interpret \<chi>: cone J C D a \<chi> using assms(4) by auto
     interpret \<tau>o\<chi>: vertical_composite J C \<chi>.A.map D D' \<chi> \<tau> ..
     interpret \<tau>o\<chi>: cone J C D' a \<tau>o\<chi>.map ..
     interpret \<chi>f: cone J C D a' \<open>D.cones_map f \<chi>\<close>
       using f \<chi>.cone_axioms D.cones_map_mapsto by blast
     interpret \<tau>o\<chi>f: vertical_composite J C \<chi>f.A.map D D' \<open>D.cones_map f \<chi>\<close> \<tau> ..
     interpret \<tau>o\<chi>_f: cone J C D' a' \<open>D'.cones_map f \<tau>o\<chi>.map\<close>
       using f \<tau>o\<chi>.cone_axioms D'.cones_map_mapsto [of f] by blast
     write C (infixr "\<cdot>" 55)
     show "D'.cones_map f \<tau>o\<chi>.map = \<tau>o\<chi>f.map"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation J C \<chi>f.A.map D' (D'.cones_map f \<tau>o\<chi>.map)" ..
       show "natural_transformation J C \<chi>f.A.map D' \<tau>o\<chi>f.map" ..
       show "\<And>j. D.J.ide j \<Longrightarrow> D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>f.map j"
       proof -
         fix j
         assume j: "D.J.ide j"
         have "D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>.map j \<cdot> f"
           using f \<tau>o\<chi>.cone_axioms \<tau>o\<chi>.map_simp_2 \<tau>o\<chi>.is_extensional by auto
         also have "... = (\<tau> j \<cdot> \<chi> (D.J.dom j)) \<cdot> f"
           using j \<tau>o\<chi>.map_simp_2 by simp
         also have "... = \<tau> j \<cdot> \<chi> (D.J.dom j) \<cdot> f"
           using D.C.comp_assoc by simp
         also have "... = \<tau>o\<chi>f.map j"
           using j f \<chi>.cone_axioms \<tau>o\<chi>f.map_simp_2 by auto
         finally show "D'.cones_map f \<tau>o\<chi>.map j = \<tau>o\<chi>f.map j" by auto
       qed
     qed
   qed
 
   text\<open>
     Given a diagram @{term D}, we can construct a contravariant set-valued functor,
     which takes each object @{term a} of @{term C} to the set of cones over @{term D}
     with apex @{term a}, and takes each arrow @{term f} of @{term C} to the function
     on cones over @{term D} induced by pre-composition with @{term f}.
     For this, we need to introduce a set category @{term S} whose universe is large
     enough to contain all the cones over @{term D}, and we need to have an explicit
     correspondence between cones and elements of the universe of @{term S}.
     A replete set category @{term S} equipped with an injective mapping
     @{term_type "\<iota> :: ('j => 'c) => 's"} serves this purpose.
 \<close>
   locale cones_functor =
     C: category C +
     Cop: dual_category C +
     J: category J +
     D: diagram J C D +
     S: replete_concrete_set_category S UNIV \<iota>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
   and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
   begin
 
     notation S.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
 
-    abbreviation \<o> where "\<o> \<equiv> S.\<o>"
+    abbreviation \<o> where "\<o> \<equiv> S.DN"
 
     definition map :: "'c \<Rightarrow> 's"
     where "map = (\<lambda>f. if C.arr f then
                         S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom f))
                                 (\<iota> o D.cones_map f o \<o>)
                       else S.null)"
 
     lemma map_simp [simp]:
     assumes "C.arr f"
     shows "map f = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom f))
                            (\<iota> o D.cones_map f o \<o>)"
       using assms map_def by auto
 
     lemma arr_map:
     assumes "C.arr f"
     shows "S.arr (map f)"
     proof -
       have "\<iota> o D.cones_map f o \<o> \<in> \<iota> ` D.cones (C.cod f) \<rightarrow> \<iota> ` D.cones (C.dom f)"
         using assms D.cones_map_mapsto by force
-      thus ?thesis using assms S.\<iota>_mapsto S.arr_mkArr by auto
+      thus ?thesis using assms S.UP_mapsto by auto
     qed
 
     lemma map_ide:
     assumes "C.ide a"
     shows "map a = S.mkIde (\<iota> ` D.cones a)"
     proof -
       have "map a = S.mkArr (\<iota> ` D.cones a) (\<iota> ` D.cones a) (\<iota> o D.cones_map a o \<o>)"
         using assms map_simp by force
       also have "... = S.mkArr (\<iota> ` D.cones a) (\<iota> ` D.cones a) (\<lambda>x. x)"
-        using S.\<iota>_mapsto D.cones_map_ide S.arr_mkArr by force
+        using S.UP_mapsto D.cones_map_ide by force
       also have "... = S.mkIde (\<iota> ` D.cones a)"
-        using assms S.mkIde_as_mkArr S.\<iota>_mapsto by blast
+        using assms S.mkIde_as_mkArr S.UP_mapsto by blast
       finally show ?thesis by auto
     qed
 
     lemma map_preserves_dom:
     assumes "Cop.arr f"
     shows "map (Cop.dom f) = S.dom (map f)"
       using assms arr_map map_ide by auto
 
     lemma map_preserves_cod:
     assumes "Cop.arr f"
     shows "map (Cop.cod f) = S.cod (map f)"
       using assms arr_map map_ide by auto
 
     lemma map_preserves_comp:
     assumes "Cop.seq g f"
     shows "map (g \<cdot>\<^sup>o\<^sup>p f) = map g \<cdot>\<^sub>S map f"
     proof -
       have "map (g \<cdot>\<^sup>o\<^sup>p f) = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
                                    ((\<iota> o D.cones_map g o \<o>) o (\<iota> o D.cones_map f o \<o>))"
       proof -
         have 1: "S.arr (map (g \<cdot>\<^sup>o\<^sup>p f))"
           using assms arr_map [of "C f g"] by simp
         have "map (g \<cdot>\<^sup>o\<^sup>p f) = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
                                      (\<iota> o D.cones_map (C f g) o \<o>)"
           using assms map_simp [of "C f g"] by simp
         also have "... = S.mkArr (\<iota> ` D.cones (C.cod f)) (\<iota> ` D.cones (C.dom g))
                                  ((\<iota> o D.cones_map g o \<o>) o (\<iota> o D.cones_map f o \<o>))"
           using assms 1 calculation D.cones_map_mapsto D.cones_map_comp by auto
         finally show ?thesis by blast
       qed
       also have "... = map g \<cdot>\<^sub>S map f"
         using assms arr_map [of f] arr_map [of g] map_simp S.comp_mkArr by auto
       finally show ?thesis by auto
     qed
 
     lemma is_functor:
     shows "functor Cop.comp S map"
       apply (unfold_locales)
       using map_def arr_map map_preserves_dom map_preserves_cod map_preserves_comp
       by auto
     
   end
 
   sublocale cones_functor \<subseteq> "functor" Cop.comp S map using is_functor by auto
-  sublocale cones_functor \<subseteq> set_valued_functor Cop.comp S map ..
+  sublocale cones_functor \<subseteq> set_valued_functor Cop.comp S \<open>\<lambda>A. A \<subseteq> S.Univ\<close> map ..
 
   section Limits
 
   subsection "Limit Cones"
 
   text\<open>
     A \emph{limit cone} for a diagram @{term D} is a cone @{term \<chi>} over @{term D}
     with the universal property that any other cone @{term \<chi>'} over the diagram @{term D}
     factors uniquely through @{term \<chi>}.
 \<close>
 
   locale limit_cone =
     C: category C +
     J: category J +
     D: diagram J C D +
     cone J C D a \<chi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and a :: 'c
   and \<chi> :: "'j \<Rightarrow> 'c" +
   assumes is_universal: "cone J C D a' \<chi>' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
   begin
 
     definition induced_arrow :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> 'c"
     where "induced_arrow a' \<chi>' = (THE f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>')"
 
     lemma induced_arrowI:
     assumes \<chi>': "\<chi>' \<in> D.cones a'"
     shows "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright>"
     and "D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
     proof -
       have "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
         using assms \<chi>' is_universal by simp
       hence 1: "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
         using theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"] induced_arrow_def
         by presburger
       show "\<guillemotleft>induced_arrow a' \<chi>' : a' \<rightarrow> a\<guillemotright>" using 1 by simp
       show "D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'" using 1 by simp
     qed
 
     lemma cones_map_induced_arrow:
     shows "induced_arrow a' \<in> D.cones a' \<rightarrow> C.hom a' a"
     and "\<And>\<chi>'. \<chi>' \<in> D.cones a' \<Longrightarrow> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
       using induced_arrowI by auto
 
     lemma induced_arrow_cones_map:
     assumes "C.ide a'"
     shows "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
     and "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> induced_arrow a' (D.cones_map f \<chi>) = f"
     proof -
       have a': "C.ide a'" using assms by (simp add: cone.ide_apex)
       have cone_\<chi>: "cone J C D a \<chi>" ..
       show "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
         using cone_\<chi> D.cones_map_mapsto by blast
       fix f
       assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
       show "induced_arrow a' (D.cones_map f \<chi>) = f"
       proof -
         have "D.cones_map f \<chi> \<in> D.cones a'"
           using f cone_\<chi> D.cones_map_mapsto by blast
         hence "\<exists>!f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = D.cones_map f \<chi>"
           using assms is_universal by auto
         thus ?thesis
           using f induced_arrow_def
                 the1_equality [of "\<lambda>f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = D.cones_map f \<chi>"]
           by presburger
       qed
     qed
 
     text\<open>
       For a limit cone @{term \<chi>} with apex @{term a}, for each object @{term a'} the
       hom-set @{term "C.hom a' a"} is in bijective correspondence with the set of cones
       with apex @{term a'}.
 \<close>
 
     lemma bij_betw_hom_and_cones:
     assumes "C.ide a'"
     shows "bij_betw (\<lambda>f. D.cones_map f \<chi>) (C.hom a' a) (D.cones a')"
     proof (intro bij_betwI)
       show "(\<lambda>f. D.cones_map f \<chi>) \<in> C.hom a' a \<rightarrow> D.cones a'"
         using assms induced_arrow_cones_map by blast
       show "induced_arrow a' \<in> D.cones a' \<rightarrow> C.hom a' a"
         using assms cones_map_induced_arrow by blast
       show "\<And>f. f \<in> C.hom a' a \<Longrightarrow> induced_arrow a' (D.cones_map f \<chi>) = f"
         using assms induced_arrow_cones_map by blast
       show "\<And>\<chi>'. \<chi>' \<in> D.cones a' \<Longrightarrow> D.cones_map (induced_arrow a' \<chi>') \<chi> = \<chi>'"
         using assms cones_map_induced_arrow by blast
     qed
 
     lemma induced_arrow_eqI:
     assumes "D.cone a' \<chi>'" and "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" and "D.cones_map f \<chi> = \<chi>'"
     shows "induced_arrow a' \<chi>' = f"
       using assms is_universal induced_arrow_def
             the1_equality [of "\<lambda>f. f \<in> C.hom a' a \<and> D.cones_map f \<chi> = \<chi>'" f]
       by simp
 
     lemma induced_arrow_self:
     shows "induced_arrow a \<chi> = a"
     proof -
       have "\<guillemotleft>a : a \<rightarrow> a\<guillemotright> \<and> D.cones_map a \<chi> = \<chi>"
         using ide_apex cone_axioms D.cones_map_ide by force
       thus ?thesis using induced_arrow_eqI cone_axioms by auto
     qed
 
   end
 
   context diagram
   begin
 
     abbreviation limit_cone
     where "limit_cone a \<chi> \<equiv> Limit.limit_cone J C D a \<chi>"
 
     text\<open>
       A diagram @{term D} has object @{term a} as a limit if @{term a} is the apex
       of some limit cone over @{term D}.
 \<close>
 
     abbreviation has_as_limit :: "'c \<Rightarrow> bool"
     where "has_as_limit a \<equiv> (\<exists>\<chi>. limit_cone a \<chi>)"
 
     abbreviation has_limit
     where "has_limit \<equiv> (\<exists>a \<chi>. limit_cone a \<chi>)"
 
     definition some_limit :: 'c
     where "some_limit = (SOME a. \<exists>\<chi>. limit_cone a \<chi>)"
 
     definition some_limit_cone :: "'j \<Rightarrow> 'c"
     where "some_limit_cone = (SOME \<chi>. limit_cone some_limit \<chi>)"
 
     lemma limit_cone_some_limit_cone:
     assumes has_limit
     shows "limit_cone some_limit some_limit_cone"
     proof -
       have "\<exists>a. has_as_limit a" using assms by simp
       hence "has_as_limit some_limit"
         using some_limit_def someI_ex [of "\<lambda>a. \<exists>\<chi>. limit_cone a \<chi>"] by simp
       thus "limit_cone some_limit some_limit_cone"
         using assms some_limit_cone_def someI_ex [of "\<lambda>\<chi>. limit_cone some_limit \<chi>"]
         by simp
     qed
 
     lemma ex_limitE:
     assumes "\<exists>a. has_as_limit a"
     obtains a \<chi> where "limit_cone a \<chi>"
       using assms someI_ex by blast
 
   end
 
   subsection "Limits by Representation"
 
   text\<open>
     A limit for a diagram D can also be given by a representation \<open>(a, \<Phi>)\<close>
     of the cones functor.
 \<close>
 
   locale representation_of_cones_functor =
     C: category C +
     Cop: dual_category C +
     J: category J +
     D: diagram J C D +
     S: replete_concrete_set_category S UNIV \<iota> +
     Cones: cones_functor J C D S \<iota> +
-    Hom: hom_functor C S \<phi> +
-    representation_of_functor C S \<phi> Cones.map a \<Phi>
+    Hom: hom_functor C S \<open>\<lambda>A. A \<subseteq> S.Univ\<close> \<phi> +
+    representation_of_functor C S S.setp \<phi> Cones.map a \<Phi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
   and a :: 'c
   and \<Phi> :: "'c \<Rightarrow> 's"
 
   subsection "Putting it all Together"
 
   text\<open>
     A ``limit situation'' combines and connects the ways of presenting a limit.
 \<close>
 
   locale limit_situation =
     C: category C +
     Cop: dual_category C +
     J: category J +
     D: diagram J C D +
     S: replete_concrete_set_category S UNIV \<iota> +
     Cones: cones_functor J C D S \<iota> +
-    Hom: hom_functor C S \<phi> +
-    \<Phi>: representation_of_functor C S \<phi> Cones.map a \<Phi> +
+    Hom: hom_functor C S S.setp \<phi> +
+    \<Phi>: representation_of_functor C S S.setp \<phi> Cones.map a \<Phi> +
     \<chi>: limit_cone J C D a \<chi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and \<iota> :: "('j \<Rightarrow> 'c) \<Rightarrow> 's"
   and a :: 'c
   and \<Phi> :: "'c \<Rightarrow> 's"
   and \<chi> :: "'j \<Rightarrow> 'c" +
-  assumes \<chi>_in_terms_of_\<Phi>: "\<chi> = S.\<o> (S.Fun (\<Phi> a) (\<phi> (a, a) a))"
+  assumes \<chi>_in_terms_of_\<Phi>: "\<chi> = S.DN (S.Fun (\<Phi> a) (\<phi> (a, a) a))"
   and \<Phi>_in_terms_of_\<chi>:
      "Cop.ide a' \<Longrightarrow> \<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a')
                                     (\<lambda>x. \<iota> (D.cones_map (Hom.\<psi> (a', a) x) \<chi>))"
 
   text (in limit_situation) \<open>
     The assumption @{prop \<chi>_in_terms_of_\<Phi>} states that the universal cone @{term \<chi>} is obtained
     by applying the function @{term "S.Fun (\<Phi> a)"} to the identity @{term a} of
     @{term[source=true] C} (after taking into account the necessary coercions).
 \<close>
 
   text (in limit_situation) \<open>
     The assumption @{prop \<Phi>_in_terms_of_\<chi>} states that the component of @{term \<Phi>} at @{term a'}
     is the arrow of @{term[source=true] S} corresponding to the function that takes an arrow
     @{term "f \<in> C.hom a' a"} and produces the cone with vertex @{term a'} obtained
     by transforming the universal cone @{term \<chi>} by @{term f}.
 \<close>
 
   subsection "Limit Cones Induce Limit Situations"
 
   text\<open>
     To obtain a limit situation from a limit cone, we need to introduce a set category
     that is large enough to contain the hom-sets of @{term C} as well as the cones
     over @{term D}.  We use the category of all @{typ "('c + ('j \<Rightarrow> 'c))"}-sets for this.
 \<close>
 
   context limit_cone
   begin
 
     interpretation Cop: dual_category C ..
     interpretation CopxC: product_category Cop.comp C ..
     interpretation S: replete_setcat \<open>undefined :: 'c + ('j \<Rightarrow> 'c)\<close> .
 
     notation S.comp      (infixr "\<cdot>\<^sub>S" 55)
 
     interpretation Sr: replete_concrete_set_category S.comp UNIV \<open>S.UP o Inr\<close>
       apply unfold_locales
       using S.UP_mapsto
        apply auto[1]
       using S.inj_UP inj_Inr inj_compose
       by metis
 
     interpretation Cones: cones_functor J C D S.comp \<open>S.UP o Inr\<close> ..
 
-    interpretation Hom: hom_functor C S.comp \<open>\<lambda>_. S.UP o Inl\<close>
+    interpretation Hom: hom_functor C S.comp S.setp \<open>\<lambda>_. S.UP o Inl\<close>
       apply (unfold_locales)
       using S.UP_mapsto
-       apply auto[1]
+        apply auto[1]
       using S.inj_UP injD inj_onI inj_Inl inj_compose
-      by (metis (no_types, lifting))
-
-    interpretation Y: yoneda_functor C S.comp \<open>\<lambda>_. S.UP o Inl\<close> ..
-    interpretation Ya: yoneda_functor_fixed_object C S.comp \<open>\<lambda>_. S.UP o Inl\<close> a
+       apply (metis (no_types, lifting))
+      using S.UP_mapsto
+      by auto
+
+    interpretation Y: yoneda_functor C S.comp S.setp \<open>\<lambda>_. S.UP o Inl\<close> ..
+    interpretation Ya: yoneda_functor_fixed_object C S.comp S.setp \<open>\<lambda>_. S.UP o Inl\<close> a
       apply (unfold_locales) using ide_apex by auto
 
     abbreviation inl :: "'c \<Rightarrow> 'c + ('j \<Rightarrow> 'c)" where "inl \<equiv> Inl"
     abbreviation inr :: "('j \<Rightarrow> 'c) \<Rightarrow> 'c + ('j \<Rightarrow> 'c)" where "inr \<equiv> Inr"
     abbreviation \<iota> where "\<iota> \<equiv> S.UP o inr"
     abbreviation \<o> where "\<o> \<equiv> Cones.\<o>"
     abbreviation \<phi> where "\<phi> \<equiv> \<lambda>_. S.UP o inl"
     abbreviation \<psi> where "\<psi> \<equiv> Hom.\<psi>"
     abbreviation Y where "Y \<equiv> Y.Y"
 
     lemma Ya_ide:
     assumes a': "C.ide a'"
     shows "Y a a' = S.mkIde (Hom.set (a', a))"
       using assms ide_apex Y.Y_simp Hom.map_ide by simp
 
     lemma Ya_arr:
     assumes g: "C.arr g"
     shows "Y a g = S.mkArr (Hom.set (C.cod g, a)) (Hom.set (C.dom g, a))
                            (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
       using ide_apex g Y.Y_ide_arr [of a g "C.dom g" "C.cod g"] by auto
 
     lemma cone_\<chi> [simp]:
     shows "\<chi> \<in> D.cones a"
       using cone_axioms by simp
     
     text\<open>
       For each object @{term a'} of @{term[source=true] C} we have a function mapping
       @{term "C.hom a' a"} to the set of cones over @{term D} with apex @{term a'},
       which takes @{term "f \<in> C.hom a' a"} to \<open>\<chi>f\<close>, where \<open>\<chi>f\<close> is the cone obtained by
       composing @{term \<chi>} with @{term f} (after accounting for coercions to and from the
       universe of @{term S}).  The corresponding arrows of @{term S} are the
       components of a natural isomorphism from @{term "Y a"} to \<open>Cones\<close>.
 \<close>
 
     definition \<Phi>o :: "'c \<Rightarrow> ('c + ('j \<Rightarrow> 'c)) setcat.arr"
     where
       "\<Phi>o a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>))"
 
     lemma \<Phi>o_in_hom:
     assumes a': "C.ide a'"
     shows "\<guillemotleft>\<Phi>o a' : S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
     proof -
       have " \<guillemotleft>S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)) :
                  S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
       proof -
         have "(\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)) \<in> Hom.set (a', a) \<rightarrow> \<iota> ` D.cones a'"
         proof
           fix x
           assume x: "x \<in> Hom.set (a', a)"
           hence "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
             using ide_apex a' Hom.\<psi>_mapsto by auto
           hence "D.cones_map (\<psi> (a', a) x) \<chi> \<in> D.cones a'"
             using ide_apex a' x D.cones_map_mapsto cone_\<chi> by force
           thus "\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) \<in> \<iota> ` D.cones a'" by simp
         qed
         moreover have "Hom.set (a', a) \<subseteq> S.Univ"
           using ide_apex a' Hom.set_subset_Univ by auto
         moreover have "\<iota> ` D.cones a' \<subseteq> S.Univ"
           using S.UP_mapsto by auto
         ultimately show ?thesis using S.mkArr_in_hom by simp
       qed
       thus ?thesis using \<Phi>o_def [of a'] by auto
     qed
 
     interpretation \<Phi>: transformation_by_components Cop.comp S.comp \<open>Y a\<close> Cones.map \<Phi>o
     proof
       fix a'
       assume A': "Cop.ide a'"
       show "\<guillemotleft>\<Phi>o a' : Y a a' \<rightarrow>\<^sub>S Cones.map a'\<guillemotright>"
         using A' Ya_ide \<Phi>o_in_hom Cones.map_ide by auto
       next
       fix g
       assume g: "Cop.arr g"
       show "\<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g)"
       proof -
         let ?A = "Hom.set (C.cod g, a)"
         let ?B = "Hom.set (C.dom g, a)"
         let ?B' = "\<iota> ` D.cones (C.cod g)"
         let ?C = "\<iota> ` D.cones (C.dom g)"
         let ?F = "\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a)"
         let ?F' = "\<iota> o D.cones_map g o \<o>"
         let ?G = "\<lambda>x. \<iota> (D.cones_map (\<psi> (C.dom g, a) x) \<chi>)"
         let ?G' = "\<lambda>x. \<iota> (D.cones_map (\<psi> (C.cod g, a) x) \<chi>)"
         have "S.arr (Y a g) \<and> Y a g = S.mkArr ?A ?B ?F"
           using ide_apex g Ya.preserves_arr Ya_arr by fastforce
         moreover have "S.arr (\<Phi>o (Cop.cod g))"
           using g \<Phi>o_in_hom [of "Cop.cod g"] by auto
         moreover have "\<Phi>o (Cop.cod g) = S.mkArr ?B ?C ?G"
           using g \<Phi>o_def [of "C.dom g"] by auto
         moreover have "S.seq (\<Phi>o (Cop.cod g)) (Y a g)"
           using ide_apex g \<Phi>o_in_hom [of "Cop.cod g"] by auto
         ultimately have 1: "S.seq (\<Phi>o (Cop.cod g)) (Y a g) \<and>
                             \<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = S.mkArr ?A ?C (?G o ?F)"
           using S.comp_mkArr [of ?A ?B ?F ?C ?G] by argo
 
         have "Cones.map g = S.mkArr (\<iota> ` D.cones (C.cod g)) (\<iota> ` D.cones (C.dom g)) ?F'"
           using g Cones.map_simp by fastforce
         moreover have "\<Phi>o (Cop.dom g) = S.mkArr ?A ?B' ?G'"
           using g \<Phi>o_def by fastforce
         moreover have "S.seq (Cones.map g) (\<Phi>o (Cop.dom g))"
           using g Cones.preserves_hom [of g "C.cod g" "C.dom g"] \<Phi>o_in_hom [of "Cop.dom g"]
           by force
         ultimately have
           2: "S.seq (Cones.map g) (\<Phi>o (Cop.dom g)) \<and>
               Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g) = S.mkArr ?A ?C (?F' o ?G')"
           using S.seqI' [of "\<Phi>o (Cop.dom g)" "Cones.map g"] S.comp_mkArr by auto
 
         have "\<Phi>o (Cop.cod g) \<cdot>\<^sub>S Y a g = S.mkArr ?A ?C (?G o ?F)"
           using 1 by auto
         also have "... = S.mkArr ?A ?C (?F' o ?G')"
         proof (intro S.mkArr_eqI')
           show "S.arr (S.mkArr ?A ?C (?G o ?F))" using 1 by force
           show "\<And>x. x \<in> ?A \<Longrightarrow> (?G o ?F) x = (?F' o ?G') x"
           proof -
             fix x
             assume x: "x \<in> ?A"
             hence 1: "\<guillemotleft>\<psi> (C.cod g, a) x : C.cod g \<rightarrow> a\<guillemotright>"
               using ide_apex g Hom.\<psi>_mapsto [of "C.cod g" a] by auto
             have "(?G o ?F) x = \<iota> (D.cones_map (\<psi> (C.dom g, a)
                                   (\<phi> (C.dom g, a) (\<psi> (C.cod g, a) x \<cdot> g))) \<chi>)"
             proof - (* Why is it so balky with this proof? *)
               have "(?G o ?F) x = ?G (?F x)" by simp
               also have "... = \<iota> (D.cones_map (\<psi> (C.dom g, a)
                                      (\<phi> (C.dom g, a) (\<psi> (C.cod g, a) x \<cdot> g))) \<chi>)"
                 by (metis Cop.comp_def comp_apply)
               finally show ?thesis by auto
             qed
             also have "... = \<iota> (D.cones_map (\<psi> (C.cod g, a) x \<cdot> g) \<chi>)"
             proof -
               have "\<guillemotleft>\<psi> (C.cod g, a) x \<cdot> g : C.dom g \<rightarrow> a\<guillemotright>" using g 1 by auto
               thus ?thesis using Hom.\<psi>_\<phi> by presburger
             qed
             also have "... = \<iota> (D.cones_map g (D.cones_map (\<psi> (C.cod g, a) x) \<chi>))"
               using g x 1 cone_\<chi> D.cones_map_comp [of "\<psi> (C.cod g, a) x" g] by fastforce
             also have "... = \<iota> (D.cones_map g (\<o> (\<iota> (D.cones_map (\<psi> (C.cod g, a) x) \<chi>))))"
-              using 1 cone_\<chi> D.cones_map_mapsto Sr.\<o>_\<iota> by auto
+              using 1 cone_\<chi> D.cones_map_mapsto Sr.DN_UP by auto
             also have "... = (?F' o ?G') x" by simp
             finally show "(?G o ?F) x = (?F' o ?G') x" by auto
           qed
         qed
         also have "... = Cones.map g \<cdot>\<^sub>S \<Phi>o (Cop.dom g)"
           using 2 by auto
         finally show ?thesis by auto
       qed
     qed
 
-    interpretation \<Phi>: set_valued_transformation Cop.comp S.comp \<open>Y a\<close> Cones.map \<Phi>.map ..
+    interpretation \<Phi>: set_valued_transformation Cop.comp S.comp S.setp
+                        \<open>Y a\<close> Cones.map \<Phi>.map ..
                                             
     interpretation \<Phi>: natural_isomorphism Cop.comp S.comp \<open>Y a\<close> Cones.map \<Phi>.map
     proof
       fix a'
       assume a': "Cop.ide a'"
       show "S.iso (\<Phi>.map a')"
       proof -
         let ?F = "\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
         have bij: "bij_betw ?F (Hom.set (a', a)) (\<iota> ` D.cones a')"
         proof -
           have "\<And>x x'. \<lbrakk> x \<in> Hom.set (a', a); x' \<in> Hom.set (a', a);
                          \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>) \<rbrakk>
                             \<Longrightarrow> x = x'"
           proof -
             fix x x'
             assume x: "x \<in> Hom.set (a', a)" and x': "x' \<in> Hom.set (a', a)"
             and xx': "\<iota> (D.cones_map (\<psi> (a', a) x) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)"
             have \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>" using x ide_apex a' Hom.\<psi>_mapsto by auto
             have \<psi>x': "\<guillemotleft>\<psi> (a', a) x' : a' \<rightarrow> a\<guillemotright>" using x' ide_apex a' Hom.\<psi>_mapsto by auto
             have 1: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
             proof -
               have "D.cones_map (\<psi> (a', a) x) \<chi> \<in> D.cones a'"
                 using \<psi>x a' cone_\<chi> D.cones_map_mapsto by force
               hence 2: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>"
                 using a' is_universal by simp
               show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
               proof -
                 have "\<And>f. \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)
                              \<longleftrightarrow> D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>"
                 proof -
                   fix f :: 'c
                   have "D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>
                            \<longrightarrow> \<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                     by simp
                   thus "(\<iota> (D.cones_map f \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>))
                             = (D.cones_map f \<chi> = D.cones_map (\<psi> (a', a) x) \<chi>)"
-                    by (meson Sr.inj_\<iota> injD)
+                    by (meson Sr.inj_UP injD)
                 qed
                 thus ?thesis using 2 by auto
               qed
             qed
             have 2: "\<exists>!x''. x'' \<in> Hom.set (a', a) \<and>
                             \<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
             proof -
               from 1 obtain f'' where
                   f'': "\<guillemotleft>f'' : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f'' \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                 by blast
               have "\<phi> (a', a) f'' \<in> Hom.set (a', a) \<and>
                     \<iota> (D.cones_map (\<psi> (a', a) (\<phi> (a', a) f'')) \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
               proof
                 show "\<phi> (a', a) f'' \<in> Hom.set (a', a)" using f'' Hom.set_def by auto
                 show "\<iota> (D.cones_map (\<psi> (a', a) (\<phi> (a', a) f'')) \<chi>) =
                          \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                   using f'' Hom.\<psi>_\<phi> by presburger
               qed
               moreover have
                  "\<And>x''. x'' \<in> Hom.set (a', a) \<and>
                          \<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)
                              \<Longrightarrow> x'' = \<phi> (a', a) f''"
               proof -
                 fix x''
                 assume x'': "x'' \<in> Hom.set (a', a) \<and>
                              \<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                 hence "\<guillemotleft>\<psi> (a', a) x'' : a' \<rightarrow> a\<guillemotright> \<and>
                        \<iota> (D.cones_map (\<psi> (a', a) x'') \<chi>) = \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                   using ide_apex a' Hom.set_def Hom.\<psi>_mapsto [of a' a] by auto
                 hence "\<phi> (a', a) (\<psi> (a', a) x'') = \<phi> (a', a) f''"
                   using 1 f'' by auto
                 thus "x'' = \<phi> (a', a) f''"
                   using ide_apex a' x'' Hom.\<phi>_\<psi> by simp
               qed
               ultimately show ?thesis
                 using ex1I [of "\<lambda>x'. x' \<in> Hom.set (a', a) \<and>
                                      \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>) =
                                         \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
                                "\<phi> (a', a) f''"]
                 by simp
             qed
             thus "x = x'" using x x' xx' by auto
           qed
           hence "inj_on ?F (Hom.set (a', a))"
             using inj_onI [of "Hom.set (a', a)" ?F] by auto 
           moreover have "?F ` Hom.set (a', a) = \<iota> ` D.cones a'"
           proof
             show "?F ` Hom.set (a', a) \<subseteq> \<iota> ` D.cones a'"
             proof
               fix X'
               assume X': "X' \<in> ?F ` Hom.set (a', a)"
               from this obtain x' where x': "x' \<in> Hom.set (a', a) \<and> ?F x' = X'" by blast
               show "X' \<in> \<iota> ` D.cones a'"
               proof -
                 have "X' = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)" using x' by blast
                 hence "X' = \<iota> (D.cones_map (\<psi> (a', a) x') \<chi>)" using x' by force
                 moreover have "\<guillemotleft>\<psi> (a', a) x' : a' \<rightarrow> a\<guillemotright>"
                   using ide_apex a' x' Hom.set_def Hom.\<psi>_\<phi> by auto
                 ultimately show ?thesis
                   using x' cone_\<chi> D.cones_map_mapsto by force
               qed
             qed
             show "\<iota> ` D.cones a' \<subseteq> ?F ` Hom.set (a', a)"
             proof
               fix X'
               assume X': "X' \<in> \<iota> ` D.cones a'"
               hence "\<o> X' \<in> \<o> ` \<iota> ` D.cones a'" by simp
-              with Sr.\<o>_\<iota> have "\<o> X' \<in> D.cones a'"
+              with Sr.DN_UP have "\<o> X' \<in> D.cones a'"
                 by auto
               hence "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<o> X'"
                 using a' is_universal by simp
               from this obtain f where "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<o> X'"
                 by auto
               hence f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> \<iota> (D.cones_map f \<chi>) = X'"
-                using X' Sr.\<iota>_\<o> by auto
+                using X' Sr.UP_DN by auto
               have "X' = ?F (\<phi> (a', a) f)"
                 using f Hom.\<psi>_\<phi> by presburger
               thus "X' \<in> ?F ` Hom.set (a', a)"
                 using f Hom.set_def by force
             qed
           qed
           ultimately show ?thesis
             using bij_betw_def [of ?F "Hom.set (a', a)" "\<iota> ` D.cones a'"] inj_on_def by auto
         qed
         let ?f = "S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
         have iso: "S.iso ?f"
         proof -
           have "?F \<in> Hom.set (a', a) \<rightarrow> \<iota> ` D.cones a'"
             using bij bij_betw_imp_funcset by fast
           hence 1: "S.arr ?f"
-            using ide_apex a' Hom.set_subset_Univ S.\<iota>_mapsto S.arr_mkArr by auto
-          thus ?thesis using bij S.iso_char S.arr_mkArr S.set_mkIde by fastforce
+            using ide_apex a' Hom.set_subset_Univ S.UP_mapsto by auto
+          thus ?thesis using bij S.iso_char S.set_mkIde by fastforce
         qed
         moreover have "?f = \<Phi>.map a'"
           using a' \<Phi>o_def by force
         finally show ?thesis by auto
       qed
     qed
 
-    interpretation R: representation_of_functor C S.comp \<phi> Cones.map a \<Phi>.map ..
+    interpretation R: representation_of_functor C S.comp S.setp \<phi> Cones.map a \<Phi>.map ..
 
     lemma \<chi>_in_terms_of_\<Phi>:
     shows "\<chi> = \<o> (\<Phi>.FUN a (\<phi> (a, a) a))"
     proof -
       have "\<Phi>.FUN a (\<phi> (a, a) a) = 
               (\<lambda>x \<in> Hom.set (a, a). \<iota> (D.cones_map (\<psi> (a, a) x) \<chi>)) (\<phi> (a, a) a)"
         using ide_apex S.Fun_mkArr \<Phi>.map_simp_ide \<Phi>o_def \<Phi>.preserves_reflects_arr [of a]
         by simp
       also have "... = \<iota> (D.cones_map a \<chi>)"
       proof -
         have "(\<lambda>x \<in> Hom.set (a, a). \<iota> (D.cones_map (\<psi> (a, a) x) \<chi>)) (\<phi> (a, a) a)
                  = \<iota> (D.cones_map (\<psi> (a, a) (\<phi> (a, a) a)) \<chi>)"
         proof -
           have "\<phi> (a, a) a \<in> Hom.set (a, a)"
             using ide_apex Hom.\<phi>_mapsto by fastforce
           thus ?thesis
             using restrict_apply' [of "\<phi> (a, a) a" "Hom.set (a, a)"] by blast
         qed
         also have "... = \<iota> (D.cones_map a \<chi>)"
         proof -
           have "\<psi> (a, a) (\<phi> (a, a) a) = a"
             using ide_apex Hom.\<psi>_\<phi> [of a a a] by fastforce
           thus ?thesis by metis
         qed
         finally show ?thesis by auto
       qed
       finally have "\<Phi>.FUN a (\<phi> (a, a) a) = \<iota> (D.cones_map a \<chi>)" by auto
       also have "... = \<iota> \<chi>"
         using ide_apex D.cones_map_ide [of \<chi> a] cone_\<chi> by simp
       finally have "\<Phi>.FUN a (\<phi> (a, a) a) = \<iota> \<chi>" by blast
       hence "\<o> (\<Phi>.FUN a (\<phi> (a, a) a)) = \<o> (\<iota> \<chi>)" by simp
-      thus ?thesis using cone_\<chi> Sr.\<o>_\<iota> by simp
+      thus ?thesis using cone_\<chi> Sr.DN_UP by simp
     qed
 
     abbreviation Hom
     where "Hom \<equiv> Hom.map"
 
     abbreviation \<Phi>
     where "\<Phi> \<equiv> \<Phi>.map"
 
     lemma induces_limit_situation:
     shows "limit_situation J C D S.comp \<phi> \<iota> a \<Phi> \<chi>"
       using \<chi>_in_terms_of_\<Phi> \<Phi>o_def by unfold_locales auto
 
     no_notation S.comp      (infixr "\<cdot>\<^sub>S" 55)
 
   end
 
   sublocale limit_cone \<subseteq> limit_situation J C D replete_setcat.comp \<phi> \<iota> a \<Phi> \<chi>
     using induces_limit_situation by auto
 
   subsection "Representations of the Cones Functor Induce Limit Situations"
 
   context representation_of_cones_functor
   begin
 
-    interpretation \<Phi>: set_valued_transformation Cop.comp S \<open>Y a\<close> Cones.map \<Phi> ..
+    interpretation \<Phi>: set_valued_transformation Cop.comp S S.setp \<open>Y a\<close> Cones.map \<Phi> ..
     interpretation \<Psi>: inverse_transformation Cop.comp S \<open>Y a\<close> Cones.map \<Phi> ..
-    interpretation \<Psi>: set_valued_transformation Cop.comp S Cones.map \<open>Y a\<close> \<Psi>.map ..
+    interpretation \<Psi>: set_valued_transformation Cop.comp S S.setp
+                        Cones.map \<open>Y a\<close> \<Psi>.map ..
 
     abbreviation \<o>
     where "\<o> \<equiv> Cones.\<o>"
 
     abbreviation \<chi>
     where "\<chi> \<equiv> \<o> (S.Fun (\<Phi> a) (\<phi> (a, a) a))"
 
     lemma Cones_SET_eq_\<iota>_img_cones:
     assumes "C.ide a'"
     shows "Cones.SET a' = \<iota> ` D.cones a'"
     proof -
-      have "\<iota> ` D.cones a' \<subseteq> S.Univ" using S.\<iota>_mapsto by auto
+      have "\<iota> ` D.cones a' \<subseteq> S.Univ" using S.UP_mapsto by auto
       thus ?thesis using assms Cones.map_ide S.set_mkIde by auto
     qed
 
     lemma \<iota>\<chi>:
     shows "\<iota> \<chi> = S.Fun (\<Phi> a) (\<phi> (a, a) a)"
     proof -
       have "S.Fun (\<Phi> a) (\<phi> (a, a) a) \<in> Cones.SET a"
         using Ya.ide_a Hom.\<phi>_mapsto S.Fun_mapsto [of "\<Phi> a"] Hom.set_map by fastforce
       thus ?thesis
         using Ya.ide_a Cones_SET_eq_\<iota>_img_cones by auto
     qed
 
     interpretation \<chi>: cone J C D a \<chi>
     proof -
       have "\<iota> \<chi> \<in> \<iota> ` D.cones a"
         using Ya.ide_a \<iota>\<chi> S.Fun_mapsto [of "\<Phi> a"] Hom.\<phi>_mapsto Hom.set_map
               Cones_SET_eq_\<iota>_img_cones by fastforce
       thus "D.cone a \<chi>"
-        by (metis (no_types, lifting) S.\<o>_\<iota> UNIV_I f_inv_into_f inv_into_into mem_Collect_eq)
+        by (metis (no_types, lifting) S.DN_UP UNIV_I f_inv_into_f inv_into_into mem_Collect_eq)
     qed
 
     lemma cone_\<chi>:
     shows "D.cone a \<chi>" ..
 
     lemma \<Phi>_FUN_simp:
     assumes a': "C.ide a'" and x: "x \<in> Hom.set (a', a)"
     shows "\<Phi>.FUN a' x = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)"
     proof -
       have \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
         using Ya.ide_a a' x Hom.\<psi>_mapsto by blast
       have \<phi>a: "\<phi> (a, a) a \<in> Hom.set (a, a)" using Ya.ide_a Hom.\<phi>_mapsto by fastforce
       have "\<Phi>.FUN a' x = (\<Phi>.FUN a' o Ya.FUN (\<psi> (a', a) x)) (\<phi> (a, a) a)"
       proof -
         have "\<phi> (a', a) (a \<cdot> \<psi> (a', a) x) = x"
           using Ya.ide_a a' x \<psi>x Hom.\<phi>_\<psi> C.comp_cod_arr by fastforce
         moreover have "S.arr (S.mkArr (Hom.set (a, a)) (Hom.set (a', a))
                              (\<phi> (a', a) \<circ> Cop.comp (\<psi> (a', a) x) \<circ> \<psi> (a, a)))"
-          by (metis (no_types) Cop.hom_char Ya.Y_ide_arr(2) Ya.preserves_reflects_arr
-              \<chi>.ide_apex \<psi>x Cop.in_homE)
+          by (metis C.arrI Cop.arr_char Ya.Y_ide_arr(2) Ya.preserves_arr \<chi>.ide_apex \<psi>x)
         ultimately show ?thesis
           using Ya.ide_a a' x Ya.Y_ide_arr \<psi>x \<phi>a C.ide_in_hom by auto
       qed
       also have "... = (Cones.FUN (\<psi> (a', a) x) o \<Phi>.FUN a) (\<phi> (a, a) a)"
       proof -
         have "(\<Phi>.FUN a' o Ya.FUN (\<psi> (a', a) x)) (\<phi> (a, a) a)
                 = S.Fun (\<Phi> a' \<cdot>\<^sub>S Y a (\<psi> (a', a) x)) (\<phi> (a, a) a)"
           using \<psi>x a' \<phi>a Ya.ide_a Ya.map_simp Hom.set_map by (elim C.in_homE, auto)
         also have "... = S.Fun (S (Cones.map (\<psi> (a', a) x)) (\<Phi> a)) (\<phi> (a, a) a)"
           using \<psi>x is_natural_1 [of "\<psi> (a', a) x"] is_natural_2 [of "\<psi> (a', a) x"] by auto
         also have "... = (Cones.FUN (\<psi> (a', a) x) o \<Phi>.FUN a) (\<phi> (a, a) a)"
         proof -
           have "S.seq (Cones.map (\<psi> (a', a) x)) (\<Phi> a)"
             using Ya.ide_a \<psi>x Cones.map_preserves_dom [of "\<psi> (a', a) x"]
             apply (intro S.seqI)
               apply auto[2]
             by fastforce
           thus ?thesis
             using Ya.ide_a \<phi>a Hom.set_map by auto
         qed
         finally show ?thesis by simp
       qed
       also have "... = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)" using \<iota>\<chi> by simp
       finally show ?thesis by auto
     qed
 
     lemma \<chi>_is_universal:
     assumes "D.cone a' \<chi>'"
     shows "\<guillemotleft>\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>')) : a' \<rightarrow> a\<guillemotright>"
     and "D.cones_map (\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))) \<chi> = \<chi>'"
     and "\<lbrakk> \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>; D.cones_map f' \<chi> = \<chi>' \<rbrakk> \<Longrightarrow> f' = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
     proof -
       interpret \<chi>': cone J C D a' \<chi>' using assms by auto
       have a': "C.ide a'" using \<chi>'.ide_apex by simp
       have \<iota>\<chi>': "\<iota> \<chi>' \<in> Cones.SET a'" using assms a' Cones_SET_eq_\<iota>_img_cones by auto
       let ?f = "\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
       have A: "\<Psi>.FUN a' (\<iota> \<chi>') \<in> Hom.set (a', a)"
       proof -
         have "\<Psi>.FUN a' \<in> Cones.SET a' \<rightarrow> Ya.SET a'"
           using a' \<Psi>.preserves_hom [of a' a' a'] S.Fun_mapsto [of "\<Psi>.map a'"] by fastforce
         thus ?thesis using a' \<iota>\<chi>' Ya.ide_a Hom.set_map by auto
       qed
       show f: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using A a' Ya.ide_a Hom.\<psi>_mapsto [of a' a] by auto
       have E: "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> Cones.FUN f (\<iota> \<chi>) = \<Phi>.FUN a' (\<phi> (a', a) f)"
       proof -
         fix f
         assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
         have "\<phi> (a', a) f \<in> Hom.set (a', a)"
           using a' Ya.ide_a f Hom.\<phi>_mapsto by auto
         thus "Cones.FUN f (\<iota> \<chi>) = \<Phi>.FUN a' (\<phi> (a', a) f)"
           using a' f \<Phi>_FUN_simp by simp
       qed
       have I: "\<Phi>.FUN a' (\<Psi>.FUN a' (\<iota> \<chi>')) = \<iota> \<chi>'"
       proof -
         have "\<Phi>.FUN a' (\<Psi>.FUN a' (\<iota> \<chi>')) =
               compose (\<Psi>.DOM a') (\<Phi>.FUN a') (\<Psi>.FUN a') (\<iota> \<chi>')"
           using a' \<iota>\<chi>' Cones.map_ide \<Psi>.preserves_hom [of a' a' a'] by force
         also have "... = (\<lambda>x \<in> \<Psi>.DOM a'. x) (\<iota> \<chi>')"
           using a' \<Psi>.inverts_components S.inverse_arrows_char by force
         also have "... = \<iota> \<chi>'"
           using a' \<iota>\<chi>' Cones.map_ide \<Psi>.preserves_hom [of a' a' a'] by force
         finally show ?thesis by auto
       qed
       show f\<chi>: "D.cones_map ?f \<chi> = \<chi>'"
       proof -
         have "D.cones_map ?f \<chi> = (\<o> o Cones.FUN ?f o \<iota>) \<chi>"
           using f Cones.preserves_arr [of ?f] cone_\<chi>
           by (cases "D.cone a \<chi>", auto)
         also have "... = \<chi>'"
            using f Ya.ide_a a' A E I by auto
         finally show ?thesis by auto
       qed
       show "\<lbrakk> \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>; D.cones_map f' \<chi> = \<chi>' \<rbrakk> \<Longrightarrow> f' = ?f"
       proof -
         assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>" and f'\<chi>: "D.cones_map f' \<chi> = \<chi>'"
         show "f' = ?f"
         proof -
           have 1: "\<phi> (a', a) f' \<in> Hom.set (a', a) \<and> \<phi> (a', a) ?f \<in> Hom.set (a', a)"
             using Ya.ide_a a' f f' Hom.\<phi>_mapsto by auto
           have "S.iso (\<Phi> a')" using \<chi>'.ide_apex components_are_iso by auto
           hence 2: "S.arr (\<Phi> a') \<and> bij_betw (\<Phi>.FUN a') (Hom.set (a', a)) (Cones.SET a')"
             using Ya.ide_a a' S.iso_char Hom.set_map by auto
           have "\<Phi>.FUN a' (\<phi> (a', a) f') = \<Phi>.FUN a' (\<phi> (a', a) ?f)"
           proof -
             have "\<Phi>.FUN a' (\<phi> (a', a) ?f) = \<iota> \<chi>'"
               using A I Hom.\<phi>_\<psi> Ya.ide_a a' by simp
             also have "... = Cones.FUN f' (\<iota> \<chi>)"
               using f f' A E cone_\<chi> Cones.preserves_arr f\<chi> f'\<chi> by (elim C.in_homE, auto)
             also have "... = \<Phi>.FUN a' (\<phi> (a', a) f')"
               using f' E by simp
             finally show ?thesis by argo
           qed
           moreover have "inj_on (\<Phi>.FUN a') (Hom.set (a', a))"
             using 2 bij_betw_imp_inj_on by blast
           ultimately have 3: "\<phi> (a', a) f' = \<phi> (a', a) ?f"
             using 1 inj_on_def [of "\<Phi>.FUN a'" "Hom.set (a', a)"] by blast
           show ?thesis
           proof -
             have "f' = \<psi> (a', a) (\<phi> (a', a) f')"
               using Ya.ide_a a' f' Hom.\<psi>_\<phi> by simp
             also have "... = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
               using Ya.ide_a a' Hom.\<psi>_\<phi> A 3 by simp
             finally show ?thesis by blast
           qed
         qed
       qed
     qed
 
     interpretation \<chi>: limit_cone J C D a \<chi>
     proof
       show "\<And>a' \<chi>'. D.cone a' \<chi>' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
       proof -
         fix a' \<chi>'
         assume 1: "D.cone a' \<chi>'"
         show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>'"
         proof
           show "\<guillemotleft>\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>')) : a' \<rightarrow> a\<guillemotright> \<and>
                 D.cones_map (\<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))) \<chi> = \<chi>'"
             using 1 \<chi>_is_universal by blast
           show "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' \<Longrightarrow> f = \<psi> (a', a) (\<Psi>.FUN a' (\<iota> \<chi>'))"
             using 1 \<chi>_is_universal by blast
         qed
       qed
     qed
 
     lemma \<chi>_is_limit_cone:
     shows "D.limit_cone a \<chi>" ..
 
     lemma induces_limit_situation:
     shows "limit_situation J C D S \<phi> \<iota> a \<Phi> \<chi>"
     proof
       show "\<chi> = \<chi>" by simp
       fix a'
       assume a': "Cop.ide a'"
       let ?F = "\<lambda>x. \<iota> (D.cones_map (\<psi> (a', a) x) \<chi>)"
       show "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
       proof -
         have 1: "\<guillemotleft>\<Phi> a' : S.mkIde (Hom.set (a', a)) \<rightarrow>\<^sub>S S.mkIde (\<iota> ` D.cones a')\<guillemotright>"
           using a' Cones.map_ide Ya.ide_a by auto
         moreover have "\<Phi>.DOM a' = Hom.set (a', a)"
           using 1 Hom.set_subset_Univ a' Ya.ide_a Hom.set_map by simp
         moreover have "\<Phi>.COD a' = \<iota> ` D.cones a'"
           using a' Cones_SET_eq_\<iota>_img_cones by fastforce
         ultimately have 2: "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<Phi>.FUN a')"
           using S.mkArr_Fun [of "\<Phi> a'"] by fastforce
         also have "... = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F"
         proof
           show "S.arr (S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') (\<Phi>.FUN a'))"
             using 1 2 by auto
           show "\<And>x. x \<in> Hom.set (a', a) \<Longrightarrow> \<Phi>.FUN a' x = ?F x"
           proof -
             fix x
             assume x: "x \<in> Hom.set (a', a)"
             hence \<psi>x: "\<guillemotleft>\<psi> (a', a) x : a' \<rightarrow> a\<guillemotright>"
               using a' Ya.ide_a Hom.\<psi>_mapsto by auto
             show "\<Phi>.FUN a' x = ?F x"
             proof -
               have "\<Phi>.FUN a' x = Cones.FUN (\<psi> (a', a) x) (\<iota> \<chi>)"
                 using a' x \<Phi>_FUN_simp by simp
               also have "... = restrict (\<iota> o D.cones_map (\<psi> (a', a) x) o \<o>) (\<iota> ` D.cones a) (\<iota> \<chi>)"
                 using \<psi>x Cones.map_simp Cones.preserves_arr [of "\<psi> (a', a) x"] S.Fun_mkArr
                 by (elim C.in_homE, auto)
               also have "... = ?F x" using cone_\<chi> by simp
               ultimately show ?thesis by simp
             qed
           qed
         qed
         finally show "\<Phi> a' = S.mkArr (Hom.set (a', a)) (\<iota> ` D.cones a') ?F" by auto
       qed
     qed
 
   end
 
   sublocale representation_of_cones_functor \<subseteq> limit_situation J C D S \<phi> \<iota> a \<Phi> \<chi>
     using induces_limit_situation by auto
 
   section "Categories with Limits"
 
   context category
   begin
 
     text\<open>
       A category @{term[source=true] C} has limits of shape @{term J} if every diagram of shape
       @{term J} admits a limit cone.
 \<close>
 
     definition has_limits_of_shape
     where "has_limits_of_shape J \<equiv> \<forall>D. diagram J C D \<longrightarrow> (\<exists>a \<chi>. limit_cone J C D a \<chi>)"
 
     text\<open>
       A category has limits at a type @{typ 'j} if it has limits of shape @{term J}
       for every category @{term J} whose arrows are of type @{typ 'j}.
 \<close>
 
     definition has_limits
     where "has_limits (_ :: 'j) \<equiv> \<forall>J :: 'j comp. category J \<longrightarrow> has_limits_of_shape J"
 
     text\<open>
       Whether a category has limits of shape \<open>J\<close> truly depends only on the ``shape''
       (\emph{i.e.}~isomorphism class) of \<open>J\<close> and not on details of its construction.
     \<close>
 
     lemma has_limits_preserved_by_isomorphism:
     assumes "has_limits_of_shape J" and "isomorphic_categories J J'"
     shows "has_limits_of_shape J'"
     proof -
       interpret J: category J
         using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
       interpret J': category J'
         using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
       from assms(2) obtain \<phi> \<psi> where IF: "inverse_functors J' J \<phi> \<psi>"
         using isomorphic_categories_def isomorphic_categories_axioms_def
               inverse_functors_sym
         by blast
       interpret IF: inverse_functors J' J \<phi> \<psi> using IF by auto
       have \<psi>\<phi>: "\<psi> o \<phi> = J.map" using IF.inv by metis
       have \<phi>\<psi>: "\<phi> o \<psi> = J'.map" using IF.inv' by metis
       have "\<And>D'. diagram J' C D' \<Longrightarrow> \<exists>a \<chi>. limit_cone J' C D' a \<chi>"
       proof -
         fix D'
         assume D': "diagram J' C D'"
         interpret D': diagram J' C D' using D' by auto
         interpret D: composite_functor J J' C \<phi> D' ..
         interpret D: diagram J C \<open>D' o \<phi>\<close> ..
         have D: "diagram J C (D' o \<phi>)" ..
         from assms(1) obtain a \<chi> where \<chi>: "D.limit_cone a \<chi>"
           using D has_limits_of_shape_def by blast
         interpret \<chi>: limit_cone J C \<open>D' o \<phi>\<close> a \<chi> using \<chi> by auto
         interpret A': constant_functor J' C a
           using \<chi>.ide_apex by (unfold_locales, auto)
         have \<chi>o\<psi>: "cone J' C (D' o \<phi> o \<psi>) a (\<chi> o \<psi>)"
           using comp_cone_functor IF.G.functor_axioms \<chi>.cone_axioms by fastforce
         hence \<chi>o\<psi>: "cone J' C D' a (\<chi> o \<psi>)"
           using \<phi>\<psi> by (metis D'.functor_axioms Fun.comp_assoc comp_functor_identity)
         interpret \<chi>o\<psi>: cone J' C D' a \<open>\<chi> o \<psi>\<close> using \<chi>o\<psi> by auto
         interpret \<chi>o\<psi>: limit_cone J' C D' a \<open>\<chi> o \<psi>\<close>
         proof
           fix a' \<chi>'
           assume \<chi>': "D'.cone a' \<chi>'"
           interpret \<chi>': cone J' C D' a' \<chi>' using \<chi>' by auto
           have \<chi>'o\<phi>: "cone J C (D' o \<phi>) a' (\<chi>' o \<phi>)"
             using \<chi>' comp_cone_functor IF.F.functor_axioms by fastforce
           interpret \<chi>'o\<phi>: cone J C \<open>D' o \<phi>\<close> a' \<open>\<chi>' o \<phi>\<close> using \<chi>'o\<phi> by auto
           have "cone J C (D' o \<phi>) a' (\<chi>' o \<phi>)" ..
           hence 1: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"
             using \<chi>.is_universal by simp
           show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f (\<chi> o \<psi>) = \<chi>'"
           proof
             let ?f = "THE f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"
             have f: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map ?f \<chi> = \<chi>' o \<phi>"
               using 1 theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = \<chi>' o \<phi>"] by blast
             have f_in_hom: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using f by blast
             have "D'.cones_map ?f (\<chi> o \<psi>) = \<chi>'"
             proof
               fix j'
               have "\<not>J'.arr j' \<Longrightarrow> D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'"
               proof -
                 assume j': "\<not>J'.arr j'"
                 have "D'.cones_map ?f (\<chi> o \<psi>) j' = null"
                   using j' f_in_hom \<chi>o\<psi> by fastforce
                 thus ?thesis
                   using j' \<chi>'.is_extensional by simp
               qed
               moreover have "J'.arr j' \<Longrightarrow> D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'"
               proof -
                 assume j': "J'.arr j'"
                 have "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi> (\<psi> j') \<cdot> ?f"
                   using j' f \<chi>o\<psi> by fastforce
                 also have "... = D.cones_map ?f \<chi> (\<psi> j')"
                   using j' f_in_hom \<chi> \<chi>.cone_\<chi> by fastforce
                 also have "... = \<chi>' j'"
                   using j' f \<chi> \<phi>\<psi> Fun.comp_def J'.map_simp by metis
                 finally show "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'" by auto
               qed
               ultimately show "D'.cones_map ?f (\<chi> o \<psi>) j' = \<chi>' j'" by blast
             qed
             thus "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map ?f (\<chi> o \<psi>) = \<chi>'" using f by auto
             fix f'
             assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f' (\<chi> o \<psi>) = \<chi>'"
             have "D.cones_map f' \<chi> = \<chi>' o \<phi>"
             proof
               fix j
               have "\<not>J.arr j \<Longrightarrow> D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j"
                 using f' \<chi> \<chi>'o\<phi>.is_extensional \<chi>.cone_\<chi> mem_Collect_eq restrict_apply by auto
               moreover have "J.arr j \<Longrightarrow> D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j"
               proof -
                 assume j: "J.arr j"
                 have "D.cones_map f' \<chi> j = C (\<chi> j) f'"
                   using j f' \<chi>.cone_\<chi> by auto
                 also have "... = C ((\<chi> o \<psi>) (\<phi> j)) f'"
                   using j f' \<psi>\<phi> by (metis comp_apply J.map_simp)
                 also have "... = D'.cones_map f' (\<chi> o \<psi>) (\<phi> j)"
                   using j f' \<chi>o\<psi> by fastforce
                 also have "... = (\<chi>' o \<phi>) j"
                   using j f' by auto
                 finally show "D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j" by auto
               qed
               ultimately show "D.cones_map f' \<chi> j = (\<chi>' o \<phi>) j" by blast
             qed
             hence "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f' \<chi> = \<chi>' o \<phi>"
               using f' by auto
             moreover have "\<And>P x x'. (\<exists>!x. P x) \<and> P x \<and> P x' \<Longrightarrow> x = x'"
               by auto
             ultimately show "f' = ?f" using 1 f by blast
           qed
         qed
         have "limit_cone J' C D' a (\<chi> o \<psi>)" ..
         thus "\<exists>a \<chi>. limit_cone J' C D' a \<chi>" by blast
       qed
       thus ?thesis using has_limits_of_shape_def by auto
     qed
 
   end
 
   subsection "Diagonal Functors"
 
   text\<open>
     The existence of limits can also be expressed in terms of adjunctions: a category @{term C}
     has limits of shape @{term J} if the diagonal functor taking each object @{term a}
     in @{term C} to the constant-@{term a} diagram and each arrow \<open>f \<in> C.hom a a'\<close>
     to the constant-@{term f} natural transformation between diagrams is a left adjoint functor.
 \<close>
 
   locale diagonal_functor =
     C: category C +
     J: category J +
     J_C: functor_category J C
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   begin
 
     notation J.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
     notation J_C.comp     (infixr "\<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>]" 55)
     notation J_C.in_hom   ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] _\<guillemotright>")
 
     definition map :: "'c \<Rightarrow> ('j, 'c) J_C.arr"
     where "map f = (if C.arr f then J_C.MkArr (constant_functor.map J C (C.dom f))
                                               (constant_functor.map J C (C.cod f))
                                               (constant_transformation.map J C f)
                                else J_C.null)"
 
     lemma is_functor:
     shows "functor C J_C.comp map"
     proof
       fix f
       show "\<not> C.arr f \<Longrightarrow> local.map f = J_C.null"
         using map_def by simp
       assume f: "C.arr f"
       interpret Dom_f: constant_functor J C \<open>C.dom f\<close>
         using f by (unfold_locales, auto)
       interpret Cod_f: constant_functor J C \<open>C.cod f\<close>
         using f by (unfold_locales, auto)
       interpret Fun_f: constant_transformation J C f
         using f by (unfold_locales, auto)
       show 1: "J_C.arr (map f)"
         using f map_def by (simp add: Fun_f.natural_transformation_axioms)
       show "J_C.dom (map f) = map (C.dom f)"
       proof -
         have "constant_transformation J C (C.dom f)"
           using f by unfold_locales auto
         hence "constant_transformation.map J C (C.dom f) = Dom_f.map"
           using Dom_f.map_def constant_transformation.map_def [of J C "C.dom f"] by auto
         thus ?thesis using f 1 by (simp add: map_def J_C.dom_char)
       qed
       show "J_C.cod (map f) = map (C.cod f)"
       proof -
         have "constant_transformation J C (C.cod f)"
           using f by unfold_locales auto
         hence "constant_transformation.map J C (C.cod f) = Cod_f.map"
           using Cod_f.map_def constant_transformation.map_def [of J C "C.cod f"] by auto
         thus ?thesis using f 1 by (simp add: map_def J_C.cod_char)
       qed
       next
       fix f g
       assume g: "C.seq g f"
       have f: "C.arr f" using g by auto
       interpret Dom_f: constant_functor J C \<open>C.dom f\<close>
         using f by unfold_locales auto
       interpret Cod_f: constant_functor J C \<open>C.cod f\<close>
         using f by unfold_locales auto
       interpret Fun_f: constant_transformation J C f
         using f by unfold_locales auto
       interpret Cod_g: constant_functor J C \<open>C.cod g\<close>
         using g by unfold_locales auto
       interpret Fun_g: constant_transformation J C g
         using g by unfold_locales auto
       interpret Fun_g: natural_transformation J C Cod_f.map Cod_g.map Fun_g.map
         apply unfold_locales
         using f g C.seqE [of g f] C.comp_arr_dom C.comp_cod_arr Fun_g.is_extensional by auto
       interpret Fun_fg: vertical_composite
                           J C Dom_f.map Cod_f.map Cod_g.map Fun_f.map Fun_g.map ..
       have 1: "J_C.arr (map f)"
         using f map_def by (simp add: Fun_f.natural_transformation_axioms)
       show "map (g \<cdot> f) = map g \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map f"
       proof -
         have "map (C g f) = J_C.MkArr Dom_f.map Cod_g.map
                                       (constant_transformation.map J C (C g f))"
           using f g map_def by simp
         also have "... = J_C.MkArr Dom_f.map Cod_g.map (\<lambda>j. if J.arr j then C g f else C.null)"
         proof -
           have "constant_transformation J C (g \<cdot> f)"
             using g by unfold_locales auto
           thus ?thesis using constant_transformation.map_def by metis
         qed
         also have "... = J_C.comp (J_C.MkArr Cod_f.map Cod_g.map Fun_g.map)
                                   (J_C.MkArr Dom_f.map Cod_f.map Fun_f.map)"
         proof -
           have "J_C.MkArr Cod_f.map Cod_g.map Fun_g.map \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>]
                 J_C.MkArr Dom_f.map Cod_f.map Fun_f.map
                   = J_C.MkArr Dom_f.map Cod_g.map Fun_fg.map"
             using J_C.comp_char J_C.comp_MkArr Fun_f.natural_transformation_axioms
                   Fun_g.natural_transformation_axioms
             by blast
           also have "... = J_C.MkArr Dom_f.map Cod_g.map
                                      (\<lambda>j. if J.arr j then g \<cdot> f else C.null)"
             using Fun_fg.is_extensional Fun_fg.map_simp_2 by auto
           finally show ?thesis by auto
         qed
         also have "... = map g \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map f"
           using f g map_def by fastforce
         finally show ?thesis by auto
       qed
     qed
 
     sublocale "functor" C J_C.comp map
       using is_functor by auto
 
     text\<open>
       The objects of \<open>[J, C]\<close> correspond bijectively to diagrams of shape @{term J}
       in @{term C}.
 \<close>
 
     lemma ide_determines_diagram:
     assumes "J_C.ide d"
     shows "diagram J C (J_C.Map d)" and "J_C.MkIde (J_C.Map d) = d"
     proof -
       interpret \<delta>: natural_transformation J C \<open>J_C.Map d\<close> \<open>J_C.Map d\<close> \<open>J_C.Map d\<close>
         using assms J_C.ide_char J_C.arr_MkArr by fastforce
       interpret D: "functor" J C \<open>J_C.Map d\<close> ..
       show "diagram J C (J_C.Map d)" ..
       show "J_C.MkIde (J_C.Map d) = d"
         using assms J_C.ide_char by (metis J_C.ideD(1) J_C.MkArr_Map)
     qed
 
     lemma diagram_determines_ide:
     assumes "diagram J C D"
     shows "J_C.ide (J_C.MkIde D)" and "J_C.Map (J_C.MkIde D) = D"
     proof -
       interpret D: diagram J C D using assms by auto
       show "J_C.ide (J_C.MkIde D)" using J_C.ide_char
         using D.functor_axioms J_C.ide_MkIde by auto
       thus "J_C.Map (J_C.MkIde D) = D"
         using J_C.in_homE by simp
     qed
 
     lemma bij_betw_ide_diagram:
     shows "bij_betw J_C.Map (Collect J_C.ide) (Collect (diagram J C))"
     proof (intro bij_betwI)
       show "J_C.Map \<in> Collect J_C.ide \<rightarrow> Collect (diagram J C)"
         using ide_determines_diagram by blast
       show "J_C.MkIde \<in> Collect (diagram J C) \<rightarrow> Collect J_C.ide"
         using diagram_determines_ide by blast
       show "\<And>d. d \<in> Collect J_C.ide \<Longrightarrow> J_C.MkIde (J_C.Map d) = d"
         using ide_determines_diagram by blast
       show "\<And>D. D \<in> Collect (diagram J C) \<Longrightarrow> J_C.Map (J_C.MkIde D) = D"
         using diagram_determines_ide by blast
     qed
 
     text\<open>
       Arrows from from the diagonal functor correspond bijectively to cones.
 \<close>
 
     lemma arrow_determines_cone:
     assumes "J_C.ide d" and "arrow_from_functor C J_C.comp map a d x"
     shows "cone J C (J_C.Map d) a (J_C.Map x)"
     and "J_C.MkArr (constant_functor.map J C a) (J_C.Map d) (J_C.Map x) = x"
     proof -
       interpret D: diagram J C \<open>J_C.Map d\<close>
         using assms ide_determines_diagram by auto
       interpret x: arrow_from_functor C J_C.comp map a d x
         using assms by auto
       interpret A: constant_functor J C a
         using x.arrow by (unfold_locales, auto)
       interpret \<alpha>: constant_transformation J C a
         using x.arrow by (unfold_locales, auto)
       have Dom_x: "J_C.Dom x = A.map"
         using J_C.in_hom_char map_def x.arrow by force
       have Cod_x: "J_C.Cod x = J_C.Map d"
         using x.arrow by auto
       interpret \<chi>: natural_transformation J C A.map \<open>J_C.Map d\<close> \<open>J_C.Map x\<close>
         using x.arrow J_C.arr_char [of x] Dom_x Cod_x by force
       show "D.cone a (J_C.Map x)" ..
       show "J_C.MkArr A.map (J_C.Map d) (J_C.Map x) = x"
         using x.arrow Dom_x Cod_x \<chi>.natural_transformation_axioms
         by (intro J_C.arr_eqI, auto)
     qed
 
     lemma cone_determines_arrow:
     assumes "J_C.ide d" and "cone J C (J_C.Map d) a \<chi>"
     shows "arrow_from_functor C J_C.comp map a d
              (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>)"
     and "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>) = \<chi>"
     proof -
        interpret \<chi>: cone J C \<open>J_C.Map d\<close> a \<chi> using assms(2) by auto
        let ?x = "J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi>"
        interpret x: arrow_from_functor C J_C.comp map a d ?x
        proof
          have "\<guillemotleft>J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi> :
                   J_C.MkIde \<chi>.A.map \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde (J_C.Map d)\<guillemotright>"
            using \<chi>.natural_transformation_axioms by auto
          moreover have "J_C.MkIde \<chi>.A.map = map a"
            using \<chi>.A.value_is_ide map_def \<chi>.A.map_def C.ide_char
            by (metis (no_types, lifting) J_C.dom_MkArr preserves_arr preserves_dom)
          moreover have "J_C.MkIde (J_C.Map d) = d"
            using assms ide_determines_diagram(2) by simp
          ultimately show "C.ide a \<and> \<guillemotleft>J_C.MkArr \<chi>.A.map (J_C.Map d) \<chi> : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] d\<guillemotright>"
            using \<chi>.A.value_is_ide by simp
        qed
        show "arrow_from_functor C J_C.comp map a d ?x" ..
        show "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) \<chi>) = \<chi>"
          by (simp add: \<chi>.natural_transformation_axioms)
     qed
 
     text\<open>
       Transforming a cone by composing at the apex with an arrow @{term g} corresponds,
       via the preceding bijections, to composition in \<open>[J, C]\<close> with the image of @{term g}
       under the diagonal functor.
 \<close>
 
     lemma cones_map_is_composition:
     assumes "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>" and "cone J C D a \<chi>"
     shows "J_C.MkArr (constant_functor.map J C a') D (diagram.cones_map J C D g \<chi>)
              = J_C.MkArr (constant_functor.map J C a) D \<chi> \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
     proof -
       interpret A: constant_transformation J C a
         using assms(1) by (unfold_locales, auto)
       interpret \<chi>: cone J C D a \<chi> using assms(2) by auto
       have cone_\<chi>: "cone J C D a \<chi>" ..
       interpret A': constant_transformation J C a'
         using assms(1) by (unfold_locales, auto)
       let ?\<chi>' = "\<chi>.D.cones_map g \<chi>"
       interpret \<chi>': cone J C D a' ?\<chi>'
         using assms(1) cone_\<chi> \<chi>.D.cones_map_mapsto by blast
       let ?x = "J_C.MkArr \<chi>.A.map D \<chi>"
       let ?x' = "J_C.MkArr \<chi>'.A.map D ?\<chi>'"
       show "?x' = J_C.comp ?x (map g)"
       proof (intro J_C.arr_eqI)
         have x: "J_C.arr ?x"
           using \<chi>.natural_transformation_axioms J_C.arr_char [of ?x] by simp
         show x': "J_C.arr ?x'"
           using \<chi>'.natural_transformation_axioms J_C.arr_char [of ?x'] by simp
         have 3: "\<guillemotleft>?x : map a \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde D\<guillemotright>"
           using \<chi>.D.diagram_axioms arrow_from_functor.arrow cone_\<chi> cone_determines_arrow(1)
                 diagram_determines_ide(1)
           by fastforce
         have 4: "\<guillemotleft>?x' : map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] J_C.MkIde D\<guillemotright>"
           by (metis (no_types, lifting) J_C.Dom.simps(1) J_C.Dom_cod J_C.Map_cod
               J_C.cod_MkArr \<chi>'.cone_axioms arrow_from_functor.arrow category.ide_cod
               cone_determines_arrow(1) functor_def is_functor x)
         have seq_xg: "J_C.seq ?x (map g)"
           using assms(1) 3 preserves_hom [of g] by (intro J_C.seqI', auto)
         show 2: "J_C.seq ?x (map g)"
           using seq_xg J_C.seqI' by blast
         show "J_C.Dom ?x' = J_C.Dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
         proof -
           have "J_C.Dom ?x' = J_C.Dom (J_C.dom ?x')"
             using x' J_C.Dom_dom by simp
           also have "... = J_C.Dom (map a')"
             using 4 by force
           also have "... = J_C.Dom (J_C.dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g))"
             using assms(1) 2 by auto
           also have "... = J_C.Dom (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
             using seq_xg J_C.Dom_dom J_C.seqI' by blast
           finally show ?thesis by auto
         qed
         show "J_C.Cod ?x' = J_C.Cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
         proof -
           have "J_C.Cod ?x' = J_C.Cod (J_C.cod ?x')"
             using x' J_C.Cod_cod by simp
           also have "... = J_C.Cod (J_C.MkIde D)"
             using 4 by force
           also have "... = J_C.Cod (J_C.cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g))"
             using 2 3 J_C.cod_comp J_C.in_homE by metis
           also have "... = J_C.Cod (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
             using seq_xg J_C.Cod_cod J_C.seqI' by blast
           finally show ?thesis by auto
         qed
         show "J_C.Map ?x' = J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g)"
         proof -
           interpret g: constant_transformation J C g
             apply unfold_locales using assms(1) by auto
           interpret \<chi>og: vertical_composite J C A'.map \<chi>.A.map D g.map \<chi>
             using assms(1) C.comp_arr_dom C.comp_cod_arr A'.is_extensional g.is_extensional
             apply (unfold_locales, auto)
             by (elim J.seqE, auto)
           have "J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g) = \<chi>og.map"
             using assms(1) 2 J_C.comp_char map_def by auto
           also have "... = J_C.Map ?x'"
             using x' \<chi>og.map_def J_C.arr_char [of ?x'] natural_transformation.is_extensional
                   assms(1) cone_\<chi> \<chi>og.map_simp_2
             by fastforce
           finally show ?thesis by auto
         qed
       qed
     qed
 
     text\<open>
       Coextension along an arrow from a functor is equivalent to a transformation of cones.
 \<close>
 
     lemma coextension_iff_cones_map:
     assumes x: "arrow_from_functor C J_C.comp map a d x"
     and g: "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>"
     and x': "\<guillemotleft>x' : map a' \<rightarrow>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] d\<guillemotright>"
     shows "arrow_from_functor.is_coext C J_C.comp map a x a' x' g
               \<longleftrightarrow> J_C.Map x' = diagram.cones_map J C (J_C.Map d) g (J_C.Map x)"
     proof -
       interpret x: arrow_from_functor C J_C.comp map a d x
         using assms by auto
       interpret A': constant_functor J C a'
         using assms(2) by (unfold_locales, auto)
       have x': "arrow_from_functor C J_C.comp map a' d x'"
         using A'.value_is_ide assms(3) by (unfold_locales, blast)
       have d: "J_C.ide d" using J_C.ide_cod x.arrow by blast
       let ?D = "J_C.Map d"
       let ?\<chi> = "J_C.Map x"
       let ?\<chi>' = "J_C.Map x'"
       interpret D: diagram J C ?D
         using ide_determines_diagram J_C.ide_cod x.arrow by blast
       interpret \<chi>: cone J C ?D a ?\<chi>
         using assms(1) d arrow_determines_cone by simp
       interpret \<gamma>: constant_transformation J C g
         using g \<chi>.ide_apex by (unfold_locales, auto)
       interpret \<chi>og: vertical_composite J C A'.map \<chi>.A.map ?D \<gamma>.map ?\<chi>
         using g C.comp_arr_dom C.comp_cod_arr \<gamma>.is_extensional by (unfold_locales, auto)
       show ?thesis
       proof
         assume 0: "x.is_coext a' x' g"
         show "?\<chi>' = D.cones_map g ?\<chi>"
         proof -
           have 1: "x' = x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
             using 0 x.is_coext_def by blast
           hence "?\<chi>' = J_C.Map x'"
             using 0 x.is_coext_def by fast
           moreover have "... = D.cones_map g ?\<chi>"
           proof -
             have "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) = x'"
             proof -
               have "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) =
                     x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g"
                 using d g cones_map_is_composition arrow_determines_cone(2) \<chi>.cone_axioms
                       x.arrow_from_functor_axioms
                 by auto
               thus ?thesis by (metis 1)
             qed
             moreover have "J_C.arr (J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)))"
               using 1 d g cones_map_is_composition preserves_arr arrow_determines_cone(2)
                     \<chi>.cone_axioms x.arrow_from_functor_axioms assms(3)
               by auto
             ultimately show ?thesis by auto
           qed
           ultimately show ?thesis by blast
         qed
         next
         assume X': "?\<chi>' = D.cones_map g ?\<chi>"
         show "x.is_coext a' x' g"
         proof -
           have 4: "J_C.seq x (map g)"
             using g x.arrow mem_Collect_eq preserves_arr preserves_cod
             by (elim C.in_homE, auto)
           hence 1: "x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] map g =
                    J_C.MkArr (J_C.Dom (map g)) (J_C.Cod x)
                              (vertical_composite.map J C (J_C.Map (map g)) ?\<chi>)"
             using J_C.comp_char [of x "map g"] by simp
           have 2: "vertical_composite.map J C (J_C.Map (map g)) ?\<chi> = \<chi>og.map"
             by (simp add: map_def \<gamma>.value_is_arr \<gamma>.natural_transformation_axioms)
           have 3: "... = D.cones_map g ?\<chi>"
             using g \<chi>og.map_simp_2 \<chi>.cone_axioms \<chi>og.is_extensional by auto
           have "J_C.MkArr A'.map ?D ?\<chi>' = J_C.comp x (map g)"
           proof -
             have f1: "A'.map = J_C.Dom (map g)"
               using \<gamma>.natural_transformation_axioms map_def g by auto
             have "J_C.Map d = J_C.Cod x"
               using x.arrow by auto
             thus ?thesis using f1 X' 1 2 3 by argo
           qed
           moreover have "J_C.MkArr A'.map ?D ?\<chi>' = x'"
             using d x' arrow_determines_cone by blast
           ultimately show ?thesis
             using g x.is_coext_def by simp
         qed
       qed
     qed
 
   end
 
   locale right_adjoint_to_diagonal_functor =
     C: category C +
     J: category J +
     J_C: functor_category J C +
     \<Delta>: diagonal_functor J C +
     "functor" J_C.comp C G +
     Adj: meta_adjunction J_C.comp C \<Delta>.map G \<phi> \<psi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and G :: "('j, 'c) functor_category.arr \<Rightarrow> 'c"
   and \<phi> :: "'c \<Rightarrow> ('j, 'c) functor_category.arr \<Rightarrow> 'c"
   and \<psi> :: "('j, 'c) functor_category.arr \<Rightarrow> 'c \<Rightarrow> ('j, 'c) functor_category.arr" +
   assumes adjoint: "adjoint_functors J_C.comp C \<Delta>.map G"
   begin
 
-    interpretation Adj: adjunction J_C.comp C replete_setcat.comp Adj.\<phi>C Adj.\<phi>D \<Delta>.map G
+    interpretation S: replete_setcat .
+    interpretation Adj: adjunction J_C.comp C S.comp S.setp Adj.\<phi>C Adj.\<phi>D \<Delta>.map G
                           \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
       using Adj.induces_adjunction by simp
 
     text\<open>
       A right adjoint @{term G} to a diagonal functor maps each object @{term d} of
       \<open>[J, C]\<close> (corresponding to a diagram @{term D} of shape @{term J} in @{term C}
       to an object of @{term C}.  This object is the limit object, and the component at @{term d}
       of the counit of the adjunction determines the limit cone.
 \<close>
 
     lemma gives_limit_cones:
     assumes "diagram J C D"
     shows "limit_cone J C D (G (J_C.MkIde D)) (J_C.Map (Adj.\<epsilon> (J_C.MkIde D)))"
     proof -
       interpret D: diagram J C D using assms by auto
       let ?d = "J_C.MkIde D"
       let ?a = "G ?d"
       let ?x = "Adj.\<epsilon> ?d"
       let ?\<chi> = "J_C.Map ?x"
       have "diagram J C D" ..
       hence 1: "J_C.ide ?d" using \<Delta>.diagram_determines_ide by auto
       hence 2: "J_C.Map (J_C.MkIde D) = D"
         using assms 1 J_C.in_homE \<Delta>.diagram_determines_ide(2) by simp
       interpret x: terminal_arrow_from_functor C J_C.comp \<Delta>.map ?a ?d ?x
         apply unfold_locales
          apply (metis (no_types, lifting) "1" preserves_ide Adj.\<epsilon>_in_terms_of_\<psi>
                 Adj.\<epsilon>o_def Adj.\<epsilon>o_in_hom)
         by (metis 1 Adj.has_terminal_arrows_from_functor(1)
                   terminal_arrow_from_functor.is_terminal)
       have 3: "arrow_from_functor C J_C.comp \<Delta>.map ?a ?d ?x" ..
       interpret \<chi>: cone J C D ?a ?\<chi>
         using 1 2 3 \<Delta>.arrow_determines_cone [of ?d] by auto
       have cone_\<chi>: "D.cone ?a ?\<chi>" ..
       interpret \<chi>: limit_cone J C D ?a ?\<chi>
       proof
         fix a' \<chi>'
         assume cone_\<chi>': "D.cone a' \<chi>'"
         interpret \<chi>': cone J C D a' \<chi>' using cone_\<chi>' by auto
         let ?x' = "J_C.MkArr \<chi>'.A.map D \<chi>'"
         interpret x': arrow_from_functor C J_C.comp \<Delta>.map a' ?d ?x'
           using 1 2 by (metis \<Delta>.cone_determines_arrow(1) cone_\<chi>')
         have "arrow_from_functor C J_C.comp \<Delta>.map a' ?d ?x'" ..
         hence 4: "\<exists>!g. x.is_coext a' ?x' g"
           using x.is_terminal by simp
         have 5: "\<And>g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<Longrightarrow> x.is_coext a' ?x' g \<longleftrightarrow> D.cones_map g ?\<chi> = \<chi>'"
           using \<Delta>.coextension_iff_cones_map x'.arrow x.arrow_from_functor_axioms by auto
         have 6: "\<And>g. x.is_coext a' ?x' g \<Longrightarrow> \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright>"
           using x.is_coext_def by simp
         show "\<exists>!g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<and> D.cones_map g ?\<chi> = \<chi>'"
         proof -
           have "\<exists>g. \<guillemotleft>g : a' \<rightarrow>\<^sub>C ?a\<guillemotright> \<and> D.cones_map g ?\<chi> = \<chi>'"
             using 4 5 6 by meson
           thus ?thesis
             using 4 5 6 by blast
         qed
       qed
       show "D.limit_cone ?a ?\<chi>" ..
     qed
 
     corollary gives_limits:
     assumes "diagram J C D"
     shows "diagram.has_as_limit J C D (G (J_C.MkIde D))"
       using assms gives_limit_cones by fastforce
 
   end
 
   lemma (in category) has_limits_iff_left_adjoint_diagonal:
   assumes "category J"
   shows "has_limits_of_shape J \<longleftrightarrow>
            left_adjoint_functor C (functor_category.comp J C) (diagonal_functor.map J C)"
   proof -
     interpret J: category J using assms by auto
     interpret J_C: functor_category J C ..
     interpret \<Delta>: diagonal_functor J C ..
     show ?thesis
     proof
       assume A: "left_adjoint_functor C J_C.comp \<Delta>.map"
       interpret \<Delta>: left_adjoint_functor C J_C.comp \<Delta>.map using A by auto
       interpret Adj: meta_adjunction J_C.comp C \<Delta>.map \<Delta>.G \<Delta>.\<phi> \<Delta>.\<psi>
         using \<Delta>.induces_meta_adjunction by auto
       have 1: "adjoint_functors J_C.comp C \<Delta>.map \<Delta>.G"
         using adjoint_functors_def \<Delta>.induces_meta_adjunction by blast
       interpret G: right_adjoint_to_diagonal_functor J C \<Delta>.G \<Delta>.\<phi> \<Delta>.\<psi>
         using 1 by unfold_locales auto
       show "has_limits_of_shape J"
         using A G.gives_limits has_limits_of_shape_def by blast
       next
       text\<open>
         If @{term "has_limits J"}, then every diagram @{term D} from @{term J} to
         @{term[source=true] C} has a limit cone.
         This means that, for every object @{term d} of the functor category
         \<open>[J, C]\<close>, there exists an object @{term a} of @{term C} and a terminal arrow from
         \<open>\<Delta> a\<close> to @{term d} in \<open>[J, C]\<close>.  The terminal arrow is given by the
         limit cone.
 \<close>
       assume A: "has_limits_of_shape J"
       show "left_adjoint_functor C J_C.comp \<Delta>.map"
       proof
         fix d
         assume D: "J_C.ide d"
         interpret D: diagram J C \<open>J_C.Map d\<close>
           using D \<Delta>.ide_determines_diagram by auto
         let ?D = "J_C.Map d"
         have "diagram J C (J_C.Map d)" ..
         from this obtain a \<chi> where limit: "limit_cone J C ?D a \<chi>"
           using A has_limits_of_shape_def by blast
         interpret A: constant_functor J C a
           using limit by (simp add: Limit.cone_def limit_cone_def)
         interpret \<chi>: limit_cone J C ?D a \<chi> using limit by simp
         have cone_\<chi>: "cone J C ?D a \<chi>" ..
         let ?x = "J_C.MkArr A.map ?D \<chi>"
         interpret x: arrow_from_functor C J_C.comp \<Delta>.map a d ?x
           using D cone_\<chi> \<Delta>.cone_determines_arrow by auto
         have "terminal_arrow_from_functor C J_C.comp \<Delta>.map a d ?x"
         proof
           show "\<And>a' x'. arrow_from_functor C J_C.comp \<Delta>.map a' d x' \<Longrightarrow> \<exists>!g. x.is_coext a' x' g"
           proof -
             fix a' x'
             assume x': "arrow_from_functor C J_C.comp \<Delta>.map a' d x'"
             interpret x': arrow_from_functor C J_C.comp \<Delta>.map a' d x' using x' by auto
             interpret A': constant_functor J C a'
               by (unfold_locales, simp add: x'.arrow)
             let ?\<chi>' = "J_C.Map x'"
             interpret \<chi>': cone J C ?D a' ?\<chi>'
               using D x' \<Delta>.arrow_determines_cone by auto
             have cone_\<chi>': "cone J C ?D a' ?\<chi>'" ..
             let ?g = "\<chi>.induced_arrow a' ?\<chi>'"
             show "\<exists>!g. x.is_coext a' x' g"
             proof
               show "x.is_coext a' x' ?g"
               proof (unfold x.is_coext_def)
                 have 1: "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map ?g \<chi> = ?\<chi>'"
                   using \<chi>.induced_arrow_def \<chi>.is_universal cone_\<chi>'
                         theI' [of "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<chi> = ?\<chi>'"]
                   by presburger
                 hence 2: "x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
                 proof -
                   have "x' = J_C.MkArr A'.map ?D ?\<chi>'"
                     using D \<Delta>.arrow_determines_cone(2) x'.arrow_from_functor_axioms by auto
                   thus ?thesis
                     using 1 cone_\<chi> \<Delta>.cones_map_is_composition [of ?g a' a ?D \<chi>] by simp
                 qed
                 show "\<guillemotleft>?g : a' \<rightarrow> a\<guillemotright> \<and> x' = ?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map ?g"
                   using 1 2 by auto
               qed
               next
               fix g
               assume X: "x.is_coext a' x' g"
               show "g = ?g"
               proof -
                 have "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'"
                 proof
                   show G: "\<guillemotleft>g : a' \<rightarrow> a\<guillemotright>" using X x.is_coext_def by blast
                   show "D.cones_map g \<chi> = ?\<chi>'"
                   proof -
                     have "?\<chi>' = J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g)"
                       using X x.is_coext_def [of a' x' g] by fast
                     also have "... = D.cones_map g \<chi>"
                     proof -
                       interpret map_g: constant_transformation J C g
                         using G by (unfold_locales, auto)
                       interpret \<chi>': vertical_composite J C
                                       map_g.F.map A.map \<open>\<chi>.\<Phi>.Ya.Cop_S.Map d\<close>
                                       map_g.map \<chi>
                       proof (intro_locales)
                         have "map_g.G.map = A.map"
                           using G by blast
                         thus "natural_transformation_axioms J (\<cdot>) map_g.F.map A.map map_g.map"
                           using map_g.natural_transformation_axioms
                           by (simp add: natural_transformation_def)
                       qed
                       have "J_C.Map (?x \<cdot>\<^sub>[\<^sub>J\<^sub>,\<^sub>C\<^sub>] \<Delta>.map g) = vertical_composite.map J C map_g.map \<chi>"
                       proof -
                         have "J_C.seq ?x (\<Delta>.map g)"
                           using G x.arrow by auto
                         thus ?thesis
                           using G \<Delta>.map_def J_C.Map_comp' [of ?x "\<Delta>.map g"] by auto
                       qed
                       also have "... = D.cones_map g \<chi>"
                         using G cone_\<chi> \<chi>'.map_def map_g.map_def \<chi>.is_natural_2 \<chi>'.map_simp_2
                         by auto
                       finally show ?thesis by blast
                     qed
                     finally show ?thesis by auto
                   qed
                 qed
                 thus ?thesis
                   using cone_\<chi>' \<chi>.is_universal \<chi>.induced_arrow_def
                         theI_unique [of "\<lambda>g. \<guillemotleft>g : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map g \<chi> = ?\<chi>'" g]
                   by presburger
               qed
             qed
           qed
         qed
         thus "\<exists>a x. terminal_arrow_from_functor C J_C.comp \<Delta>.map a d x" by auto
       qed
     qed
   qed
 
   section "Right Adjoint Functors Preserve Limits"
 
   context right_adjoint_functor
   begin
 
     lemma preserves_limits:
     fixes J :: "'j comp"
     assumes "diagram J C E" and "diagram.has_as_limit J C E a"
     shows "diagram.has_as_limit J D (G o E) (G a)"
     proof -
       text\<open>
         From the assumption that @{term E} has a limit, obtain a limit cone @{term \<chi>}.
 \<close>
       interpret J: category J using assms(1) diagram_def by auto
       interpret E: diagram J C E using assms(1) by auto
       from assms(2) obtain \<chi> where \<chi>: "limit_cone J C E a \<chi>" by auto
       interpret \<chi>: limit_cone J C E a \<chi> using \<chi> by auto
       have a: "C.ide a" using \<chi>.ide_apex by auto
       text\<open>
         Form the @{term E}-image \<open>GE\<close> of the diagram @{term E}.
 \<close>
       interpret GE: composite_functor J C D E G ..
       interpret GE: diagram J D GE.map ..
       text\<open>Let \<open>G\<chi>\<close> be the @{term G}-image of the cone @{term \<chi>},
              and note that it is a cone over \<open>GE\<close>.\<close>
       let ?G\<chi> = "G o \<chi>"
       interpret G\<chi>: cone J D GE.map \<open>G a\<close> ?G\<chi>
         using \<chi>.cone_axioms preserves_cones by blast
       text\<open>
         Claim that \<open>G\<chi>\<close> is a limit cone for diagram \<open>GE\<close>.
 \<close>
       interpret G\<chi>: limit_cone J D GE.map \<open>G a\<close> ?G\<chi>
       proof
         text \<open>
           Let @{term \<kappa>} be an arbitrary cone over \<open>GE\<close>.
 \<close>
         fix b \<kappa>
         assume \<kappa>: "GE.cone b \<kappa>"
         interpret \<kappa>: cone J D GE.map b \<kappa> using \<kappa> by auto
         interpret Fb: constant_functor J C \<open>F b\<close>
           apply unfold_locales
           by (meson F_is_functor \<kappa>.ide_apex functor.preserves_ide)
         interpret Adj: meta_adjunction C D F G \<phi> \<psi>
           using induces_meta_adjunction by auto
-        interpret Adj: adjunction C D replete_setcat.comp
+        interpret S: replete_setcat .
+        interpret Adj: adjunction C D S.comp S.setp
                          Adj.\<phi>C Adj.\<phi>D F G \<phi> \<psi> Adj.\<eta> Adj.\<epsilon> Adj.\<Phi> Adj.\<Psi>
           using Adj.induces_adjunction by simp
         text\<open>
           For each arrow @{term j} of @{term J}, let @{term "\<chi>' j"} be defined to be
           the adjunct of @{term "\<chi> j"}.  We claim that @{term \<chi>'} is a cone over @{term E}.
 \<close>
         let ?\<chi>' = "\<lambda>j. if J.arr j then Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j) else C.null"
         have cone_\<chi>': "E.cone (F b) ?\<chi>'"
         proof
           show "\<And>j. \<not>J.arr j \<Longrightarrow> ?\<chi>' j = C.null" by simp
           fix j
           assume j: "J.arr j"
           show "C.dom (?\<chi>' j) = Fb.map (J.dom j)" using j \<psi>_in_hom by simp
           show "C.cod (?\<chi>' j) = E (J.cod j)" using j \<psi>_in_hom by simp
           show "E j \<cdot>\<^sub>C ?\<chi>' (J.dom j) = ?\<chi>' j"
           proof -
             have "E j \<cdot>\<^sub>C ?\<chi>' (J.dom j) = (E j \<cdot>\<^sub>C Adj.\<epsilon> (E (J.dom j))) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
               using j C.comp_assoc by simp
             also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
             proof -
               have "(E j \<cdot>\<^sub>C Adj.\<epsilon> (E (J.dom j))) \<cdot>\<^sub>C F (\<kappa> (J.dom j))
                        = (Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C Adj.FG.map (E j)) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
                 using j Adj.\<epsilon>.naturality [of "E j"] by fastforce
               also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j))"
                 using C.comp_assoc by simp
               also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
               proof -
                 have "Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j)) = F (GE.map j \<cdot>\<^sub>D \<kappa> (J.dom j))"
                   using j by simp
                 hence "Adj.FG.map (E j) \<cdot>\<^sub>C F (\<kappa> (J.dom j)) = F (\<kappa> j)"
                   using j \<kappa>.is_natural_1 by metis
                 thus ?thesis using j by simp
               qed
               finally show ?thesis by auto
             qed
             also have "... = ?\<chi>' j"
               using j by simp
             finally show ?thesis by auto
           qed
           show "?\<chi>' (J.cod j) \<cdot>\<^sub>C Fb.map j = ?\<chi>' j"
           proof -
             have "?\<chi>' (J.cod j) \<cdot>\<^sub>C Fb.map j = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> (J.cod j))"
               using j Fb.value_is_ide Adj.\<epsilon>.preserves_hom C.comp_arr_dom [of "F (\<kappa> (J.cod j))"]
                     C.comp_assoc
               by simp
             also have "... = Adj.\<epsilon> (E (J.cod j)) \<cdot>\<^sub>C F (\<kappa> j)"
               using j \<kappa>.is_natural_1 \<kappa>.is_natural_2 Adj.\<epsilon>.naturality J.arr_cod_iff_arr
               by (metis J.cod_cod \<kappa>.A.map_simp)
             also have "... = ?\<chi>' j" using j by simp
             finally show ?thesis by auto
           qed
         qed
         text\<open>
           Using the universal property of the limit cone @{term \<chi>}, obtain the unique arrow
           @{term f} that transforms @{term \<chi>} into @{term \<chi>'}.
 \<close>
         from this \<chi>.is_universal [of "F b" ?\<chi>'] obtain f
           where f: "\<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'"
           by auto
         text\<open>
           Let @{term g} be the adjunct of @{term f}, and show that @{term g} transforms
           @{term G\<chi>} into @{term \<kappa>}.
 \<close>
         let ?g = "G f \<cdot>\<^sub>D Adj.\<eta> b"
         have 1: "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright>" using f \<kappa>.ide_apex by fastforce
         moreover have "GE.cones_map ?g ?G\<chi> = \<kappa>"
         proof
           fix j
           have "\<not>J.arr j \<Longrightarrow> GE.cones_map ?g ?G\<chi> j = \<kappa> j"
             using 1 G\<chi>.cone_axioms \<kappa>.is_extensional by auto
           moreover have "J.arr j \<Longrightarrow> GE.cones_map ?g ?G\<chi> j = \<kappa> j"
           proof -
             fix j
             assume j: "J.arr j"
             have "GE.cones_map ?g ?G\<chi> j = G (\<chi> j) \<cdot>\<^sub>D ?g"
               using j 1 G\<chi>.cone_axioms mem_Collect_eq restrict_apply by auto
             also have "... = G (\<chi> j \<cdot>\<^sub>C f) \<cdot>\<^sub>D Adj.\<eta> b"
               using j f \<chi>.preserves_hom [of j "J.dom j" "J.cod j"] D.comp_assoc by fastforce
             also have "... = G (E.cones_map f \<chi> j) \<cdot>\<^sub>D Adj.\<eta> b"
             proof -
               have "\<chi> j \<cdot>\<^sub>C f = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
               proof -
                 have "\<chi> j \<cdot>\<^sub>C f = E.cones_map f \<chi> j"
                 proof -
                   have "E.cone (C.cod f) \<chi>"
                     using f \<chi>.cone_axioms by blast
                   thus ?thesis
                     using \<chi>.is_extensional by simp
                 qed
                 also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
                   using j f by simp
                 finally show ?thesis by blast
               qed
               thus ?thesis
                 using f mem_Collect_eq restrict_apply Adj.F.is_extensional by simp
             qed
             also have "... = (G (Adj.\<epsilon> (C.cod (E j))) \<cdot>\<^sub>D Adj.\<eta> (D.cod (GE.map j))) \<cdot>\<^sub>D \<kappa> j"
               using j f Adj.\<eta>.naturality [of "\<kappa> j"] D.comp_assoc by auto
             also have "... = D.cod (\<kappa> j) \<cdot>\<^sub>D \<kappa> j"
               using j Adj.\<eta>\<epsilon>.triangle_G Adj.\<epsilon>_in_terms_of_\<psi> Adj.\<epsilon>o_def
                       Adj.\<eta>_in_terms_of_\<phi> Adj.\<eta>o_def Adj.unit_counit_G
               by fastforce
             also have "... = \<kappa> j"
               using j D.comp_cod_arr by simp
             finally show "GE.cones_map ?g ?G\<chi> j = \<kappa> j" by metis
           qed
           ultimately show "GE.cones_map ?g ?G\<chi> j = \<kappa> j" by auto
         qed
         ultimately have "\<guillemotleft>?g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map ?g ?G\<chi> = \<kappa>" by auto
         text\<open>
           It remains to be shown that @{term g} is the unique such arrow.
           Given any @{term g'} that transforms @{term G\<chi>} into @{term \<kappa>},
           its adjunct transforms @{term \<chi>} into @{term \<chi>'}.
           The adjunct of @{term g'} is therefore equal to @{term f},
           which implies @{term g'} = @{term g}.
 \<close>
         moreover have "\<And>g'. \<guillemotleft>g' : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g' ?G\<chi> = \<kappa> \<Longrightarrow> g' = ?g"
         proof -
           fix g'
           assume g': "\<guillemotleft>g' : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g' ?G\<chi> = \<kappa>"
           have 1: "\<guillemotleft>\<psi> a g' : F b \<rightarrow>\<^sub>C a\<guillemotright>"
             using g' a \<psi>_in_hom by simp
           have 2: "E.cones_map (\<psi> a g') \<chi> = ?\<chi>'"
           proof
             fix j
             have "\<not>J.arr j \<Longrightarrow> E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j"
               using 1 \<chi>.cone_axioms by auto
             moreover have "J.arr j \<Longrightarrow> E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j"
             proof -
               fix j
               assume j: "J.arr j"
               have "E.cones_map (\<psi> a g') \<chi> j = \<chi> j \<cdot>\<^sub>C \<psi> a g'"
                 using 1 \<chi>.cone_axioms \<chi>.is_extensional by auto
               also have "... = (\<chi> j \<cdot>\<^sub>C Adj.\<epsilon> a) \<cdot>\<^sub>C F g'"
                 using j a g' Adj.\<psi>_in_terms_of_\<epsilon> C.comp_assoc Adj.\<epsilon>_def by auto
               also have "... = (Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (G (\<chi> j))) \<cdot>\<^sub>C F g'"
                 using j a g' Adj.\<epsilon>.naturality [of "\<chi> j"] by simp
               also have "... = Adj.\<epsilon> (C.cod (E j)) \<cdot>\<^sub>C F (\<kappa> j)"
                 using j a g' G\<chi>.cone_axioms C.comp_assoc by auto
               finally show "E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j" by (simp add: j)
             qed
             ultimately show "E.cones_map (\<psi> a g') \<chi> j = ?\<chi>' j" by auto
           qed
           have "\<psi> a g' = f"
           proof -
             have "\<exists>!f. \<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'"
               using cone_\<chi>' \<chi>.is_universal by simp
             moreover have "\<guillemotleft>\<psi> a g' : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map (\<psi> a g') \<chi> = ?\<chi>'"
               using 1 2 by simp
             ultimately show ?thesis
               using ex1E [of "\<lambda>f. \<guillemotleft>f : F b \<rightarrow>\<^sub>C a\<guillemotright> \<and> E.cones_map f \<chi> = ?\<chi>'" "\<psi> a g' = f"]
               using 1 2 Adj.\<epsilon>.is_extensional C.comp_null(2) C.ex_un_null \<chi>.cone_axioms f
                     mem_Collect_eq restrict_apply
               by blast
           qed
           hence "\<phi> b (\<psi> a g') = \<phi> b f" by auto
           hence "g' = \<phi> b f" using \<chi>.ide_apex g' by (simp add: \<phi>_\<psi>)
           moreover have "?g = \<phi> b f" using f Adj.\<phi>_in_terms_of_\<eta> \<kappa>.ide_apex Adj.\<eta>_def by auto
           ultimately show "g' = ?g" by argo
         qed
         ultimately show "\<exists>!g. \<guillemotleft>g : b \<rightarrow>\<^sub>D G a\<guillemotright> \<and> GE.cones_map g ?G\<chi> = \<kappa>" by blast
       qed
       have "GE.limit_cone (G a) ?G\<chi>" ..
       thus ?thesis by auto
     qed
 
   end
 
   section "Special Kinds of Limits"
 
   subsection "Terminal Objects"
 
   text\<open>
    An object of a category @{term C} is a terminal object if and only if it is a limit of the
    empty diagram in @{term C}.
 \<close>
 
   locale empty_diagram =
     diagram J C D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c" +
   assumes is_empty: "\<not>J.arr j"
   begin
 
     lemma has_as_limit_iff_terminal:
     shows "has_as_limit a \<longleftrightarrow> C.terminal a"
     proof
       assume a: "has_as_limit a"
       show "C.terminal a"
       proof
         have "\<exists>\<chi>. limit_cone a \<chi>" using a by auto
         from this obtain \<chi> where \<chi>: "limit_cone a \<chi>" by blast
         interpret \<chi>: limit_cone J C D a \<chi> using \<chi> by auto
         have cone_\<chi>: "cone a \<chi>" ..
         show "C.ide a" using \<chi>.ide_apex by auto
         have 1: "\<chi> = (\<lambda>j. C.null)" using is_empty \<chi>.is_extensional by auto
         show "\<And>a'. C.ide a' \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>"
         proof -
           fix a'
           assume a': "C.ide a'"
           interpret A': constant_functor J C a'
             apply unfold_locales using a' by auto
           let ?\<chi>' = "\<lambda>j. C.null"
           have cone_\<chi>': "cone a' ?\<chi>'"
             using a' is_empty apply unfold_locales by auto
           hence "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f \<chi> = ?\<chi>'"
             using \<chi>.is_universal by force
           moreover have "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> cones_map f \<chi> = ?\<chi>'"
             using 1 cone_\<chi> by auto
           ultimately show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" by blast
         qed
       qed
       next
       assume a: "C.terminal a"
       show "has_as_limit a"
       proof -
         let ?\<chi> = "\<lambda>j. C.null"
         have "C.ide a" using a C.terminal_def by simp
         interpret A: constant_functor J C a
           apply unfold_locales using \<open>C.ide a\<close> by simp
         interpret \<chi>: cone J C D a ?\<chi>
           using \<open>C.ide a\<close> is_empty by (unfold_locales, auto)
         have cone_\<chi>: "cone a ?\<chi>" .. 
         have 1: "\<And>a' \<chi>'. cone a' \<chi>' \<Longrightarrow> \<chi>' = (\<lambda>j. C.null)"
         proof -
           fix a' \<chi>'
           assume \<chi>': "cone a' \<chi>'"
           interpret \<chi>': cone J C D a' \<chi>' using \<chi>' by auto
           show "\<chi>' = (\<lambda>j. C.null)"
             using is_empty \<chi>'.is_extensional by metis
         qed
         have "limit_cone a ?\<chi>"
         proof
           fix a' \<chi>'
           assume \<chi>': "cone a' \<chi>'"
           have 2: "\<chi>' = (\<lambda>j. C.null)" using 1 \<chi>' by simp
           interpret \<chi>': cone J C D a' \<chi>' using \<chi>' by auto
           have "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" using a C.terminal_def \<chi>'.ide_apex by simp
           moreover have "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<Longrightarrow> cones_map f ?\<chi> = \<chi>'"
            using 1 2 cones_map_mapsto cone_\<chi> \<chi>'.cone_axioms mem_Collect_eq by blast
           ultimately show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f (\<lambda>j. C.null) = \<chi>'"
             by blast
         qed
         thus ?thesis by auto
       qed
     qed
 
   end
 
   subsection "Products"
 
   text\<open>
     A \emph{product} in a category @{term C} is a limit of a discrete diagram in @{term C}.
 \<close>
 
   locale discrete_diagram =
     J: category J +
     diagram J C D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c" +
   assumes is_discrete: "J.arr = J.ide"
   begin
 
     abbreviation mkCone
     where "mkCone F \<equiv> (\<lambda>j. if J.arr j then F j else C.null)"
 
     lemma cone_mkCone:
     assumes "C.ide a" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j : a \<rightarrow> D j\<guillemotright>"
     shows "cone a (mkCone F)"
     proof -
       interpret A: constant_functor J C a
          using assms(1) by unfold_locales auto
       show "cone a (mkCone F)"
         using assms(2) is_discrete
         apply unfold_locales
             apply auto
          apply (metis C.in_homE C.comp_cod_arr)
         using C.comp_arr_ide by fastforce
     qed
 
     lemma mkCone_cone:
     assumes "cone a \<pi>"
     shows "mkCone \<pi> = \<pi>"
     proof -
       interpret \<pi>: cone J C D a \<pi>
         using assms by auto
       show "mkCone \<pi> = \<pi>" using \<pi>.is_extensional by auto
     qed
 
   end
 
   text\<open>
     The following locale defines a discrete diagram in a category @{term C},
     given an index set @{term I} and a function @{term D} mapping @{term I}
     to objects of @{term C}.  Here we obtain the diagram shape @{term J}
     using a discrete category construction that allows us to directly identify
     the objects of @{term J} with the elements of @{term I}, however this construction
     can only be applied in case the set @{term I} is not the universe of its
     element type.
 \<close>
 
   locale discrete_diagram_from_map =
     J: discrete_category I null +
     C: category C
   for I :: "'i set"
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'i \<Rightarrow> 'c"
   and null :: 'i +
   assumes maps_to_ide: "i \<in> I \<Longrightarrow> C.ide (D i)"
   begin
 
     definition map
     where "map j \<equiv> if J.arr j then D j else C.null"
 
   end
 
   sublocale discrete_diagram_from_map \<subseteq> discrete_diagram J.comp C map
     using map_def maps_to_ide J.arr_char J.Null_not_in_Obj J.null_char
     by unfold_locales auto
 
   locale product_cone =
     J: category J +
     C: category C +
     D: discrete_diagram J C D +
     limit_cone J C D a \<pi>
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and C :: "'c comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 'c"
   and a :: 'c
   and \<pi> :: "'j \<Rightarrow> 'c"
   begin
 
     lemma is_cone:
     shows "D.cone a \<pi>" ..
 
     text\<open>
       The following versions of @{prop is_universal} and @{prop induced_arrowI}
       from the \<open>limit_cone\<close> locale are specialized to the case in which the
       underlying diagram is a product diagram.
 \<close>
 
     lemma is_universal':
     assumes "C.ide b" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j: b \<rightarrow> D j\<guillemotright>"
     shows "\<exists>!f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<and> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
     proof -
       let ?\<chi> = "D.mkCone F"
       interpret B: constant_functor J C b
         using assms(1) by unfold_locales auto
       have cone_\<chi>: "D.cone b ?\<chi>"
         using assms D.is_discrete D.cone_mkCone by blast
       interpret \<chi>: cone J C D b ?\<chi> using cone_\<chi> by auto
       have "\<exists>!f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<pi> = ?\<chi>"
         using cone_\<chi> is_universal by force
       moreover have
            "\<And>f. \<guillemotleft>f : b \<rightarrow> a\<guillemotright> \<Longrightarrow> D.cones_map f \<pi> = ?\<chi> \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
       proof -
         fix f
         assume f: "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
         show "D.cones_map f \<pi> = ?\<chi> \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j)"
         proof
           assume 1: "D.cones_map f \<pi> = ?\<chi>"
           show "\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j"
           proof -
             have "\<And>j. J.arr j \<Longrightarrow> \<pi> j \<cdot> f = F j"
             proof -
               fix j
               assume j: "J.arr j"
               have "\<pi> j \<cdot> f = D.cones_map f \<pi> j"
                 using j f cone_axioms by force
               also have "... = F j" using j 1 by simp
               finally show "\<pi> j \<cdot> f = F j" by auto
             qed
             thus ?thesis by auto
           qed
           next
           assume 1: "\<forall>j. J.arr j \<longrightarrow> \<pi> j \<cdot> f = F j"
           show "D.cones_map f \<pi> = ?\<chi>"
             using 1 f is_cone \<chi>.is_extensional D.is_discrete is_cone cone_\<chi> by auto
         qed
       qed
       ultimately show ?thesis by blast
     qed
 
     abbreviation induced_arrow' :: "'c \<Rightarrow> ('j \<Rightarrow> 'c) \<Rightarrow> 'c"
     where "induced_arrow' b F \<equiv> induced_arrow b (D.mkCone F)"
 
     lemma induced_arrowI':
     assumes "C.ide b" and "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>F j : b \<rightarrow> D j\<guillemotright>"
     shows "\<And>j. J.arr j \<Longrightarrow> \<pi> j \<cdot> induced_arrow' b F = F j"
     proof -
       interpret B: constant_functor J C b
         using assms(1) by unfold_locales auto
       interpret \<chi>: cone J C D b \<open>D.mkCone F\<close>
         using assms D.cone_mkCone by blast
       have cone_\<chi>: "D.cone b (D.mkCone F)" ..
       hence 1: "D.cones_map (induced_arrow' b F) \<pi> = D.mkCone F"
         using induced_arrowI by blast
       fix j
       assume j: "J.arr j"
       have "\<pi> j \<cdot> induced_arrow' b F = D.cones_map (induced_arrow' b F) \<pi> j"
         using induced_arrowI(1) cone_\<chi> is_cone is_extensional by force
       also have "... = F j"
         using j 1 by auto
       finally show "\<pi> j \<cdot> induced_arrow' b F = F j"
         by auto
     qed
 
   end
 
   context discrete_diagram
   begin
 
     lemma product_coneI:
     assumes "limit_cone a \<pi>" 
     shows "product_cone J C D a \<pi>"
       by (meson assms discrete_diagram_axioms functor_axioms functor_def product_cone.intro)
 
   end
 
   context category
   begin
 
     definition has_as_product
     where "has_as_product J D a \<equiv> (\<exists>\<pi>. product_cone J C D a \<pi>)"
 
     lemma product_is_ide:
     assumes "has_as_product J D a"
     shows "ide a"
     proof -
       obtain \<pi> where \<pi>: "product_cone J C D a \<pi>"
         using assms has_as_product_def by blast
       interpret \<pi>: product_cone J C D a \<pi>
         using \<pi> by auto
       show ?thesis using \<pi>.ide_apex by auto
     qed
 
     text\<open>
       A category has @{term I}-indexed products for an @{typ 'i}-set @{term I}
       if every @{term I}-indexed discrete diagram has a product.
       In order to reap the benefits of being able to directly identify the elements
       of a set I with the objects of discrete category it generates (thereby avoiding
       the use of coercion maps), it is necessary to assume that @{term "I \<noteq> UNIV"}.
       If we want to assert that a category has products indexed by the universe of
       some type @{typ 'i}, we have to pass to a larger type, such as @{typ "'i option"}.
 \<close>
 
     definition has_products
     where "has_products (I :: 'i set) \<equiv>
              I \<noteq> UNIV \<and>
              (\<forall>J D. discrete_diagram J C D \<and> Collect (partial_magma.arr J) = I
                       \<longrightarrow> (\<exists>a. has_as_product J D a))"
 
     lemma ex_productE:
     assumes "\<exists>a. has_as_product J D a"
     obtains a \<pi> where "product_cone J C D a \<pi>"
       using assms has_as_product_def someI_ex [of "\<lambda>a. has_as_product J D a"] by metis
 
     lemma has_products_if_has_limits:
     assumes "has_limits (undefined :: 'j)" and "I \<noteq> (UNIV :: 'j set)"
     shows "has_products I"
     proof (unfold has_products_def, intro conjI allI impI)
       show "I \<noteq> UNIV" by fact
       fix J D
       assume D: "discrete_diagram J C D \<and> Collect (partial_magma.arr J) = I"
       interpret D: discrete_diagram J C D
         using D by simp
       have 1: "\<exists>a. D.has_as_limit a"
         using assms D D.diagram_axioms D.J.category_axioms
         by (simp add: has_limits_of_shape_def has_limits_def)
       show "\<exists>a. has_as_product J D a"
         using 1 has_as_product_def D.product_coneI by blast
     qed
 
     lemma has_finite_products_if_has_finite_limits:
     assumes "\<And>J :: 'j comp. (finite (Collect (partial_magma.arr J))) \<Longrightarrow> has_limits_of_shape J"
     and "finite (I :: 'j set)" and "I \<noteq> UNIV"
     shows "has_products I"
     proof (unfold has_products_def, intro conjI allI impI)
       show "I \<noteq> UNIV" by fact
       fix J D
       assume D: "discrete_diagram J C D \<and> Collect (partial_magma.arr J) = I"
       interpret D: discrete_diagram J C D
         using D by simp
       have 1: "\<exists>a. D.has_as_limit a"
         using assms D has_limits_of_shape_def D.diagram_axioms by auto
       show "\<exists>a. has_as_product J D a"
         using 1 has_as_product_def D.product_coneI by blast
     qed
 
     lemma has_products_preserved_by_bijection:
     assumes "has_products I" and "bij_betw \<phi> I I'" and "I' \<noteq> UNIV"
     shows "has_products I'"
     proof (unfold has_products_def, intro conjI allI impI)
       show "I' \<noteq> UNIV" by fact
       show "\<And>J' D'. discrete_diagram J' C D' \<and> Collect (partial_magma.arr J') = I'
                      \<Longrightarrow> \<exists>a. has_as_product J' D' a"
       proof -
         fix J' D'
         assume 1: "discrete_diagram J' C D' \<and> Collect (partial_magma.arr J') = I'"
         interpret J': category J'
           using 1 by (simp add: discrete_diagram_def)
         interpret D': discrete_diagram J' C D'
           using 1 by simp
         interpret J: discrete_category I \<open>SOME x. x \<notin> I\<close>
           using assms has_products_def [of I] someI_ex [of "\<lambda>x. x \<notin> I"]
           by unfold_locales auto
         have 2: "Collect J.arr = I \<and> Collect J'.arr = I'"
           using 1 by auto
         have \<phi>: "bij_betw \<phi> (Collect J.arr) (Collect J'.arr)"
           using 2 assms(2) by simp
         let ?\<phi> = "\<lambda>j. if J.arr j then \<phi> j else J'.null"
         let ?\<phi>' = "\<lambda>j'. if J'.arr j' then the_inv_into I \<phi> j' else J.null"
         interpret \<phi>: "functor" J.comp J' ?\<phi>
         proof -
           have "\<phi> ` I = I'"
             using \<phi> 2 bij_betw_def [of \<phi> I I'] by simp
           hence "\<And>j. J.arr j \<Longrightarrow> J'.arr (?\<phi> j)"
             using 1 D'.is_discrete by auto
           thus "functor J.comp J' ?\<phi>"
             using D'.is_discrete J.is_discrete J.seqE
             by unfold_locales auto
         qed
         interpret \<phi>': "functor" J' J.comp ?\<phi>'
         proof -
           have "the_inv_into I \<phi> ` I' = I"
             using assms(2) \<phi> bij_betw_the_inv_into bij_betw_imp_surj_on by metis
           hence "\<And>j'. J'.arr j' \<Longrightarrow> J.arr (?\<phi>' j')"
             using 2 D'.is_discrete J.is_discrete by auto
           thus "functor J' J.comp ?\<phi>'"
             using D'.is_discrete J.is_discrete J'.seqE
             by unfold_locales auto
         qed
         let ?D = "\<lambda>i. D' (\<phi> i)"
         interpret D: discrete_diagram_from_map I C ?D \<open>SOME j. j \<notin> I\<close>
           using assms 1 D'.is_discrete bij_betw_imp_surj_on \<phi>.preserves_ide
           by unfold_locales auto
         obtain a where a: "has_as_product J.comp D.map a"
           using assms D.discrete_diagram_axioms has_products_def [of I] by auto
         obtain \<pi> where \<pi>: "product_cone J.comp C D.map a \<pi>"
           using a has_as_product_def by blast
         interpret \<pi>: product_cone J.comp C D.map a \<pi>
           using \<pi> by simp
         let ?\<pi>' = "\<pi> o ?\<phi>'"
         interpret A: constant_functor J' C a
           using \<pi>.ide_apex by unfold_locales simp
         interpret \<pi>': natural_transformation J' C A.map D' ?\<pi>'
         proof -
           have "\<pi>.A.map \<circ> ?\<phi>' = A.map"
             using \<phi> A.map_def \<phi>'.preserves_arr \<pi>.A.is_extensional J.not_arr_null by auto
           moreover have "D.map \<circ> ?\<phi>' = D'"
           proof
             fix j'
             have "J'.arr j' \<Longrightarrow> (D.map \<circ> ?\<phi>') j' = D' j'"
             proof -
               assume 2: "J'.arr j'"
               have 3: "inj_on \<phi> I"
                 using assms(2) bij_betw_imp_inj_on by auto
               have "\<phi> ` I = I'"
                 by (metis (no_types) assms(2) bij_betw_imp_surj_on)
               hence "\<phi> ` I = Collect J'.arr"
                 using 1 by force
               thus ?thesis
                 using 2 3 D.map_def \<phi>'.preserves_arr f_the_inv_into_f by fastforce
             qed
             moreover have "\<not> J'.arr j' \<Longrightarrow> (D.map \<circ> ?\<phi>') j' = D' j'"
               using D.is_extensional D'.is_extensional
               by (simp add: J.Null_not_in_Obj J.null_char)
             ultimately show "(D.map \<circ> ?\<phi>') j' = D' j'" by blast
           qed
           ultimately show "natural_transformation J' C A.map D' ?\<pi>'"
             using \<pi>.natural_transformation_axioms \<phi>'.as_nat_trans.natural_transformation_axioms
                   horizontal_composite [of J' J.comp ?\<phi>' ?\<phi>' ?\<phi>' C \<pi>.A.map D.map \<pi>]
             by simp
         qed
         interpret \<pi>': cone J' C D' a ?\<pi>' ..
         interpret \<pi>': product_cone J' C D' a ?\<pi>'
         proof
           fix a' \<chi>'
           assume \<chi>': "D'.cone a' \<chi>'"
           interpret \<chi>': cone J' C D' a' \<chi>'
             using \<chi>' by simp
           show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f (\<pi> \<circ> ?\<phi>') = \<chi>'"
           proof -
             let ?\<chi> = "\<chi>' o ?\<phi>"
             interpret A': constant_functor J.comp C a'
               using \<chi>'.ide_apex by unfold_locales simp
             interpret \<chi>: natural_transformation J.comp C A'.map D.map ?\<chi>
             proof -
               have "\<chi>'.A.map \<circ> ?\<phi> = A'.map"
                 using \<phi> \<phi>.preserves_arr A'.map_def \<chi>'.A.is_extensional by auto
               moreover have "D' \<circ> ?\<phi> = D.map"
                 using \<phi> D.map_def D'.is_extensional by auto
               ultimately show "natural_transformation J.comp C A'.map D.map ?\<chi>"
                 using \<chi>'.natural_transformation_axioms
                       \<phi>.as_nat_trans.natural_transformation_axioms
                       horizontal_composite [of J.comp J' ?\<phi> ?\<phi> ?\<phi> C \<chi>'.A.map D' \<chi>']
                 by simp
             qed
             interpret \<chi>: cone J.comp C D.map a' ?\<chi> ..
             have *: "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<pi> = ?\<chi>"
               using \<pi>.is_universal \<chi>.cone_axioms by simp
             show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f ?\<pi>' = \<chi>'"
             proof -
               have "\<exists>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D'.cones_map f ?\<pi>' = \<chi>'"
               proof -
                 obtain f where f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f \<pi> = ?\<chi>"
                   using * by blast
                 have "D'.cones_map f ?\<pi>' = \<chi>'"
                 proof
                   fix j'
                   show "D'.cones_map f ?\<pi>' j' = \<chi>' j'"
                   proof (cases "J'.arr j'")
                     assume j': "\<not> J'.arr j'"
                     show "D'.cones_map f ?\<pi>' j' = \<chi>' j'"
                       using f j' \<chi>'.is_extensional \<pi>'.cone_axioms by auto
                     next
                     assume j': "J'.arr j'"
                     show "D'.cones_map f ?\<pi>' j' = \<chi>' j'"
                     proof -
                       have "D'.cones_map f ?\<pi>' j' = \<pi> (the_inv_into I \<phi> j') \<cdot> f"
                         using f j' \<pi>'.cone_axioms by auto
                       also have "... = D.cones_map f \<pi> (the_inv_into I \<phi> j')"
                       proof -
                         have "arr f \<and> dom f = a' \<and> cod f = a"
                           using f by blast
                         thus ?thesis
                           using \<phi>'.preserves_arr \<pi>.cone_\<chi> j' by auto
                       qed
                       also have "... = (\<chi>' \<circ> ?\<phi>) (the_inv_into I \<phi> j')"
                         using f by simp
                       also have "... = \<chi>' j'"
                         using assms(2) j' 2 bij_betw_def [of \<phi> I I'] bij_betw_imp_inj_on
                               \<phi>'.preserves_arr f_the_inv_into_f
                         by fastforce
                       finally show ?thesis by simp
                     qed
                   qed
                 qed
                 thus ?thesis using f by blast
               qed
               moreover have "\<And>f f'. \<lbrakk> \<guillemotleft>f : a' \<rightarrow> a\<guillemotright>; D'.cones_map f ?\<pi>' = \<chi>';
                                       \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>; D'.cones_map f' ?\<pi>' = \<chi>' \<rbrakk>
                                          \<Longrightarrow> f = f'"
               proof -
                 fix f f'
                 assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright>" and f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>"
                 and f\<chi>': "D'.cones_map f ?\<pi>' = \<chi>'" and f'\<chi>': "D'.cones_map f' ?\<pi>' = \<chi>'"
                 have "D.cones_map f \<pi> = \<chi>' \<circ> ?\<phi> \<and> D.cones_map f' \<pi> = \<chi>' o ?\<phi>"
                 proof (intro conjI)
                   show "D.cones_map f \<pi> = \<chi>' \<circ> ?\<phi>"
                   proof
                     fix j
                     have "\<not> J.arr j \<Longrightarrow> D.cones_map f \<pi> j = (\<chi>' \<circ> ?\<phi>) j"
                       using f f\<chi>' \<pi>.cone_axioms \<chi>.is_extensional by auto
                     moreover have "J.arr j \<Longrightarrow> D.cones_map f \<pi> j = (\<chi>' \<circ> ?\<phi>) j"
                     proof -
                       assume j: "J.arr j"
                       have 1: "j = the_inv_into I \<phi> (\<phi> j)"
                         using assms(2) j \<phi> the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
                         by metis
                       have "D.cones_map f \<pi> j = D.cones_map f \<pi> (the_inv_into I \<phi> (\<phi> j))"
                         using 1 by simp
                       also have "... = (\<chi>' \<circ> ?\<phi>) j"
                         using f j f\<chi>' 1 \<pi>.cone_axioms \<pi>'.cone_axioms \<phi>.preserves_arr by auto
                       finally show "D.cones_map f \<pi> j = (\<chi>' \<circ> ?\<phi>) j" by blast
                     qed
                     ultimately show "D.cones_map f \<pi> j = (\<chi>' \<circ> ?\<phi>) j" by blast
                   qed
                   show "D.cones_map f' \<pi> = \<chi>' \<circ> ?\<phi>"
                   proof
                     fix j
                     have "\<not> J.arr j \<Longrightarrow> D.cones_map f' \<pi> j = (\<chi>' \<circ> ?\<phi>) j"
                       using f' f\<chi>' \<pi>.cone_axioms \<chi>.is_extensional by auto
                     moreover have "J.arr j \<Longrightarrow> D.cones_map f' \<pi> j = (\<chi>' \<circ> ?\<phi>) j"
                     proof -
                       assume j: "J.arr j"
                       have 1: "j = the_inv_into I \<phi> (\<phi> j)"
                         using assms(2) j \<phi> the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
                         by metis
                       have "D.cones_map f' \<pi> j = D.cones_map f' \<pi> (the_inv_into I \<phi> (\<phi> j))"
                         using 1 by simp
                       also have "... = (\<chi>' \<circ> ?\<phi>) j"
                         using f' j f'\<chi>' 1 \<pi>.cone_axioms \<pi>'.cone_axioms \<phi>.preserves_arr by auto
                       finally show "D.cones_map f' \<pi> j = (\<chi>' \<circ> ?\<phi>) j" by blast
                     qed
                     ultimately show "D.cones_map f' \<pi> j = (\<chi>' \<circ> ?\<phi>) j" by blast
                   qed
                 qed
                 thus "f = f'"
                   using f f' * by auto
               qed
               ultimately show ?thesis by blast
             qed
           qed
         qed
         have "has_as_product J' D' a"
           using has_as_product_def \<pi>'.product_cone_axioms by auto
         thus "\<exists>a. has_as_product J' D' a" by blast
       qed
     qed
 
     lemma ide_is_unary_product:
     assumes "ide a"
     shows "\<And>m n :: nat. m \<noteq> n \<Longrightarrow> has_as_product (discrete_category.comp {m :: nat} (n :: nat))
                                                   (\<lambda>i. if i = m then a else null) a"
     proof -
       fix m n :: nat
       assume neq: "m \<noteq> n"
       have "{m :: nat} \<noteq> UNIV"
       proof -
         have "finite {m :: nat}" by simp
         moreover have "\<not>finite (UNIV :: nat set)" by simp
         ultimately show ?thesis by fastforce
       qed
       interpret J: discrete_category "{m :: nat}" \<open>n :: nat\<close>
          using neq \<open>{m :: nat} \<noteq> UNIV\<close> by unfold_locales auto
       let ?D = "\<lambda>i. if i = m then a else null"
       interpret D: discrete_diagram J.comp C ?D
         apply unfold_locales
         using assms J.null_char neq
              apply auto
         by metis
       interpret A: constant_functor J.comp C a
         using assms by unfold_locales auto
       show "has_as_product J.comp ?D a"
       proof (unfold has_as_product_def)
         let ?\<pi> = "\<lambda>i :: nat. if i = m then a else null"
         interpret \<pi>: natural_transformation J.comp C A.map ?D ?\<pi>
           using assms J.arr_char J.dom_char J.cod_char
           by unfold_locales auto
         interpret \<pi>: cone J.comp C ?D a ?\<pi> ..
         interpret \<pi>: product_cone J.comp C ?D a ?\<pi>
         proof
           fix a' \<chi>'
           assume \<chi>': "D.cone a' \<chi>'"
           interpret \<chi>': cone J.comp C ?D a' \<chi>' using \<chi>' by auto
           show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>'"
           proof
             show "\<guillemotleft>\<chi>' m : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map (\<chi>' m) ?\<pi> = \<chi>'"
             proof
               show 1: "\<guillemotleft>\<chi>' m : a' \<rightarrow> a\<guillemotright>"
                 using \<chi>'.preserves_hom \<chi>'.A.map_def J.arr_char J.dom_char J.cod_char
                 by auto
               show "D.cones_map (\<chi>' m) ?\<pi> = \<chi>'"
               proof
                 fix j
                 show "D.cones_map (\<chi>' m) (\<lambda>i. if i = m then a else null) j = \<chi>' j"
                   using J.arr_char J.dom_char J.cod_char J.ide_char \<pi>.cone_axioms comp_cod_arr
                   apply (cases "j = m")
                    apply simp
                   using \<chi>'.is_extensional by simp
               qed
             qed
             show "\<And>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>' \<Longrightarrow> f = \<chi>' m"
             proof -
               fix f
               assume f: "\<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map f ?\<pi> = \<chi>'"
               show "f = \<chi>' m"
                 using assms f \<chi>'.preserves_hom J.arr_char J.dom_char J.cod_char \<pi>.cone_axioms
                       comp_cod_arr
                 by auto
             qed
           qed
         qed
         show "\<exists>\<pi>. product_cone J.comp C (\<lambda>i. if i = m then a else null) a \<pi>"
           using \<pi>.product_cone_axioms by blast
       qed
     qed
 
     lemma has_unary_products:
     assumes "card I = 1" and "I \<noteq> UNIV"
     shows "has_products I"
     proof -
       obtain i where i: "I = {i}"
         using assms card_1_singletonE by blast
       obtain n where n: "n \<notin> I"
         using assms by auto
       have "has_products {1 :: nat}"
       proof (unfold has_products_def, intro conjI)
         show "{1 :: nat} \<noteq> UNIV" by auto
         show "\<forall>(J :: nat comp) D.
                 discrete_diagram J (\<cdot>) D \<and> Collect (partial_magma.arr J) = {1}
                    \<longrightarrow> (\<exists>a. has_as_product J D a)"
         proof
           fix J :: "nat comp"
           show "\<forall>D. discrete_diagram J (\<cdot>) D \<and> Collect (partial_magma.arr J) = {1}
                        \<longrightarrow> (\<exists>a. has_as_product J D a)"
           proof (intro allI impI)
             fix D
             assume D: "discrete_diagram J (\<cdot>) D \<and> Collect (partial_magma.arr J) = {1}"
             interpret D: discrete_diagram J C D
               using D by auto
             interpret J: discrete_category \<open>{1 :: nat}\<close> D.J.null
               by (metis D D.J.not_arr_null discrete_category.intro mem_Collect_eq)
             have 1: "has_as_product J.comp D (D 1)"
             proof -
               have "has_as_product J.comp (\<lambda>i. if i = 1 then D 1 else null) (D 1)"
                 using ide_is_unary_product D.preserves_ide D.is_discrete D J.null_char
                 by (metis J.Null_not_in_Obj insertCI mem_Collect_eq)
               moreover have "D = (\<lambda>i. if i = 1 then D 1 else null)"
               proof
                 fix j
                 show "D j = (if j = 1 then D 1 else null)"
                   using D D.is_extensional by auto
               qed
               ultimately show ?thesis by simp
             qed
             moreover have "J = J.comp"
             proof -
               have "\<And>j j'. J j j' = J.comp j j'"
               proof -
                 fix j j'
                 show "J j j' = J.comp j j'"
                   using J.comp_char D.is_discrete D
                   by (metis D.J.category_axioms D.J.ext D.J.ide_def J.null_char
                             category.seqE mem_Collect_eq)
               qed
               thus ?thesis by auto
             qed
             ultimately show "\<exists>a. has_as_product J D a" by auto
           qed
         qed
       qed
       moreover have "bij_betw (\<lambda>k. if k = 1 then i else n) {1 :: nat} I"
         using i by (intro bij_betwI') auto
       ultimately show "has_products I"
         using assms has_products_preserved_by_bijection by blast
     qed
 
   end
 
   subsection "Equalizers"
 
   text\<open>
     An \emph{equalizer} in a category @{term C} is a limit of a parallel pair
     of arrows in @{term C}.
 \<close>
 
   locale parallel_pair_diagram =
     J: parallel_pair +
     C: category C
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and f0 :: 'c
   and f1 :: 'c +
   assumes is_parallel: "C.par f0 f1"
   begin
 
     no_notation J.comp   (infixr "\<cdot>" 55)
     notation J.comp      (infixr "\<cdot>\<^sub>J" 55)
 
     definition map
     where "map \<equiv> (\<lambda>j. if j = J.Zero then C.dom f0
                        else if j = J.One then C.cod f0
                        else if j = J.j0 then f0
                        else if j = J.j1 then f1
                        else C.null)"
 
     lemma map_simp:
     shows "map J.Zero = C.dom f0"
     and "map J.One = C.cod f0"
     and "map J.j0 = f0"
     and "map J.j1 = f1"
     proof -
       show "map J.Zero = C.dom f0"
         using map_def by metis
       show "map J.One = C.cod f0"
         using map_def J.Zero_not_eq_One by metis
       show "map J.j0 = f0"
         using map_def J.Zero_not_eq_j0 J.One_not_eq_j0 by metis
       show "map J.j1 = f1"
         using map_def J.Zero_not_eq_j1 J.One_not_eq_j1 J.j0_not_eq_j1 by metis
     qed
 
   end
 
   sublocale parallel_pair_diagram \<subseteq> diagram J.comp C map
     apply unfold_locales
         apply (simp add: J.arr_char map_def)
     using map_def is_parallel J.arr_char J.cod_simp J.dom_simp
        apply auto[2]
   proof -
     show 1: "\<And>j. J.arr j \<Longrightarrow> C.cod (map j) = map (J.cod j)"
       using is_parallel map_simp(1-4) J.arr_char by auto
     next
     fix j j'
     assume jj': "J.seq j' j"
     show "map (j' \<cdot>\<^sub>J j) = map j' \<cdot> map j"
     proof -
       have 1: "(j = J.Zero \<and> j' \<noteq> J.One) \<or> (j \<noteq> J.Zero \<and> j' = J.One)"
         using jj' J.seq_char by blast
       moreover have "j = J.Zero \<and> j' \<noteq> J.One \<Longrightarrow> ?thesis"
         by (metis (no_types, lifting) C.arr_dom_iff_arr C.comp_arr_dom C.dom_dom
             J.comp_simp(1) jj' map_simp(1,3-4) J.arr_char is_parallel)
       moreover have "j \<noteq> J.Zero \<and> j' = J.One \<Longrightarrow> ?thesis"
         by (metis (no_types, lifting) C.comp_arr_dom C.comp_cod_arr C.seqE J.comp_char jj'
             map_simp(2-4) J.arr_char is_parallel)
       ultimately show ?thesis by blast
     qed
   qed
 
   context parallel_pair_diagram
   begin
 
     definition mkCone
     where "mkCone e \<equiv> \<lambda>j. if J.arr j then if j = J.Zero then e else f0 \<cdot> e else C.null"
 
     abbreviation is_equalized_by
     where "is_equalized_by e \<equiv> C.seq f0 e \<and> f0 \<cdot> e = f1 \<cdot> e"
 
     abbreviation has_as_equalizer
     where "has_as_equalizer e \<equiv> limit_cone (C.dom e) (mkCone e)"
 
     lemma cone_mkCone:
     assumes "is_equalized_by e"
     shows "cone (C.dom e) (mkCone e)"
     proof -
       interpret E: constant_functor J.comp C \<open>C.dom e\<close>
         apply unfold_locales using assms by auto
       show "cone (C.dom e) (mkCone e)"
         using assms mkCone_def apply unfold_locales
             apply auto[2]
         using C.dom_comp C.seqE C.cod_comp J.Zero_not_eq_One J.arr_char' J.cod_char map_def
           apply (metis (no_types, lifting) C.not_arr_null parallel_pair.cod_simp(1) preserves_arr)
       proof -
         show "\<And>j. J.arr j \<Longrightarrow> map j \<cdot> mkCone e (J.dom j) = mkCone e j"
         proof -
           fix j
           assume j: "J.arr j"
           have 1: "j = J.Zero \<or> map j \<cdot> mkCone e (J.dom j) = mkCone e j"
             using assms j mkCone_def C.cod_comp
             by (metis (no_types, lifting) C.comp_cod_arr J.arr_char J.dom_char map_def
                 J.dom_simp(2))
           show "map j \<cdot> mkCone e (J.dom j) = mkCone e j"
             by (metis (no_types, lifting) 1 C.comp_cod_arr C.seqE assms j map_simp(1)
                   mkCone_def J.dom_simp(1))
         qed
         next
         show "\<And>j. J.arr j \<Longrightarrow> mkCone e (J.cod j) \<cdot> E.map j = mkCone e j"
           by (metis (no_types, lifting) C.comp_arr_dom C.comp_assoc C.seqE
               J.arr_cod_iff_arr J.seqI J.seq_char assms E.map_simp mkCone_def
               J.cod_simp(1) J.dom_simp(1))
       qed
     qed
 
     lemma is_equalized_by_cone:
     assumes "cone a \<chi>"
     shows "is_equalized_by (\<chi> (J.Zero))"
     proof -
       interpret \<chi>: cone J.comp C map a \<chi>
         using assms by auto
       show ?thesis
         by (metis (no_types, lifting) J.arr_char J.cod_char cone_def
             \<chi>.component_in_hom \<chi>.is_natural_1 \<chi>.naturality assms C.in_homE
             constant_functor.map_simp J.dom_simp(3-4) map_simp(3-4))
     qed
 
     lemma mkCone_cone:
     assumes "cone a \<chi>"
     shows "mkCone (\<chi> J.Zero) = \<chi>"
     proof -
       interpret \<chi>: cone J.comp C map a \<chi>
         using assms by auto
       have 1: "is_equalized_by (\<chi> J.Zero)"
         using assms is_equalized_by_cone by blast
       show ?thesis
       proof
         fix j
         have "j = J.Zero \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
           using mkCone_def \<chi>.is_extensional by simp
         moreover have "j = J.One \<or> j = J.j0 \<or> j = J.j1 \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
           using J.arr_char J.cod_char J.dom_char J.seq_char mkCone_def
                 \<chi>.is_natural_1 \<chi>.is_natural_2 \<chi>.A.map_simp map_def
           by (metis (no_types, lifting) J.Zero_not_eq_j0 J.dom_simp(2))
         ultimately have "J.arr j \<Longrightarrow> mkCone (\<chi> J.Zero) j = \<chi> j"
           using J.arr_char by auto
         thus "mkCone (\<chi> J.Zero) j = \<chi> j"
           using mkCone_def \<chi>.is_extensional by fastforce
       qed
     qed
 
   end
 
   locale equalizer_cone =
     J: parallel_pair +
     C: category C +
     D: parallel_pair_diagram C f0 f1 +
     limit_cone J.comp C D.map "C.dom e" "D.mkCone e"
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and f0 :: 'c
   and f1 :: 'c
   and e :: 'c
   begin
 
     lemma equalizes:
     shows "D.is_equalized_by e"
     proof
       show "C.seq f0 e"
       proof (intro C.seqI)
         show "C.arr e" using ide_apex C.arr_dom_iff_arr by fastforce
         show "C.arr f0"
           using D.map_simp D.preserves_arr J.arr_char by metis
         show "C.dom f0 = C.cod e"
           using J.arr_char J.ide_char D.mkCone_def D.map_simp preserves_cod [of J.Zero]
           by auto
       qed
       show "f0 \<cdot> e = f1 \<cdot> e"
         using D.map_simp D.mkCone_def J.arr_char naturality [of J.j0] naturality [of J.j1]
         by force
     qed
 
     lemma is_universal':
     assumes "D.is_equalized_by e'"
     shows "\<exists>!h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<and> e \<cdot> h = e'"
     proof -
       have "D.cone (C.dom e') (D.mkCone e')"
         using assms D.cone_mkCone by blast
       moreover have 0: "D.cone (C.dom e) (D.mkCone e)" ..
       ultimately have 1: "\<exists>!h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<and>
                                D.cones_map h (D.mkCone e) = D.mkCone e'"
         using is_universal [of "C.dom e'" "D.mkCone e'"] by auto
       have 2: "\<And>h. \<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright> \<Longrightarrow>
                     D.cones_map h (D.mkCone e) = D.mkCone e' \<longleftrightarrow> e \<cdot> h = e'"
       proof -
         fix h
         assume h: "\<guillemotleft>h : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
         show "D.cones_map h (D.mkCone e) = D.mkCone e' \<longleftrightarrow> e \<cdot> h = e'"
         proof
           assume 3: "D.cones_map h (D.mkCone e) = D.mkCone e'"
           show "e \<cdot> h = e'"
           proof -
             have "e' = D.mkCone e' J.Zero"
               using D.mkCone_def J.arr_char by simp
             also have "... = D.cones_map h (D.mkCone e) J.Zero"
               using 3 by simp
             also have "... = e \<cdot> h"
               using 0 h D.mkCone_def J.arr_char by auto
             finally show ?thesis by auto
           qed
           next
           assume e': "e \<cdot> h = e'"
           show "D.cones_map h (D.mkCone e) = D.mkCone e'"
           proof
             fix j
             have "\<not>J.arr j \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
               using h cone_axioms D.mkCone_def by auto
             moreover have "j = J.Zero \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
               using h e' cone_\<chi> D.mkCone_def J.arr_char [of J.Zero] by force
             moreover have
                 "J.arr j \<and> j \<noteq> J.Zero \<Longrightarrow> D.cones_map h (D.mkCone e) j = D.mkCone e' j"
               using C.comp_assoc D.mkCone_def cone_\<chi> e' h by auto
             ultimately show "D.cones_map h (D.mkCone e) j = D.mkCone e' j" by blast
           qed
         qed
       qed
       thus ?thesis using 1 by blast
     qed
 
     lemma induced_arrowI':
     assumes "D.is_equalized_by e'"
     shows "\<guillemotleft>induced_arrow (C.dom e') (D.mkCone e') : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
     and "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
     proof -
       interpret A': constant_functor J.comp C \<open>C.dom e'\<close>
         using assms by (unfold_locales, auto)
       have cone: "D.cone (C.dom e') (D.mkCone e')"
         using assms D.cone_mkCone [of e'] by blast
       have "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') =
               D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) J.Zero"
         using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_\<chi> by force
       also have "... = e'"
       proof -
         have "D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) =
               D.mkCone e'"
           using cone induced_arrowI by blast
         thus ?thesis
           using J.arr_char D.mkCone_def by simp
       qed
       finally have 1: "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
         by auto
       show "\<guillemotleft>induced_arrow (C.dom e') (D.mkCone e') : C.dom e' \<rightarrow> C.dom e\<guillemotright>"
         using 1 cone induced_arrowI by simp
       show "e \<cdot> induced_arrow (C.dom e') (D.mkCone e') = e'"
         using 1 cone induced_arrowI by simp
     qed
 
   end
 
   context category
   begin
 
     definition has_as_equalizer
     where "has_as_equalizer f0 f1 e \<equiv> par f0 f1 \<and> parallel_pair_diagram.has_as_equalizer C f0 f1 e"
 
     definition has_equalizers
     where "has_equalizers = (\<forall>f0 f1. par f0 f1 \<longrightarrow> (\<exists>e. has_as_equalizer f0 f1 e))"
 
   end
 
   section "Limits by Products and Equalizers"
  
   text\<open>
     A category with equalizers has limits of shape @{term J} if it has products
     indexed by the set of arrows of @{term J} and the set of objects of @{term J}.
     The proof is patterned after \cite{MacLane}, Theorem 2, page 109:
     \begin{quotation}
        \noindent
        ``The limit of \<open>F: J \<rightarrow> C\<close> is the equalizer \<open>e\<close>
        of \<open>f, g: \<Pi>\<^sub>i F\<^sub>i \<rightarrow> \<Pi>\<^sub>u F\<^sub>c\<^sub>o\<^sub>d \<^sub>u (u \<in> arr J, i \<in> J)\<close>
        where \<open>p\<^sub>u f = p\<^sub>c\<^sub>o\<^sub>d \<^sub>u\<close>, \<open>p\<^sub>u g = F\<^sub>u o p\<^sub>d\<^sub>o\<^sub>m \<^sub>u\<close>;
        the limiting cone \<open>\<mu>\<close> is \<open>\<mu>\<^sub>j = p\<^sub>j e\<close>, for \<open>j \<in> J\<close>.''
     \end{quotation}
 \<close>
 
   locale category_with_equalizers =
     category C
   for C :: "'c comp"      (infixr "\<cdot>" 55) +
   assumes has_equalizers: "has_equalizers"
   begin
 
     lemma has_limits_if_has_products:
     fixes J :: "'j comp"  (infixr "\<cdot>\<^sub>J" 55)
     assumes "category J" and "has_products (Collect (partial_magma.ide J))"
     and "has_products (Collect (partial_magma.arr J))"
     shows "has_limits_of_shape J"
     proof (unfold has_limits_of_shape_def)
       interpret J: category J using assms(1) by auto
       have "\<And>D. diagram J C D \<Longrightarrow> (\<exists>a \<chi>. limit_cone J C D a \<chi>)"
       proof -
         fix D
         assume D: "diagram J C D"
         interpret D: diagram J C D using D by auto
 
         text\<open>
           First, construct the two required products and their cones.
 \<close>
         interpret Obj: discrete_category \<open>Collect J.ide\<close> J.null
           using J.not_arr_null J.ideD(1) mem_Collect_eq by (unfold_locales, blast)
         interpret \<Delta>o: discrete_diagram_from_map \<open>Collect J.ide\<close> C D J.null
           using D.preserves_ide by (unfold_locales, auto)
         have "\<exists>p. has_as_product Obj.comp \<Delta>o.map p"
           using assms(2) \<Delta>o.diagram_axioms has_products_def Obj.arr_char
           by (metis (no_types, lifting) Collect_cong \<Delta>o.discrete_diagram_axioms mem_Collect_eq)
         from this obtain \<Pi>o \<pi>o where \<pi>o: "product_cone Obj.comp C \<Delta>o.map \<Pi>o \<pi>o"
            using ex_productE [of Obj.comp \<Delta>o.map] by auto
         interpret \<pi>o: product_cone Obj.comp C \<Delta>o.map \<Pi>o \<pi>o using \<pi>o by auto
         have \<pi>o_in_hom: "\<And>j. Obj.arr j \<Longrightarrow> \<guillemotleft>\<pi>o j : \<Pi>o \<rightarrow> D j\<guillemotright>"
           using \<pi>o.preserves_dom \<pi>o.preserves_cod \<Delta>o.map_def by auto
 
         interpret Arr: discrete_category \<open>Collect J.arr\<close> J.null
           using J.not_arr_null by (unfold_locales, blast)
         interpret \<Delta>a: discrete_diagram_from_map \<open>Collect J.arr\<close> C \<open>D o J.cod\<close> J.null
           by (unfold_locales, auto)
         have "\<exists>p. has_as_product Arr.comp \<Delta>a.map p"
           using assms(3) has_products_def [of "Collect J.arr"] \<Delta>a.discrete_diagram_axioms
           by blast
         from this obtain \<Pi>a \<pi>a where \<pi>a: "product_cone Arr.comp C \<Delta>a.map \<Pi>a \<pi>a"
           using ex_productE [of Arr.comp \<Delta>a.map] by auto
         interpret \<pi>a: product_cone Arr.comp C \<Delta>a.map \<Pi>a \<pi>a using \<pi>a by auto
         have \<pi>a_in_hom: "\<And>j. Arr.arr j \<Longrightarrow> \<guillemotleft>\<pi>a j : \<Pi>a \<rightarrow> D (J.cod j)\<guillemotright>"
           using \<pi>a.preserves_cod \<pi>a.preserves_dom \<Delta>a.map_def by auto
 
         text\<open>
            Next, construct a parallel pair of arrows \<open>f, g: \<Pi>o \<rightarrow> \<Pi>a\<close>
            that expresses the commutativity constraints imposed by the diagram.
 \<close>
         interpret \<Pi>o: constant_functor Arr.comp C \<Pi>o
           using \<pi>o.ide_apex by (unfold_locales, auto)
         let ?\<chi> = "\<lambda>j. if Arr.arr j then \<pi>o (J.cod j) else null"
         interpret \<chi>: cone Arr.comp C \<Delta>a.map \<Pi>o ?\<chi>
           using \<pi>o.ide_apex \<pi>o_in_hom \<Delta>a.map_def \<Delta>o.map_def \<Delta>o.is_discrete \<pi>o.is_natural_2
                 comp_cod_arr
           by (unfold_locales, auto)
 
         let ?f = "\<pi>a.induced_arrow \<Pi>o ?\<chi>"
         have f_in_hom: "\<guillemotleft>?f : \<Pi>o \<rightarrow> \<Pi>a\<guillemotright>"
           using \<chi>.cone_axioms \<pi>a.induced_arrowI by blast
         have f_map: "\<Delta>a.cones_map ?f \<pi>a = ?\<chi>"
           using \<chi>.cone_axioms \<pi>a.induced_arrowI by blast
         have ff: "\<And>j. J.arr j \<Longrightarrow> \<pi>a j \<cdot> ?f = \<pi>o (J.cod j)"
           using \<chi>.component_in_hom \<pi>a.induced_arrowI' \<pi>o.ide_apex by auto
 
         let ?\<chi>' = "\<lambda>j. if Arr.arr j then D j \<cdot> \<pi>o (J.dom j) else null"
         interpret \<chi>': cone Arr.comp C \<Delta>a.map \<Pi>o ?\<chi>'
           using \<pi>o.ide_apex \<pi>o_in_hom \<Delta>o.map_def \<Delta>a.map_def comp_arr_dom comp_cod_arr
           by (unfold_locales, auto)
         let ?g = "\<pi>a.induced_arrow \<Pi>o ?\<chi>'"
         have g_in_hom: "\<guillemotleft>?g : \<Pi>o \<rightarrow> \<Pi>a\<guillemotright>"
           using \<chi>'.cone_axioms \<pi>a.induced_arrowI by blast
         have g_map: "\<Delta>a.cones_map ?g \<pi>a = ?\<chi>'"
           using \<chi>'.cone_axioms \<pi>a.induced_arrowI by blast
         have gg: "\<And>j. J.arr j \<Longrightarrow> \<pi>a j \<cdot> ?g = D j \<cdot> \<pi>o (J.dom j)"
           using \<chi>'.component_in_hom \<pi>a.induced_arrowI' \<pi>o.ide_apex by force
 
         interpret PP: parallel_pair_diagram C ?f ?g
           using f_in_hom g_in_hom
           by (elim in_homE, unfold_locales, auto)
         from PP.is_parallel obtain e where equ: "PP.has_as_equalizer e"
           using has_equalizers has_equalizers_def has_as_equalizer_def by blast
         interpret EQU: limit_cone PP.J.comp C PP.map \<open>dom e\<close> \<open>PP.mkCone e\<close>
           using equ by auto
         interpret EQU: equalizer_cone C ?f ?g e ..
 
         text\<open>
           An arrow @{term h} with @{term "cod h = \<Pi>o"} equalizes @{term f} and @{term g}
           if and only if it satisfies the commutativity condition required for a cone over
           @{term D}.
 \<close>
         have E: "\<And>h. \<guillemotleft>h : dom h \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
                    ?f \<cdot> h = ?g \<cdot> h \<longleftrightarrow> (\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h)"
         proof
           fix h
           assume h: "\<guillemotleft>h : dom h \<rightarrow> \<Pi>o\<guillemotright>"
           show "?f \<cdot> h = ?g \<cdot> h \<Longrightarrow> \<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
           proof -
             assume E: "?f \<cdot> h = ?g \<cdot> h"
             have "\<And>j. J.arr j \<Longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
             proof -
               fix j
               assume j: "J.arr j"
               have "?\<chi> j \<cdot> h = \<Delta>a.cones_map ?f \<pi>a j \<cdot> h"
                 using j f_map by fastforce
               also have "... = \<pi>a j \<cdot> ?f \<cdot> h"
                 using j f_in_hom \<Delta>a.map_def \<pi>a.cone_\<chi> comp_assoc by auto
               also have "... = \<pi>a j \<cdot> ?g \<cdot> h"
                 using j E by simp
               also have "... = \<Delta>a.cones_map ?g \<pi>a j \<cdot> h"
                 using j g_in_hom \<Delta>a.map_def \<pi>a.cone_\<chi> comp_assoc by auto
               also have "... = ?\<chi>' j \<cdot> h"
                 using j g_map by force
               finally show "?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h" by auto
             qed
             thus "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h" by blast
           qed
           show "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h \<Longrightarrow> ?f \<cdot> h = ?g \<cdot> h"
           proof -
             assume 1: "\<forall>j. J.arr j \<longrightarrow> ?\<chi> j \<cdot> h = ?\<chi>' j \<cdot> h"
             have 2: "\<And>j. j \<in> Collect J.arr \<Longrightarrow> \<pi>a j \<cdot> ?f \<cdot> h = \<pi>a j \<cdot> ?g \<cdot> h"
             proof -
               fix j
               assume j: "j \<in> Collect J.arr"
               have "\<pi>a j \<cdot> ?f \<cdot> h = (\<pi>a j \<cdot> ?f) \<cdot> h"
                 using comp_assoc by simp
               also have "... = ?\<chi> j \<cdot> h"
                 using ff j by force
               also have "... = ?\<chi>' j \<cdot> h"
                 using 1 j by auto
               also have "... = (\<pi>a j \<cdot> ?g) \<cdot> h"
                 using gg j by force
               also have "... = \<pi>a j \<cdot> ?g \<cdot> h"
                 using comp_assoc by simp
               finally show "\<pi>a j \<cdot> ?f \<cdot> h = \<pi>a j \<cdot> ?g \<cdot> h"
                 by auto
             qed
             show "C ?f h = C ?g h"
             proof -
               have "\<And>j. Arr.arr j \<Longrightarrow> \<guillemotleft>\<pi>a j \<cdot> ?f \<cdot> h : dom h \<rightarrow> \<Delta>a.map j\<guillemotright>"
                 using f_in_hom h \<pi>a_in_hom by (elim in_homE, auto)
               hence 3: "\<exists>!k. \<guillemotleft>k : dom h \<rightarrow> \<Pi>a\<guillemotright> \<and> (\<forall>j. Arr.arr j \<longrightarrow> \<pi>a j \<cdot> k = \<pi>a j \<cdot> ?f \<cdot> h)"
                 using h \<pi>a \<pi>a.is_universal' [of "dom h" "\<lambda>j. \<pi>a j \<cdot> ?f \<cdot> h"] \<Delta>a.map_def
                       ide_dom [of h]
                 by blast
               have 4: "\<And>P x x'. \<exists>!k. P k x \<Longrightarrow> P x x \<Longrightarrow> P x' x \<Longrightarrow> x' = x" by auto
               let ?P = "\<lambda> k x. \<guillemotleft>k : dom h \<rightarrow> \<Pi>a\<guillemotright> \<and>
                                (\<forall>j. j \<in> Collect J.arr \<longrightarrow> \<pi>a j \<cdot> k = \<pi>a j \<cdot> x)"
               have "?P (?g \<cdot> h) (?g \<cdot> h)"
                 using g_in_hom h by force
               moreover have "?P (?f \<cdot> h) (?g \<cdot> h)"
                 using 2 f_in_hom g_in_hom h by force
               ultimately show ?thesis
                 using 3 4 [of ?P "?f \<cdot> h" "?g \<cdot> h"] by auto
             qed
           qed
         qed
         have E': "\<And>e. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
                    ?f \<cdot> e = ?g \<cdot> e \<longleftrightarrow>
                    (\<forall>j. J.arr j \<longrightarrow>
                            (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e)"
         proof -
           have 1: "\<And>e j. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow> J.arr j \<Longrightarrow>
                           ?\<chi> j \<cdot> e = (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e"
           proof -
             fix e j
             assume e: "\<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright>"
             assume j: "J.arr j"
             have "\<guillemotleft>\<pi>o (J.cod j) \<cdot> e : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
               using e j \<pi>o_in_hom by auto
             thus "?\<chi> j \<cdot> e = (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e"
               using j comp_arr_dom comp_cod_arr by (elim in_homE, auto)
           qed
           have 2: "\<And>e j. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow> J.arr j \<Longrightarrow> ?\<chi>' j \<cdot> e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e"
             by (simp add: comp_assoc)
           show "\<And>e. \<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright> \<Longrightarrow>
                    ?f \<cdot> e = ?g \<cdot> e \<longleftrightarrow>
                      (\<forall>j. J.arr j \<longrightarrow>
                            (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> e) \<cdot> dom e = D j \<cdot> \<pi>o (J.dom j) \<cdot> e)"
             using 1 2 E by presburger
         qed
         text\<open>
           The composites of @{term e} with the projections from the product @{term \<Pi>o}
           determine a limit cone @{term \<mu>} for @{term D}.  The component of @{term \<mu>}
           at an object @{term j} of @{term[source=true] J} is the composite @{term "C (\<pi>o j) e"}.
           However, we need to extend @{term \<mu>} to all arrows @{term j} of @{term[source=true] J},
           so the correct definition is @{term "\<mu> j = C (D j) (C (\<pi>o (J.dom j)) e)"}.
 \<close>
         have e_in_hom: "\<guillemotleft>e : dom e \<rightarrow> \<Pi>o\<guillemotright>"
           using EQU.equalizes f_in_hom in_homI
           by (metis (no_types, lifting) seqE in_homE)
         have e_map: "C ?f e = C ?g e"
           using EQU.equalizes f_in_hom in_homI by fastforce
         interpret domE: constant_functor J C \<open>dom e\<close>
           using e_in_hom by (unfold_locales, auto)
         let ?\<mu> = "\<lambda>j. if J.arr j then D j \<cdot> \<pi>o (J.dom j) \<cdot> e else null"
         have \<mu>: "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>?\<mu> j : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
         proof -
           fix j
           assume j: "J.arr j"
           show "\<guillemotleft>?\<mu> j : dom e \<rightarrow> D (J.cod j)\<guillemotright>"
             using j e_in_hom \<pi>o_in_hom [of "J.dom j"] by auto
         qed
         interpret \<mu>: cone J C D \<open>dom e\<close> ?\<mu>
           using \<mu> comp_cod_arr e_in_hom e_map E'
             apply unfold_locales
                apply auto
           by (metis D.as_nat_trans.is_natural_1 comp_assoc)
         text\<open>
           If @{term \<tau>} is any cone over @{term D} then @{term \<tau>} restricts to a cone over
           @{term \<Delta>o} for which the induced arrow to @{term \<Pi>o} equalizes @{term f} and @{term g}.
 \<close>
         have R: "\<And>a \<tau>. cone J C D a \<tau> \<Longrightarrow>
                         cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>) \<and>
                         ?f \<cdot> \<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)
                            = ?g \<cdot> \<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
         proof -
           fix a \<tau>
           assume cone_\<tau>: "cone J C D a \<tau>"
           interpret \<tau>: cone J C D a \<tau> using cone_\<tau> by auto
           interpret A: constant_functor Obj.comp C a
             using \<tau>.ide_apex by (unfold_locales, auto)
           interpret \<tau>o: cone Obj.comp C \<Delta>o.map a \<open>\<Delta>o.mkCone \<tau>\<close>
             using A.value_is_ide \<Delta>o.map_def comp_cod_arr comp_arr_dom
             by (unfold_locales, auto)
           let ?e = "\<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
           have mkCone_\<tau>: "\<Delta>o.mkCone \<tau> \<in> \<Delta>o.cones a"
             using \<tau>o.cone_axioms by auto
           have e: "\<guillemotleft>?e : a \<rightarrow> \<Pi>o\<guillemotright>"
             using mkCone_\<tau> \<pi>o.induced_arrowI by simp
           have ee: "\<And>j. J.ide j \<Longrightarrow> \<pi>o j \<cdot> ?e = \<tau> j"
           proof -
             fix j
             assume j: "J.ide j"
             have "\<pi>o j \<cdot> ?e = \<Delta>o.cones_map ?e \<pi>o j"
               using j e \<pi>o.cone_axioms by force
             also have "... = \<Delta>o.mkCone \<tau> j"
               using j mkCone_\<tau> \<pi>o.induced_arrowI [of "\<Delta>o.mkCone \<tau>" a] by fastforce
             also have "... = \<tau> j"
               using j by simp
             finally show "\<pi>o j \<cdot> ?e = \<tau> j" by auto
           qed
           have "\<And>j. J.arr j \<Longrightarrow>
                       (D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
           proof -
             fix j
             assume j: "J.arr j"
             have 1: "\<guillemotleft>\<pi>o (J.cod j) : \<Pi>o \<rightarrow> D (J.cod j)\<guillemotright>" using j \<pi>o_in_hom by simp
             have 2: "(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e
                         = D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e"
             proof -
               have "seq (D (J.cod j)) (\<pi>o (J.cod j))"
                 using j 1 by auto
               moreover have "seq (\<pi>o (J.cod j)) ?e"
                 using j e by fastforce
               ultimately show ?thesis using comp_arr_dom by auto
             qed
             also have 3: "... = \<pi>o (J.cod j) \<cdot> ?e"
               using j e 1 comp_cod_arr by (elim in_homE, auto)
             also have "... = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
               using j e ee 2 3 \<tau>.naturality \<tau>.A.map_simp \<tau>.ide_apex comp_cod_arr by auto
             finally show "(D (J.cod j) \<cdot> \<pi>o (J.cod j) \<cdot> ?e) \<cdot> dom ?e = D j \<cdot> \<pi>o (J.dom j) \<cdot> ?e"
               by auto
           qed
           hence "C ?f ?e = C ?g ?e"
             using E' \<pi>o.induced_arrowI \<tau>o.cone_axioms mem_Collect_eq by blast
           thus "cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>) \<and> C ?f ?e = C ?g ?e"
             using \<tau>o.cone_axioms by auto
         qed
         text\<open>
           Finally, show that @{term \<mu>} is a limit cone.
 \<close>
         interpret \<mu>: limit_cone J C D \<open>dom e\<close> ?\<mu>
         proof
           fix a \<tau>
           assume cone_\<tau>: "cone J C D a \<tau>"
           interpret \<tau>: cone J C D a \<tau> using cone_\<tau> by auto
           interpret A: constant_functor Obj.comp C a
             using \<tau>.ide_apex by unfold_locales auto
           have cone_\<tau>o: "cone Obj.comp C \<Delta>o.map a (\<Delta>o.mkCone \<tau>)"
             using A.value_is_ide \<Delta>o.map_def D.preserves_ide comp_cod_arr comp_arr_dom
                   \<tau>.preserves_hom
             by unfold_locales auto
           show "\<exists>!h. \<guillemotleft>h : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h ?\<mu> = \<tau>"
           proof
             let ?e' = "\<pi>o.induced_arrow a (\<Delta>o.mkCone \<tau>)"
             have e'_in_hom: "\<guillemotleft>?e' : a \<rightarrow> \<Pi>o\<guillemotright>"
               using cone_\<tau> R \<pi>o.induced_arrowI by auto
             have e'_map: "?f \<cdot> ?e' = ?g \<cdot> ?e' \<and> \<Delta>o.cones_map ?e' \<pi>o = \<Delta>o.mkCone \<tau>"
               using cone_\<tau> R \<pi>o.induced_arrowI [of "\<Delta>o.mkCone \<tau>" a] by auto
             have equ: "PP.is_equalized_by ?e'"
               using e'_map e'_in_hom f_in_hom seqI' by blast
             let ?h = "EQU.induced_arrow a (PP.mkCone ?e')"
             have h_in_hom: "\<guillemotleft>?h : a \<rightarrow> dom e\<guillemotright>"
               using EQU.induced_arrowI PP.cone_mkCone [of ?e'] e'_in_hom equ by fastforce
             have h_map: "PP.cones_map ?h (PP.mkCone e) = PP.mkCone ?e'"
               using EQU.induced_arrowI [of "PP.mkCone ?e'" a] PP.cone_mkCone [of ?e']
                     e'_in_hom equ
               by fastforce
             have 3: "D.cones_map ?h ?\<mu> = \<tau>"
             proof
               fix j
               have "\<not>J.arr j \<Longrightarrow> D.cones_map ?h ?\<mu> j = \<tau> j"
                 using h_in_hom \<mu>.cone_axioms cone_\<tau> \<tau>.is_extensional by force
               moreover have "J.arr j \<Longrightarrow> D.cones_map ?h ?\<mu> j = \<tau> j"
               proof -
                 fix j
                 assume j: "J.arr j"
                 have 1: "\<guillemotleft>\<pi>o (J.dom j) \<cdot> e : dom e \<rightarrow> D (J.dom j)\<guillemotright>"
                   using j e_in_hom \<pi>o_in_hom [of "J.dom j"] by auto
                 have "D.cones_map ?h ?\<mu> j = ?\<mu> j \<cdot> ?h"
                   using h_in_hom j \<mu>.cone_axioms by auto
                 also have "... = D j \<cdot> (\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h"
                   using j comp_assoc by simp
                 also have "... = D j \<cdot> \<tau> (J.dom j)"
                 proof -
                   have "(\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h = \<tau> (J.dom j)"
                   proof -
                     have "(\<pi>o (J.dom j) \<cdot> e) \<cdot> ?h = \<pi>o (J.dom j) \<cdot> e \<cdot> ?h"
                       using j 1 e_in_hom h_in_hom \<pi>o arrI comp_assoc by auto
                     also have "... = \<pi>o (J.dom j) \<cdot> ?e'"
                       using equ e'_in_hom EQU.induced_arrowI' [of ?e'] by auto
                     also have "... = \<Delta>o.cones_map ?e' \<pi>o (J.dom j)"
                       using j e'_in_hom \<pi>o.cone_axioms by auto
                     also have "... = \<tau> (J.dom j)"
                       using j e'_map by simp
                     finally show ?thesis by auto
                   qed
                   thus ?thesis by simp
                 qed
                 also have "... = \<tau> j"
                   using j \<tau>.is_natural_1 by simp
                 finally show "D.cones_map ?h ?\<mu> j = \<tau> j" by auto
               qed
               ultimately show "D.cones_map ?h ?\<mu> j = \<tau> j" by auto
             qed
             show "\<guillemotleft>?h : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map ?h ?\<mu> = \<tau>"
               using h_in_hom 3 by simp
             show "\<And>h'. \<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h' ?\<mu> = \<tau> \<Longrightarrow> h' = ?h"
             proof -
               fix h'
               assume h': "\<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright> \<and> D.cones_map h' ?\<mu> = \<tau>"
               have h'_in_hom: "\<guillemotleft>h' : a \<rightarrow> dom e\<guillemotright>" using h' by simp
               have h'_map: "D.cones_map h' ?\<mu> = \<tau>" using h' by simp
               show "h' = ?h"
               proof -
                 have 1: "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright> \<and> ?f \<cdot> e \<cdot> h' = ?g \<cdot> e \<cdot> h' \<and>
                          \<Delta>o.cones_map (C e h') \<pi>o = \<Delta>o.mkCone \<tau>"
                 proof -
                   have 2: "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright>" using h'_in_hom e_in_hom by auto
                   moreover have "?f \<cdot> e \<cdot> h' = ?g \<cdot> e \<cdot> h'"
                     by (metis (no_types, lifting) EQU.equalizes comp_assoc)
                   moreover have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o = \<Delta>o.mkCone \<tau>"
                   proof
                     have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o = \<Delta>o.cones_map h' (\<Delta>o.cones_map e \<pi>o)"
                       using \<pi>o.cone_axioms e_in_hom h'_in_hom \<Delta>o.cones_map_comp [of e h']
                       by fastforce
                     fix j
                     have "\<not>Obj.arr j \<Longrightarrow> \<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j"
                       using 2 e_in_hom h'_in_hom \<pi>o.cone_axioms by auto
                     moreover have "Obj.arr j \<Longrightarrow> \<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j"
                     proof -
                       assume j: "Obj.arr j"
                       have "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<pi>o j \<cdot> e \<cdot> h'"
                         using 2 j \<pi>o.cone_axioms by auto
                       also have "... = (\<pi>o j \<cdot> e) \<cdot> h'"
                         using comp_assoc by auto
                       also have "... = \<Delta>o.mkCone ?\<mu> j \<cdot> h'"
                         using j e_in_hom \<pi>o_in_hom comp_ide_arr [of "D j" "\<pi>o j \<cdot> e"]
                         by fastforce
                       also have "... = \<Delta>o.mkCone \<tau> j"
                         using j h' \<mu>.cone_axioms mem_Collect_eq by auto
                       finally show "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j" by auto
                     qed
                     ultimately show "\<Delta>o.cones_map (e \<cdot> h') \<pi>o j = \<Delta>o.mkCone \<tau> j" by auto
                   qed
                   ultimately show ?thesis by auto
                 qed
                 have "\<guillemotleft>e \<cdot> h' : a \<rightarrow> \<Pi>o\<guillemotright>" using 1 by simp
                 moreover have "e \<cdot> h' = ?e'"
                   using 1 cone_\<tau>o e'_in_hom e'_map \<pi>o.is_universal \<pi>o by blast
                 ultimately show "h' = ?h"
                   using 1 h'_in_hom h'_map EQU.is_universal' [of "e \<cdot> h'"]
                         EQU.induced_arrowI' [of ?e'] equ
                   by (elim in_homE) auto
               qed
             qed
           qed
         qed
         have "limit_cone J C D (dom e) ?\<mu>" ..
         thus "\<exists>a \<mu>. limit_cone J C D a \<mu>" by auto
       qed
       thus "\<forall>D. diagram J C D \<longrightarrow> (\<exists>a \<mu>. limit_cone J C D a \<mu>)" by blast
     qed
 
   end
 
   section "Limits in a Set Category"
 
   text\<open>
     In this section, we consider the special case of limits in a set category.
 \<close>
 
   locale diagram_in_set_category =
     J: category J +
-    S: set_category S \<AA> +
+    S: set_category S is_set +
     diagram J S D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and S :: "'s comp"      (infixr "\<cdot>" 55)
-  and \<AA> :: "'a rel"
+  and is_set :: "'s set \<Rightarrow> bool"
   and D :: "'j \<Rightarrow> 's"
   begin
 
     notation S.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text\<open>
       An object @{term a} of a set category @{term[source=true] S} is a limit of a diagram in
       @{term[source=true] S} if and only if there is a bijection between the set
       @{term "S.hom S.unity a"} of points of @{term a} and the set of cones over the diagram
       that have apex @{term S.unity}.
 \<close>
 
     lemma limits_are_sets_of_cones:
     shows "has_as_limit a \<longleftrightarrow> S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
     proof
       text\<open>
         If \<open>has_limit a\<close>, then by the universal property of the limit cone,
         composition in @{term[source=true] S} yields a bijection between @{term "S.hom S.unity a"}
         and @{term "cones S.unity"}.
 \<close>
       assume a: "has_as_limit a"
       hence "S.ide a"
         using limit_cone_def cone.ide_apex by metis
       from a obtain \<chi> where \<chi>: "limit_cone a \<chi>" by auto
       interpret \<chi>: limit_cone J S D a \<chi> using \<chi> by auto
       have "bij_betw (\<lambda>f. cones_map f \<chi>) (S.hom S.unity a) (cones S.unity)"
         using \<chi>.bij_betw_hom_and_cones S.ide_unity by simp
       thus "S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
         using \<open>S.ide a\<close> by blast
       next
       text\<open>
         Conversely, an arbitrary bijection @{term \<phi>} between @{term "S.hom S.unity a"}
         and cones unity extends pointwise to a natural bijection @{term "\<Phi> a'"} between
         @{term "S.hom a' a"} and @{term "cones a'"}, showing that @{term a} is a limit.
 
         In more detail, the hypotheses give us a correspondence between points of @{term a}
         and cones with apex @{term "S.unity"}.  We extend this to a correspondence between
         functions to @{term a} and general cones, with each arrow from @{term a'} to @{term a}
         determining a cone with apex @{term a'}.  If @{term "f \<in> hom a' a"} then composition
         with @{term f} takes each point @{term y} of @{term a'} to the point @{term "S f y"}
         of @{term a}.  To this we may apply the given bijection @{term \<phi>} to obtain
         @{term "\<phi> (S f y) \<in> cones S.unity"}.  The component @{term "\<phi> (S f y) j"} at @{term j}
         of this cone is a point of @{term "S.cod (D j)"}.  Thus, @{term "f \<in> hom a' a"} determines
         a cone @{term \<chi>f} with apex @{term a'} whose component at @{term j} is the
         unique arrow @{term "\<chi>f j"} of @{term[source=true] S} such that
         @{term "\<chi>f j \<in> hom a' (cod (D j))"} and @{term "S (\<chi>f j) y = \<phi> (S f y) j"}
         for all points @{term y} of @{term a'}.
         The cone @{term \<chi>a} corresponding to @{term "a \<in> S.hom a a"} is then a limit cone.
 \<close>
       assume a: "S.ide a \<and> (\<exists>\<phi>. bij_betw \<phi> (S.hom S.unity a) (cones S.unity))"
       hence ide_a: "S.ide a" by auto
       show "has_as_limit a"
       proof -
         from a obtain \<phi> where \<phi>: "bij_betw \<phi> (S.hom S.unity a) (cones S.unity)" by blast
         have X: "\<And>f j y. \<lbrakk> \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>; J.arr j; \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<rbrakk>
                                 \<Longrightarrow> \<guillemotleft>\<phi> (f \<cdot> y) j : S.unity \<rightarrow> S.cod (D j)\<guillemotright>"
         proof -
           fix f j y
           assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>" and j: "J.arr j" and y: "\<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright>"
           interpret \<chi>: cone J S D S.unity \<open>\<phi> (S f y)\<close>
             using f y \<phi> bij_betw_imp_funcset funcset_mem by blast
           show "\<guillemotleft>\<phi> (f \<cdot> y) j : S.unity \<rightarrow> S.cod (D j)\<guillemotright>" using j by auto
         qed
         text\<open>
           We want to define the component @{term "\<chi>j \<in> S.hom (S.dom f) (S.cod (D j))"}
           at @{term j} of a cone by specifying how it acts by composition on points
           @{term "y \<in> S.hom S.unity (S.dom f)"}.  We can do this because @{term[source=true] S}
           is a set category.
 \<close>
         let ?P = "\<lambda>f j \<chi>j. \<guillemotleft>\<chi>j : S.dom f \<rightarrow> S.cod (D j)\<guillemotright> \<and>
                            (\<forall>y. \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<longrightarrow> \<chi>j \<cdot> y = \<phi> (f \<cdot> y) j)"
         let ?\<chi> = "\<lambda>f j. if J.arr j then (THE \<chi>j. ?P f j \<chi>j) else S.null"
         have \<chi>: "\<And>f j. \<lbrakk> \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>; J.arr j \<rbrakk> \<Longrightarrow> ?P f j (?\<chi> f j)"
         proof -
           fix b f j
           assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>" and j: "J.arr j"
           interpret B: constant_functor J S \<open>S.dom f\<close>
             using f by (unfold_locales) auto
           have "(\<lambda>y. \<phi> (f \<cdot> y) j) \<in> S.hom S.unity (S.dom f) \<rightarrow> S.hom S.unity (S.cod (D j))"
             using f j X Pi_I' by simp
           hence "\<exists>!\<chi>j. ?P f j \<chi>j"
             using f j S.fun_complete' by (elim S.in_homE) auto
           thus "?P f j (?\<chi> f j)" using j theI' [of "?P f j"] by simp
         qed
         text\<open>
           The arrows @{term "\<chi> f j"} are in fact the components of a cone with apex
           @{term "S.dom f"}.
 \<close>
         have cone: "\<And>f. \<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright> \<Longrightarrow> cone (S.dom f) (?\<chi> f)"
         proof -
           fix f
           assume f: "\<guillemotleft>f : S.dom f \<rightarrow> a\<guillemotright>"
           interpret B: constant_functor J S \<open>S.dom f\<close>
             using f by unfold_locales auto
           show "cone (S.dom f) (?\<chi> f)"
           proof
             show "\<And>j. \<not>J.arr j \<Longrightarrow> ?\<chi> f j = S.null" by simp
             fix j
             assume j: "J.arr j"
             have 0: "\<guillemotleft>?\<chi> f j : S.dom f \<rightarrow> S.cod (D j)\<guillemotright>" using f j \<chi> by simp
             show "S.dom (?\<chi> f j) = B.map (J.dom j)" using f j \<chi> by auto
             show "S.cod (?\<chi> f j) = D (J.cod j)" using f j \<chi> by auto
             have par2: "S.par (?\<chi> f (J.cod j) \<cdot> B.map j) (?\<chi> f j)"
               using f j 0 \<chi> [of f "J.cod j"] by (elim S.in_homE, auto)
             have nat: "\<And>y. \<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow>
                               (D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y \<and>
                               (?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y"
             proof -
               fix y
               assume y: "\<guillemotleft>y : S.unity \<rightarrow> S.dom f\<guillemotright>"
               show "(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y \<and>
                     (?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y"
               proof
                 have 1: "\<phi> (f \<cdot> y) \<in> cones S.unity"
                   using f y \<phi> bij_betw_imp_funcset PiE
                         S.seqI S.cod_comp S.dom_comp mem_Collect_eq
                   by fastforce
                 interpret \<chi>: cone J S D S.unity \<open>\<phi> (f \<cdot> y)\<close>
                   using 1 by simp
                 show "(D j \<cdot> ?\<chi> f (J.dom j)) \<cdot> y = ?\<chi> f j \<cdot> y"
                   using J.arr_dom S.comp_assoc \<chi> \<chi>.is_natural_1 f j y by presburger
                 have "(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f (J.cod j) \<cdot> y"
                   using j B.map_simp par2 B.value_is_ide S.comp_arr_ide
                   by (metis (no_types, lifting))
                 also have "... = \<phi> (f \<cdot> y) (J.cod j)"
                   using f y \<chi> \<chi>.is_extensional by simp
                 also have "... = \<phi> (f \<cdot> y) j"
                   using j \<chi>.is_natural_2
                   by (metis J.arr_cod \<chi>.A.map_simp J.cod_cod)
                 also have "... = ?\<chi> f j \<cdot> y"
                   using f y \<chi> \<chi>.is_extensional by simp
                 finally show "(?\<chi> f (J.cod j) \<cdot> B.map j) \<cdot> y = ?\<chi> f j \<cdot> y" by auto
               qed
             qed
             show "D j \<cdot> ?\<chi> f (J.dom j) = ?\<chi> f j"
             proof -
               have "S.par (D j \<cdot> ?\<chi> f (J.dom j)) (?\<chi> f j)"
                 using f j 0 \<chi> [of f "J.dom j"] by (elim S.in_homE, auto)
               thus ?thesis
                 using nat 0
                 apply (intro S.arr_eqI' [of "D j \<cdot> ?\<chi> f (J.dom j)" "?\<chi> f j"])
                  apply force
                 by auto
             qed
             show "?\<chi> f (J.cod j) \<cdot> B.map j = ?\<chi> f j"
               using par2 nat 0 f j \<chi>
               apply (intro S.arr_eqI' [of "?\<chi> f (J.cod j) \<cdot> B.map j" "?\<chi> f j"])
                apply force
               by (metis (no_types, lifting) S.in_homE)
           qed
         qed
         interpret \<chi>a: cone J S D a \<open>?\<chi> a\<close> using a cone [of a] by fastforce
         text\<open>
           Finally, show that \<open>\<chi> a\<close> is a limit cone.
 \<close>
         interpret \<chi>a: limit_cone J S D a \<open>?\<chi> a\<close>
         proof
           fix a' \<chi>'
           assume cone_\<chi>': "cone a' \<chi>'"
           interpret \<chi>': cone J S D a' \<chi>' using cone_\<chi>' by auto
           show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and> cones_map f (?\<chi> a) = \<chi>'"
           proof
             let ?\<psi> = "inv_into (S.hom S.unity a) \<phi>"
             have \<psi>: "?\<psi> \<in> cones S.unity \<rightarrow> S.hom S.unity a"
               using \<phi> bij_betw_inv_into bij_betwE by blast
             let ?P = "\<lambda>f. \<guillemotleft>f : a' \<rightarrow> a\<guillemotright> \<and>
                           (\<forall>y. y \<in> S.hom S.unity a' \<longrightarrow> f \<cdot> y = ?\<psi> (cones_map y \<chi>'))"
             have 1: "\<exists>!f. ?P f"
             proof -
               have "(\<lambda>y. ?\<psi> (cones_map y \<chi>')) \<in> S.hom S.unity a' \<rightarrow> S.hom S.unity a"
               proof
                 fix x
                 assume "x \<in> S.hom S.unity a'"
                 hence "\<guillemotleft>x : S.unity \<rightarrow> a'\<guillemotright>" by simp
                 hence "cones_map x \<in> cones a' \<rightarrow> cones S.unity"
                   using cones_map_mapsto [of x] by (elim S.in_homE) auto
                 hence "cones_map x \<chi>' \<in> cones S.unity"
                   using cone_\<chi>' by blast
                 thus "?\<psi> (cones_map x \<chi>') \<in> S.hom S.unity a"
                   using \<psi> by auto
               qed
               thus ?thesis
                 using S.fun_complete' a \<chi>'.ide_apex by simp
             qed
             let ?f = "THE f. ?P f"
             have f: "?P ?f" using 1 theI' [of ?P] by simp
             have f_in_hom: "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright>" using f by simp
             have f_map: "cones_map ?f (?\<chi> a) = \<chi>'"
             proof -
               have 1: "cone a' (cones_map ?f (?\<chi> a))"
               proof -
                 have "cones_map ?f \<in> cones a \<rightarrow> cones a'"
                   using f_in_hom cones_map_mapsto [of ?f] by (elim S.in_homE) auto
                 hence "cones_map ?f (?\<chi> a) \<in> cones a'"
                   using \<chi>a.cone_axioms by blast
                 thus ?thesis by simp
               qed
               interpret f\<chi>a: cone J S D a' \<open>cones_map ?f (?\<chi> a)\<close>
                 using 1 by simp
               show ?thesis
               proof
                 fix j
                 have "\<not>J.arr j \<Longrightarrow> cones_map ?f (?\<chi> a) j = \<chi>' j"
                   using 1 \<chi>'.is_extensional f\<chi>a.is_extensional by presburger
                 moreover have "J.arr j \<Longrightarrow> cones_map ?f (?\<chi> a) j = \<chi>' j"
                 proof -
                   assume j: "J.arr j"
                   show "cones_map ?f (?\<chi> a) j = \<chi>' j"
                   proof (intro S.arr_eqI' [of "cones_map ?f (?\<chi> a) j" "\<chi>' j"])
                     show par: "S.par (cones_map ?f (?\<chi> a) j) (\<chi>' j)"
                       using j \<chi>'.preserves_cod \<chi>'.preserves_dom \<chi>'.preserves_reflects_arr
                             f\<chi>a.preserves_cod f\<chi>a.preserves_dom f\<chi>a.preserves_reflects_arr
                       by presburger
                     fix y
                     assume "\<guillemotleft>y : S.unity \<rightarrow> S.dom (cones_map ?f (?\<chi> a) j)\<guillemotright>"
                     hence y: "\<guillemotleft>y : S.unity \<rightarrow> a'\<guillemotright>"
                       using j f\<chi>a.preserves_dom by simp
                     have 1: "\<guillemotleft>?\<chi> a j : a \<rightarrow> D (J.cod j)\<guillemotright>"
                       using j \<chi>a.preserves_hom by force
                     have 2: "\<guillemotleft>?f \<cdot> y : S.unity \<rightarrow> a\<guillemotright>"
                       using f_in_hom y by blast
                     have "cones_map ?f (?\<chi> a) j \<cdot> y = (?\<chi> a j \<cdot> ?f) \<cdot> y"
                     proof -
                       have "S.cod ?f = a" using f_in_hom by blast
                       thus ?thesis using j \<chi>a.cone_axioms by simp
                     qed
                     also have "... = ?\<chi> a j \<cdot> ?f \<cdot> y"
                       using 1 j y f_in_hom S.comp_assoc S.seqI' by blast
                     also have "... = \<phi> (a \<cdot> ?f \<cdot> y) j"
                       using 1 2 ide_a f j y \<chi> [of a] by (simp add: S.ide_in_hom)
                     also have "... = \<phi> (?f \<cdot> y) j"
                       using a 2 y S.comp_cod_arr by (elim S.in_homE, auto)
                     also have "... = \<phi> (?\<psi> (cones_map y \<chi>')) j"
                       using j y f by simp
                     also have "... = cones_map y \<chi>' j"
                     proof -
                       have "cones_map y \<chi>' \<in> cones S.unity"
                         using cone_\<chi>' y cones_map_mapsto by force
                       hence "\<phi> (?\<psi> (cones_map y \<chi>')) = cones_map y \<chi>'"
                         using \<phi> bij_betw_inv_into_right [of \<phi>] by simp
                       thus ?thesis by auto
                     qed
                     also have "... = \<chi>' j \<cdot> y"
                       using cone_\<chi>' j y by auto
                     finally show "cones_map ?f (?\<chi> a) j \<cdot> y = \<chi>' j \<cdot> y"
                       by auto
                   qed
                 qed
                 ultimately show "cones_map ?f (?\<chi> a) j = \<chi>' j" by blast
               qed
             qed
             show "\<guillemotleft>?f : a' \<rightarrow> a\<guillemotright> \<and> cones_map ?f (?\<chi> a) = \<chi>'"
               using f_in_hom f_map by simp
             show "\<And>f'. \<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> cones_map f' (?\<chi> a) = \<chi>' \<Longrightarrow> f' = ?f"
             proof -
               fix f'
               assume f': "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright> \<and> cones_map f' (?\<chi> a) = \<chi>'"
               have f'_in_hom: "\<guillemotleft>f' : a' \<rightarrow> a\<guillemotright>" using f' by simp
               have f'_map: "cones_map f' (?\<chi> a) = \<chi>'" using f' by simp
               show "f' = ?f"
               proof (intro S.arr_eqI' [of f' ?f])
                 show "S.par f' ?f"
                   using f_in_hom f'_in_hom by (elim S.in_homE, auto)
                 show "\<And>y'. \<guillemotleft>y' : S.unity \<rightarrow> S.dom f'\<guillemotright> \<Longrightarrow> f' \<cdot> y' = ?f \<cdot> y'"
                 proof -
                   fix y'
                   assume y': "\<guillemotleft>y' : S.unity \<rightarrow> S.dom f'\<guillemotright>"
                   have 0: "\<phi> (f' \<cdot> y') = cones_map y' \<chi>'"
                   proof
                     fix j
                     have 1: "\<guillemotleft>f' \<cdot> y' : S.unity \<rightarrow> a\<guillemotright>" using f'_in_hom y' by auto
                     hence 2: "\<phi> (f' \<cdot> y') \<in> cones S.unity"
                       using \<phi> bij_betw_imp_funcset [of \<phi> "S.hom S.unity a" "cones S.unity"]
                       by auto
                     interpret \<chi>'': cone J S D S.unity \<open>\<phi> (f' \<cdot> y')\<close> using 2 by auto
                     have "\<not>J.arr j \<Longrightarrow> \<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j"
                       using f' y' cone_\<chi>' \<chi>''.is_extensional mem_Collect_eq restrict_apply
                       by (elim S.in_homE, auto)
                     moreover have "J.arr j \<Longrightarrow> \<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j"
                     proof -
                       assume j: "J.arr j"
                       have 3: "\<guillemotleft>?\<chi> a j : a \<rightarrow> D (J.cod j)\<guillemotright>"
                         using j \<chi>a.preserves_hom by force
                       have "\<phi> (f' \<cdot> y') j = \<phi> (a \<cdot> f' \<cdot> y') j"
                         using a f' y' j S.comp_cod_arr by (elim S.in_homE, auto)
                       also have "... = ?\<chi> a j \<cdot> f' \<cdot> y'"
                         using 1 3 \<chi> [of a] a f' y' j by fastforce
                       also have "... = (?\<chi> a j \<cdot> f') \<cdot> y'"
                         using S.comp_assoc by simp
                       also have "... = cones_map f' (?\<chi> a) j \<cdot> y'"
                         using f' y' j \<chi>a.cone_axioms by auto
                       also have "... = \<chi>' j \<cdot> y'"
                         using f' by blast
                       also have "... = cones_map y' \<chi>' j"
                         using y' j cone_\<chi>' f' mem_Collect_eq restrict_apply by force
                       finally show "\<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j" by auto
                     qed
                     ultimately show "\<phi> (f' \<cdot> y') j = cones_map y' \<chi>' j" by auto
                   qed
                   hence "f' \<cdot> y' = ?\<psi> (cones_map y' \<chi>')"
                     using \<phi> f'_in_hom y' S.comp_in_homI
                           bij_betw_inv_into_left [of \<phi> "S.hom S.unity a" "cones S.unity" "f' \<cdot> y'"]
                     by (elim S.in_homE, auto)
                   moreover have "?f \<cdot> y' = ?\<psi> (cones_map y' \<chi>')"
                     using \<phi> 0 1 f f_in_hom f'_in_hom y' S.comp_in_homI
                           bij_betw_inv_into_left [of \<phi> "S.hom S.unity a" "cones S.unity" "?f \<cdot> y'"]
                     by (elim S.in_homE, auto)
                   ultimately show "f' \<cdot> y' = ?f \<cdot> y'" by auto
                 qed
               qed
             qed
           qed
         qed
         have "limit_cone a (?\<chi> a)" ..
         thus ?thesis by auto
       qed
     qed
 
   end
 
   locale diagram_in_replete_set_category =
     J: category J +
     S: replete_set_category S +
     diagram J S D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and S :: "'s comp"      (infixr "\<cdot>" 55)
   and D :: "'j \<Rightarrow> 's"
   begin
 
-    sublocale diagram_in_set_category J S \<open>cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)\<close> D
+    sublocale diagram_in_set_category J S S.setp D
       ..
 
   end
 
   context set_category
   begin
 
     text\<open>
       A set category has an equalizer for any parallel pair of arrows.
 \<close>
 
     lemma has_equalizers:
     shows "has_equalizers"
     proof (unfold has_equalizers_def)
       have "\<And>f0 f1. par f0 f1 \<Longrightarrow> \<exists>e. has_as_equalizer f0 f1 e"
       proof -
         fix f0 f1
         assume par: "par f0 f1"
         interpret J: parallel_pair .
         interpret PP: parallel_pair_diagram S f0 f1
           using par by unfold_locales auto
-        interpret PP: diagram_in_set_category J.comp S \<AA> PP.map ..
+        interpret PP: diagram_in_set_category J.comp S setp PP.map ..
         text\<open>
           Let @{term a} be the object corresponding to the set of all images of equalizing points
           of @{term "dom f0"}, and let @{term e} be the inclusion of @{term a} in @{term "dom f0"}.
 \<close>
         let ?a = "mkIde (img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e})"
         have 0: "{e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e} \<subseteq> hom unity (dom f0)"
           by auto
         hence 1: "img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e} \<subseteq> Univ"
           using img_point_in_Univ by auto
-        have 2: "|img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}| <o \<AA>"
+        have 2: "setp (img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e})"
         proof -
-          have "|hom unity (dom f0)| =o |Dom f0|"
-            using par bij_betw_points_and_set [of "dom f0"]
-            by (simp add: card_of_ordIsoI)
-          moreover have "|Dom f0| <o \<AA>"
-            using par set_card by simp
-          ultimately have "|hom unity (dom f0)| <o \<AA>"
-            using ordIso_ordLess_trans by blast
-          moreover have
-              "|{e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}| \<le>o |hom unity (dom f0)|"
-            using 0 by simp
-          ultimately have "|{e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}| <o \<AA>"
-            using ordLeq_ordLess_trans by blast
-          thus ?thesis
-            using card_of_image ordLeq_ordLess_trans by blast
+          have "setp (img ` hom unity (dom f0))"
+            using ide_dom par setp_img_points by blast
+          moreover have "img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e} \<subseteq>
+                         img ` hom unity (dom f0)"
+            by blast
+          ultimately show ?thesis
+            by (meson setp_respects_subset)
         qed
         have ide_a: "ide ?a" using 1 2 ide_mkIde by auto
         have set_a: "set ?a = img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
           using 1 2 set_mkIde by simp
         have incl_in_a: "incl_in ?a (dom f0)"
         proof -
           have "ide (dom f0)"
             using PP.is_parallel by simp
           moreover have "set ?a \<subseteq> set (dom f0)"
             using img_point_elem_set set_a by fastforce
           ultimately show ?thesis
             using incl_in_def \<open>ide ?a\<close> by simp
         qed
         text\<open>
           Then @{term "set a"} is in bijective correspondence with @{term "PP.cones unity"}.
 \<close>
         let ?\<phi> = "\<lambda>t. PP.mkCone (mkPoint (dom f0) t)"
         let ?\<psi> = "\<lambda>\<chi>. img (\<chi> (J.Zero))"
         have bij: "bij_betw ?\<phi> (set ?a) (PP.cones unity)"
         proof (intro bij_betwI)
           show "?\<phi> \<in> set ?a \<rightarrow> PP.cones unity"
           proof
             fix t
             assume t: "t \<in> set ?a"
             hence 1: "t \<in> img ` {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
               using set_a by blast
             then have 2: "mkPoint (dom f0) t \<in> hom unity (dom f0)"
               using mkPoint_in_hom imageE mem_Collect_eq mkPoint_img(2) by auto
             with 1 have 3: "mkPoint (dom f0) t \<in> {e. e \<in> hom unity (dom f0) \<and> f0 \<cdot> e = f1 \<cdot> e}"
               using mkPoint_img(2) by auto
             then have "PP.is_equalized_by (mkPoint (dom f0) t)"
               using CollectD par by fastforce
             thus "PP.mkCone (mkPoint (dom f0) t) \<in> PP.cones unity"
               using 2 PP.cone_mkCone [of "mkPoint (dom f0) t"] by auto
           qed
           show "?\<psi> \<in> PP.cones unity \<rightarrow> set ?a"
           proof
             fix \<chi>
             assume \<chi>: "\<chi> \<in> PP.cones unity"
             interpret \<chi>: cone J.comp S PP.map unity \<chi> using \<chi> by auto
             have "\<chi> (J.Zero) \<in> hom unity (dom f0) \<and> f0 \<cdot> \<chi> (J.Zero) = f1 \<cdot> \<chi> (J.Zero)"
               using \<chi> PP.map_def PP.is_equalized_by_cone J.arr_char by auto
             hence "img (\<chi> (J.Zero)) \<in> set ?a"
               using set_a by simp
             thus "?\<psi> \<chi> \<in> set ?a" by blast
           qed
           show "\<And>t. t \<in> set ?a \<Longrightarrow> ?\<psi> (?\<phi> t) = t"
             using set_a J.arr_char PP.mkCone_def imageE mem_Collect_eq mkPoint_img(2)
             by auto
           show "\<And>\<chi>. \<chi> \<in> PP.cones unity \<Longrightarrow> ?\<phi> (?\<psi> \<chi>) = \<chi>"
           proof -
             fix \<chi>
             assume \<chi>: "\<chi> \<in> PP.cones unity"
             interpret \<chi>: cone J.comp S PP.map unity \<chi> using \<chi> by auto
             have 1: "\<chi> (J.Zero) \<in> hom unity (dom f0) \<and> f0 \<cdot> \<chi> (J.Zero) = f1 \<cdot> \<chi> (J.Zero)"
               using \<chi> PP.map_def PP.is_equalized_by_cone J.arr_char by auto
             hence "img (\<chi> (J.Zero)) \<in> set ?a"
               using set_a by simp
             hence "img (\<chi> (J.Zero)) \<in> set (dom f0)"
               using incl_in_a incl_in_def by auto
             hence "mkPoint (dom f0) (img (\<chi> J.Zero)) = \<chi> J.Zero"
               using 1 mkPoint_img(2) by blast
             hence "?\<phi> (?\<psi> \<chi>) = PP.mkCone (\<chi> J.Zero)" by simp
             also have "... = \<chi>"
               using \<chi> PP.mkCone_cone by simp
             finally show "?\<phi> (?\<psi> \<chi>) = \<chi>" by auto
           qed
         qed
         text\<open>
           It follows that @{term a} is a limit of \<open>PP\<close>, and that the limit cone gives an
           equalizer of @{term f0} and @{term f1}.
 \<close>
         have "PP.has_as_limit ?a"
         proof -
           have "\<exists>\<mu>. bij_betw \<mu> (hom unity ?a) (set ?a)"
             using bij_betw_points_and_set ide_a by auto
           from this obtain \<mu> where \<mu>: "bij_betw \<mu> (hom unity ?a) (set ?a)" by blast
           have "bij_betw (?\<phi> o \<mu>) (hom unity ?a) (PP.cones unity)"
             using bij \<mu> bij_betw_comp_iff by blast
           hence "\<exists>\<phi>. bij_betw \<phi> (hom unity ?a) (PP.cones unity)" by auto
           thus ?thesis
             using ide_a PP.limits_are_sets_of_cones by simp
         qed
         from this obtain \<epsilon> where \<epsilon>: "limit_cone J.comp S PP.map ?a \<epsilon>" by auto
         have "PP.has_as_equalizer (\<epsilon> J.Zero)"
         proof -
           interpret \<epsilon>: limit_cone J.comp S PP.map ?a \<epsilon> using \<epsilon> by auto
           have "PP.mkCone (\<epsilon> (J.Zero)) = \<epsilon>"
             using \<epsilon> PP.mkCone_cone \<epsilon>.cone_axioms by simp
           moreover have "dom (\<epsilon> (J.Zero)) = ?a"
             using J.ide_char \<epsilon>.preserves_hom \<epsilon>.A.map_def by simp
           ultimately show ?thesis
             using \<epsilon> by simp
         qed
         thus "\<exists>e. has_as_equalizer f0 f1 e"
           using par has_as_equalizer_def by auto   
       qed
       thus "\<forall>f0 f1. par f0 f1 \<longrightarrow> (\<exists>e. has_as_equalizer f0 f1 e)" by auto
     qed
 
   end
 
   sublocale set_category \<subseteq> category_with_equalizers S
     apply unfold_locales using has_equalizers by auto
 
   context set_category
   begin
 
     text\<open>
       The aim of the next results is to characterize the conditions under which a set
       category has products.  In a traditional development of category theory,
       one shows that the category \textbf{Set} of \emph{all} sets has all small
       (\emph{i.e.}~set-indexed) products.  In the present context we do not have a
       category of \emph{all} sets, but rather only a category of all sets with
       elements at a particular type.  Clearly, we cannot expect such a category
       to have products indexed by arbitrarily large sets.  The existence of
       @{term I}-indexed products in a set category @{term[source=true] S} implies that the universe
       \<open>S.Univ\<close> of @{term[source=true] S} must be large enough to admit the formation of
       @{term I}-tuples of its elements.  Conversely, for a set category @{term[source=true] S}
       the ability to form @{term I}-tuples in @{term Univ} implies that
       @{term[source=true] S} has @{term I}-indexed products.  Below we make this precise by
       defining the notion of when a set category @{term[source=true] S}
       ``admits @{term I}-indexed tupling'' and we show that @{term[source=true] S}
       has @{term I}-indexed products if and only if it admits @{term I}-indexed tupling.
 
       The definition of ``@{term[source=true] S} admits @{term I}-indexed tupling'' says that
       there is an injective map, from the space of extensional functions from
       @{term I} to @{term Univ}, to @{term Univ}.  However for a convenient
       statement and proof of the desired result, the definition of extensional
       function from theory @{theory "HOL-Library.FuncSet"} needs to be modified.
       The theory @{theory "HOL-Library.FuncSet"} uses the definite, but arbitrarily chosen value
       @{term undefined} as the value to be assumed by an extensional function outside
       of its domain.  In the context of the \<open>set_category\<close>, though, it is
       more natural to use \<open>S.unity\<close>, which is guaranteed to be an element of the
       universe of @{term[source=true] S}, for this purpose.  Doing things that way makes it
       simpler to establish a bijective correspondence between cones over @{term D} with apex
       @{term unity} and the set of extensional functions @{term d} that map
       each arrow @{term j} of @{term J} to an element @{term "d j"} of @{term "set (D j)"}.
       Possibly it makes sense to go back and make this change in \<open>set_category\<close>,
       but that would mean completely abandoning @{theory "HOL-Library.FuncSet"} and essentially
       introducing a duplicate version for use with \<open>set_category\<close>.
       As a compromise, what I have done here is to locally redefine the few notions from
       @{theory "HOL-Library.FuncSet"} that I need in order to prove the next set of results.
       The redefined notions are primed to avoid confusion with the original versions.
 \<close>
 
     definition extensional'
     where "extensional' A \<equiv> {f. \<forall>x. x \<notin> A \<longrightarrow> f x = unity}"
 
     abbreviation PiE'
     where "PiE' A B \<equiv> Pi A B \<inter> extensional' A"
 
     abbreviation restrict'
     where "restrict' f A \<equiv> \<lambda>x. if x \<in> A then f x else unity"
 
     lemma extensional'I [intro]:
     assumes "\<And>x. x \<notin> A \<Longrightarrow> f x = unity"
     shows "f \<in> extensional' A"
       using assms extensional'_def by auto
 
     lemma extensional'_arb:
     assumes "f \<in> extensional' A" and "x \<notin> A"
     shows "f x = unity"
       using assms extensional'_def by fast
 
     lemma extensional'_monotone:
     assumes "A \<subseteq> B"
     shows "extensional' A \<subseteq> extensional' B"
       using assms extensional'_arb by fastforce
 
     lemma PiE'_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> PiE' A B \<subseteq> PiE' A C"
       by auto
 
   end
 
-  locale discrete_diagram_in_replete_set_category =
-    S: replete_set_category S +
+  locale discrete_diagram_in_set_category =
+    S: set_category S \<SS> +
     discrete_diagram J S D +
-    diagram_in_replete_set_category J S D
+    diagram_in_set_category J S \<SS> D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and S :: "'s comp"      (infixr "\<cdot>" 55)
+  and \<SS> :: "'s set \<Rightarrow> bool"
   and D :: "'j \<Rightarrow> 's"
   begin
 
     text\<open>
       For @{term D} a discrete diagram in a set category, there is a bijective correspondence
       between cones over @{term D} with apex unity and the set of extensional functions @{term d}
       that map each arrow @{term j} of @{term[source=true] J} to an element of
       @{term "S.set (D j)"}.
 \<close>
 
     abbreviation I
     where "I \<equiv> Collect J.arr"
 
     definition funToCone
     where "funToCone F \<equiv> \<lambda>j. if J.arr j then S.mkPoint (D j) (F j) else S.null"
 
     definition coneToFun
     where "coneToFun \<chi> \<equiv> \<lambda>j. if J.arr j then S.img (\<chi> j) else S.unity"
 
     lemma funToCone_mapsto:
     shows "funToCone \<in> S.PiE' I (S.set o D) \<rightarrow> cones S.unity"
     proof
       fix F
       assume F: "F \<in> S.PiE' I (S.set o D)"
       interpret U: constant_functor J S S.unity
         apply unfold_locales using S.ide_unity by auto
-      have 1: "S.ide (S.mkIde S.Univ)"
-        using S.ide_mkIde by simp
       have "cone S.unity (funToCone F)"
       proof
         show "\<And>j. \<not>J.arr j \<Longrightarrow> funToCone F j = S.null"
           using funToCone_def by simp
         fix j
         assume j: "J.arr j"
         have "funToCone F j = S.mkPoint (D j) (F j)"
           using j funToCone_def by simp
         moreover have "... \<in> S.hom S.unity (D j)"
           using F j is_discrete S.img_mkPoint(1) [of "D j"] by force
         ultimately have 2: "funToCone F j \<in> S.hom S.unity (D j)" by auto
         show 3: "S.dom (funToCone F j) = U.map (J.dom j)"
           using 2 j U.map_simp by auto
         show 4: "S.cod (funToCone F j) = D (J.cod j)"
           using 2 j is_discrete by auto
         show "D j \<cdot> funToCone F (J.dom j) = funToCone F j"
           using 2 j is_discrete S.comp_cod_arr by auto
         show "funToCone F (J.cod j) \<cdot> (U.map j) = funToCone F j"
           using 3 j is_discrete U.map_simp S.arr_dom_iff_arr S.comp_arr_dom U.preserves_arr
           by (metis J.ide_char)
       qed
       thus "funToCone F \<in> cones S.unity" by auto
     qed
 
     lemma coneToFun_mapsto:
     shows "coneToFun \<in> cones S.unity \<rightarrow> S.PiE' I (S.set o D)"
     proof
       fix \<chi>
       assume \<chi>: "\<chi> \<in> cones S.unity"
       interpret \<chi>: cone J S D S.unity \<chi> using \<chi> by auto
       show "coneToFun \<chi> \<in> S.PiE' I (S.set o D)"
       proof
         show "coneToFun \<chi> \<in> Pi I (S.set o D)"
           using S.mkPoint_img(1) coneToFun_def is_discrete \<chi>.component_in_hom
           by (simp add: S.img_point_elem_set restrict_apply')
         show "coneToFun \<chi> \<in> S.extensional' I"
           by (metis S.extensional'I coneToFun_def mem_Collect_eq)
       qed
     qed
 
     lemma funToCone_coneToFun:
     assumes "\<chi> \<in> cones S.unity"
     shows "funToCone (coneToFun \<chi>) = \<chi>"
     proof
       interpret \<chi>: cone J S D S.unity \<chi> using assms by auto
       fix j
       have "\<not>J.arr j \<Longrightarrow> funToCone (coneToFun \<chi>) j = \<chi> j"
         using funToCone_def \<chi>.is_extensional by simp
       moreover have "J.arr j \<Longrightarrow> funToCone (coneToFun \<chi>) j = \<chi> j"
         using funToCone_def coneToFun_def S.mkPoint_img(2) is_discrete \<chi>.component_in_hom
         by auto
       ultimately show "funToCone (coneToFun \<chi>) j = \<chi> j" by blast
     qed
 
     lemma coneToFun_funToCone:
     assumes "F \<in> S.PiE' I (S.set o D)"
     shows "coneToFun (funToCone F) = F"
     proof
       fix i
       have "i \<notin> I \<Longrightarrow> coneToFun (funToCone F) i = F i"
         using assms coneToFun_def S.extensional'_arb [of F I i] by auto
       moreover have "i \<in> I \<Longrightarrow> coneToFun (funToCone F) i = F i"
       proof -
         assume i: "i \<in> I"
         have "coneToFun (funToCone F) i = S.img (funToCone F i)"
           using i coneToFun_def by simp
         also have "... = S.img (S.mkPoint (D i) (F i))"
           using i funToCone_def by auto
         also have "... = F i"
           using assms i is_discrete S.img_mkPoint(2) by force
         finally show "coneToFun (funToCone F) i = F i" by auto
       qed
       ultimately show "coneToFun (funToCone F) i = F i" by auto
     qed
 
     lemma bij_coneToFun:
     shows "bij_betw coneToFun (cones S.unity) (S.PiE' I (S.set o D))"
       using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
             bij_betwI
       by blast
 
     lemma bij_funToCone:
     shows "bij_betw funToCone (S.PiE' I (S.set o D)) (cones S.unity)"
       using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
             bij_betwI
       by blast
  
   end
 
-  context replete_set_category
+  context set_category
   begin
 
     text\<open>
       A set category admits @{term I}-indexed tupling if there is an injective map that takes
       each extensional function from @{term I} to @{term Univ} to an element of @{term Univ}.
 \<close>
 
     definition admits_tupling
     where "admits_tupling I \<equiv> \<exists>\<pi>. \<pi> \<in> PiE' I (\<lambda>_. Univ) \<rightarrow> Univ \<and> inj_on \<pi> (PiE' I (\<lambda>_. Univ))"
 
     lemma admits_tupling_monotone:
     assumes "admits_tupling I" and "I' \<subseteq> I"
     shows "admits_tupling I'"
     proof -
       from assms(1) obtain \<pi>
       where \<pi>: "\<pi> \<in> PiE' I (\<lambda>_. Univ) \<rightarrow> Univ \<and> inj_on \<pi> (PiE' I (\<lambda>_. Univ))"
         using admits_tupling_def by metis
       have "\<pi> \<in> PiE' I' (\<lambda>_. Univ) \<rightarrow> Univ"
       proof
         fix f
         assume f: "f \<in> PiE' I' (\<lambda>_. Univ)"
         have "f \<in> PiE' I (\<lambda>_. Univ)"
           using assms(2) f extensional'_def [of I'] terminal_unity extensional'_monotone by auto
         thus "\<pi> f \<in> Univ" using \<pi> by auto
       qed
       moreover have "inj_on \<pi> (PiE' I' (\<lambda>_. Univ))"
       proof -
         have 1: "\<And>F A A'. inj_on F A \<and> A' \<subseteq> A \<Longrightarrow> inj_on F A'"
           using subset_inj_on by blast
         moreover have "PiE' I' (\<lambda>_. Univ) \<subseteq> PiE' I (\<lambda>_. Univ)"
           using assms(2) extensional'_def [of I'] terminal_unity by auto
         ultimately show ?thesis using \<pi> assms(2) by blast
       qed
       ultimately show ?thesis using admits_tupling_def by metis
     qed
 
+    lemma admits_tupling_respects_bij:
+    assumes "admits_tupling I" and "bij_betw \<phi> I I'"
+    shows "admits_tupling I'"
+    proof -
+      obtain \<pi> where \<pi>: "\<pi> \<in> (I \<rightarrow> Univ) \<inter> extensional' I \<rightarrow> Univ \<and>
+                         inj_on \<pi> ((I \<rightarrow> Univ) \<inter> extensional' I)"
+        using assms(1) admits_tupling_def by metis
+      have inv: "bij_betw (inv_into I \<phi>) I' I"
+        using assms(2) bij_betw_inv_into by blast
+      let ?C = "\<lambda>f x. if x \<in> I then f (\<phi> x) else unity"
+      let ?\<pi>' = "\<lambda>f. \<pi> (?C f)"
+      have 1: "\<And>f. f \<in> (I' \<rightarrow> Univ) \<inter> extensional' I' \<Longrightarrow> ?C f \<in> (I \<rightarrow> Univ) \<inter> extensional' I"
+        using assms bij_betw_apply by fastforce
+      have "?\<pi>' \<in> (I' \<rightarrow> Univ) \<inter> extensional' I' \<rightarrow> Univ \<and>
+            inj_on ?\<pi>' ((I' \<rightarrow> Univ) \<inter> extensional' I')"
+      proof
+        show "(\<lambda>f. \<pi> (?C f)) \<in> (I' \<rightarrow> Univ) \<inter> extensional' I' \<rightarrow> Univ"
+          using 1 \<pi> by blast
+        show "inj_on ?\<pi>' ((I' \<rightarrow> Univ) \<inter> extensional' I')"
+        proof
+          fix f g
+          assume f: "f \<in> (I' \<rightarrow> Univ) \<inter> extensional' I'"
+          assume g: "g \<in> (I' \<rightarrow> Univ) \<inter> extensional' I'"
+          assume eq: "?\<pi>' f = ?\<pi>' g"
+          have f': "?C f \<in> (I \<rightarrow> Univ) \<inter> extensional' I"
+            using f 1 by simp
+          have g': "?C g \<in> (I \<rightarrow> Univ) \<inter> extensional' I"
+            using g 1 by simp
+          have 2: "?C f = ?C g"
+            using f' g' \<pi> eq by (simp add: inj_on_def)
+          show "f = g"
+          proof
+            fix x
+            show "f x = g x"
+            proof (cases "x \<in> I'")
+              show "x \<in> I' \<Longrightarrow> ?thesis"
+                using f g
+                by (metis (no_types, opaque_lifting) "2" assms(2) bij_betw_apply
+                    bij_betw_inv_into_right inv)
+              show "x \<notin> I' \<Longrightarrow> ?thesis"
+                using f g by (metis IntD2 extensional'_arb)
+            qed
+          qed
+        qed
+      qed
+      thus ?thesis
+        using admits_tupling_def by blast
+    qed
+
+  end
+
+  context replete_set_category
+  begin
+
     lemma has_products_iff_admits_tupling:
     fixes I :: "'i set"
     shows "has_products I \<longleftrightarrow> I \<noteq> UNIV \<and> admits_tupling I"
     proof
       text\<open>
         If @{term[source=true] S} has @{term I}-indexed products, then for every @{term I}-indexed
         discrete diagram @{term D} in @{term[source=true] S} there is an object @{term \<Pi>D}
         of @{term[source=true] S} whose points are in bijective correspondence with the set of
         cones over @{term D} with apex @{term unity}.  In particular this is true for
         the diagram @{term D} that assigns to each element of @{term I} the
         ``universal object'' @{term "mkIde Univ"}.
 \<close>
       assume has_products: "has_products I"
       have I: "I \<noteq> UNIV" using has_products has_products_def by auto
       interpret J: discrete_category I \<open>SOME x. x \<notin> I\<close>
         using I someI_ex [of "\<lambda>x. x \<notin> I"] by (unfold_locales, auto)
       let ?D = "\<lambda>i. mkIde Univ"
       interpret D: discrete_diagram_from_map I S ?D \<open>SOME j. j \<notin> I\<close>
         using J.not_arr_null J.arr_char ide_mkIde
         by (unfold_locales, auto)
-      interpret D: discrete_diagram_in_replete_set_category J.comp S D.map ..
+      interpret D: discrete_diagram_in_set_category J.comp S \<open>\<lambda>A. A \<subseteq> Univ\<close> D.map ..
       have "discrete_diagram J.comp S D.map" ..
       from this obtain \<Pi>D \<chi> where \<chi>: "product_cone J.comp S D.map \<Pi>D \<chi>"
         using has_products has_products_def [of I] ex_productE [of "J.comp" D.map]
               D.diagram_axioms
         by blast
       interpret \<chi>: product_cone J.comp S D.map \<Pi>D \<chi>
         using \<chi> by auto
       have "D.has_as_limit \<Pi>D"
         using \<chi>.limit_cone_axioms by auto
       hence \<Pi>D: "ide \<Pi>D \<and> (\<exists>\<phi>. bij_betw \<phi> (hom unity \<Pi>D) (D.cones unity))"
         using D.limits_are_sets_of_cones by simp
       from this obtain \<phi> where \<phi>: "bij_betw \<phi> (hom unity \<Pi>D) (D.cones unity)"
         by blast
       have \<phi>': "inv_into (hom unity \<Pi>D) \<phi> \<in> D.cones unity \<rightarrow> hom unity \<Pi>D \<and>
                 inj_on (inv_into (hom unity \<Pi>D) \<phi>) (D.cones unity)"
         using \<phi> bij_betw_inv_into bij_betw_imp_inj_on bij_betw_imp_funcset by blast
       let ?\<pi> = "img o (inv_into (hom unity \<Pi>D) \<phi>) o D.funToCone"
       have 1: "D.funToCone \<in> PiE' I (set o D.map) \<rightarrow> D.cones unity"
         using D.funToCone_mapsto extensional'_def [of I] by auto
       have 2: "inv_into (hom unity \<Pi>D) \<phi> \<in> D.cones unity \<rightarrow> hom unity \<Pi>D"
         using \<phi>' by auto
       have 3: "img \<in> hom unity \<Pi>D \<rightarrow> Univ"
         using img_point_in_Univ by blast
       have 4: "inj_on D.funToCone (PiE' I (set o D.map))"
       proof -
         have "D.I = I" by auto
         thus ?thesis
           using D.bij_funToCone bij_betw_imp_inj_on by auto
       qed
       have 5: "inj_on (inv_into (hom unity \<Pi>D) \<phi>) (D.cones unity)"
         using \<phi>' by auto
       have 6: "inj_on img (hom unity \<Pi>D)"
         using \<Pi>D bij_betw_points_and_set bij_betw_imp_inj_on [of img "hom unity \<Pi>D" "set \<Pi>D"]
         by simp
       have "?\<pi> \<in> PiE' I (set o D.map) \<rightarrow> Univ"
         using 1 2 3 by force
       moreover have "inj_on ?\<pi> (PiE' I (set o D.map))"
       proof -
         have 7: "\<And>A B C D F G H. F \<in> A \<rightarrow> B \<and> G \<in> B \<rightarrow> C \<and> H \<in> C \<rightarrow> D
                       \<and> inj_on F A \<and> inj_on G B \<and> inj_on H C
                     \<Longrightarrow> inj_on (H o G o F) A"
           by (simp add: Pi_iff inj_on_def)
         show ?thesis
           using 1 2 3 4 5 6 7 [of D.funToCone "PiE' I (set o D.map)" "D.cones unity"
                                   "inv_into (hom unity \<Pi>D) \<phi>" "hom unity \<Pi>D"
                                   img Univ]
           by fastforce
       qed
       moreover have "PiE' I (set o D.map) = PiE' I (\<lambda>x. Univ)"
       proof -
         have "\<And>i. i \<in> I \<Longrightarrow> (set o D.map) i = Univ"
-          using J.arr_char D.map_def set_mkIde by simp
+          using J.arr_char D.map_def by simp
         thus ?thesis by blast
       qed
       ultimately have "?\<pi> \<in> (PiE' I (\<lambda>x. Univ)) \<rightarrow> Univ \<and> inj_on ?\<pi> (PiE' I (\<lambda>x. Univ))"
         by auto
       thus "I \<noteq> UNIV \<and> admits_tupling I"
         using I admits_tupling_def by auto
       next
       assume ex_\<pi>: "I \<noteq> UNIV \<and> admits_tupling I"
       show "has_products I"
       proof (unfold has_products_def)
         from ex_\<pi> obtain \<pi>
         where \<pi>: "\<pi> \<in> (PiE' I (\<lambda>x. Univ)) \<rightarrow> Univ \<and> inj_on \<pi> (PiE' I (\<lambda>x. Univ))"
           using admits_tupling_def by metis
         text\<open>
           Given an @{term I}-indexed discrete diagram @{term D}, obtain the object @{term \<Pi>D}
           of @{term[source=true] S} corresponding to the set @{term "\<pi> ` PiE I D"} of all
           @{term "\<pi> d"} where \<open>d \<in> d \<in> J \<rightarrow>\<^sub>E Univ\<close> and @{term "d i \<in> D i"}
           for all @{term "i \<in> I"}.
           The elements of @{term \<Pi>D} are in bijective correspondence with the set of cones
           over @{term D}, hence @{term \<Pi>D} is a limit of @{term D}.
 \<close>
         have "\<And>J D. discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I
                  \<Longrightarrow> \<exists>\<Pi>D. has_as_product J D \<Pi>D"
         proof
           fix J :: "'i comp" and D
           assume D: "discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I"
           interpret J: category J
             using D discrete_diagram.axioms(1) by blast
           interpret D: discrete_diagram J S D
             using D by simp
-          interpret D: discrete_diagram_in_replete_set_category J S D ..
+          interpret D: discrete_diagram_in_set_category J S \<open>\<lambda>A. A \<subseteq> Univ\<close> D ..
           let ?\<Pi>D = "mkIde (\<pi> ` PiE' I (set o D))"
           have 0: "ide ?\<Pi>D"
           proof -
             have "set o D \<in> I \<rightarrow> Pow Univ"
-              using Pow_iff incl_in_def o_apply elem_set_implies_incl_in
-                    set_subset_Univ subsetI
-              by (metis (mono_tags, lifting) Pi_I')
+              using Pow_iff incl_in_def o_apply elem_set_implies_incl_in subsetI Pi_I'
+                    setp_set_ide
+              by (metis (mono_tags, lifting))
             hence "\<pi> ` PiE' I (set o D) \<subseteq> Univ"
               using \<pi> by blast
             thus ?thesis using \<pi> ide_mkIde by simp
           qed
           hence set_\<Pi>D: "\<pi> ` PiE' I (set o D) = set ?\<Pi>D"
             using 0 ide_in_hom arr_mkIde set_mkIde by auto
           text\<open>
             The elements of @{term \<Pi>D} are all values of the form @{term "\<pi> d"},
             where @{term d} satisfies @{term "d i \<in> set (D i)"} for all @{term "i \<in> I"}.
             Such @{term d} correspond bijectively to cones.
             Since @{term \<pi>} is injective, the values @{term "\<pi> d"} correspond bijectively to cones.
 \<close>
           let ?\<phi> = "mkPoint ?\<Pi>D o \<pi> o D.coneToFun"
           let ?\<phi>' = "D.funToCone o inv_into (PiE' I (set o D)) \<pi> o img"
           have 1: "\<pi> \<in> PiE' I (set o D) \<rightarrow> set ?\<Pi>D \<and> inj_on \<pi> (PiE' I (set o D))"
           proof -
             have "PiE' I (set o D) \<subseteq> PiE' I (\<lambda>x. Univ)"
-              by (metis PiE'_mono comp_apply elem_set_implies_incl_in incl_in_def
-                  set_subset_Univ subsetI)
+              using setp_set_ide elem_set_implies_incl_in elem_set_implies_set_eq_singleton
+                    incl_in_def PiE'_mono comp_apply subsetI
+              by (metis (no_types, lifting))
             thus ?thesis using \<pi> subset_inj_on set_\<Pi>D Pi_I' imageI by fastforce
           qed
           have 2: "inv_into (PiE' I (set o D)) \<pi> \<in> set ?\<Pi>D \<rightarrow> PiE' I (set o D)"
           proof
             fix y
             assume y: "y \<in> set ?\<Pi>D"
             have "y \<in> \<pi> ` (PiE' I (set o D))" using y set_\<Pi>D by auto
             thus "inv_into (PiE' I (set o D)) \<pi> y \<in> PiE' I (set o D)"
               using inv_into_into [of y \<pi> "PiE' I (set o D)"] by simp
           qed
           have 3: "\<And>x. x \<in> set ?\<Pi>D \<Longrightarrow> \<pi> (inv_into (PiE' I (set o D)) \<pi> x) = x"
             using set_\<Pi>D by (simp add: f_inv_into_f)
           have 4: "\<And>d. d \<in> PiE' I (set o D) \<Longrightarrow> inv_into (PiE' I (set o D)) \<pi> (\<pi> d) = d"
             using 1 by auto
           have 5: "D.I = I"
             using D by auto
           have "bij_betw ?\<phi> (D.cones unity) (hom unity ?\<Pi>D)"
           proof (intro bij_betwI)
             show "?\<phi> \<in> D.cones unity \<rightarrow> hom unity ?\<Pi>D"
             proof
               fix \<chi>
               assume \<chi>: "\<chi> \<in> D.cones unity"
               show "?\<phi> \<chi> \<in> hom unity ?\<Pi>D"
                 using \<chi> 0 1 5 D.coneToFun_mapsto mkPoint_in_hom [of ?\<Pi>D]
                 by (simp, blast)
             qed
             show "?\<phi>' \<in> hom unity ?\<Pi>D \<rightarrow> D.cones unity"
             proof
               fix x
               assume x: "x \<in> hom unity ?\<Pi>D"
               hence "img x \<in> set ?\<Pi>D"
                 using img_point_elem_set by blast
               hence "inv_into (PiE' I (set o D)) \<pi> (img x) \<in> Pi I (set \<circ> D) \<inter> extensional' I"
                 using 2 by blast
               thus "?\<phi>' x \<in> D.cones unity"
                 using 5 D.funToCone_mapsto by auto
             qed
             show "\<And>x. x \<in> hom unity ?\<Pi>D \<Longrightarrow> ?\<phi> (?\<phi>' x) = x"
             proof -
               fix x
               assume x: "x \<in> hom unity ?\<Pi>D"
               show "?\<phi> (?\<phi>' x) = x"
               proof -
                 have "D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) \<pi> (img x)))
                           = inv_into (PiE' I (set o D)) \<pi> (img x)"
                   using x 1 5 img_point_elem_set set_\<Pi>D D.coneToFun_funToCone by force
                 hence "\<pi> (D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) \<pi> (img x))))
                           = img x"
                   using x 3 img_point_elem_set set_\<Pi>D by force
                 thus ?thesis using x 0 mkPoint_img by auto
               qed
             qed
             show "\<And>\<chi>. \<chi> \<in> D.cones unity \<Longrightarrow> ?\<phi>' (?\<phi> \<chi>) = \<chi>"
             proof -
               fix \<chi>
               assume \<chi>: "\<chi> \<in> D.cones unity"
               show "?\<phi>' (?\<phi> \<chi>) = \<chi>"
               proof -
                 have "img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>))) = \<pi> (D.coneToFun \<chi>)"
                   using \<chi> 0 1 5 D.coneToFun_mapsto img_mkPoint(2) by blast
                 hence "inv_into (PiE' I (set o D)) \<pi> (img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>))))
                          = D.coneToFun \<chi>"
-                  using \<chi> D.coneToFun_mapsto 4 5 by (metis PiE)
+                  using \<chi> D.coneToFun_mapsto 4 5
+                  by (metis (no_types, lifting) PiE)
                 hence "D.funToCone (inv_into (PiE' I (set o D)) \<pi>
                                              (img (mkPoint ?\<Pi>D (\<pi> (D.coneToFun \<chi>)))))
                          = \<chi>"
                   using \<chi> D.funToCone_coneToFun by auto
                 thus ?thesis by auto
               qed
             qed
           qed
           hence "bij_betw (inv_into (D.cones unity) ?\<phi>) (hom unity ?\<Pi>D) (D.cones unity)"
             using bij_betw_inv_into by blast
           hence "\<exists>\<phi>. bij_betw \<phi> (hom unity ?\<Pi>D) (D.cones unity)" by blast
           hence "D.has_as_limit ?\<Pi>D"
             using \<open>ide ?\<Pi>D\<close> D.limits_are_sets_of_cones by simp
           from this obtain \<chi> where \<chi>: "limit_cone J S D ?\<Pi>D \<chi>" by blast
           interpret \<chi>: limit_cone J S D ?\<Pi>D \<chi> using \<chi> by auto
           interpret P: product_cone J S D ?\<Pi>D \<chi>
             using \<chi> D.product_coneI by blast
           have "product_cone J S D ?\<Pi>D \<chi>" ..
           thus "has_as_product J D ?\<Pi>D"
             using has_as_product_def by auto
         qed
         thus "I \<noteq> UNIV \<and>
               (\<forall>J D. discrete_diagram J S D \<and> Collect (partial_magma.arr J) = I
                   \<longrightarrow> (\<exists>\<Pi>D. has_as_product J D \<Pi>D))"
           using ex_\<pi> by blast
       qed
     qed
 
+  end
+
+  context replete_set_category
+  begin
+
     text\<open>
       Characterization of the completeness properties enjoyed by a set category:
       A set category @{term[source=true] S} has all limits at a type @{typ 'j},
       if and only if @{term[source=true] S} admits @{term I}-indexed tupling
       for all @{typ 'j}-sets @{term I} such that @{term "I \<noteq> UNIV"}.
 \<close>
 
     theorem has_limits_iff_admits_tupling:
     shows "has_limits (undefined :: 'j) \<longleftrightarrow> (\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I)"
     proof
       assume has_limits: "has_limits (undefined :: 'j)"
       show "\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I"
         using has_limits has_products_if_has_limits has_products_iff_admits_tupling by blast
       next
       assume admits_tupling: "\<forall>I :: 'j set. I \<noteq> UNIV \<longrightarrow> admits_tupling I"
       show "has_limits (undefined :: 'j)"
         using has_limits_def admits_tupling has_products_iff_admits_tupling
         by (metis category.axioms(1) category.ideD(1) has_limits_if_has_products
             iso_tuple_UNIV_I mem_Collect_eq partial_magma.not_arr_null)
     qed
 
   end
 
   section "Limits in Functor Categories"
 
   text\<open>
     In this section, we consider the special case of limits in functor categories,
     with the objective of showing that limits in a functor category \<open>[A, B]\<close>
     are given pointwise, and that \<open>[A, B]\<close> has all limits that @{term B} has.
 \<close>
 
   locale parametrized_diagram =
     J: category J +
     A: category A +
     B: category B +
     JxA: product_category J A +
     binary_functor J A B D
   for J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and A :: "'a comp"      (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"      (infixr "\<cdot>\<^sub>B" 55)
   and D :: "'j * 'a \<Rightarrow> 'b"
   begin
 
     (* Notation for A.in_hom and B.in_hom is being inherited, but from where? *)
     notation J.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J _\<guillemotright>")
     notation JxA.comp     (infixr "\<cdot>\<^sub>J\<^sub>x\<^sub>A" 55)
     notation JxA.in_hom   ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J\<^sub>x\<^sub>A _\<guillemotright>")
 
     text\<open>
       A choice of limit cone for each diagram \<open>D (-, a)\<close>, where @{term a}
       is an object of @{term[source=true] A}, extends to a functor \<open>L: A \<rightarrow> B\<close>,
       where the action of @{term L} on arrows of @{term[source=true] A} is determined by
       universality.
 \<close>
 
     abbreviation L
     where "L \<equiv> \<lambda>l \<chi>. \<lambda>a. if A.arr a then
                             limit_cone.induced_arrow J B (\<lambda>j. D (j, A.cod a))
                               (l (A.cod a)) (\<chi> (A.cod a))
                               (l (A.dom a)) (vertical_composite.map J B
                                                (\<chi> (A.dom a)) (\<lambda>j. D (j, a)))
                           else B.null"
 
     abbreviation P
     where "P \<equiv> \<lambda>l \<chi>. \<lambda>a f. \<guillemotleft>f : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright> \<and>
                            diagram.cones_map J B (\<lambda>j. D (j, A.cod a)) f (\<chi> (A.cod a)) =
                            vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a))"
 
     lemma L_arr:
     assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
     shows "\<And>a. A.arr a \<Longrightarrow> (\<exists>!f. P l \<chi> a f) \<and> P l \<chi> a (L l \<chi> a)"
     proof
       fix a
       assume a: "A.arr a"
       interpret \<chi>_dom_a: limit_cone J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>l (A.dom a)\<close> \<open>\<chi> (A.dom a)\<close>
         using a assms by auto
       interpret \<chi>_cod_a: limit_cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.cod a)\<close> \<open>\<chi> (A.cod a)\<close>
         using a assms by auto
       interpret Da: natural_transformation J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close>
                                                \<open>\<lambda>j. D (j, a)\<close>
         using a fixing_arr_gives_natural_transformation_2 by simp
       interpret Dao\<chi>_dom_a: vertical_composite J B
                               \<chi>_dom_a.A.map \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close>
                               \<open>\<chi> (A.dom a)\<close> \<open>\<lambda>j. D (j, a)\<close> ..
       interpret Dao\<chi>_dom_a: cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.dom a)\<close> Dao\<chi>_dom_a.map ..
       show "P l \<chi> a (L l \<chi> a)"
         using a Dao\<chi>_dom_a.cone_axioms \<chi>_cod_a.induced_arrowI [of Dao\<chi>_dom_a.map "l (A.dom a)"]
         by auto
       show "\<exists>!f. P l \<chi> a f"
         using \<chi>_cod_a.is_universal Dao\<chi>_dom_a.cone_axioms by blast
     qed
 
     lemma L_ide:
     assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
     shows "\<And>a. A.ide a \<Longrightarrow> L l \<chi> a = l a"
     proof -
       let ?L = "L l \<chi>"
       let ?P = "P l \<chi>"
       fix a
       assume a: "A.ide a"
       interpret \<chi>a: limit_cone J B \<open>\<lambda>j. D (j, a)\<close> \<open>l a\<close> \<open>\<chi> a\<close> using a assms by auto
       have Pa: "?P a = (\<lambda>f. f \<in> B.hom (l a) (l a) \<and>
                             diagram.cones_map J B (\<lambda>j. D (j, a)) f (\<chi> a) = \<chi> a)"
         using a vcomp_ide_dom \<chi>a.natural_transformation_axioms by simp
       have "?P a (?L a)" using assms a L_arr [of l \<chi> a] by fastforce
       moreover have "?P a (l a)"
       proof -
         have "?P a (l a) \<longleftrightarrow> l a \<in> B.hom (l a) (l a) \<and> \<chi>a.D.cones_map (l a) (\<chi> a) = \<chi> a"
           using Pa by meson
         thus ?thesis
           using a \<chi>a.ide_apex \<chi>a.cone_axioms \<chi>a.D.cones_map_ide [of "\<chi> a" "l a"] by force
       qed
       moreover have "\<exists>!f. ?P a f"
         using a Pa \<chi>a.is_universal \<chi>a.cone_axioms by force
       ultimately show "?L a = l a" by blast
     qed
 
     lemma chosen_limits_induce_functor:
     assumes "\<forall>a. A.ide a \<longrightarrow> limit_cone J B (\<lambda>j. D (j, a)) (l a) (\<chi> a)"
     shows "functor A B (L l \<chi>)"
     proof -
       let ?L = "L l \<chi>"
       let ?P = "\<lambda>a. \<lambda>f. \<guillemotleft>f : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright> \<and>
                         diagram.cones_map J B (\<lambda>j. D (j, A.cod a)) f (\<chi> (A.cod a))
                              = vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a))"
       interpret L: "functor" A B ?L
         apply unfold_locales
         using assms L_arr [of l] L_ide
             apply auto[4]
       proof -
         fix a' a
         assume 1: "A.arr (A a' a)"
         have a: "A.arr a" using 1 by auto
         have a': "\<guillemotleft>a' : A.cod a \<rightarrow>\<^sub>A A.cod a'\<guillemotright>" using 1 by auto
         have a'a: "A.seq a' a" using 1 by auto
         interpret \<chi>_dom_a: limit_cone J B \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>l (A.dom a)\<close> \<open>\<chi> (A.dom a)\<close>
           using a assms by auto
         interpret \<chi>_cod_a: limit_cone J B \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>l (A.cod a)\<close> \<open>\<chi> (A.cod a)\<close>
           using a'a assms by auto
         interpret \<chi>_dom_a'a: limit_cone J B \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.dom (a' \<cdot>\<^sub>A a))\<close>
                                             \<open>\<chi> (A.dom (a' \<cdot>\<^sub>A a))\<close>
           using a'a assms by auto
         interpret \<chi>_cod_a'a: limit_cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.cod (a' \<cdot>\<^sub>A a))\<close>
                                             \<open>\<chi> (A.cod (a' \<cdot>\<^sub>A a))\<close>
           using a'a assms by auto
         interpret Da: natural_transformation J B
                          \<open>\<lambda>j. D (j, A.dom a)\<close> \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>\<lambda>j. D (j, a)\<close>
           using a fixing_arr_gives_natural_transformation_2 by simp
         interpret Da': natural_transformation J B
                          \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>\<lambda>j. D (j, a')\<close>
           using a a'a fixing_arr_gives_natural_transformation_2 by fastforce
         interpret Da'o\<chi>_cod_a: vertical_composite J B
                                  \<chi>_cod_a.A.map \<open>\<lambda>j. D (j, A.cod a)\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
                                  \<open>\<chi> (A.cod a)\<close> \<open>\<lambda>j. D (j, a')\<close>..
         interpret Da'o\<chi>_cod_a: cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>l (A.cod a)\<close> Da'o\<chi>_cod_a.map
           ..
         interpret Da'a: natural_transformation J B
                           \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close> \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
                           \<open>\<lambda>j. D (j, a' \<cdot>\<^sub>A a)\<close>
           using a'a fixing_arr_gives_natural_transformation_2 [of "a' \<cdot>\<^sub>A a"] by auto
         interpret Da'ao\<chi>_dom_a'a:
             vertical_composite J B \<chi>_dom_a'a.A.map \<open>\<lambda>j. D (j, A.dom (a' \<cdot>\<^sub>A a))\<close>
                                    \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close> \<open>\<chi> (A.dom (a' \<cdot>\<^sub>A a))\<close>
                                    \<open>\<lambda>j. D (j, a' \<cdot>\<^sub>A a)\<close> ..
         interpret Da'ao\<chi>_dom_a'a: cone J B \<open>\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))\<close>
                                        \<open>l (A.dom (a' \<cdot>\<^sub>A a))\<close> Da'ao\<chi>_dom_a'a.map ..
         show "?L (a' \<cdot>\<^sub>A a) = ?L a' \<cdot>\<^sub>B ?L a"
         proof -
           have "?P (a' \<cdot>\<^sub>A a) (?L (a' \<cdot>\<^sub>A a))" using assms a'a L_arr [of l \<chi> "a' \<cdot>\<^sub>A a"] by fastforce
           moreover have "?P (a' \<cdot>\<^sub>A a) (?L a' \<cdot>\<^sub>B ?L a)"
           proof
             have La: "\<guillemotleft>?L a : l (A.dom a) \<rightarrow>\<^sub>B l (A.cod a)\<guillemotright>"
               using assms a L_arr by fast
             moreover have La': "\<guillemotleft>?L a' : l (A.cod a) \<rightarrow>\<^sub>B l (A.cod a')\<guillemotright>"
               using assms a a' L_arr [of l \<chi> a'] by auto
             ultimately have seq: "B.seq (?L a') (?L a)" by (elim B.in_homE, auto)
             thus La'_La: "\<guillemotleft>?L a' \<cdot>\<^sub>B ?L a : l (A.dom (a' \<cdot>\<^sub>A a)) \<rightarrow>\<^sub>B l (A.cod (a' \<cdot>\<^sub>A a))\<guillemotright>"
               using a a' 1 La La' by (intro B.comp_in_homI, auto)
             show "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a)))
                     = Da'ao\<chi>_dom_a'a.map"
             proof -
               have "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a)))
                        = (\<chi>_cod_a'a.D.cones_map (?L a) o \<chi>_cod_a'a.D.cones_map (?L a'))
                            (\<chi> (A.cod a'))"
               proof -
                 have "\<chi>_cod_a'a.D.cones_map (?L a' \<cdot>\<^sub>B ?L a) (\<chi> (A.cod (a' \<cdot>\<^sub>A a))) =
                       restrict (\<chi>_cod_a'a.D.cones_map (?L a) \<circ> \<chi>_cod_a'a.D.cones_map (?L a'))
                                (\<chi>_cod_a'a.D.cones (B.cod (?L a')))
                                (\<chi> (A.cod (a' \<cdot>\<^sub>A a)))"
                   using seq \<chi>_cod_a'a.cone_axioms \<chi>_cod_a'a.D.cones_map_comp [of "?L a'" "?L a"]
                   by argo
                 also have "... = (\<chi>_cod_a'a.D.cones_map (?L a) o \<chi>_cod_a'a.D.cones_map (?L a'))
                                  (\<chi> (A.cod a'))"
                 proof -
                   have "\<chi> (A.cod a') \<in> \<chi>_cod_a'a.D.cones (l (A.cod a'))"
                     using \<chi>_cod_a'a.cone_axioms a'a by simp
                   moreover have "B.cod (?L a') = l (A.cod a')"
                     using assms a' L_arr [of l] by auto
                   ultimately show ?thesis
                     using a' a'a by simp
                 qed
                 finally show ?thesis by blast
               qed
               also have "... = \<chi>_cod_a'a.D.cones_map (?L a)
                                    (\<chi>_cod_a'a.D.cones_map (?L a') (\<chi> (A.cod a')))"
                   by simp
               also have "... = \<chi>_cod_a'a.D.cones_map (?L a) Da'o\<chi>_cod_a.map"
               proof -
                 have "?P a' (?L a')" using assms a' L_arr [of l \<chi> a'] by fast
                 moreover have
                     "?P a' = (\<lambda>f. f \<in> B.hom (l (A.cod a)) (l (A.cod a')) \<and>
                                   \<chi>_cod_a'a.D.cones_map f (\<chi> (A.cod a')) = Da'o\<chi>_cod_a.map)"
                   using a'a by force
                 ultimately show ?thesis using a'a by force
               qed
               also have "... = vertical_composite.map J B
                                  (\<chi>_cod_a.D.cones_map (?L a) (\<chi> (A.cod a)))
                                  (\<lambda>j. D (j, a'))"
                 using assms \<chi>_cod_a.D.diagram_axioms \<chi>_cod_a'a.D.diagram_axioms
                       Da'.natural_transformation_axioms \<chi>_cod_a.cone_axioms La
                       cones_map_vcomp [of J B "\<lambda>j. D (j, A.cod a)" "\<lambda>j. D (j, A.cod (a' \<cdot>\<^sub>A a))"
                                           "\<lambda>j. D (j, a')" "l (A.cod a)" "\<chi> (A.cod a)"
                                           "?L a" "l (A.dom a)"]
                 by blast
               also have "... = vertical_composite.map J B
                                  (vertical_composite.map J B (\<chi> (A.dom a)) (\<lambda>j. D (j, a)))
                                  (\<lambda>j. D (j, a'))"
                 using assms a L_arr by presburger
               also have "... = vertical_composite.map J B (\<chi> (A.dom a))
                                  (vertical_composite.map J B (\<lambda>j. D (j, a)) (\<lambda>j. D (j, a')))"
                 using a'a Da.natural_transformation_axioms Da'.natural_transformation_axioms
                       \<chi>_dom_a.natural_transformation_axioms vcomp_assoc
                 by auto
               also have
                   "... = vertical_composite.map J B (\<chi> (A.dom (a' \<cdot>\<^sub>A a))) (\<lambda>j. D (j, a' \<cdot>\<^sub>A a))"
                 using a'a preserves_comp_2 by simp
               finally show ?thesis by auto
             qed
           qed
           moreover have "\<exists>!f. ?P (a' \<cdot>\<^sub>A a) f"
             using \<chi>_cod_a'a.is_universal
                     [of "l (A.dom (a' \<cdot>\<^sub>A a))"
                         "vertical_composite.map J B (\<chi> (A.dom (a' \<cdot>\<^sub>A a))) (\<lambda>j. D (j, a' \<cdot>\<^sub>A a))"]
                   Da'ao\<chi>_dom_a'a.cone_axioms
             by fast
           ultimately show ?thesis by blast
         qed
       qed
       show ?thesis ..
     qed
 
   end
 
   locale diagram_in_functor_category =
     A: category A +
     B: category B +
     A_B: functor_category A B +
     diagram J A_B.comp D
   for A :: "'a comp"      (infixr "\<cdot>\<^sub>A" 55)
   and B :: "'b comp"      (infixr "\<cdot>\<^sub>B" 55)
   and J :: "'j comp"      (infixr "\<cdot>\<^sub>J" 55)
   and D :: "'j \<Rightarrow> ('a, 'b) functor_category.arr"
   begin
 
     interpretation JxA: product_category J A ..
     interpretation A_BxA: product_category A_B.comp A ..
     interpretation E: evaluation_functor A B ..
     interpretation Curry: currying J A B ..
 
     notation JxA.comp     (infixr "\<cdot>\<^sub>J\<^sub>x\<^sub>A" 55)
     notation JxA.in_hom   ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>J\<^sub>x\<^sub>A _\<guillemotright>")
 
     text\<open>
       Evaluation of a functor or natural transformation from @{term[source=true] J}
       to \<open>[A, B]\<close> at an arrow @{term a} of @{term[source=true] A}.
 \<close>
 
     abbreviation at
     where "at a \<tau> \<equiv> \<lambda>j. Curry.uncurry \<tau> (j, a)"
 
     lemma at_simp:
     assumes "A.arr a" and "J.arr j" and "A_B.arr (\<tau> j)"
     shows "at a \<tau> j = A_B.Map (\<tau> j) a"
       using assms Curry.uncurry_def E.map_simp by simp
 
     lemma functor_at_ide_is_functor:
     assumes "functor J A_B.comp F" and "A.ide a"
     shows "functor J B (at a F)"
     proof -
       interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
         using assms(1) Curry.uncurry_preserves_functors by simp
       interpret uncurry_F: binary_functor J A B \<open>Curry.uncurry F\<close> ..
       show ?thesis using assms(2) uncurry_F.fixing_ide_gives_functor_2 by simp
     qed
 
     lemma functor_at_arr_is_transformation:
     assumes "functor J A_B.comp F" and "A.arr a"
     shows "natural_transformation J B (at (A.dom a) F) (at (A.cod a) F) (at a F)"
     proof -
       interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
         using assms(1) Curry.uncurry_preserves_functors by simp
       interpret uncurry_F: binary_functor J A B \<open>Curry.uncurry F\<close> ..
       show ?thesis
         using assms(2) uncurry_F.fixing_arr_gives_natural_transformation_2 by simp
     qed
 
     lemma transformation_at_ide_is_transformation:
     assumes "natural_transformation J A_B.comp F G \<tau>" and "A.ide a"
     shows "natural_transformation J B (at a F) (at a G) (at a \<tau>)"
     proof -
       interpret \<tau>: natural_transformation J A_B.comp F G \<tau> using assms(1) by auto
       interpret uncurry_F: "functor" JxA.comp B \<open>Curry.uncurry F\<close>
         using Curry.uncurry_preserves_functors \<tau>.F.functor_axioms by simp
       interpret uncurry_f: binary_functor J A B \<open>Curry.uncurry F\<close> ..
       interpret uncurry_G: "functor" JxA.comp B \<open>Curry.uncurry G\<close>
         using Curry.uncurry_preserves_functors \<tau>.G.functor_axioms by simp
       interpret uncurry_G: binary_functor J A B \<open>Curry.uncurry G\<close> ..
       interpret uncurry_\<tau>: natural_transformation
                              JxA.comp B \<open>Curry.uncurry F\<close> \<open>Curry.uncurry G\<close> \<open>Curry.uncurry \<tau>\<close>
         using Curry.uncurry_preserves_transformations \<tau>.natural_transformation_axioms
         by simp
       interpret uncurry_\<tau>: binary_functor_transformation J A B
                             \<open>Curry.uncurry F\<close> \<open>Curry.uncurry G\<close> \<open>Curry.uncurry \<tau>\<close> ..
       show ?thesis
         using assms(2) uncurry_\<tau>.fixing_ide_gives_natural_transformation_2 by simp
     qed
 
     lemma constant_at_ide_is_constant:
     assumes "cone x \<chi>" and a: "A.ide a"
     shows "at a (constant_functor.map J A_B.comp x) =
            constant_functor.map J B (A_B.Map x a)"
     proof -
       interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
       have x: "A_B.ide x" using \<chi>.ide_apex by auto
       interpret Fun_x: "functor" A B \<open>A_B.Map x\<close>
         using x A_B.ide_char by simp
       interpret Da: "functor" J B \<open>at a D\<close>
         using a functor_at_ide_is_functor functor_axioms by blast
       interpret Da: diagram J B \<open>at a D\<close> ..
       interpret Xa: constant_functor J B \<open>A_B.Map x a\<close>
         using a Fun_x.preserves_ide by unfold_locales simp
       show "at a \<chi>.A.map = Xa.map"
         using a x Curry.uncurry_def E.map_def Xa.is_extensional by auto
     qed
 
     lemma at_ide_is_diagram:
     assumes a: "A.ide a"
     shows "diagram J B (at a D)"
     proof -
       interpret Da: "functor" J B "at a D"
         using a functor_at_ide_is_functor functor_axioms by simp
       show ?thesis ..
     qed
 
     lemma cone_at_ide_is_cone:
     assumes "cone x \<chi>" and a: "A.ide a"
     shows "diagram.cone J B (at a D) (A_B.Map x a) (at a \<chi>)"
     proof -
       interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
       have x: "A_B.ide x" using \<chi>.ide_apex by auto
       interpret Fun_x: "functor" A B \<open>A_B.Map x\<close>
         using x A_B.ide_char by simp
       interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
       interpret Xa: constant_functor J B \<open>A_B.Map x a\<close>
         using a by (unfold_locales, simp)
       interpret \<chi>a: natural_transformation J B Xa.map \<open>at a D\<close> \<open>at a \<chi>\<close>
         using assms(1) x a transformation_at_ide_is_transformation \<chi>.natural_transformation_axioms
               constant_at_ide_is_constant
         by fastforce
       interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close> ..
       show cone_\<chi>a: "Da.cone (A_B.Map x a) (at a \<chi>)" ..
     qed
 
     lemma at_preserves_comp:
     assumes "A.seq a' a"
     shows "at (A a' a) D = vertical_composite.map J B (at a D) (at a' D)"
     proof -
       interpret Da: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at a D\<close>
         using assms functor_at_arr_is_transformation functor_axioms by blast
       interpret Da': natural_transformation J B \<open>at (A.cod a) D\<close> \<open>at (A.cod a') D\<close> \<open>at a' D\<close>
         using assms functor_at_arr_is_transformation [of D a'] functor_axioms by fastforce
       interpret Da'oDa: vertical_composite J B
                           \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at (A.cod a') D\<close>
                           \<open>at a D\<close> \<open>at a' D\<close> ..
       interpret Da'a: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a') D\<close>
                           \<open>at (a' \<cdot>\<^sub>A a) D\<close>
         using assms functor_at_arr_is_transformation [of D "a' \<cdot>\<^sub>A a"] functor_axioms by simp
       show "at (a' \<cdot>\<^sub>A a) D = Da'oDa.map"
       proof (intro NaturalTransformation.eqI)
         show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) Da'oDa.map" ..
         show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) (at (a' \<cdot>\<^sub>A a) D)" ..
         show "\<And>j. J.ide j \<Longrightarrow> at (a' \<cdot>\<^sub>A a) D j = Da'oDa.map j"
         proof -
           fix j
           assume j: "J.ide j"
           interpret Dj: "functor" A B \<open>A_B.Map (D j)\<close>
             using j preserves_ide A_B.ide_char by simp
           show "at (a' \<cdot>\<^sub>A a) D j = Da'oDa.map j"
             using assms j Dj.preserves_comp at_simp Da'oDa.map_simp_ide by auto
         qed
       qed
     qed
 
     lemma cones_map_pointwise:
     assumes "cone x \<chi>" and "cone x' \<chi>'"
     and f: "f \<in> A_B.hom x' x"
     shows "cones_map f \<chi> = \<chi>' \<longleftrightarrow>
              (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>')"
     proof
       interpret \<chi>: cone J A_B.comp D x \<chi> using assms(1) by auto
       interpret \<chi>': cone J A_B.comp D x' \<chi>' using assms(2) by auto
       have x: "A_B.ide x" using \<chi>.ide_apex by auto
       have x': "A_B.ide x'" using \<chi>'.ide_apex by auto
       interpret \<chi>f: cone J A_B.comp D x' \<open>cones_map f \<chi>\<close>
         using x' f assms(1) cones_map_mapsto by blast
       interpret Fun_x: "functor" A B \<open>A_B.Map x\<close> using x A_B.ide_char by simp
       interpret Fun_x': "functor" A B \<open>A_B.Map x'\<close> using x' A_B.ide_char by simp
       show "cones_map f \<chi> = \<chi>' \<Longrightarrow>
               (\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>')"
       proof -
         assume \<chi>': "cones_map f \<chi> = \<chi>'"
         have "\<And>a. A.ide a \<Longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
         proof -
           fix a
           assume a: "A.ide a"
           interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
           interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
             using a assms(1) cone_at_ide_is_cone by simp
           interpret \<chi>'a: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close> \<open>at a \<chi>'\<close>
             using a assms(2) cone_at_ide_is_cone by simp
           have 1: "\<guillemotleft>A_B.Map f a : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>"
             using f a A_B.arr_char A_B.Map_cod A_B.Map_dom mem_Collect_eq
                   natural_transformation.preserves_hom A.ide_in_hom
             by (metis (no_types, lifting) A_B.in_homE)
           interpret \<chi>fa: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close>
                            \<open>Da.cones_map (A_B.Map f a) (at a \<chi>)\<close>
             using 1 \<chi>a.cone_axioms Da.cones_map_mapsto by force
           show "Da.cones_map (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
           proof
             fix j
             have "\<not>J.arr j \<Longrightarrow> Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j"
               using \<chi>'a.is_extensional \<chi>fa.is_extensional [of j] by simp
             moreover have "J.arr j \<Longrightarrow> Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j"
               using a f 1 \<chi>.cone_axioms \<chi>a.cone_axioms at_simp
               apply simp
               apply (elim A_B.in_homE B.in_homE, auto)
               using \<chi>' \<chi>.A.map_simp A_B.Map_comp [of "\<chi> j" f a a] by auto
             ultimately show "Da.cones_map (A_B.Map f a) (at a \<chi>) j = at a \<chi>' j" by blast
           qed
         qed
         thus "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
           by simp
       qed
       show "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'
               \<Longrightarrow> cones_map f \<chi> = \<chi>'"
       proof -
         assume A:
             "\<forall>a. A.ide a \<longrightarrow> diagram.cones_map J B (at a D) (A_B.Map f a) (at a \<chi>) = at a \<chi>'"
         show "cones_map f \<chi> = \<chi>'"
         proof (intro NaturalTransformation.eqI)
           show "natural_transformation J A_B.comp \<chi>'.A.map D (cones_map f \<chi>)" ..
           show "natural_transformation J A_B.comp \<chi>'.A.map D \<chi>'" ..
           show "\<And>j. J.ide j \<Longrightarrow> cones_map f \<chi> j = \<chi>' j"
           proof (intro A_B.arr_eqI)
             fix j
             assume j: "J.ide j"
             show 1: "A_B.arr (cones_map f \<chi> j)"
               using j \<chi>f.preserves_reflects_arr by simp
             show "A_B.arr (\<chi>' j)" using j by auto
             have Dom_\<chi>f_j: "A_B.Dom (cones_map f \<chi> j) = A_B.Map x'"
               using x' j 1 A_B.Map_dom \<chi>'.A.map_simp \<chi>f.preserves_dom J.ide_in_hom
               by (metis (no_types, lifting) J.ideD(2) \<chi>f.preserves_reflects_arr)
             also have Dom_\<chi>'_j: "... = A_B.Dom (\<chi>' j)"
               using x' j A_B.Map_dom [of "\<chi>' j"] \<chi>'.preserves_hom \<chi>'.A.map_simp by simp
             finally show "A_B.Dom (cones_map f \<chi> j) = A_B.Dom (\<chi>' j)" by auto
             have Cod_\<chi>f_j: "A_B.Cod (cones_map f \<chi> j) = A_B.Map (D (J.cod j))"
               using j A_B.Map_cod A_B.cod_char J.ide_in_hom \<chi>f.preserves_hom
               by (metis (no_types, lifting) "1" J.ideD(1) \<chi>f.preserves_cod)
             also have Cod_\<chi>'_j: "... = A_B.Cod (\<chi>' j)"
               using j A_B.Map_cod [of "\<chi>' j"] \<chi>'.preserves_hom by simp
             finally show "A_B.Cod (cones_map f \<chi> j) = A_B.Cod (\<chi>' j)" by auto
             show "A_B.Map (cones_map f \<chi> j) = A_B.Map (\<chi>' j)"
             proof (intro NaturalTransformation.eqI)
               interpret \<chi>fj: natural_transformation A B \<open>A_B.Map x'\<close> \<open>A_B.Map (D (J.cod j))\<close>
                                                     \<open>A_B.Map (cones_map f \<chi> j)\<close>
                 using j \<chi>f.preserves_reflects_arr A_B.arr_char [of "cones_map f \<chi> j"]
                       Dom_\<chi>f_j Cod_\<chi>f_j
                 by simp
               show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
                                            (A_B.Map (cones_map f \<chi> j))" ..
               interpret \<chi>'j: natural_transformation A B \<open>A_B.Map x'\<close> \<open>A_B.Map (D (J.cod j))\<close>
                                                    \<open>A_B.Map (\<chi>' j)\<close>
                 using j A_B.arr_char [of "\<chi>' j"] Dom_\<chi>'_j Cod_\<chi>'_j by simp
               show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
                                            (A_B.Map (\<chi>' j))" ..
               show "\<And>a. A.ide a \<Longrightarrow> A_B.Map (cones_map f \<chi> j) a = A_B.Map (\<chi>' j) a"
               proof -
                 fix a
                 assume a: "A.ide a"
                 interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
                 have cone_\<chi>a: "Da.cone (A_B.Map x a) (at a \<chi>)"
                   using a assms(1) cone_at_ide_is_cone by simp
                 interpret \<chi>a: cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
                   using cone_\<chi>a by auto
                 interpret Fun_f: natural_transformation A B \<open>A_B.Dom f\<close> \<open>A_B.Cod f\<close>
                                    \<open>A_B.Map f\<close>
                   using f A_B.arr_char by fast
                 have fa: "A_B.Map f a \<in> B.hom (A_B.Map x' a) (A_B.Map x a)"
                   using a f Fun_f.preserves_hom A.ide_in_hom by auto
                 have "A_B.Map (cones_map f \<chi> j) a = Da.cones_map (A_B.Map f a) (at a \<chi>) j"
                 proof -
                   have "A_B.Map (cones_map f \<chi> j) a = A_B.Map (A_B.comp (\<chi> j) f) a"
                     using assms(1) f \<chi>.is_extensional by auto
                   also have "... = B (A_B.Map (\<chi> j) a) (A_B.Map f a)"
                     using f j a \<chi>.preserves_hom A.ide_in_hom J.ide_in_hom A_B.Map_comp
                           \<chi>.A.map_simp
                     by (metis (no_types, lifting) A.comp_ide_self A.ideD(1) A_B.seqI'
                         J.ideD(1) mem_Collect_eq)
                   also have "... = Da.cones_map (A_B.Map f a) (at a \<chi>) j"
                     using j a cone_\<chi>a fa Curry.uncurry_def E.map_simp by auto
                   finally show ?thesis by auto
                 qed
                 also have "... = at a \<chi>' j" using j a A by simp
                 also have "... = A_B.Map (\<chi>' j) a"
                   using j Curry.uncurry_def E.map_simp \<chi>'j.is_extensional by simp
                 finally show "A_B.Map (cones_map f \<chi> j) a = A_B.Map (\<chi>' j) a" by auto
               qed
             qed
           qed
         qed
       qed
     qed
        
     text\<open>
       If @{term \<chi>} is a cone with apex @{term a} over @{term D}, then @{term \<chi>}
       is a limit cone if, for each object @{term x} of @{term X}, the cone obtained
       by evaluating @{term \<chi>} at @{term x} is a limit cone with apex @{term "A_B.Map a x"}
       for the diagram in @{term C} obtained by evaluating @{term D} at @{term x}.
 \<close>
 
     lemma cone_is_limit_if_pointwise_limit:
     assumes cone_\<chi>: "cone x \<chi>"
     and "\<forall>a. A.ide a \<longrightarrow> diagram.limit_cone J B (at a D) (A_B.Map x a) (at a \<chi>)"
     shows "limit_cone x \<chi>"
     proof -
       interpret \<chi>: cone J A_B.comp D x \<chi> using assms by auto
       have x: "A_B.ide x" using \<chi>.ide_apex by auto
       show "limit_cone x \<chi>"
       proof
         fix x' \<chi>'
         assume cone_\<chi>': "cone x' \<chi>'"
         interpret \<chi>': cone J A_B.comp D x' \<chi>' using cone_\<chi>' by auto
         have x': "A_B.ide x'" using \<chi>'.ide_apex by auto
         text\<open>
           The universality of the limit cone \<open>at a \<chi>\<close> yields, for each object
           \<open>a\<close> of \<open>A\<close>, a unique arrow \<open>fa\<close> that transforms
           \<open>at a \<chi>\<close> to \<open>at a \<chi>'\<close>.
 \<close>
         have EU: "\<And>a. A.ide a \<Longrightarrow>
                         \<exists>!fa. fa \<in> B.hom (A_B.Map x' a) (A_B.Map x a) \<and>
                                    diagram.cones_map J B (at a D) fa (at a \<chi>) = at a \<chi>'"
         proof -
           fix a
           assume a: "A.ide a"
           interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
           interpret \<chi>a: limit_cone J B \<open>at a D\<close> \<open>A_B.Map x a\<close> \<open>at a \<chi>\<close>
             using assms(2) a by auto
           interpret \<chi>'a: cone J B \<open>at a D\<close> \<open>A_B.Map x' a\<close> \<open>at a \<chi>'\<close>
             using a cone_\<chi>' cone_at_ide_is_cone by auto
           have "Da.cone (A_B.Map x' a) (at a \<chi>')" ..
           thus "\<exists>!fa. fa \<in> B.hom (A_B.Map x' a) (A_B.Map x a) \<and>
                       Da.cones_map fa (at a \<chi>) = at a \<chi>'"
             using \<chi>a.is_universal by simp
         qed
         text\<open>
           Our objective is to show the existence of a unique arrow \<open>f\<close> that transforms
           \<open>\<chi>\<close> into \<open>\<chi>'\<close>.  We obtain \<open>f\<close> by bundling the arrows \<open>fa\<close>
           of \<open>C\<close> and proving that this yields a natural transformation from \<open>X\<close>
           to \<open>C\<close>, hence an arrow of \<open>[X, C]\<close>.
 \<close>
         show "\<exists>!f. \<guillemotleft>f : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f \<chi> = \<chi>'"
         proof
           let ?P = "\<lambda>a fa. \<guillemotleft>fa : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright> \<and>
                            diagram.cones_map J B (at a D) fa (at a \<chi>) = at a \<chi>'"
           have AaPa: "\<And>a. A.ide a \<Longrightarrow> ?P a (THE fa. ?P a fa)"
           proof -
             fix a
             assume a: "A.ide a"
             have "\<exists>!fa. ?P a fa" using a EU by simp
             thus "?P a (THE fa. ?P a fa)" using a theI' [of "?P a"] by fastforce
           qed
           have AaPa_in_hom:
               "\<And>a. A.ide a \<Longrightarrow> \<guillemotleft>THE fa. ?P a fa : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>"
             using AaPa by blast
           have AaPa_map:
                   "\<And>a. A.ide a \<Longrightarrow>
                        diagram.cones_map J B (at a D) (THE fa. ?P a fa) (at a \<chi>) = at a \<chi>'"
             using AaPa by blast
           let ?Fun_f = "\<lambda>a. if A.ide a then (THE fa. ?P a fa) else B.null"
           interpret Fun_x: "functor" A B \<open>\<lambda>a. A_B.Map x a\<close>
             using x A_B.ide_char by simp
           interpret Fun_x': "functor" A B \<open>\<lambda>a. A_B.Map x' a\<close>
             using x' A_B.ide_char by simp
           text\<open>
             The arrows \<open>Fun_f a\<close> are the components of a natural transformation.
             It is more work to verify the naturality than it seems like it ought to be.
 \<close>
           interpret \<phi>: transformation_by_components A B
                          \<open>\<lambda>a. A_B.Map x' a\<close> \<open>\<lambda>a. A_B.Map x a\<close> ?Fun_f
           proof
             fix a
             assume a: "A.ide a"
             show "\<guillemotleft>?Fun_f a : A_B.Map x' a \<rightarrow>\<^sub>B A_B.Map x a\<guillemotright>" using a AaPa by simp
             next
             fix a
             assume a: "A.arr a"
             text\<open>
 \newcommand\xdom{\mathop{\rm dom}}
 \newcommand\xcod{\mathop{\rm cod}}
 $$\xymatrix{
   {x_{\xdom a}} \drtwocell\omit{\omit(A)} \ar[d]_{\chi_{\xdom a}} \ar[r]^{x_a} & {x_{\xcod a}}
      \ar[d]^{\chi_{\xcod a}} \\
   {D_{\xdom a}} \ar[r]^{D_a} & {D_{\xcod a}} \\
   {x'_{\xdom a}} \urtwocell\omit{\omit(B)} \ar@/^5em/[uu]^{f_{\xdom a}}_{\hspace{1em}(C)} \ar[u]^{\chi'_{\xdom a}}
      \ar[r]_{x'_a} & {x'_{\xcod a}} \ar[u]_{x'_{\xcod a}} \ar@/_5em/[uu]_{f_{\xcod a}}
 }$$
 \<close>
             let ?x_dom_a = "A_B.Map x (A.dom a)"
             let ?x_cod_a = "A_B.Map x (A.cod a)"
             let ?x_a = "A_B.Map x a"
             have x_a: "\<guillemotleft>?x_a : ?x_dom_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright>"
               using a x A_B.ide_char by auto
             let ?x'_dom_a = "A_B.Map x' (A.dom a)"
             let ?x'_cod_a = "A_B.Map x' (A.cod a)"
             let ?x'_a = "A_B.Map x' a"
             have x'_a: "\<guillemotleft>?x'_a : ?x'_dom_a \<rightarrow>\<^sub>B ?x'_cod_a\<guillemotright>"
               using a x' A_B.ide_char by auto
             let ?f_dom_a = "?Fun_f (A.dom a)"
             let ?f_cod_a = "?Fun_f (A.cod a)"
             have f_dom_a: "\<guillemotleft>?f_dom_a : ?x'_dom_a \<rightarrow>\<^sub>B ?x_dom_a\<guillemotright>" using a AaPa by simp
             have f_cod_a: "\<guillemotleft>?f_cod_a : ?x'_cod_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright>" using a AaPa by simp
             interpret D_dom_a: diagram J B \<open>at (A.dom a) D\<close> using a at_ide_is_diagram by simp
             interpret D_cod_a: diagram J B \<open>at (A.cod a) D\<close> using a at_ide_is_diagram by simp
             interpret Da: natural_transformation J B \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close> \<open>at a D\<close>
               using a functor_axioms functor_at_arr_is_transformation by simp
             interpret \<chi>_dom_a: limit_cone J B \<open>at (A.dom a) D\<close> \<open>A_B.Map x (A.dom a)\<close>
                                               \<open>at (A.dom a) \<chi>\<close>
               using assms(2) a by auto
             interpret \<chi>_cod_a: limit_cone J B \<open>at (A.cod a) D\<close> \<open>A_B.Map x (A.cod a)\<close>
                                               \<open>at (A.cod a) \<chi>\<close>
               using assms(2) a by auto
             interpret \<chi>'_dom_a: cone J B \<open>at (A.dom a) D\<close> \<open>A_B.Map x' (A.dom a)\<close>
                                          \<open>at (A.dom a) \<chi>'\<close>
               using a cone_\<chi>' cone_at_ide_is_cone by auto
             interpret \<chi>'_cod_a: cone J B \<open>at (A.cod a) D\<close> \<open>A_B.Map x' (A.cod a)\<close>
                                          \<open>at (A.cod a) \<chi>'\<close>
               using a cone_\<chi>' cone_at_ide_is_cone by auto
             text\<open>
               Now construct cones with apexes \<open>x_dom_a\<close> and \<open>x'_dom_a\<close>
               over @{term "at (A.cod a) D"} by forming the vertical composites of
               @{term "at (A.dom a) \<chi>"} and @{term "at (A.cod a) \<chi>'"} with the natural
               transformation @{term "at a D"}.
 \<close>
             interpret Dao\<chi>_dom_a: vertical_composite J B
                                     \<chi>_dom_a.A.map \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close>
                                     \<open>at (A.dom a) \<chi>\<close> \<open>at a D\<close> ..
             interpret Dao\<chi>_dom_a: cone J B \<open>at (A.cod a) D\<close> ?x_dom_a Dao\<chi>_dom_a.map
               using \<chi>_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
               by metis
             interpret Dao\<chi>'_dom_a: vertical_composite J B
                                      \<chi>'_dom_a.A.map \<open>at (A.dom a) D\<close> \<open>at (A.cod a) D\<close>
                                      \<open>at (A.dom a) \<chi>'\<close> \<open>at a D\<close> ..
             interpret Dao\<chi>'_dom_a: cone J B \<open>at (A.cod a) D\<close> ?x'_dom_a Dao\<chi>'_dom_a.map
               using \<chi>'_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
               by metis
             have Dao\<chi>_dom_a: "D_cod_a.cone ?x_dom_a Dao\<chi>_dom_a.map" ..
             have Dao\<chi>'_dom_a: "D_cod_a.cone ?x'_dom_a Dao\<chi>'_dom_a.map" ..
             text\<open>
               These cones are also obtained by transforming the cones @{term "at (A.cod a) \<chi>"}
               and @{term "at (A.cod a) \<chi>'"} by \<open>x_a\<close> and \<open>x'_a\<close>, respectively.
 \<close>
             have A: "Dao\<chi>_dom_a.map = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>)"
             proof
               fix j
               have "\<not>J.arr j \<Longrightarrow> Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
                 using Dao\<chi>_dom_a.is_extensional \<chi>_cod_a.cone_axioms x_a by force
               moreover have
                    "J.arr j \<Longrightarrow> Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
               proof -
                 assume j: "J.arr j"
                 have "Dao\<chi>_dom_a.map j = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> (J.dom j)"
                   using j Dao\<chi>_dom_a.map_simp_2 by simp
                 also have "... = A_B.Map (D j) a \<cdot>\<^sub>B A_B.Map (\<chi> (J.dom j)) (A.dom a)"
                   using a j at_simp by simp
                 also have "... = A_B.Map (A_B.comp (D j) (\<chi> (J.dom j))) a"
                   using a j A_B.Map_comp
                   by (metis (no_types, lifting) A.comp_arr_dom \<chi>.is_natural_1
                       \<chi>.preserves_reflects_arr)
                 also have "... = A_B.Map (A_B.comp (\<chi> (J.cod j)) (\<chi>.A.map j)) a"
                   using a j \<chi>.naturality by simp
                 also have "... = A_B.Map (\<chi> (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Map x a"
                   using a j x A_B.Map_comp
                   by (metis (no_types, lifting) A.comp_cod_arr \<chi>.A.map_simp \<chi>.is_natural_2
                             \<chi>.preserves_reflects_arr)
                 also have "... = at (A.cod a) \<chi> (J.cod j) \<cdot>\<^sub>B A_B.Map x a"
                   using a j at_simp by simp
                 also have "... = at (A.cod a) \<chi> j \<cdot>\<^sub>B A_B.Map x a"
                   using a j \<chi>_cod_a.is_natural_2 \<chi>_cod_a.A.map_simp
                   by (metis J.arr_cod_iff_arr J.cod_cod)
                 also have "... = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
                   using a j x \<chi>_cod_a.cone_axioms preserves_cod by simp
                 finally show ?thesis by blast
               qed
               ultimately show "Dao\<chi>_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>) j"
                 by blast
             qed
             have B: "Dao\<chi>'_dom_a.map = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>')"
             proof
               fix j
               have "\<not>J.arr j \<Longrightarrow>
                       Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
                 using Dao\<chi>'_dom_a.is_extensional \<chi>'_cod_a.cone_axioms x'_a by force
               moreover have
                   "J.arr j \<Longrightarrow> Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
               proof -
                 assume j: "J.arr j"
                 have "Dao\<chi>'_dom_a.map j = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi>' (J.dom j)"
                   using j Dao\<chi>'_dom_a.map_simp_2 by simp
                 also have "... = A_B.Map (D j) a \<cdot>\<^sub>B A_B.Map (\<chi>' (J.dom j)) (A.dom a)"
                   using a j at_simp by simp
                 also have "... = A_B.Map (A_B.comp (D j) (\<chi>' (J.dom j))) a"
                   using a j A_B.Map_comp
                   by (metis (no_types, lifting) A.comp_arr_dom \<chi>'.is_natural_1
                       \<chi>'.preserves_reflects_arr)
                 also have "... = A_B.Map (A_B.comp (\<chi>' (J.cod j)) (\<chi>'.A.map j)) a"
                   using a j \<chi>'.naturality by simp
                 also have "... = A_B.Map (\<chi>' (J.cod j)) (A.cod a) \<cdot>\<^sub>B A_B.Map x' a"
                   using a j x' A_B.Map_comp
                   by (metis (no_types, lifting) A.comp_cod_arr \<chi>'.A.map_simp \<chi>'.is_natural_2
                             \<chi>'.preserves_reflects_arr)
                 also have "... = at (A.cod a) \<chi>' (J.cod j) \<cdot>\<^sub>B A_B.Map x' a"
                   using a j at_simp by simp
                 also have "... = at (A.cod a) \<chi>' j \<cdot>\<^sub>B A_B.Map x' a"
                   using a j \<chi>'_cod_a.is_natural_2 \<chi>'_cod_a.A.map_simp
                   by (metis J.arr_cod_iff_arr J.cod_cod)
                 also have "... = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
                   using a j x' \<chi>'_cod_a.cone_axioms preserves_cod by simp
                 finally show ?thesis by blast
               qed
               ultimately show
                   "Dao\<chi>'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) \<chi>') j"
                 by blast
             qed
             text\<open>
               Next, we show that \<open>f_dom_a\<close>, which is the unique arrow that transforms
               \<open>\<chi>_dom_a\<close> into \<open>\<chi>'_dom_a\<close>, is also the unique arrow that transforms
               \<open>Dao\<chi>_dom_a\<close> into \<open>Dao\<chi>'_dom_a\<close>.
 \<close>
             have C: "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map = Dao\<chi>'_dom_a.map"
             proof (intro NaturalTransformation.eqI)
               show "natural_transformation
                       J B \<chi>'_dom_a.A.map (at (A.cod a) D) Dao\<chi>'_dom_a.map" ..
               show "natural_transformation J B \<chi>'_dom_a.A.map (at (A.cod a) D)
                       (D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map)"
               proof -
                 interpret \<kappa>: cone J B \<open>at (A.cod a) D\<close> ?x'_dom_a
                                   \<open>D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map\<close>
                 proof -
                   have "\<And>b b' f. \<lbrakk> f \<in> B.hom b' b; D_cod_a.cone b Dao\<chi>_dom_a.map \<rbrakk>
                                      \<Longrightarrow> D_cod_a.cone b' (D_cod_a.cones_map f Dao\<chi>_dom_a.map)"
                     using D_cod_a.cones_map_mapsto by blast
                   moreover have "D_cod_a.cone ?x_dom_a Dao\<chi>_dom_a.map" ..
                   ultimately show "D_cod_a.cone ?x'_dom_a
                                      (D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map)"
                     using f_dom_a by simp
                 qed
                 show ?thesis ..
               qed
               show "\<And>j. J.ide j \<Longrightarrow>
                           D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j = Dao\<chi>'_dom_a.map j"
               proof -
                 fix j
                 assume j: "J.ide j"
                 have "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j =
                       Dao\<chi>_dom_a.map j \<cdot>\<^sub>B ?f_dom_a"
                   using j f_dom_a Dao\<chi>_dom_a.cone_axioms
                   by (elim B.in_homE, auto)
                 also have "... = (at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> j) \<cdot>\<^sub>B ?f_dom_a"
                   using j Dao\<chi>_dom_a.map_simp_ide by simp
                 also have "... = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi> j \<cdot>\<^sub>B ?f_dom_a"
                   using B.comp_assoc by simp
                 also have "... = at a D j \<cdot>\<^sub>B D_dom_a.cones_map ?f_dom_a (at (A.dom a) \<chi>) j"
                   using j \<chi>_dom_a.cone_axioms f_dom_a
                   by (elim B.in_homE, auto)
                 also have "... = at a D j \<cdot>\<^sub>B at (A.dom a) \<chi>' j"
                   using a AaPa A.ide_dom by presburger
                 also have "... = Dao\<chi>'_dom_a.map j"
                   using j Dao\<chi>'_dom_a.map_simp_ide by simp
                 finally show
                     "D_cod_a.cones_map ?f_dom_a Dao\<chi>_dom_a.map j = Dao\<chi>'_dom_a.map j"
                   by auto
               qed
             qed
             text\<open>
               Naturality amounts to showing that \<open>C f_cod_a x'_a = C x_a f_dom_a\<close>.
               To do this, we show that both arrows transform @{term "at (A.cod a) \<chi>"}
               into \<open>Dao\<chi>'_cod_a\<close>, thus they are equal by the universality of
               @{term "at (A.cod a) \<chi>"}.
 \<close>
             have "\<exists>!fa. \<guillemotleft>fa : ?x'_dom_a \<rightarrow>\<^sub>B ?x_cod_a\<guillemotright> \<and>
                         D_cod_a.cones_map fa (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
               using Dao\<chi>'_dom_a.cone_axioms a \<chi>_cod_a.is_universal [of ?x'_dom_a Dao\<chi>'_dom_a.map]
               by fast
             moreover have
                  "?f_cod_a \<cdot>\<^sub>B ?x'_a \<in> B.hom ?x'_dom_a ?x_cod_a \<and>
                   D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
             proof
               show "?f_cod_a \<cdot>\<^sub>B ?x'_a \<in> B.hom ?x'_dom_a ?x_cod_a"
                 using f_cod_a x'_a by blast
               show "D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
               proof -
                 have "D_cod_a.cones_map (?f_cod_a \<cdot>\<^sub>B ?x'_a) (at (A.cod a) \<chi>)
                          = restrict (D_cod_a.cones_map ?x'_a o D_cod_a.cones_map ?f_cod_a)
                                     (D_cod_a.cones (?x_cod_a))
                                     (at (A.cod a) \<chi>)"
                   using x'_a D_cod_a.cones_map_comp [of ?f_cod_a ?x'_a] f_cod_a
                   by (elim B.in_homE, auto)
                 also have "... = D_cod_a.cones_map ?x'_a
                                    (D_cod_a.cones_map ?f_cod_a (at (A.cod a) \<chi>))"
                   using \<chi>_cod_a.cone_axioms by simp
                 also have "... = Dao\<chi>'_dom_a.map"
                   using a B AaPa_map A.ide_cod by presburger
                 finally show ?thesis by auto
               qed
             qed
             moreover have
                  "?x_a \<cdot>\<^sub>B ?f_dom_a \<in> B.hom ?x'_dom_a ?x_cod_a \<and>
                   D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
             proof
               show "?x_a \<cdot>\<^sub>B ?f_dom_a \<in> B.hom ?x'_dom_a ?x_cod_a"
                 using f_dom_a x_a by blast
               show "D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>) = Dao\<chi>'_dom_a.map"
               proof -
                 have
                     "D_cod_a.cones (B.cod (A_B.Map x a)) = D_cod_a.cones (A_B.Map x (A.cod a))"
                   using a x by simp
                 moreover have "B.seq ?x_a ?f_dom_a"
                   using f_dom_a x_a by (elim B.in_homE, auto)
                 ultimately have
                      "D_cod_a.cones_map (?x_a \<cdot>\<^sub>B ?f_dom_a) (at (A.cod a) \<chi>)
                          = restrict (D_cod_a.cones_map ?f_dom_a o D_cod_a.cones_map ?x_a)
                                     (D_cod_a.cones (?x_cod_a))
                                     (at (A.cod a) \<chi>)"
                   using D_cod_a.cones_map_comp [of ?x_a ?f_dom_a] x_a by argo
                 also have "... = D_cod_a.cones_map ?f_dom_a
                                    (D_cod_a.cones_map ?x_a (at (A.cod a) \<chi>))"
                   using \<chi>_cod_a.cone_axioms by simp
                 also have "... = Dao\<chi>'_dom_a.map"
                   using A C a AaPa by argo
                 finally show ?thesis by blast
               qed
             qed
             ultimately show "?f_cod_a \<cdot>\<^sub>B ?x'_a = ?x_a \<cdot>\<^sub>B ?f_dom_a"
               using a \<chi>_cod_a.is_universal by blast
           qed
           text\<open>
             The arrow from @{term x'} to @{term x} in \<open>[A, B]\<close> determined by
             the natural transformation \<open>\<phi>\<close> transforms @{term \<chi>} into @{term \<chi>'}.
             Moreover, it is the unique such arrow, since the components of \<open>\<phi>\<close>
             are each determined by universality.
 \<close>
           let ?f = "A_B.MkArr (\<lambda>a. A_B.Map x' a) (\<lambda>a. A_B.Map x a) \<phi>.map"
           have f_in_hom: "?f \<in> A_B.hom x' x"
           proof -
             have arr_f: "A_B.arr ?f"
               using x' x A_B.arr_MkArr \<phi>.natural_transformation_axioms by simp
             moreover have "A_B.MkIde (\<lambda>a. A_B.Map x a) = x"
               using x A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
             moreover have "A_B.MkIde (\<lambda>a. A_B.Map x' a) = x'"
               using x' A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
             ultimately show ?thesis
               using A_B.dom_char A_B.cod_char by auto
           qed
           have Fun_f: "\<And>a. A.ide a \<Longrightarrow> A_B.Map ?f a = (THE fa. ?P a fa)"
             using f_in_hom \<phi>.map_simp_ide by fastforce
           have cones_map_f: "cones_map ?f \<chi> = \<chi>'"
             using AaPa Fun_f at_ide_is_diagram assms(2) x x' cone_\<chi> cone_\<chi>' f_in_hom Fun_f
                   cones_map_pointwise
             by presburger
           show "\<guillemotleft>?f : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map ?f \<chi> = \<chi>'" using f_in_hom cones_map_f by auto
           show "\<And>f'. \<guillemotleft>f' : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f' \<chi> = \<chi>' \<Longrightarrow> f' = ?f"
           proof -
             fix f'
             assume f': "\<guillemotleft>f' : x' \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] x\<guillemotright> \<and> cones_map f' \<chi> = \<chi>'"
             have 0: "\<And>a. A.ide a \<Longrightarrow>
                            diagram.cones_map J B (at a D) (A_B.Map f' a) (at a \<chi>) = at a \<chi>'"
               using f' cone_\<chi> cone_\<chi>' cones_map_pointwise by blast
             have "f' = A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f')"
               using f' A_B.MkArr_Map by auto
             also have "... = ?f"
             proof (intro A_B.MkArr_eqI)
               show "A_B.arr (A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f'))"
                 using f' calculation by blast
               show 1: "A_B.Dom f' = A_B.Map x'" using f' A_B.Map_dom by auto
               show 2: "A_B.Cod f' = A_B.Map x" using f' A_B.Map_cod by auto
               show "A_B.Map f' = \<phi>.map"
               proof (intro NaturalTransformation.eqI)
                 show "natural_transformation A B (A_B.Map x') (A_B.Map x) \<phi>.map" ..
                 show "natural_transformation A B (A_B.Map x') (A_B.Map x) (A_B.Map f')"
                   using f' 1 2 A_B.arr_char [of f'] by auto
                 show "\<And>a. A.ide a \<Longrightarrow> A_B.Map f' a = \<phi>.map a"
                 proof -
                   fix a
                   assume a: "A.ide a"
                   interpret Da: diagram J B \<open>at a D\<close> using a at_ide_is_diagram by auto
                   interpret Fun_f': natural_transformation A B \<open>A_B.Dom f'\<close> \<open>A_B.Cod f'\<close>
                                                            \<open>A_B.Map f'\<close>
                     using f' A_B.arr_char by fast
                   have "A_B.Map f' a \<in> B.hom (A_B.Map x' a) (A_B.Map x a)"
                     using a f' Fun_f'.preserves_hom A.ide_in_hom by auto
                   hence "?P a (A_B.Map f' a)" using a 0 [of a] by simp
                   moreover have "?P a (\<phi>.map a)"
                     using a \<phi>.map_simp_ide Fun_f AaPa by presburger
                   ultimately show "A_B.Map f' a = \<phi>.map a" using a EU by blast
                 qed
               qed
             qed
             finally show "f' = ?f" by auto
           qed
         qed
       qed
     qed
 
   end
 
   context functor_category
   begin
 
     text\<open>
       A functor category \<open>[A, B]\<close> has limits of shape @{term[source=true] J}
       whenever @{term B} has limits of shape @{term[source=true] J}.
 \<close>
 
     lemma has_limits_of_shape_if_target_does:
     assumes "category (J :: 'j comp)"
     and "B.has_limits_of_shape J"
     shows "has_limits_of_shape J"
     proof (unfold has_limits_of_shape_def)
       have "\<And>D. diagram J comp D \<Longrightarrow> (\<exists>x \<chi>. limit_cone J comp D x \<chi>)"
       proof -
         fix D
         assume D: "diagram J comp D"
         interpret J: category J using assms(1) by auto
         interpret JxA: product_category J A ..
         interpret D: diagram J comp D using D by auto
         interpret D: diagram_in_functor_category A B J D ..
         interpret Curry: currying J A B ..
         text\<open>
           Given diagram @{term D} in \<open>[A, B]\<close>, choose for each object \<open>a\<close>
           of \<open>A\<close> a limit cone \<open>(la, \<chi>a)\<close> for \<open>at a D\<close> in \<open>B\<close>.
 \<close>
         let ?l = "\<lambda>a. diagram.some_limit J B (D.at a D)"
         let ?\<chi> = "\<lambda>a. diagram.some_limit_cone J B (D.at a D)"
         have l\<chi>: "\<And>a. A.ide a \<Longrightarrow> diagram.limit_cone J B (D.at a D) (?l a) (?\<chi> a)"
           using B.has_limits_of_shape_def D.at_ide_is_diagram assms(2)
                 diagram.limit_cone_some_limit_cone
           by blast
         text\<open>
           The choice of limit cones induces a limit functor from \<open>A\<close> to \<open>B\<close>.
 \<close>
         interpret uncurry_D: diagram JxA.comp B "Curry.uncurry D"
         proof -
           interpret "functor" JxA.comp B \<open>Curry.uncurry D\<close>
             using D.functor_axioms Curry.uncurry_preserves_functors by simp
           interpret binary_functor J A B \<open>Curry.uncurry D\<close> ..
           show "diagram JxA.comp B (Curry.uncurry D)" ..
         qed
         interpret uncurry_D: parametrized_diagram J A B \<open>Curry.uncurry D\<close> ..
         let ?L = "uncurry_D.L ?l ?\<chi>"
         let ?P = "uncurry_D.P ?l ?\<chi>"
         interpret L: "functor" A B ?L
           using l\<chi> uncurry_D.chosen_limits_induce_functor [of ?l ?\<chi>] by simp
         have L_ide: "\<And>a. A.ide a \<Longrightarrow> ?L a = ?l a"
           using uncurry_D.L_ide [of ?l ?\<chi>] l\<chi> by blast
         have L_arr: "\<And>a. A.arr a \<Longrightarrow> (\<exists>!f. ?P a f) \<and> ?P a (?L a)"
           using uncurry_D.L_arr [of ?l ?\<chi>] l\<chi> by blast
         text\<open>
           The functor \<open>L\<close> extends to a functor \<open>L'\<close> from \<open>JxA\<close>
           to \<open>B\<close> that is constant on \<open>J\<close>.
 \<close>
         let ?L' = "\<lambda>ja. if JxA.arr ja then ?L (snd ja) else B.null"
         let ?P' = "\<lambda>ja. ?P (snd ja)"
         interpret L': "functor" JxA.comp B ?L'
           apply unfold_locales
           using L.preserves_arr L.preserves_dom L.preserves_cod
               apply auto[4]
           using L.preserves_comp JxA.comp_char by (elim JxA.seqE, auto)
         have "\<And>ja. JxA.arr ja \<Longrightarrow> (\<exists>!f. ?P' ja f) \<and> ?P' ja (?L' ja)"
         proof -
           fix ja
           assume ja: "JxA.arr ja"
           have "A.arr (snd ja)" using ja by blast
           thus "(\<exists>!f. ?P' ja f) \<and> ?P' ja (?L' ja)"
             using ja L_arr by presburger
         qed
         hence L'_arr: "\<And>ja. JxA.arr ja \<Longrightarrow> ?P' ja (?L' ja)" by blast
         have L'_ide: "\<And>ja. \<lbrakk> J.arr (fst ja); A.ide (snd ja) \<rbrakk> \<Longrightarrow> ?L' ja = ?l (snd ja)"
           using L_ide l\<chi> by force
         have L'_arr_map:
              "\<And>ja. JxA.arr ja \<Longrightarrow> uncurry_D.P ?l ?\<chi> (snd ja) (uncurry_D.L ?l ?\<chi> (snd ja))"
            using L'_arr by presburger
         text\<open>
           The map that takes an object \<open>(j, a)\<close> of \<open>JxA\<close> to the component
           \<open>\<chi> a j\<close> of the limit cone \<open>\<chi> a\<close> is a natural transformation
           from \<open>L\<close> to uncurry \<open>D\<close>.
 \<close>
         let ?\<chi>' = "\<lambda>ja. ?\<chi> (snd ja) (fst ja)"
         interpret \<chi>': transformation_by_components JxA.comp B ?L' \<open>Curry.uncurry D\<close> ?\<chi>'
         proof
           fix ja
           assume ja: "JxA.ide ja"
           let ?j = "fst ja"
           let ?a = "snd ja"
           interpret \<chi>a: limit_cone J B \<open>D.at ?a D\<close> \<open>?l ?a\<close> \<open>?\<chi> ?a\<close>
             using ja l\<chi> by blast
           show "\<guillemotleft>?\<chi>' ja : ?L' ja \<rightarrow>\<^sub>B Curry.uncurry D ja\<guillemotright>"
             using ja L'_ide [of ja] by force
           next
           fix ja
           assume ja: "JxA.arr ja"
           let ?j = "fst ja"
           let ?a = "snd ja"
           have j: "J.arr ?j" using ja by simp
           have a: "A.arr ?a" using ja by simp
           interpret D_dom_a: diagram J B \<open>D.at (A.dom ?a) D\<close>
             using a D.at_ide_is_diagram by auto
           interpret D_cod_a: diagram J B \<open>D.at (A.cod ?a) D\<close>
             using a D.at_ide_is_diagram by auto
           interpret Da: natural_transformation J B
                           \<open>D.at (A.dom ?a) D\<close> \<open>D.at (A.cod ?a) D\<close> \<open>D.at ?a D\<close>
             using a D.functor_axioms D.functor_at_arr_is_transformation by simp
           interpret \<chi>_dom_a: limit_cone J B \<open>D.at (A.dom ?a) D\<close> \<open>?l (A.dom ?a)\<close>
                                \<open>?\<chi> (A.dom ?a)\<close>
             using a l\<chi> by simp
           interpret \<chi>_cod_a: limit_cone J B \<open>D.at (A.cod ?a) D\<close> \<open>?l (A.cod ?a)\<close>
                                \<open>?\<chi> (A.cod ?a)\<close>
             using a l\<chi> by simp
           interpret Dao\<chi>_dom_a: vertical_composite J B
                                   \<chi>_dom_a.A.map \<open>D.at (A.dom ?a) D\<close> \<open>D.at (A.cod ?a) D\<close>
                                   \<open>?\<chi> (A.dom ?a)\<close> \<open>D.at ?a D\<close>
             ..
           interpret Dao\<chi>_dom_a: cone J B \<open>D.at (A.cod ?a) D\<close> \<open>?l (A.dom ?a)\<close> Dao\<chi>_dom_a.map ..
           show "?\<chi>' (JxA.cod ja) \<cdot>\<^sub>B ?L' ja = B (Curry.uncurry D ja) (?\<chi>' (JxA.dom ja))"
           proof -
             have "?\<chi>' (JxA.cod ja) \<cdot>\<^sub>B ?L' ja = ?\<chi> (A.cod ?a) (J.cod ?j) \<cdot>\<^sub>B ?L' ja"
               using ja by fastforce
             also have "... = D_cod_a.cones_map (?L' ja) (?\<chi> (A.cod ?a)) (J.cod ?j)"
               using ja L'_arr_map [of ja] \<chi>_cod_a.cone_axioms by auto
             also have "... = Dao\<chi>_dom_a.map (J.cod ?j)"
               using ja \<chi>_cod_a.induced_arrowI Dao\<chi>_dom_a.cone_axioms L'_arr by presburger
             also have "... = D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D_dom_a.some_limit_cone (J.cod ?j)"
               using ja Dao\<chi>_dom_a.map_simp_ide by fastforce
             also have "... = D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D.at (A.dom ?a) D ?j \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
               using ja \<chi>_dom_a.naturality \<chi>_dom_a.ide_apex apply simp
               by (metis B.comp_arr_ide \<chi>_dom_a.preserves_reflects_arr)
             also have "... = (D.at ?a D (J.cod ?j) \<cdot>\<^sub>B D.at (A.dom ?a) D ?j) \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
               using j ja B.comp_assoc by presburger
             also have "... = B (D.at ?a D ?j) (?\<chi>' (JxA.dom ja))"
               using a j ja Map_comp A.comp_arr_dom D.as_nat_trans.is_natural_2 by simp
            also have "... = Curry.uncurry D ja \<cdot>\<^sub>B ?\<chi>' (JxA.dom ja)"
              using Curry.uncurry_def by simp
            finally show ?thesis by auto
          qed
        qed
        text\<open>
          Since \<open>\<chi>'\<close> is constant on \<open>J\<close>, \<open>curry \<chi>'\<close> is a cone over \<open>D\<close>.
 \<close>
        interpret constL: constant_functor J comp \<open>MkIde ?L\<close>
          using L.as_nat_trans.natural_transformation_axioms MkArr_in_hom ide_in_hom
               L.functor_axioms
          by unfold_locales blast
        (* TODO: This seems a little too involved. *)
        have curry_L': "constL.map = Curry.curry ?L' ?L' ?L'"
        proof
          fix j
          have "\<not>J.arr j \<Longrightarrow> constL.map j = Curry.curry ?L' ?L' ?L' j"
            using Curry.curry_def constL.is_extensional by simp
          moreover have "J.arr j \<Longrightarrow> constL.map j = Curry.curry ?L' ?L' ?L' j"
            using Curry.curry_def constL.value_is_ide in_homE ide_in_hom by auto
          ultimately show "constL.map j = Curry.curry ?L' ?L' ?L' j" by blast
        qed
        hence uncurry_constL: "Curry.uncurry constL.map = ?L'"
          using L'.as_nat_trans.natural_transformation_axioms Curry.uncurry_curry by simp
        interpret curry_\<chi>': natural_transformation J comp constL.map D
                              \<open>Curry.curry ?L' (Curry.uncurry D) \<chi>'.map\<close>
        proof -
          have "Curry.curry (Curry.uncurry D) (Curry.uncurry D) (Curry.uncurry D) = D"
            using Curry.curry_uncurry D.functor_axioms D.as_nat_trans.natural_transformation_axioms
            by blast
          thus "natural_transformation J comp constL.map D
                  (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map)"
            using Curry.curry_preserves_transformations curry_L' \<chi>'.natural_transformation_axioms
            by force
        qed
        interpret curry_\<chi>': cone J comp D \<open>MkIde ?L\<close> \<open>Curry.curry ?L' (Curry.uncurry D) \<chi>'.map\<close>
          ..
        text\<open>
          The value of \<open>curry_\<chi>'\<close> at each object \<open>a\<close> of \<open>A\<close> is the
          limit cone \<open>\<chi> a\<close>, hence \<open>curry_\<chi>'\<close> is a limit cone.
 \<close>
        have 1: "\<And>a. A.ide a \<Longrightarrow> D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) = ?\<chi> a"
        proof -
          fix a
          assume a: "A.ide a"
          have "D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) =
                  (\<lambda>j. Curry.uncurry (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) (j, a))"
            using a by simp
          moreover have "... = (\<lambda>j. \<chi>'.map (j, a))"
            using a Curry.uncurry_curry \<chi>'.natural_transformation_axioms by simp
          moreover have "... = ?\<chi> a"
          proof (intro NaturalTransformation.eqI)
            interpret \<chi>a: limit_cone J B \<open>D.at a D\<close> \<open>?l a\<close> \<open>?\<chi> a\<close> using a l\<chi> by simp
            interpret \<chi>': binary_functor_transformation J A B ?L' \<open>Curry.uncurry D\<close> \<chi>'.map ..
            show "natural_transformation J B \<chi>a.A.map (D.at a D) (?\<chi> a)" ..
            show "natural_transformation J B \<chi>a.A.map (D.at a D) (\<lambda>j. \<chi>'.map (j, a))"
            proof -
              have "\<chi>a.A.map = (\<lambda>j. ?L' (j, a))"
                using a \<chi>a.A.map_def L'_ide by auto
              thus ?thesis
                using a \<chi>'.fixing_ide_gives_natural_transformation_2 by simp
            qed
            fix j
            assume j: "J.ide j"
            show "\<chi>'.map (j, a) = ?\<chi> a j"
              using a j \<chi>'.map_simp_ide by simp
          qed
          ultimately show "D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map) = ?\<chi> a" by simp
        qed
        hence 2: "\<And>a. A.ide a \<Longrightarrow> diagram.limit_cone J B (D.at a D) (?l a)
                                 (D.at a (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map))"
          using l\<chi> by simp
        hence "limit_cone J comp D (MkIde ?L) (Curry.curry ?L' (Curry.uncurry D) \<chi>'.map)"
          using 1 2 L.functor_axioms L_ide curry_\<chi>'.cone_axioms curry_L'
                D.cone_is_limit_if_pointwise_limit
          by simp
        thus "\<exists>x \<chi>. limit_cone J comp D x \<chi>" by blast
      qed
      thus "\<forall>D. diagram J comp D \<longrightarrow> (\<exists>x \<chi>. limit_cone J comp D x \<chi>)" by blast
     qed
 
     lemma has_limits_if_target_does:
     assumes "B.has_limits (undefined :: 'j)"
     shows "has_limits (undefined :: 'j)"
       using assms B.has_limits_def has_limits_def has_limits_of_shape_if_target_does by fast
 
   end
 
   section "The Yoneda Functor Preserves Limits"
 
   text\<open>
     In this section, we show that the Yoneda functor from \<open>C\<close> to \<open>[Cop, S]\<close>
     preserves limits.
 \<close>
 
   context yoneda_functor
   begin
 
     lemma preserves_limits:
     fixes J :: "'j comp"
     assumes "diagram J C D" and "diagram.has_as_limit J C D a"
     shows "diagram.has_as_limit J Cop_S.comp (map o D) (map a)"
     proof -
       text\<open>
         The basic idea of the proof is as follows:
         If \<open>\<chi>\<close> is a limit cone in \<open>C\<close>, then for every object \<open>a'\<close>
         of \<open>Cop\<close> the evaluation of \<open>Y o \<chi>\<close> at \<open>a'\<close> is a limit cone
         in \<open>S\<close>.  By the results on limits in functor categories,
         this implies that \<open>Y o \<chi>\<close> is a limit cone in \<open>[Cop, S]\<close>.
 \<close>
       interpret J: category J using assms(1) diagram_def by auto
       interpret D: diagram J C D using assms(1) by auto
       from assms(2) obtain \<chi> where \<chi>: "D.limit_cone a \<chi>" by blast
       interpret \<chi>: limit_cone J C D a \<chi> using \<chi> by auto
       have a: "C.ide a" using \<chi>.ide_apex by auto
       interpret YoD: diagram J Cop_S.comp \<open>map o D\<close>
         using D.diagram_axioms functor_axioms preserves_diagrams [of J D] by simp
       interpret YoD: diagram_in_functor_category Cop.comp S J \<open>map o D\<close> ..
       interpret Yo\<chi>: cone J Cop_S.comp \<open>map o D\<close> \<open>map a\<close> \<open>map o \<chi>\<close>
         using \<chi>.cone_axioms preserves_cones by blast
       have "\<And>a'. C.ide a' \<Longrightarrow>
                    limit_cone J S (YoD.at a' (map o D))
                                   (Cop_S.Map (map a) a') (YoD.at a' (map o \<chi>))"
       proof -
         fix a'
         assume a': "C.ide a'"
         interpret A': constant_functor J C a'
           using a' by (unfold_locales, auto)
         interpret YoD_a': diagram J S \<open>YoD.at a' (map o D)\<close>
           using a' YoD.at_ide_is_diagram by simp
         interpret Yo\<chi>_a': cone J S \<open>YoD.at a' (map o D)\<close>
                                    \<open>Cop_S.Map (map a) a'\<close> \<open>YoD.at a' (map o \<chi>)\<close>
           using a' YoD.cone_at_ide_is_cone Yo\<chi>.cone_axioms by fastforce
         have eval_at_ide: "\<And>j. J.ide j \<Longrightarrow> YoD.at a' (map \<circ> D) j = Hom.map (a', D j)"
         proof -
           fix j
           assume j: "J.ide j"
           have "YoD.at a' (map \<circ> D) j = Cop_S.Map (map (D j)) a'"
             using a' j YoD.at_simp YoD.preserves_arr [of j] by auto
           also have "... = Y (D j) a'" using Y_def by simp
           also have "... = Hom.map (a', D j)" using a' j D.preserves_arr by simp
           finally show "YoD.at a' (map \<circ> D) j = Hom.map (a', D j)" by auto
         qed
         have eval_at_arr: "\<And>j. J.arr j \<Longrightarrow> YoD.at a' (map \<circ> \<chi>) j = Hom.map (a', \<chi> j)"
         proof -
           fix j
           assume j: "J.arr j"
           have "YoD.at a' (map \<circ> \<chi>) j = Cop_S.Map ((map o \<chi>) j) a'"
             using a' j YoD.at_simp [of a' j "map o \<chi>"] preserves_arr by fastforce
           also have "... = Y (\<chi> j) a'" using Y_def by simp
             also have "... = Hom.map (a', \<chi> j)" using a' j by simp
           finally show "YoD.at a' (map \<circ> \<chi>) j = Hom.map (a', \<chi> j)" by auto
         qed
         have Fun_map_a_a': "Cop_S.Map (map a) a' = Hom.map (a', a)"
           using a a' map_simp preserves_arr [of a] by simp
         show "limit_cone J S (YoD.at a' (map o D))
                              (Cop_S.Map (map a) a') (YoD.at a' (map o \<chi>))"
         proof
           fix x \<sigma>
           assume \<sigma>: "YoD_a'.cone x \<sigma>"
           interpret \<sigma>: cone J S \<open>YoD.at a' (map o D)\<close> x \<sigma> using \<sigma> by auto
           have x: "S.ide x" using \<sigma>.ide_apex by simp
           text\<open>
             For each object \<open>j\<close> of \<open>J\<close>, the component \<open>\<sigma> j\<close>
             is an arrow in \<open>S.hom x (Hom.map (a', D j))\<close>.
             Each element \<open>e \<in> S.set x\<close> therefore determines an arrow
             \<open>\<psi> (a', D j) (S.Fun (\<sigma> j) e) \<in> C.hom a' (D j)\<close>.
             These arrows are the components of a cone \<open>\<kappa> e\<close> over @{term D}
             with apex @{term a'}.
 \<close>
           have \<sigma>j: "\<And>j. J.ide j \<Longrightarrow> \<guillemotleft>\<sigma> j : x \<rightarrow>\<^sub>S Hom.map (a', D j)\<guillemotright>"
             using eval_at_ide \<sigma>.preserves_hom J.ide_in_hom by force
           have \<kappa>: "\<And>e. e \<in> S.set x \<Longrightarrow>
                         transformation_by_components
                           J C A'.map D (\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
           proof -
             fix e
             assume e: "e \<in> S.set x"
             show "transformation_by_components J C A'.map D (\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
             proof
               fix j
               assume j: "J.ide j"
               show "\<guillemotleft>\<psi> (a', D j) (S.Fun (\<sigma> j) e) : A'.map j \<rightarrow> D j\<guillemotright>"
                 using e j S.Fun_mapsto [of "\<sigma> j"] A'.preserves_ide Hom.set_map eval_at_ide
                       Hom.\<psi>_mapsto [of "A'.map j" "D j"]
                 by force
               next
               fix j
               assume j: "J.arr j"
               show "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> A'.map j =
                     D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)"
               proof -
                 have "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> A'.map j =
                       \<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<cdot> a'"
                   using A'.map_simp j by simp
                 also have "... = \<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e)"
                 proof -
                   have "\<psi> (a', D (J.cod j)) (S.Fun (\<sigma> (J.cod j)) e) \<in> C.hom a' (D (J.cod j))"
                     using a' e j Hom.\<psi>_mapsto [of "A'.map j" "D (J.cod j)"] A'.map_simp
                           S.Fun_mapsto [of "\<sigma> (J.cod j)"] Hom.set_map eval_at_ide
                     by auto
                   thus ?thesis
                     using C.comp_arr_dom by fastforce
                 qed
                 also have "... = \<psi> (a', D (J.cod j)) (S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e))"
                 proof -
                   have "S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) =
                         (S.Fun (Y (D j) a') o S.Fun (\<sigma> (J.dom j))) e"
                     by simp
                   also have "... = S.Fun (Y (D j) a' \<cdot>\<^sub>S \<sigma> (J.dom j)) e"
                     using a' e j Y_arr_ide(1) S.in_homE \<sigma>j eval_at_ide S.Fun_comp by force
                   also have "... = S.Fun (\<sigma> (J.cod j)) e"
                     using a' j x \<sigma>.is_natural_2 \<sigma>.A.map_simp S.comp_arr_dom J.arr_cod_iff_arr
                           J.cod_cod YoD.preserves_arr \<sigma>.is_natural_1 YoD.at_simp
                     by auto
                   finally have
                       "S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) = S.Fun (\<sigma> (J.cod j)) e"
                     by auto
                   thus ?thesis by simp
                 qed
                 also have "... = D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)"
                 proof -
                   have "S.Fun (Y (D j) a') (S.Fun (\<sigma> (J.dom j)) e) =
                          \<phi> (a', D (J.cod j)) (D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e))"
                   proof -
                     have "S.Fun (\<sigma> (J.dom j)) e \<in> Hom.set (a', D (J.dom j))"
                       using a' e j \<sigma>j S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map
                             YoD.at_simp eval_at_ide
                       by auto
                     moreover have "C.arr (\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)) \<and>
                                    C.dom (\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)) = a'"
                       using a' e j \<sigma>j S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map eval_at_ide
                             Hom.\<psi>_mapsto [of a' "D (J.dom j)"]
                       by auto
                     ultimately show ?thesis
                       using a' e j Hom.Fun_map C.comp_arr_dom by force
                   qed
                   moreover have "D j \<cdot> \<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e)
                                    \<in> C.hom a' (D (J.cod j))"
                   proof -
                     have "\<psi> (a', D (J.dom j)) (S.Fun (\<sigma> (J.dom j)) e) \<in> C.hom a' (D (J.dom j))"
                       using a' e j Hom.\<psi>_mapsto [of a' "D (J.dom j)"] eval_at_ide
                             S.Fun_mapsto [of "\<sigma> (J.dom j)"] Hom.set_map
                       by auto
                     thus ?thesis using j D.preserves_hom by blast
                   qed
                   ultimately show ?thesis using a' j Hom.\<psi>_\<phi> by simp
                 qed
                 finally show ?thesis by auto
               qed
             qed
           qed
           let ?\<kappa> = "\<lambda>e. transformation_by_components.map J C A'.map
                           (\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e))"
           have cone_\<kappa>e: "\<And>e. e \<in> S.set x \<Longrightarrow> D.cone a' (?\<kappa> e)"
           proof -
             fix e
             assume e: "e \<in> S.set x"
             interpret \<kappa>e: transformation_by_components J C A'.map D
                             \<open>\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)\<close>
               using e \<kappa> by blast
             show "D.cone a' (?\<kappa> e)" ..
           qed
           text\<open>
             Since \<open>\<kappa> e\<close> is a cone for each element \<open>e\<close> of \<open>S.set x\<close>,
             by the universal property of the limit cone \<open>\<chi>\<close> there is a unique arrow
             \<open>fe \<in> C.hom a' a\<close> that transforms \<open>\<chi>\<close> to \<open>\<kappa> e\<close>.
 \<close>
           have ex_fe: "\<And>e. e \<in> S.set x \<Longrightarrow> \<exists>!fe. \<guillemotleft>fe : a' \<rightarrow> a\<guillemotright> \<and> D.cones_map fe \<chi> = ?\<kappa> e"
             using cone_\<kappa>e \<chi>.is_universal by simp
           text\<open>
             The map taking \<open>e \<in> S.set x\<close> to \<open>fe \<in> C.hom a' a\<close>
             determines an arrow \<open>f \<in> S.hom x (Hom (a', a))\<close> that
             transforms the cone obtained by evaluating \<open>Y o \<chi>\<close> at \<open>a'\<close>
             to the cone \<open>\<sigma>\<close>.
 \<close>
           let ?f = "S.mkArr (S.set x) (Hom.set (a', a))
                             (\<lambda>e. \<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)))"
           have 0: "(\<lambda>e. \<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e))) \<in> S.set x \<rightarrow> Hom.set (a', a)"
           proof
             fix e
             assume e: "e \<in> S.set x"
             interpret \<kappa>e: cone J C D a' \<open>?\<kappa> e\<close> using e cone_\<kappa>e by simp
             have "\<chi>.induced_arrow a' (?\<kappa> e) \<in> C.hom a' a"
               using a a' e ex_fe \<chi>.induced_arrowI \<kappa>e.cone_axioms by simp
             thus "\<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)) \<in> Hom.set (a', a)"
               using a a' Hom.\<phi>_mapsto by auto
           qed
           have f: "\<guillemotleft>?f : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright>"
           proof -
             have "(\<lambda>e. \<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e))) \<in> S.set x \<rightarrow> Hom.set (a', a)"
             proof
               fix e
               assume e: "e \<in> S.set x"
               interpret \<kappa>e: cone J C D a' \<open>?\<kappa> e\<close> using e cone_\<kappa>e by simp
               have "\<chi>.induced_arrow a' (?\<kappa> e) \<in> C.hom a' a"
                 using a a' e ex_fe \<chi>.induced_arrowI \<kappa>e.cone_axioms by simp
               thus "\<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)) \<in> Hom.set (a', a)"
                 using a a' Hom.\<phi>_mapsto by auto
             qed
-            thus ?thesis
+            moreover have "setp (Hom.set (a', a))"
+              using a a' Hom.small_homs
+              by (metis Fun_map_a_a' Hom.map_ide S.arr_mkIde S.ideD(1) Yo\<chi>_a'.ide_apex)
+            ultimately show ?thesis
               using a a' x \<sigma>.ide_apex S.mkArr_in_hom [of "S.set x" "Hom.set (a', a)"]
                     Hom.set_subset_Univ S.mkIde_set
               by simp
           qed
           have "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) = \<sigma>"
           proof (intro NaturalTransformation.eqI)
             show "natural_transformation J S \<sigma>.A.map (YoD.at a' (map o D)) \<sigma>"
               using \<sigma>.natural_transformation_axioms by auto
             have 1: "S.cod ?f = Cop_S.Map (map a) a'"
               using f Fun_map_a_a' by force
             interpret YoD_a'of: cone J S \<open>YoD.at a' (map o D)\<close> x
                                      \<open>YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>))\<close>
             proof -
               have "YoD_a'.cone (S.cod ?f) (YoD.at a' (map o \<chi>))"
                 using a a' f Yo\<chi>_a'.cone_axioms preserves_arr [of a] by auto
               hence "YoD_a'.cone (S.dom ?f) (YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))"
                 using f YoD_a'.cones_map_mapsto S.arrI by blast
               thus "cone J S (YoD.at a' (map o D)) x
                                         (YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))"
                 using f by auto
             qed
             show "natural_transformation J S \<sigma>.A.map (YoD.at a' (map o D))
                                          (YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)))" ..
             fix j
             assume j: "J.ide j"
             have "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j = YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f"
               using f j Fun_map_a_a' Yo\<chi>_a'.cone_axioms by fastforce
             also have "... = \<sigma> j"
             proof (intro S.arr_eqI)
               show "S.par (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) (\<sigma> j)"
                 using 1 f j x YoD_a'.preserves_hom by fastforce
               show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) = S.Fun (\<sigma> j)"
               proof
                 fix e
                 have "e \<notin> S.set x \<Longrightarrow> S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
                   using 1 f j x S.Fun_mapsto [of "\<sigma> j"] \<sigma>.A.map_simp
                         extensional_arb [of "S.Fun (\<sigma> j)"]
                   by auto
                 moreover have "e \<in> S.set x \<Longrightarrow>
                                   S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
                 proof -
                   assume e: "e \<in> S.set x"
                   interpret \<kappa>e: transformation_by_components J C A'.map D
                                   \<open>\<lambda>j. \<psi> (a', D j) (S.Fun (\<sigma> j) e)\<close>
                     using e \<kappa> by blast
                   interpret \<kappa>e: cone J C D a' \<open>?\<kappa> e\<close> using e cone_\<kappa>e by simp
                   have induced_arrow: "\<chi>.induced_arrow a' (?\<kappa> e) \<in> C.hom a' a"
                     using a a' e ex_fe \<chi>.induced_arrowI \<kappa>e.cone_axioms by simp
                   have "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e =
                           restrict (S.Fun (YoD.at a' (map o \<chi>) j) o S.Fun ?f) (S.set x) e"
                     using 1 e f j S.Fun_comp YoD_a'.preserves_hom by force
                   also have "... = (\<phi> (a', D j) o C (\<chi> j) o \<psi> (a', a)) (S.Fun ?f e)"
                     using j a' f e Hom.map_simp_2 S.Fun_mkArr Hom.preserves_arr [of "(a', \<chi> j)"]
-                          eval_at_arr S.arr_mkArr
+                          eval_at_arr
                     by (elim S.in_homE, auto)
                   also have "... = (\<phi> (a', D j) o C (\<chi> j) o \<psi> (a', a))
                                      (\<phi> (a', a) (\<chi>.induced_arrow a' (?\<kappa> e)))"
                     using e f S.Fun_mkArr by fastforce
                   also have "... = \<phi> (a', D j) (D.cones_map (\<chi>.induced_arrow a' (?\<kappa> e)) \<chi> j)"
                       using a a' e j 0 Hom.\<psi>_\<phi> induced_arrow \<chi>.cone_axioms by auto
                   also have "... = \<phi> (a', D j) (?\<kappa> e j)"
                     using \<chi>.induced_arrowI \<kappa>e.cone_axioms by fastforce
                   also have "... = \<phi> (a', D j) (\<psi> (a', D j) (S.Fun (\<sigma> j) e))"
                     using j \<kappa>e.map_def [of j] by simp
                   also have "... = S.Fun (\<sigma> j) e"
                   proof -
                     have "S.Fun (\<sigma> j) e \<in> Hom.set (a', D j)"
                       using a' e j S.Fun_mapsto [of "\<sigma> j"] eval_at_ide Hom.set_map by auto
                     thus ?thesis
                       using a' j Hom.\<phi>_\<psi> C.ide_in_hom J.ide_in_hom by blast
                   qed
                   finally show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
                     by auto
                 qed
                 ultimately show "S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e = S.Fun (\<sigma> j) e"
                   by auto
               qed
             qed
             finally show "YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j = \<sigma> j" by auto
           qed
           hence ff: "?f \<in> S.hom x (Hom.map (a', a)) \<and>
                      YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) = \<sigma>"
             using f by auto
           text\<open>
             Any other arrow \<open>f' \<in> S.hom x (Hom.map (a', a))\<close> that
             transforms the cone obtained by evaluating \<open>Y o \<chi>\<close> at @{term a'}
             to the cone @{term \<sigma>}, must equal \<open>f\<close>, showing that \<open>f\<close>
             is unique.
 \<close>
           moreover have "\<And>f'. \<guillemotleft>f' : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
                               YoD_a'.cones_map f' (YoD.at a' (map o \<chi>)) = \<sigma>
                                 \<Longrightarrow> f' = ?f"
           proof -
             fix f'
             assume f': "\<guillemotleft>f' : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
                         YoD_a'.cones_map f' (YoD.at a' (map o \<chi>)) = \<sigma>"
             show "f' = ?f"
             proof (intro S.arr_eqI)
               show par: "S.par f' ?f" using f f' by (elim S.in_homE, auto)
               show "S.Fun f' = S.Fun ?f"
               proof
                 fix e
                 have "e \<notin> S.set x \<Longrightarrow> S.Fun f' e = S.Fun ?f e"
                   using f f' S.Fun_in_terms_of_comp by fastforce
                 moreover have "e \<in> S.set x \<Longrightarrow> S.Fun f' e = S.Fun ?f e"
                 proof -
                   assume e: "e \<in> S.set x"
                   have fe: "S.Fun ?f e \<in> Hom.set (a', a)"
-                    using e f S.arr_mkArr par by auto
+                    using e f par by auto
                   have f'e: "S.Fun f' e \<in> Hom.set (a', a)"
                     using a a' e f' S.Fun_mapsto Hom.set_map by fastforce
                   have 1: "\<guillemotleft>\<psi> (a', a) (S.Fun f' e) : a' \<rightarrow> a\<guillemotright>"
                     using a a' e f' f'e S.Fun_mapsto Hom.\<psi>_mapsto Hom.set_map by blast
                   have 2: "\<guillemotleft>\<psi> (a', a) (S.Fun ?f e) : a' \<rightarrow> a\<guillemotright>"
                     using a a' e f' fe S.Fun_mapsto Hom.\<psi>_mapsto Hom.set_map by blast
                   interpret \<chi>ofe: cone J C D a' \<open>D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>\<close>
                   proof -
                     have "D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<in> D.cones a \<rightarrow> D.cones a'"
                       using 2 D.cones_map_mapsto [of "\<psi> (a', a) (S.Fun ?f e)"]
                       by (elim C.in_homE, auto)
                     thus "cone J C D a' (D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>)"
                       using \<chi>.cone_axioms by blast
                   qed
                   have A: "\<And>h j. h \<in> C.hom a' a \<Longrightarrow> J.arr j \<Longrightarrow>
                                    S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
                                      = \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
                   proof -
                     fix h j
                     assume j: "J.arr j"
                     assume h: "h \<in> C.hom a' a"
                     have "S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
                               = (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a)) (\<phi> (a', a) h)"
                     proof -
                       have "S.Fun (YoD.at a' (map o \<chi>) j)
                               = restrict (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a))
                                          (Hom.set (a', a))"
                       proof -
                         have "S.Fun (YoD.at a' (map o \<chi>) j) = S.Fun (Y (\<chi> j) a')"
                           using a' j YoD.at_simp Y_def Yo\<chi>.preserves_reflects_arr [of j]
                           by simp
                         also have "... = restrict (\<phi> (a', D (J.cod j)) \<circ> C (\<chi> j) \<circ> \<psi> (a', a))
                                                   (Hom.set (a', a))"
                           using a' j \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
                                 Y_arr_ide [of a' "\<chi> j" a "D (J.cod j)"] \<chi>.A.map_simp S.Fun_mkArr
                           by fastforce
                         finally show ?thesis by blast
                       qed
                       thus ?thesis
                         using a a' h Hom.\<phi>_mapsto by auto
                     qed
                     also have "... = \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
                       using a a' h Hom.\<psi>_\<phi> by simp
                     finally show "S.Fun (YoD.at a' (map o \<chi>) j) (\<phi> (a', a) h)
                                     = \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> h)"
                       by auto
                   qed
                   have "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> =
                         D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi>"
                   proof
                     fix j
                     have "\<not>J.arr j \<Longrightarrow> D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
                                        D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
                       using 1 2 \<chi>.cone_axioms by (elim C.in_homE, auto)
                     moreover have "J.arr j \<Longrightarrow> D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
                                                D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
                     proof -
                       assume j: "J.arr j"
                       have "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
                               \<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e)"
                         using j 1 \<chi>.cone_axioms by auto
                       also have "... = \<psi> (a', D (J.cod j)) (S.Fun (\<sigma> j) e)"
                       proof -
                         have "\<psi> (a', D (J.cod j)) (S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun f' e)) =
                                 \<psi> (a', D (J.cod j))
                                   (\<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e)))"
                           using j a a' f'e A Hom.\<phi>_\<psi> Hom.\<psi>_mapsto by force
                         moreover have "\<chi> j \<cdot> \<psi> (a', a) (S.Fun f' e) \<in> C.hom a' (D (J.cod j))"
                           using a a' j f'e Hom.\<psi>_mapsto \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
                                 \<chi>.A.map_simp
                           by auto
                         moreover have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun f' e) =
                                        S.Fun (\<sigma> j) e"
                           using Fun_map_a_a' a a' j f' e x Yo\<chi>_a'.A.map_simp eval_at_ide
                                 Yo\<chi>_a'.cone_axioms
                           by auto
                         ultimately show ?thesis
                           using a a' Hom.\<psi>_\<phi> by auto
                       qed
                       also have "... = \<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e)"
                       proof -
                         have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e) =
                                 \<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e))"
                           using j a a' fe A [of "\<psi> (a', a) (S.Fun ?f e)" j] Hom.\<phi>_\<psi> Hom.\<psi>_mapsto
                           by auto
                         hence "\<psi> (a', D (J.cod j)) (S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e)) =
                                 \<psi> (a', D (J.cod j))
                                   (\<phi> (a', D (J.cod j)) (\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e)))"
                           by simp
                         moreover have "\<chi> j \<cdot> \<psi> (a', a) (S.Fun ?f e) \<in> C.hom a' (D (J.cod j))"
                           using a a' j fe Hom.\<psi>_mapsto \<chi>.preserves_hom [of j "J.dom j" "J.cod j"]
                                 \<chi>.A.map_simp
                           by auto
                         moreover have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e) =
                                        S.Fun (\<sigma> j) e"
                         proof -
                           have "S.Fun (YoD.at a' (map o \<chi>) j) (S.Fun ?f e)
                                   = (S.Fun (YoD.at a' (map o \<chi>) j) o S.Fun ?f) e"
                             by simp
                           also have "... = S.Fun (YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f) e"
                             using Fun_map_a_a' a a' j f e x Yo\<chi>_a'.A.map_simp eval_at_ide
                             by auto
                           also have "... = S.Fun (\<sigma> j) e"
                           proof -
                             have "YoD.at a' (map o \<chi>) j \<cdot>\<^sub>S ?f =
                                   YoD_a'.cones_map ?f (YoD.at a' (map o \<chi>)) j"
                               using j f Yo\<chi>_a'.cone_axioms Fun_map_a_a' by auto
                             thus ?thesis using j ff by argo
                           qed
                           finally show ?thesis by auto
                         qed
                         ultimately show ?thesis
                           using a a' Hom.\<psi>_\<phi> by auto
                       qed
                       also have "... = D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
                         using j 2 \<chi>.cone_axioms by force
                       finally show "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
                                     D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
                         by auto
                     qed
                     ultimately show "D.cones_map (\<psi> (a', a) (S.Fun f' e)) \<chi> j =
                                      D.cones_map (\<psi> (a', a) (S.Fun ?f e)) \<chi> j"
                       by auto
                   qed
                   hence "\<psi> (a', a) (S.Fun f' e) = \<psi> (a', a) (S.Fun ?f e)"
                     using 1 2 \<chi>ofe.cone_axioms \<chi>.cone_axioms \<chi>.is_universal by blast
                   hence "\<phi> (a', a) (\<psi> (a', a) (S.Fun f' e)) = \<phi> (a', a) (\<psi> (a', a) (S.Fun ?f e))"
                     by simp
                   thus "S.Fun f' e = S.Fun ?f e"
                     using a a' fe f'e Hom.\<phi>_\<psi> by force
                 qed
                 ultimately show "S.Fun f' e = S.Fun ?f e" by auto
               qed
             qed
           qed
           ultimately have "\<exists>!f. \<guillemotleft>f : x \<rightarrow>\<^sub>S Hom.map (a', a)\<guillemotright> \<and>
                                 YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"
             using ex1I [of "\<lambda>f. S.in_hom x (Hom.map (a', a)) f \<and>
                                 YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"]
             by blast
           thus "\<exists>!f. \<guillemotleft>f : x \<rightarrow>\<^sub>S Cop_S.Map (map a) a'\<guillemotright> \<and>
                      YoD_a'.cones_map f (YoD.at a' (map o \<chi>)) = \<sigma>"
             using a a' Y_def by simp
         qed
       qed
       thus "YoD.has_as_limit (map a)"
         using YoD.cone_is_limit_if_pointwise_limit Yo\<chi>.cone_axioms by auto
     qed
 
   end
 
 end
diff --git a/thys/Category3/ROOT b/thys/Category3/ROOT
--- a/thys/Category3/ROOT
+++ b/thys/Category3/ROOT
@@ -1,12 +1,11 @@
 chapter AFP
 
 session "Category3" (AFP) = "HOL-Library" +
   options [timeout = 3000, names_unique = false]
   sessions
-    "HOL-Cardinals"
-    "HereditarilyFinite"
+    "HereditarilyFinite" "ZFC_in_HOL"
   theories
-    Limit Subcategory EquivalenceOfCategories HFSetCat
+    EquivalenceOfCategories HFSetCat ZFC_SetCat
   document_files
     "root.bib"
     "root.tex"
diff --git a/thys/Category3/SetCat.thy b/thys/Category3/SetCat.thy
--- a/thys/Category3/SetCat.thy
+++ b/thys/Category3/SetCat.thy
@@ -1,874 +1,1347 @@
 (*  Title:       SetCat
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter SetCat
 
 theory SetCat
 imports SetCategory ConcreteCategory
 begin
 
   text\<open>
     This theory proves the consistency of the \<open>set_category\<close> locale by giving
     a particular concrete construction of an interpretation for it.
     Applying the general construction given by @{locale concrete_category},
     we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
     and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
 \<close>
 
   text\<open>
     This locale uses an extra dummy parameter just to fix the element type for sets.
     Without this, a type is used for each interpretation, which makes it impossible to
     construct set categories whose element types are related to the context.
+    An additional parameter, @{term Setp}, allows some control over which subsets of
+    the element type are assumed to correspond to objects of the category.
   \<close>
 
   locale setcat =
   fixes dummy :: 'e
-  and \<AA> :: "'a rel"
-  assumes cardinal: "Card_order \<AA> \<and> infinite (Field \<AA>)"
+  and Setp :: "'e set \<Rightarrow> bool"
+  assumes Setp_singleton: "Setp {x}"
+  and Setp_respects_subset: "A' \<subseteq> A \<Longrightarrow> Setp A \<Longrightarrow> Setp A'"
+  and union_preserves_Setp: "\<lbrakk> Setp A; Setp B \<rbrakk> \<Longrightarrow> Setp (A \<union> B)"
   begin
 
-    lemma finite_imp_card_less:
-    assumes "finite A"
-    shows "|A| <o \<AA>"
-    proof -
-      have "finite (Field |A| )"
-        using assms by simp
-      thus ?thesis
-        using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
-        by blast
-    qed
+    lemma finite_imp_Setp: "finite A \<Longrightarrow> Setp A"
+      using Setp_singleton
+      by (metis finite_induct insert_is_Un Setp_respects_subset singleton_insert_inj_eq
+          union_preserves_Setp)
 
     type_synonym 'b arr = "('b set, 'b \<Rightarrow> 'b) concrete_category.arr"
 
-    interpretation concrete_category \<open>{A :: 'e set. |A| <o \<AA>}\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
-                     \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
+    interpretation S: concrete_category \<open>Collect Setp\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
+                        \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
       using compose_Id Id_compose
       apply unfold_locales
           apply auto[3]
        apply blast
       by (metis IntD2 compose_assoc)
 
     abbreviation comp :: "'e setcat.arr comp"     (infixr "\<cdot>" 55)
-    where "comp \<equiv> COMP"
-    notation in_hom                               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
+    where "comp \<equiv> S.COMP"
+    notation S.in_hom                               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
+
+    lemma is_category:
+    shows "category comp"
+      using S.category_axioms by simp
 
     lemma MkArr_expansion:
-    assumes "arr f"
-    shows "f = MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x)"
-    proof (intro arr_eqI)
-      show "arr f" by fact
-      show "arr (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
-        using assms arr_char
-        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
-      show "Dom f = Dom (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+    assumes "S.arr f"
+    shows "f = S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x)"
+    proof (intro S.arr_eqI)
+      show "S.arr f" by fact
+      show "S.arr (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
+        using assms S.arr_char
+        by (metis (mono_tags, lifting) Int_iff S.MkArr_Map extensional_restrict)
+      show "S.Dom f = S.Dom (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         by simp
-      show "Cod f = Cod (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
+      show "S.Cod f = S.Cod (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
         by simp
-      show "Map f = Map (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
-        using assms arr_char
-        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
+      show "S.Map f = S.Map (S.MkArr (S.Dom f) (S.Cod f) (\<lambda>x \<in> S.Dom f. S.Map f x))"
+        using assms S.arr_char
+        by (metis (mono_tags, lifting) Int_iff S.MkArr_Map extensional_restrict)
     qed
 
     lemma arr_char:
-    shows "arr f \<longleftrightarrow> f \<noteq> Null \<and> |Dom f| <o \<AA> \<and> |Cod f| <o \<AA> \<and>
-                     Map f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
-      using arr_char by auto
+    shows "S.arr f \<longleftrightarrow> f \<noteq> S.Null \<and> Setp (S.Dom f) \<and> Setp (S.Cod f) \<and>
+                       S.Map f \<in> extensional (S.Dom f) \<inter> (S.Dom f \<rightarrow> S.Cod f)"
+      using S.arr_char by auto
 
     lemma terminal_char:
-    shows "terminal a \<longleftrightarrow> (\<exists>x. a = MkIde {x})"
+    shows "S.terminal a \<longleftrightarrow> (\<exists>x. a = S.MkIde {x})"
     proof
-      show "\<exists>x. a = MkIde {x} \<Longrightarrow> terminal a"
+      show "\<exists>x. a = S.MkIde {x} \<Longrightarrow> S.terminal a"
       proof -
-        assume a: "\<exists>x. a = MkIde {x}"
-        from this obtain x where x: "a = MkIde {x}" by blast
-        have "terminal (MkIde {x})"
+        assume a: "\<exists>x. a = S.MkIde {x}"
+        from this obtain x where x: "a = S.MkIde {x}" by blast
+        have "S.terminal (S.MkIde {x})"
         proof
-          show 1: "ide (MkIde {x})"
-            using finite_imp_card_less ide_MkIde by auto
-          show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
+          show 1: "S.ide (S.MkIde {x})"
+            using finite_imp_Setp S.ide_MkIde by auto
+          show "\<And>a. S.ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> S.MkIde {x}\<guillemotright>"
           proof
             fix a :: "'e setcat.arr"
-            assume a: "ide a"
-            show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> MkIde {x}\<guillemotright>"
+            assume a: "S.ide a"
+            show "\<guillemotleft>S.MkArr (S.Dom a) {x} (\<lambda>_\<in>S.Dom a. x) : a \<rightarrow> S.MkIde {x}\<guillemotright>"
             proof
-              show 2: "arr (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x))"
-                using a 1 arr_MkArr [of "Dom a" "{x}"] ide_char by force
-              show "dom (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)) = a"
-                using a 2 dom_MkArr by force
-              show "cod (MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x)) = MkIde {x}"
-                using 2 cod_MkArr by blast
+              show 2: "S.arr (S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x))"
+                using a 1 S.arr_MkArr [of "S.Dom a" "{x}"] S.ide_char by force
+              show "S.dom (S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x)) = a"
+                using a 2 S.dom_MkArr by force
+              show "S.cod (S.MkArr (S.Dom a) {x} (\<lambda>_\<in>S.Dom a. x)) = S.MkIde {x}"
+                using 2 S.cod_MkArr by blast
             qed
             fix f :: "'e setcat.arr"
-            assume f: "\<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
-            show "f = MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)"
+            assume f: "\<guillemotleft>f : a \<rightarrow> S.MkIde {x}\<guillemotright>"
+            show "f = S.MkArr (S.Dom a) {x} (\<lambda>_ \<in> S.Dom a. x)"
             proof -
-              have 1: "Dom f = Dom a \<and> Cod f = {x}"
-                using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
-              moreover have "Map f = (\<lambda>_ \<in> Dom a. x)"
+              have 1: "S.Dom f = S.Dom a \<and> S.Cod f = {x}"
+                using a f by (metis (mono_tags, lifting) S.Dom.simps(1) S.in_hom_char)
+              moreover have "S.Map f = (\<lambda>_ \<in> S.Dom a. x)"
               proof
                 fix z
-                have "z \<notin> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
+                have "z \<notin> S.Dom a \<Longrightarrow> S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z"
                   using f 1 MkArr_expansion
-                  by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
-                moreover have "z \<in> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
+                  by (metis (mono_tags, lifting) S.Map.simps(1) S.in_homE restrict_apply)
+                moreover have "z \<in> S.Dom a \<Longrightarrow> S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z"
                   using f 1 arr_char [of f] by fastforce
-                ultimately show "Map f z = (\<lambda>_ \<in> Dom a. x) z" by auto
+                ultimately show "S.Map f z = (\<lambda>_ \<in> S.Dom a. x) z" by auto
               qed
               ultimately show ?thesis
                using f MkArr_expansion [of f] by fastforce
             qed
           qed
         qed
-        thus "terminal a" using x by simp
+        thus "S.terminal a" using x by simp
       qed
-      show "terminal a \<Longrightarrow> \<exists>x. a = MkIde {x}"
+      show "S.terminal a \<Longrightarrow> \<exists>x. a = S.MkIde {x}"
       proof -
-        assume a: "terminal a"
-        hence ide_a: "ide a" using terminal_def by auto
-        have 1: "\<exists>!x. x \<in> Dom a"
+        assume a: "S.terminal a"
+        hence ide_a: "S.ide a" using S.terminal_def by auto
+        have 1: "\<exists>!x. x \<in> S.Dom a"
         proof -
-          have "Dom a = {} \<Longrightarrow> \<not>terminal a"
+          have "S.Dom a = {} \<Longrightarrow> \<not>S.terminal a"
           proof -
-            assume "Dom a = {}"
-            hence 1: "a = MkIde {}"
-              using MkIde_Dom' \<open>ide a\<close> by fastforce
-            have "\<And>f. f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))
-                         \<Longrightarrow> Map f \<in> {undefined} \<rightarrow> {}"
+            assume "S.Dom a = {}"
+            hence 1: "a = S.MkIde {}"
+              using S.MkIde_Dom' \<open>S.ide a\<close> by fastforce
+            have "\<And>f. f \<in> S.hom (S.MkIde {undefined}) (S.MkIde ({} :: 'e set))
+                         \<Longrightarrow> S.Map f \<in> {undefined} \<rightarrow> {}"
             proof -
               fix f
-              assume f: "f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))"
-              show "Map f \<in> {undefined} \<rightarrow> {}"
-                using f MkArr_expansion arr_char [of f] in_hom_char by auto
+              assume f: "f \<in> S.hom (S.MkIde {undefined}) (S.MkIde ({} :: 'e set))"
+              show "S.Map f \<in> {undefined} \<rightarrow> {}"
+                using f MkArr_expansion arr_char [of f] S.in_hom_char by auto
             qed
-            hence "hom (MkIde {undefined}) a = {}" using 1 by auto
-            moreover have "ide (MkIde {undefined})"
-              using finite_imp_card_less
-              by (metis (mono_tags, lifting) finite.intros(1-2) ide_MkIde mem_Collect_eq)
-            ultimately show "\<not>terminal a" by blast
+            hence "S.hom (S.MkIde {undefined}) a = {}" using 1 by auto
+            moreover have "S.ide (S.MkIde {undefined})"
+              using finite_imp_Setp
+              by (metis (mono_tags, lifting) finite.intros(1-2) S.ide_MkIde mem_Collect_eq)
+            ultimately show "\<not>S.terminal a" by blast
           qed
-          moreover have "\<And>x x'. x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>terminal a"
+          moreover have "\<And>x x'. x \<in> S.Dom a \<and> x' \<in> S.Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>S.terminal a"
           proof -
             fix x x'
-            assume 1: "x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x'"
-            let ?f = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x)"
-            let ?f' = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x')"
-            have "\<guillemotleft>?f : MkIde {undefined} \<rightarrow> a\<guillemotright>"
-            proof
-              show 2: "arr ?f"
-              proof (intro arr_MkArr)
-                show "{undefined} \<in> {A. |A| <o \<AA>}"
-                  by (simp add: finite_imp_card_less)
-                show "Dom a \<in> {A. |A| <o \<AA>}"
-                  using ide_a ide_char by blast
-                show "(\<lambda>_ \<in> {undefined}. x) \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
-                  using 1 by blast
+            assume 1: "x \<in> S.Dom a \<and> x' \<in> S.Dom a \<and> x \<noteq> x'"
+            let ?f = "S.MkArr {undefined} (S.Dom a) (\<lambda>_ \<in> {undefined}. x)"
+            let ?f' = "S.MkArr {undefined} (S.Dom a) (\<lambda>_ \<in> {undefined}. x')"
+            have "S.par ?f ?f'"
+            proof -
+              have "\<guillemotleft>?f : S.MkIde {undefined} \<rightarrow> a\<guillemotright>"
+              proof
+                show 2: "S.arr ?f"
+                proof (intro S.arr_MkArr)
+                  show "{undefined} \<in> {A. Setp A}"
+                    by (simp add: finite_imp_Setp)
+                  show "S.Dom a \<in> {A. Setp A}"
+                    using ide_a S.ide_char by blast
+                  show "(\<lambda>_ \<in> {undefined}. x) \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> S.Dom a)"
+                    using 1 by blast
+                qed
+                show "S.dom ?f = S.MkIde {undefined}"
+                  using 2 S.dom_MkArr by auto
+                show "S.cod ?f = a"
+                  using 2 S.cod_MkArr ide_a by force
               qed
-              show "dom ?f = MkIde {undefined}"
-                using 2 dom_MkArr by auto
-              show "cod ?f = a"
-                using 2 cod_MkArr ide_a by force
-            qed
-            moreover have "\<guillemotleft>?f' : MkIde {undefined} \<rightarrow> a\<guillemotright>"
-            proof
-              show 2: "arr ?f'"
-                using 1 ide_a ide_char arr_MkArr [of "{undefined}" "Dom a"]
-                      finite_imp_card_less
-              proof (intro arr_MkArr)
-                show "{undefined} \<in> {A. |A| <o \<AA>}"
-                  by (simp add: finite_imp_card_less)
-                show "Dom a \<in> {A. |A| <o \<AA>}"
-                  using ide_a ide_char by blast
-                show "(\<lambda>_ \<in> {undefined}. x') \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
-                  using 1 by blast
+              moreover have "\<guillemotleft>?f' : S.MkIde {undefined} \<rightarrow> a\<guillemotright>"
+              proof
+                show 2: "S.arr ?f'"
+                proof (intro S.arr_MkArr)
+                  show "{undefined} \<in> {A. Setp A}"
+                    by (simp add: finite_imp_Setp)
+                  show "S.Dom a \<in> {A. Setp A}"
+                    using ide_a S.ide_char by blast
+                  show "(\<lambda>_ \<in> {undefined}. x') \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> S.Dom a)"
+                    using 1 by blast
+                qed
+                show "S.dom ?f' = S.MkIde {undefined}"
+                  using 2 S.dom_MkArr by auto
+                show "S.cod ?f' = a"
+                  using 2 S.cod_MkArr ide_a by force
               qed
-              show "dom ?f' = MkIde {undefined}"
-                using 2 dom_MkArr by auto
-              show "cod ?f' = a"
-                using 2 cod_MkArr ide_a by force
+              ultimately show ?thesis
+                by (metis (no_types, lifting) S.in_homE)
             qed
             moreover have "?f \<noteq> ?f'"
-              using 1 by (metis arr.inject restrict_apply' singletonI)
-            ultimately show "\<not>terminal a"
-              using terminal_arr_unique
-              by (metis (mono_tags, lifting) in_homE)
+              using 1 by (metis S.arr.inject restrict_apply' singletonI)
+            ultimately show "\<not>S.terminal a"
+              using S.cod_MkArr ide_a S.terminal_arr_unique [of ?f ?f'] by auto
           qed
           ultimately show ?thesis
             using a by auto
         qed
-        hence "Dom a = {THE x. x \<in> Dom a}"
-          using theI [of "\<lambda>x. x \<in> Dom a"] by auto
-        hence "a = MkIde {THE x. x \<in> Dom a}"
-          using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
-        thus "\<exists>x. a = MkIde {x}"
+        hence "S.Dom a = {THE x. x \<in> S.Dom a}"
+          using theI [of "\<lambda>x. x \<in> S.Dom a"] by auto
+        hence "a = S.MkIde {THE x. x \<in> S.Dom a}"
+          using a S.terminal_def by (metis (mono_tags, lifting) S.MkIde_Dom')
+        thus "\<exists>x. a = S.MkIde {x}"
           by auto
       qed
     qed
 
     definition IMG :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
-    where "IMG f = MkIde (Map f ` Dom f)"
+    where "IMG f = S.MkIde (S.Map f ` S.Dom f)"
   
-    interpretation set_category_data comp IMG ..
+    interpretation S: set_category_data comp IMG
+      ..
 
     lemma terminal_unity:
-    shows "terminal unity"
-      using terminal_char unity_def someI_ex [of terminal]
+    shows "S.terminal S.unity"
+      using terminal_char S.unity_def someI_ex [of S.terminal]
       by (metis (mono_tags, lifting))
   
     text\<open>
-      The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
+      The inverse maps @{term arr_of} and @{term elem_of} are used to pass back and forth between
       the inhabitants of type @{typ 'a} and the corresponding terminal objects.
       These are exported so that a client of the theory can relate the concrete
       element type @{typ 'a} to the otherwise abstract arrow type.
 \<close>
 
-    definition UP :: "'e \<Rightarrow> 'e setcat.arr"
-    where "UP x \<equiv> MkIde {x}"
+    definition arr_of :: "'e \<Rightarrow> 'e setcat.arr"
+    where "arr_of x \<equiv> S.MkIde {x}"
   
-    definition DOWN :: "'e setcat.arr \<Rightarrow> 'e"
-    where "DOWN t \<equiv> the_elem (Dom t)"
+    definition elem_of :: "'e setcat.arr \<Rightarrow> 'e"
+    where "elem_of t \<equiv> the_elem (S.Dom t)"
 
     abbreviation U
-    where "U \<equiv> DOWN unity"
+    where "U \<equiv> elem_of S.unity"
   
-    lemma UP_mapsto:
-    shows "UP \<in> UNIV \<rightarrow> Univ"
-      using terminal_char UP_def by fast
+    lemma arr_of_mapsto:
+    shows "arr_of \<in> UNIV \<rightarrow> S.Univ"
+      using terminal_char arr_of_def by fast
     
-    lemma DOWN_mapsto:
-    shows "DOWN \<in> Univ \<rightarrow> UNIV"
+    lemma elem_of_mapsto:
+    shows "elem_of \<in> Univ \<rightarrow> UNIV"
       by auto
     
-    lemma DOWN_UP [simp]:
-    shows "DOWN (UP x) = x"
-      by (simp add: DOWN_def UP_def)
+    lemma elem_of_arr_of [simp]:
+    shows "elem_of (arr_of x) = x"
+      by (simp add: elem_of_def arr_of_def)
     
-    lemma UP_DOWN [simp]:
-    assumes "t \<in> Univ"
-    shows "UP (DOWN t) = t"
-      using assms terminal_char UP_def DOWN_def
-      by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)
+    lemma arr_of_elem_of [simp]:
+    assumes "t \<in> S.Univ"
+    shows "arr_of (elem_of t) = t"
+      using assms terminal_char arr_of_def elem_of_def
+      by (metis (mono_tags, lifting) mem_Collect_eq elem_of_arr_of)
   
-    lemma inj_UP:
-    shows "inj UP"
-      by (metis DOWN_UP injI)
+    lemma inj_arr_of:
+    shows "inj arr_of"
+      by (metis elem_of_arr_of injI)
   
-    lemma bij_UP:
-    shows "bij_betw UP UNIV Univ"
+    lemma bij_arr_of:
+    shows "bij_betw arr_of UNIV S.Univ"
     proof (intro bij_betwI)
-      interpret category comp using is_category by auto
-      show DOWN_UP: "\<And>x :: 'e. DOWN (UP x) = x" by simp
-      show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by simp
-      show "UP \<in> UNIV \<rightarrow> Univ" using UP_mapsto by auto
-      show "DOWN \<in> Collect terminal \<rightarrow> UNIV" by auto
+      show "\<And>x :: 'e. elem_of (arr_of x) = x" by simp
+      show "\<And>t. t \<in> S.Univ \<Longrightarrow> arr_of (elem_of t) = t" by simp
+      show "arr_of \<in> UNIV \<rightarrow> S.Univ" using arr_of_mapsto by auto
+      show "elem_of \<in> Collect S.terminal \<rightarrow> UNIV" by auto
     qed
   
+    lemma bij_elem_of:
+    shows "bij_betw elem_of S.Univ UNIV"
+    proof (intro bij_betwI)
+      show "\<And>t. t \<in> S.Univ \<Longrightarrow> arr_of (elem_of t) = t" by simp
+      show "\<And>x. x \<in> UNIV \<Longrightarrow> elem_of (arr_of x) = x" by simp
+      show "elem_of \<in> S.Univ \<rightarrow> UNIV" using elem_of_mapsto by auto
+      show "arr_of \<in> UNIV \<rightarrow> S.Univ" using arr_of_mapsto by auto
+    qed
+
+    lemma elem_of_img_arr_of_img [simp]:
+    shows "elem_of ` arr_of ` A = A"
+      by force
+
+    lemma arr_of_img_elem_of_img [simp]:
+    assumes "A \<subseteq> S.Univ"
+    shows "arr_of ` elem_of ` A = A"
+      using assms by force
+
     lemma Dom_terminal:
-    assumes "terminal t"
-    shows "Dom t = {DOWN t}"
-      using assms UP_def
-      by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)
+    assumes "S.terminal t"
+    shows "S.Dom t = {elem_of t}"
+      using assms arr_of_def
+      by (metis (mono_tags, lifting) S.Dom.simps(1) elem_of_def terminal_char the_elem_eq)
 
     text\<open>
       The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
-      by the formula @{term "(UP o Fun p o DOWN) unity"}.
+      by the formula @{term "(arr_of o Fun p o elem_of) unity"}.
 \<close>
 
     lemma IMG_point:
-    assumes "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright>"
-    shows "IMG \<in> hom unity a \<rightarrow> Univ"
-    and "IMG p = (UP o Map p o DOWN) unity"
+    assumes "\<guillemotleft>p : S.unity \<rightarrow> a\<guillemotright>"
+    shows "IMG \<in> S.hom S.unity a \<rightarrow> S.Univ"
+    and "IMG p = (arr_of o S.Map p o elem_of) S.unity"
     proof -
-      show "IMG \<in> hom unity a \<rightarrow> Univ"
+      show "IMG \<in> S.hom S.unity a \<rightarrow> S.Univ"
       proof
         fix f
-        assume f: "f \<in> hom unity a"
-        have "terminal (MkIde (Map f ` Dom unity))"
+        assume f: "f \<in> S.hom S.unity a"
+        have "S.terminal (S.MkIde (S.Map f ` S.Dom S.unity))"
         proof -
-          obtain u :: 'e where u: "unity = MkIde {u}"
+          obtain u :: 'e where u: "S.unity = S.MkIde {u}"
             using terminal_unity terminal_char
             by (metis (mono_tags, lifting))
-          have "Map f ` Dom unity = {Map f u}"
+          have "S.Map f ` S.Dom S.unity = {S.Map f u}"
             using u by simp
           thus ?thesis
             using terminal_char by auto
         qed
-        hence "MkIde (Map f ` Dom unity) \<in> Univ" by simp
-        moreover have "MkIde (Map f ` Dom unity) = IMG f"
-          using f IMG_def in_hom_char
+        hence "S.MkIde (S.Map f ` S.Dom S.unity) \<in> S.Univ" by simp
+        moreover have "S.MkIde (S.Map f ` S.Dom S.unity) = IMG f"
+          using f IMG_def S.in_hom_char
           by (metis (mono_tags, lifting) mem_Collect_eq)
-        ultimately show "IMG f \<in> Univ" by auto
+        ultimately show "IMG f \<in> S.Univ" by auto
       qed
-      have "IMG p = MkIde (Map p ` Dom p)" using IMG_def by blast
-      also have "... = MkIde (Map p ` {U})"
-        using assms in_hom_char terminal_unity Dom_terminal
+      have "IMG p = S.MkIde (S.Map p ` S.Dom p)" using IMG_def by blast
+      also have "... = S.MkIde (S.Map p ` {U})"
+        using assms S.in_hom_char terminal_unity Dom_terminal
         by (metis (mono_tags, lifting))
-      also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
-      finally show "IMG p = (UP o Map p o DOWN) unity" using assms by auto
+      also have "... = (arr_of o S.Map p o elem_of) S.unity" by (simp add: arr_of_def)
+      finally show "IMG p = (arr_of o S.Map p o elem_of) S.unity" using assms by auto
     qed
   
     text\<open>
       The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
       a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
       constant-@{term t} function.
 \<close>
 
     abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
-    where "MkElem t a \<equiv> MkArr {U} (Dom a) (\<lambda>_ \<in> {U}. DOWN t)"
+    where "MkElem t a \<equiv> S.MkArr {U} (S.Dom a) (\<lambda>_ \<in> {U}. elem_of t)"
 
     lemma MkElem_in_hom:
-    assumes "arr f" and "x \<in> Dom f"
-    shows "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
+    assumes "S.arr f" and "x \<in> S.Dom f"
+    shows "\<guillemotleft>MkElem (arr_of x) (S.dom f) : S.unity \<rightarrow> S.dom f\<guillemotright>"
     proof -
-      have "(\<lambda>_ \<in> {U}. DOWN (UP x)) \<in> {U} \<rightarrow> Dom (dom f)"
-        using assms dom_char [of f] by simp
-      moreover have "MkIde {U} = unity"
+      have "(\<lambda>_ \<in> {U}. elem_of (arr_of x)) \<in> {U} \<rightarrow> S.Dom (S.dom f)"
+        using assms S.dom_char [of f] by simp
+      moreover have "S.MkIde {U} = S.unity"
         using terminal_char terminal_unity
-        by (metis (mono_tags, lifting) DOWN_UP UP_def)
-      moreover have "MkIde (Dom (dom f)) = dom f"
-        using assms dom_char MkIde_Dom' ide_dom by blast
+        by (metis (mono_tags, lifting) elem_of_arr_of arr_of_def)
+      moreover have "S.MkIde (S.Dom (S.dom f)) = S.dom f"
+        using assms S.dom_char S.MkIde_Dom' S.ide_dom by blast
       ultimately show ?thesis
-        using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "\<lambda>_ \<in> {U}. DOWN (UP x)"]
-        by (metis (no_types, lifting) Dom.simps(1) Dom_in_Obj IntI arr_dom ideD(1)
-            restrict_extensional terminal_def terminal_unity)
+        using assms S.MkArr_in_hom [of "{U}" "S.Dom (S.dom f)" "\<lambda>_ \<in> {U}. elem_of (arr_of x)"]
+        by (metis (no_types, lifting) S.Dom.simps(1) S.Dom_in_Obj IntI S.arr_dom S.ideD(1)
+            restrict_extensional S.terminal_def terminal_unity)
     qed
 
     lemma MkElem_IMG:
-    assumes "p \<in> hom unity a"
+    assumes "p \<in> S.hom S.unity a"
     shows "MkElem (IMG p) a = p"
     proof -
-      have 0: "IMG p = UP (Map p U)"
+      have 0: "IMG p = arr_of (S.Map p U)"
         using assms IMG_point(2) by auto
-      have 1: "Dom p = {U}"
+      have 1: "S.Dom p = {U}"
         using assms terminal_unity Dom_terminal
-        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
-      moreover have "Cod p = Dom a"
+        by (metis (mono_tags, lifting) S.in_hom_char mem_Collect_eq)
+      moreover have "S.Cod p = S.Dom a"
         using assms
-        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
-      moreover have "Map p = (\<lambda>_ \<in> {U}. DOWN (IMG p))"
+        by (metis (mono_tags, lifting) S.in_hom_char mem_Collect_eq)
+      moreover have "S.Map p = (\<lambda>_ \<in> {U}. elem_of (IMG p))"
       proof
         fix e
-        show "Map p e = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
+        show "S.Map p e = (\<lambda>_ \<in> {U}. elem_of (IMG p)) e"
         proof -
-          have "Map p e = (\<lambda>x \<in> Dom p. Map p x) e"
+          have "S.Map p e = (\<lambda>x \<in> S.Dom p. S.Map p x) e"
             using assms MkArr_expansion [of p]
-            by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
-          also have "... = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
+            by (metis (mono_tags, lifting) CollectD S.Map.simps(1) S.in_homE)
+          also have "... = (\<lambda>_ \<in> {U}. elem_of (IMG p)) e"
             using assms 0 1 by simp
           finally show ?thesis by blast
         qed
       qed
       ultimately show "MkElem (IMG p) a = p"
-        using assms MkArr_Map CollectD
-        by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
+        using assms S.MkArr_Map CollectD
+        by (metis (mono_tags, lifting) S.in_homE mem_Collect_eq)
     qed
 
     lemma inj_IMG:
-    assumes "ide a"
-    shows "inj_on IMG (hom unity a)"
+    assumes "S.ide a"
+    shows "inj_on IMG (S.hom S.unity a)"
     proof (intro inj_onI)
       fix x y
-      assume x: "x \<in> hom unity a"
-      assume y: "y \<in> hom unity a"
+      assume x: "x \<in> S.hom S.unity a"
+      assume y: "y \<in> S.hom S.unity a"
       assume eq: "IMG x = IMG y"
       show "x = y"
-      proof (intro arr_eqI)
-        show "arr x" using x by blast
-        show "arr y" using y by blast
-        show "Dom x = Dom y"
-          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
-        show "Cod x = Cod y"
-          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
-        show "Map x = Map y"
+      proof (intro S.arr_eqI)
+        show "S.arr x" using x by blast
+        show "S.arr y" using y by blast
+        show "S.Dom x = S.Dom y"
+          using x y S.in_hom_char by (metis (mono_tags, lifting) CollectD)
+        show "S.Cod x = S.Cod y"
+          using x y S.in_hom_char by (metis (mono_tags, lifting) CollectD)
+        show "S.Map x = S.Map y"
         proof -
-          have "\<And>a. y \<in> hom unity a \<Longrightarrow> MkArr {U} (Dom a) (\<lambda>e\<in>{U}. DOWN (IMG x)) = y"
+          have "\<And>a. y \<in> S.hom S.unity a \<Longrightarrow> S.MkArr {U} (S.Dom a) (\<lambda>e\<in>{U}. elem_of (IMG x)) = y"
             using MkElem_IMG eq by presburger
           hence "y = x"
             using MkElem_IMG x y by blast
           thus ?thesis by meson
         qed
       qed
     qed
 
     lemma set_char:
-    assumes "ide a"
-    shows "set a = UP ` Dom a"
+    assumes "S.ide a"
+    shows "S.set a = arr_of ` S.Dom a"
     proof
-      show "set a \<subseteq> UP ` Dom a"
+      show "S.set a \<subseteq> arr_of ` S.Dom a"
       proof
         fix t
-        assume "t \<in> set a"
-        from this obtain p where p: "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright> \<and> t = IMG p"
-          using set_def by blast
-        have "t = (UP o Map p o DOWN) unity"
+        assume "t \<in> S.set a"
+        from this obtain p where p: "\<guillemotleft>p : S.unity \<rightarrow> a\<guillemotright> \<and> t = IMG p"
+          using S.set_def by blast
+        have "t = (arr_of o S.Map p o elem_of) S.unity"
           using p IMG_point(2) by blast
-        moreover have "(Map p o DOWN) unity \<in> Dom a"
-          using p arr_char in_hom_char Dom_terminal terminal_unity
+        moreover have "(S.Map p o elem_of) S.unity \<in> S.Dom a"
+          using p arr_char S.in_hom_char Dom_terminal terminal_unity
           by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
-        ultimately show "t \<in> UP ` Dom a" by simp
+        ultimately show "t \<in> arr_of ` S.Dom a" by simp
       qed
-      show "UP ` Dom a \<subseteq> set a"
+      show "arr_of ` S.Dom a \<subseteq> S.set a"
       proof
         fix t
-        assume "t \<in> UP ` Dom a"
-        from this obtain x where x: "x \<in> Dom a \<and> t = UP x" by blast
-        let ?p = "MkElem (UP x) a"
-        have p: "?p \<in> hom unity a"
-          using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
+        assume "t \<in> arr_of ` S.Dom a"
+        from this obtain x where x: "x \<in> S.Dom a \<and> t = arr_of x" by blast
+        let ?p = "MkElem (arr_of x) a"
+        have p: "?p \<in> S.hom S.unity a"
+          using assms x MkElem_in_hom [of "S.dom a"] S.ideD(1-2) by force
         moreover have "IMG ?p = t"
-          using p x DOWN_UP IMG_def UP_def
-          by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
+          using p x elem_of_arr_of IMG_def arr_of_def
+          by (metis (no_types, lifting) S.Dom.simps(1) S.Map.simps(1) image_empty
               image_insert image_restrict_eq)
-        ultimately show "t \<in> set a" using set_def by blast
+        ultimately show "t \<in> S.set a" using S.set_def by blast
       qed
     qed
   
     lemma Map_via_comp:
-    assumes "arr f"
-    shows "Map f = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U)"
+    assumes "S.arr f"
+    shows "S.Map f = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U)"
     proof
       fix x
-      have "x \<notin> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
+      have "x \<notin> S.Dom f \<Longrightarrow> S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
         using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
       moreover have
-           "x \<in> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
+           "x \<in> S.Dom f \<Longrightarrow> S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
       proof -
-        assume x: "x \<in> Dom f"
-        let ?X = "MkElem (UP x) (dom f)"
-        have "\<guillemotleft>?X : unity \<rightarrow> dom f\<guillemotright>"
+        assume x: "x \<in> S.Dom f"
+        let ?X = "MkElem (arr_of x) (S.dom f)"
+        have "\<guillemotleft>?X : S.unity \<rightarrow> S.dom f\<guillemotright>"
           using assms x MkElem_in_hom by auto
-        moreover have "Dom ?X = {U} \<and> Map ?X = (\<lambda>_ \<in> {U}. x)"
+        moreover have "S.Dom ?X = {U} \<and> S.Map ?X = (\<lambda>_ \<in> {U}. x)"
           using x by simp
         ultimately have
-          "Map (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Map f) (\<lambda>_ \<in> {U}. x)"
-          using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
-          by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
+          "S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) = compose {U} (S.Map f) (\<lambda>_ \<in> {U}. x)"
+          using assms x S.Map_comp [of "MkElem (arr_of x) (S.dom f)" f]
+          by (metis (mono_tags, lifting) S.Cod.simps(1) S.Dom_dom S.arr_iff_in_hom S.seqE S.seqI')
         thus ?thesis
           using x by (simp add: compose_eq restrict_apply' singletonI)
       qed
-      ultimately show "Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
+      ultimately show "S.Map f x = (\<lambda>x \<in> S.Dom f. S.Map (f \<cdot> MkElem (arr_of x) (S.dom f)) U) x"
         by auto
     qed
 
     lemma arr_eqI':
-    assumes "par f f'" and "\<And>t. \<guillemotleft>t : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> t = f' \<cdot> t"
+    assumes "S.par f f'" and "\<And>t. \<guillemotleft>t : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow> f \<cdot> t = f' \<cdot> t"
     shows "f = f'"
-    proof (intro arr_eqI)
-      show "arr f" using assms by simp
-      show "arr f'" using assms by simp
-      show "Dom f = Dom f'"
-        using assms by (metis (mono_tags, lifting) Dom_dom)
-      show "Cod f = Cod f'"
-        using assms by (metis (mono_tags, lifting) Cod_cod)
-      show "Map f = Map f'"
+    proof (intro S.arr_eqI)
+      show "S.arr f" using assms by simp
+      show "S.arr f'" using assms by simp
+      show "S.Dom f = S.Dom f'"
+        using assms by (metis (mono_tags, lifting) S.Dom_dom)
+      show "S.Cod f = S.Cod f'"
+        using assms by (metis (mono_tags, lifting) S.Cod_cod)
+      show "S.Map f = S.Map f'"
       proof
-        have 1: "\<And>x. x \<in> Dom f \<Longrightarrow> \<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
+        have 1: "\<And>x. x \<in> S.Dom f \<Longrightarrow> \<guillemotleft>MkElem (arr_of x) (S.dom f) : S.unity \<rightarrow> S.dom f\<guillemotright>"
           using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
         fix x
-        show "Map f x = Map f' x"
-          using assms 1 \<open>Dom f = Dom f'\<close> by (simp add: Map_via_comp)
+        show "S.Map f x = S.Map f' x"
+          using assms 1 \<open>S.Dom f = S.Dom f'\<close> by (simp add: Map_via_comp)
       qed
     qed
 
-    text \<open>
-      We need to show that the cardinality constraint on the sets that determine objects
-      implies a corresponding constraint on the sets of global elements of those objects.
-    \<close>
-    
-    lemma card_points_less:
-    assumes "ide a"
-    shows "|hom unity a| <o \<AA>"
+    lemma Setp_elem_of_img:
+    assumes "A \<in> S.set ` Collect S.ide"
+    shows "Setp (elem_of ` A)"
     proof -
-      have "bij_betw (\<lambda>f. Map f U) (hom unity a) (Dom a)"
-      proof (intro bij_betwI')
-        show "\<And>x. x \<in> hom unity a \<Longrightarrow> Map x (DOWN unity) \<in> Dom a"
-          using arr_char Dom_terminal terminal_unity in_hom_char by auto
-        show "\<And>x y. \<lbrakk>x \<in> hom unity a; y \<in> hom unity a\<rbrakk> \<Longrightarrow> Map x U = Map y U \<longleftrightarrow> x = y"
-        proof -
-          fix x y
-          assume x: "x \<in> hom unity a" and y: "y \<in> hom unity a"
-          have 1: "Map x \<in> extensional {U} \<and> Map y \<in> extensional {U}"
-            using x y in_hom_char Dom_terminal terminal_unity
-            by (metis (mono_tags, lifting) Map_via_comp mem_Collect_eq restrict_extensional)
-          show "Map x U = Map y U \<longleftrightarrow> x = y"
-          proof
-            show "x = y \<Longrightarrow> Map x U = Map y U"
-              by simp
-            show "Map x U = Map y U \<Longrightarrow> x = y"
-            proof -
-              assume 2: "Map x U = Map y U"
-              have "Map x = Map y"
-              proof
-                fix z
-                show "Map x z = Map y z"
-                  using 1 2 extensional_arb [of "Map x"] extensional_arb [of "Map y"]
-                  by (cases "z = U") auto
-              qed
-              thus "x = y"
-                using x y 1 in_hom_char
-                by (intro arr_eqI) auto
-            qed
-          qed
-        qed
-        show "\<And>y. y \<in> Dom a \<Longrightarrow> \<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
-        proof -
-          fix y
-          assume y: "y \<in> Dom a"
-          let ?x = "MkArr {DOWN unity} (Dom a) (\<lambda>_ \<in> {U}. y)"
-          have "arr ?x"
-          proof (intro arr_MkArr)
-            show "{U} \<in> {A. |A| <o \<AA>}"
-              by (metis (mono_tags, lifting) Dom_terminal ide_char terminal_def terminal_unity)
-            show "Dom a \<in> {A. |A| <o \<AA>}"
-              using assms ide_char by blast
-            show "(\<lambda>_ \<in> {U}. y) \<in> extensional {U} \<inter> ({U} \<rightarrow> Dom a)"
-              using assms y by blast
-          qed
-          hence "?x \<in> hom unity a"
-            using UP_DOWN UP_def assms cod_MkArr dom_char in_homI terminal_unity by simp
-          moreover have "y = Map ?x (DOWN unity)"
-            by simp
-          ultimately show "\<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
-            by auto
-        qed
+      obtain a where a: "S.ide a \<and> S.set a = A"
+        using assms by blast
+      have "elem_of ` S.set a = S.Dom a"
+      proof -
+        have "S.set a = arr_of ` S.Dom a"
+        using a set_char by blast
+        moreover have "elem_of ` arr_of ` S.Dom a = S.Dom a"
+          using elem_of_arr_of by force
+        ultimately show ?thesis by presburger
       qed
-      hence "|hom unity a| =o |Dom a|"
-        using card_of_ordIsoI by auto
-      moreover have "|Dom a| <o \<AA>"
-        using assms ide_char by auto
-      ultimately show "|hom unity a| <o \<AA>"
-        using ordIso_ordLess_trans by auto
+      thus ?thesis
+        using a S.ide_char by auto
+    qed
+
+    lemma set_MkIde_elem_of_img:
+    assumes "A \<subseteq> S.Univ" and "S.ide (S.MkIde (elem_of ` A))"
+    shows "S.set (S.MkIde (elem_of ` A)) = A"
+    proof -
+      have "S.Dom (S.MkIde (elem_of ` A)) = elem_of ` A"
+        by simp
+      moreover have "arr_of ` elem_of ` A = A"
+        using assms arr_of_elem_of by force
+      ultimately show ?thesis
+        using assms Setp_elem_of_img set_char S.ide_MkIde by auto
+    qed
+
+    (*
+     * We need this result, which characterizes what sets of terminals correspond
+     * to sets.
+     *)
+    lemma set_img_Collect_ide_iff:
+    shows "A \<in> S.set ` Collect S.ide \<longleftrightarrow> A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
+    proof
+      show "A \<in> S.set ` Collect S.ide \<Longrightarrow> A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
+        using set_char arr_of_mapsto Setp_elem_of_img by auto
+      assume A: "A \<subseteq> S.Univ \<and> Setp (elem_of ` A)"
+      have "S.ide (S.MkIde (elem_of ` A))"
+        using A S.ide_MkIde by blast
+      moreover have "S.set (S.MkIde (elem_of ` A)) = A"
+        using A calculation set_MkIde_elem_of_img by presburger
+      ultimately show "A \<in> S.set ` Collect S.ide" by blast
     qed
 
     text\<open>
       The main result, which establishes the consistency of the \<open>set_category\<close> locale
       and provides us with a way of obtaining ``set categories'' at arbitrary types.
 \<close>
 
     theorem is_set_category:
-    shows "set_category comp \<AA>"
+    shows "set_category comp (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
     proof
-      show "\<exists>img :: 'e setcat.arr \<Rightarrow> 'e setcat.arr. set_category_given_img comp img \<AA>"
+      show "\<exists>img :: 'e setcat.arr \<Rightarrow> 'e setcat.arr.
+                       set_category_given_img comp img (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
       proof
-        show "set_category_given_img (comp :: 'e setcat.arr comp) IMG \<AA>"
+        show "set_category_given_img comp IMG (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A))"
         proof
-          show "Card_order \<AA> \<and> infinite (Field \<AA> )"
-            using cardinal by simp
-          show "Univ \<noteq> {}" using terminal_char by blast
+          show "S.Univ \<noteq> {}" using terminal_char by blast
           fix a :: "'e setcat.arr"
-          assume a: "ide a"
-          show "IMG \<in> hom unity a \<rightarrow> Univ" using IMG_point terminal_unity by blast
-          show "|hom unity a| <o \<AA>" using a card_points_less by simp
-          show "inj_on IMG (hom unity a)" using a inj_IMG terminal_unity by blast
+          assume a: "S.ide a"
+          show "S.set a \<subseteq> S.Univ \<and> Setp (elem_of ` S.set a)"
+            using a set_img_Collect_ide_iff by auto
+          show "inj_on IMG (S.hom S.unity a)" using a inj_IMG terminal_unity by blast
           next
           fix t :: "'e setcat.arr"
-          assume t: "terminal t"
-          show "t \<in> IMG ` hom unity t"
+          assume t: "S.terminal t"
+          show "t \<in> IMG ` S.hom S.unity t"
           proof -
-            have "t \<in> set t"
+            have "t \<in> S.set t"
               using t set_char [of t]
-              by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
-                  terminal_char terminal_def)
+              by (metis (mono_tags, lifting) S.Dom.simps(1) image_insert insertI1 arr_of_def
+                  terminal_char S.terminal_def)
             thus ?thesis
-              using t set_def [of t] by simp
+              using t S.set_def [of t] by simp
           qed
           next
-          fix A :: "'e setcat.arr set"
-          assume A: "A \<subseteq> Univ" and 0: "|A| <o \<AA>"
-          show "\<exists>a. ide a \<and> set a = A"
-          proof
-            let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x \<in> (DOWN ` A). x)"
-            show "ide ?a \<and> set ?a = A"
-            proof
-              have "|DOWN ` A| <o \<AA>"
-                using 0 card_of_image ordLeq_ordLess_trans by blast
-              thus 1: "ide ?a"
-                using ide_char [of ?a] by simp
-              show "set ?a = A"
-              proof -
-                have 2: "\<And>x. x \<in> A \<Longrightarrow> x = UP (DOWN x)"
-                  using A UP_DOWN by force
-                hence "UP ` DOWN ` A = A"
-                  using A UP_DOWN by auto
-                thus ?thesis
-                  using 1 A set_char [of ?a] by simp
-              qed
-            qed
-          qed
+          show "\<And>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A) \<Longrightarrow> \<exists>a. S.ide a \<and> S.set a = A"
+            using set_img_Collect_ide_iff by fast
           next
           fix a b :: "'e setcat.arr"
-          assume a: "ide a" and b: "ide b" and ab: "set a = set b"
+          assume a: "S.ide a" and b: "S.ide b" and ab: "S.set a = S.set b"
           show "a = b"
-            using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
+            using a b ab set_char inj_arr_of inj_image_eq_iff S.dom_char S.in_homE S.ide_in_hom
             by (metis (mono_tags, lifting))
           next
           fix f f' :: "'e setcat.arr"
-          assume par: "par f f'" and ff': "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
+          assume par: "S.par f f'" and ff': "\<And>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
           show "f = f'" using par ff' arr_eqI' by blast
           next
           fix a b :: "'e setcat.arr" and F :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
-          assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
-          show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
+          assume a: "S.ide a" and b: "S.ide b" and F: "F \<in> S.hom S.unity a \<rightarrow> S.hom S.unity b"
+          show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
           proof
-            let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)"
+            let ?f = "S.MkArr (S.Dom a) (S.Dom b) (\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U)"
             have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
             proof -
-              have "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)
-                      \<in> extensional (Dom a) \<inter> (Dom a \<rightarrow> Dom b)"
+              have "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U)
+                      \<in> extensional (S.Dom a) \<inter> (S.Dom a \<rightarrow> S.Dom b)"
               proof
-                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> extensional (Dom a)"
+                show "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U) \<in> extensional (S.Dom a)"
                   using a F by simp
-                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
+                show "(\<lambda>x \<in> S.Dom a. S.Map (F (MkElem (arr_of x) a)) U) \<in> S.Dom a \<rightarrow> S.Dom b"
                 proof
                   fix x
-                  assume x: "x \<in> Dom a"
-                  have "MkElem (UP x) a \<in> hom unity a"
-                    using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
-                  hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
+                  assume x: "x \<in> S.Dom a"
+                  have "MkElem (arr_of x) a \<in> S.hom S.unity a"
+                    using x a MkElem_in_hom [of a x] S.ide_char S.ideD(1-2) by force
+                  hence 1: "F (MkElem (arr_of x) a) \<in> S.hom S.unity b"
                     using F by auto
-                  moreover have "Dom (F (MkElem (UP x) a)) = {U}"
+                  moreover have "S.Dom (F (MkElem (arr_of x) a)) = {U}"
                     using 1 MkElem_IMG
-                    by (metis (mono_tags, lifting) Dom.simps(1))
-                  moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
-                    using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
-                  ultimately have "Map (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
-                    using arr_char [of "F (MkElem (UP x) a)"] by blast
-                  thus "Map (F (MkElem (UP x) a)) U \<in> Dom b" by blast
+                    by (metis (mono_tags, lifting) S.Dom.simps(1))
+                  moreover have "S.Cod (F (MkElem (arr_of x) a)) = S.Dom b"
+                    using 1 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
+                  ultimately have "S.Map (F (MkElem (arr_of x) a)) \<in> {U} \<rightarrow> S.Dom b"
+                    using arr_char [of "F (MkElem (arr_of x) a)"] by blast
+                  thus "S.Map (F (MkElem (arr_of x) a)) U \<in> S.Dom b" by blast
                 qed
               qed
-              hence "\<guillemotleft>?f : MkIde (Dom a) \<rightarrow> MkIde (Dom b)\<guillemotright>"
-                using a b MkArr_in_hom ide_char by blast
+              hence "\<guillemotleft>?f : S.MkIde (S.Dom a) \<rightarrow> S.MkIde (S.Dom b)\<guillemotright>"
+                using a b S.MkArr_in_hom S.ide_char by blast
               thus ?thesis
                 using a b by simp
             qed
-            moreover have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
+            moreover have "\<And>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
             proof -
               fix x
-              assume x: "\<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright>"
+              assume x: "\<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright>"
               have 2: "x = MkElem (IMG x) a"
                 using a x 1 MkElem_IMG [of x a]
-                by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
-              moreover have 5: "Dom x = {U} \<and> Cod x = Dom a \<and>
-                                Map x = (\<lambda>_ \<in> {U}. DOWN (IMG x))"
+                by (metis (mono_tags, lifting) S.in_homE mem_Collect_eq)
+              moreover have 5: "S.Dom x = {U} \<and> S.Cod x = S.Dom a \<and>
+                                S.Map x = (\<lambda>_ \<in> {U}. elem_of (IMG x))"
                 using x 2
-                by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
-              moreover have "Cod ?f = Dom b" using 1 by simp
+                by (metis (no_types, lifting) S.Cod.simps(1) S.Dom.simps(1) S.Map.simps(1))
+              moreover have "S.Cod ?f = S.Dom b" using 1 by simp
               ultimately have
                    3: "?f \<cdot> x =
-                       MkArr {U} (Dom b) (compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)))"
-                by (metis (no_types, lifting) "1" Map.simps(1) comp_MkArr in_homE x)
-              have 4: "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) = Map (F x)"
+                       S.MkArr {U} (S.Dom b) (compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)))"
+                by (metis (no_types, lifting) "1" S.Map.simps(1) S.comp_MkArr S.in_homE x)
+              have 4: "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) = S.Map (F x)"
               proof
                 fix y
                 have "y \<notin> {U} \<Longrightarrow>
-                        compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
+                        compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                 proof -
                   assume y: "y \<notin> {U}"
-                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = undefined"
+                  have "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = undefined"
                     using y compose_def extensional_arb by simp
-                  also have "... = Map (F x) y"
+                  also have "... = S.Map (F x) y"
                   proof -
-                    have 5: "F x \<in> hom unity b" using x F 1 by fastforce
-                    hence "Dom (F x) = {U}"
-                      by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
+                    have 5: "F x \<in> S.hom S.unity b" using x F 1 by fastforce
+                    hence "S.Dom (F x) = {U}"
+                      by (metis (mono_tags, lifting) "2" CollectD S.Dom.simps(1) S.in_hom_char x)
                     thus ?thesis
-                      using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
-                      by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
+                      using x y F 5 arr_char [of "F x"] extensional_arb [of "S.Map (F x)" "{U}" y]
+                      by (metis (mono_tags, lifting) CollectD Int_iff S.in_hom_char)
                   qed
                   ultimately show ?thesis by auto
                 qed
                 moreover have
                     "y \<in> {U} \<Longrightarrow>
-                       compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
+                       compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                 proof -
                   assume y: "y \<in> {U}"
-                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y =
-                        Map ?f (DOWN (IMG x))"
+                  have "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y =
+                        S.Map ?f (elem_of (IMG x))"
                     using y by (simp add: compose_eq restrict_apply')
-                  also have "... = (\<lambda>x. Map (F (MkElem (UP x) a)) U) (DOWN (IMG x))"
+                  also have "... = (\<lambda>x. S.Map (F (MkElem (arr_of x) a)) U) (elem_of (IMG x))"
                   proof -
-                    have "DOWN (IMG x) \<in> Dom a"
-                      using x y a 5 arr_char in_homE restrict_apply by force
+                    have "elem_of (IMG x) \<in> S.Dom a"
+                      using x y a 5 arr_char S.in_homE restrict_apply by force
                     thus ?thesis
                       using restrict_apply by simp
                   qed
-                  also have "... = Map (F x) y"
+                  also have "... = S.Map (F x) y"
                     using x y 1 2 MkElem_IMG [of x a] by simp
                   finally show
-                      "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
+                      "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                     by auto
                 qed
                 ultimately show
-                    "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
+                    "compose {U} (S.Map ?f) (\<lambda>_ \<in> {U}. elem_of (IMG x)) y = S.Map (F x) y"
                   by auto
               qed
               show "?f \<cdot> x = F x"
-              proof (intro arr_eqI)
-                have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by blast
-                have 6: "F x \<in> hom unity b"
+              proof (intro S.arr_eqI)
+                have 5: "?f \<cdot> x \<in> S.hom S.unity b" using 1 x by blast
+                have 6: "F x \<in> S.hom S.unity b"
                   using x F 1
-                  by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
-                show "arr (comp ?f x)" using 5 by blast
-                show "arr (F x)" using 6 by blast
-                show "Dom (comp ?f x) = Dom (F x)"
-                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
-                show "Cod (comp ?f x) = Cod (F x)"
-                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
-                show "Map (comp ?f x) = Map (F x)"
+                  by (metis (mono_tags, lifting) PiE S.in_homE mem_Collect_eq)
+                show "S.arr (comp ?f x)" using 5 by blast
+                show "S.arr (F x)" using 6 by blast
+                show "S.Dom (comp ?f x) = S.Dom (F x)"
+                  using 5 6 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
+                show "S.Cod (comp ?f x) = S.Cod (F x)"
+                  using 5 6 by (metis (mono_tags, lifting) CollectD S.in_hom_char)
+                show "S.Map (comp ?f x) = S.Map (F x)"
                   using 3 4 by simp
               qed
             qed
-            thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
+            thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : S.unity \<rightarrow> S.dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
               using 1 by blast
           qed
+          next
+          show "\<And>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A) \<Longrightarrow> A \<subseteq> S.Univ"
+            by simp
+          show "\<And>A' A. \<lbrakk>A' \<subseteq> A; A \<subseteq> S.Univ \<and> Setp (elem_of ` A)\<rbrakk> \<Longrightarrow> A' \<subseteq> S.Univ \<and> Setp (elem_of ` A')"
+            by (meson image_mono setcat.Setp_respects_subset setcat_axioms subset_trans)
+          show "\<And>A B. \<lbrakk>A \<subseteq> S.Univ \<and> Setp (elem_of ` A); B \<subseteq> S.Univ \<and> Setp (elem_of ` B)\<rbrakk>
+                         \<Longrightarrow> A \<union> B \<subseteq> S.Univ \<and> Setp (elem_of ` (A \<union> B))"
+            by (simp add: image_Un union_preserves_Setp)
         qed
       qed
     qed
 
     text\<open>
       \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
-      @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
+      @{typ 'a}, using @{term arr_of} as the required injection from @{typ 'a} to the universe
       of \<open>SetCat\<close>.
 \<close>
 
     corollary is_concrete_set_category:
-    shows "concrete_set_category comp \<AA> UNIV UP"
+    shows "concrete_set_category comp (\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A)) UNIV arr_of"
     proof -
-      interpret S: set_category comp \<AA> using is_set_category by auto
+      interpret S': set_category comp \<open>\<lambda>A. A \<subseteq> S.Univ \<and> Setp (elem_of ` A)\<close>
+        using is_set_category by auto
       show ?thesis
       proof
-        show 1: "UP \<in> UNIV \<rightarrow> S.Univ"
-          using UP_def terminal_char by force
-        show "inj_on UP UNIV"
-          using inj_UP by blast
+        show 1: "arr_of \<in> UNIV \<rightarrow> S'.Univ"
+          using arr_of_def terminal_char by force
+        show "inj_on arr_of UNIV"
+          using inj_arr_of by blast
       qed
     qed
 
     text\<open>
       As a consequence of the categoricity of the \<open>set_category\<close> axioms,
       if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
       the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
       to the category \<open>setcat\<close> of @{typ 'a} sets and functions between them constructed here.
 \<close>
 
     corollary set_category_iso_SetCat:
     fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'e"
-    assumes "set_category S \<AA>"
-    and "bij_betw \<phi> (Collect (category.terminal S)) UNIV"
-    shows "\<exists>\<Phi>. invertible_functor S (comp :: 'e setcat.arr comp) \<Phi>
-                 \<and> (\<forall>m. set_category.incl S \<AA> m \<longrightarrow> set_category.incl comp \<AA> (\<Phi> m))"
+    assumes "set_category S \<S>"
+    and "bij_betw \<phi> (set_category_data.Univ S) UNIV"
+    and "\<And>A. \<S> A \<longleftrightarrow> A \<subseteq> set_category_data.Univ S \<and> (arr_of \<circ> \<phi>) ` A \<in> S.set ` Collect S.ide"
+    shows "\<exists>\<Phi>. invertible_functor S comp \<Phi>
+                 \<and> (\<forall>m. set_category.incl S \<S> m
+                           \<longrightarrow> set_category.incl comp (\<lambda>A. A \<in> S.set ` Collect S.ide) (\<Phi> m))"
     proof -
-      interpret S: set_category S using assms by auto
-      let ?\<psi> = "inv_into S.Univ \<phi>"
-      have "bij_betw (UP o \<phi>) S.Univ (Collect terminal)"
+      interpret S': set_category S \<S> using assms by auto
+      let ?\<psi> = "inv_into S'.Univ \<phi>"
+      have "bij_betw (arr_of o \<phi>) S'.Univ S.Univ"
       proof (intro bij_betwI)
-        show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect terminal"
-          using assms(2) UP_mapsto by auto
-        show "?\<psi> o DOWN \<in> Collect terminal \<rightarrow> S.Univ"
+        show "arr_of o \<phi> \<in> S'.Univ \<rightarrow> Collect S.terminal"
+          using assms(2) arr_of_mapsto by auto
+        show "?\<psi> o elem_of \<in> S.Univ \<rightarrow> S'.Univ"
         proof
           fix x :: "'e setcat.arr"
-          assume x: "x \<in> Univ"
-          show "(inv_into S.Univ \<phi> \<circ> DOWN) x \<in> S.Univ"
+          assume x: "x \<in> S.Univ"
+          show "(inv_into S'.Univ \<phi> \<circ> elem_of) x \<in> S'.Univ"
             using x assms(2) bij_betw_def comp_apply inv_into_into
             by (metis UNIV_I)
         qed
         fix t
-        assume "t \<in> S.Univ"
-        thus "(?\<psi> o DOWN) ((UP o \<phi>) t) = t"
+        assume "t \<in> S'.Univ"
+        thus "(?\<psi> o elem_of) ((arr_of o \<phi>) t) = t"
           using assms(2) bij_betw_inv_into_left
-          by (metis comp_apply DOWN_UP)
+          by (metis comp_apply elem_of_arr_of)
         next
         fix t' :: "'e setcat.arr"
-        assume "t' \<in> Collect terminal"
-        thus "(UP o \<phi>) ((?\<psi> o DOWN) t') = t'"
+        assume "t' \<in> S.Univ"
+        thus "(arr_of o \<phi>) ((?\<psi> o elem_of) t') = t'"
           using assms(2) by (simp add: bij_betw_def f_inv_into_f)
       qed
       thus ?thesis
-        using assms(1) set_category_is_categorical [of S \<AA> comp "UP o \<phi>"] is_set_category
-        by auto
+        using assms is_set_category set_img_Collect_ide_iff
+              set_category_is_categorical
+                [of S \<S> comp "\<lambda>A. A \<in> S.set ` Collect S.ide" "arr_of o \<phi>"]
+        by simp
+    qed
+
+    sublocale category comp
+      using is_category by blast
+    sublocale set_category comp \<open>\<lambda>A. A \<subseteq> Collect S.terminal \<and> Setp (elem_of ` A)\<close>
+      using is_set_category set_img_Collect_ide_iff by simp
+    sublocale concrete_set_category comp \<open>\<lambda>A. A \<subseteq> Collect S.terminal \<and> Setp (elem_of ` A)\<close>
+                       UNIV arr_of
+      using is_concrete_set_category by simp
+
+  end
+
+  text\<open>
+    Here we discard the temporary interpretations \<open>S\<close>, leaving only the exported
+    definitions and facts.
+\<close>
+
+  context setcat
+  begin
+
+    text\<open>
+      We establish mappings to pass back and forth between objects and arrows of the category
+      and sets and functions on the underlying elements.
+\<close>
+
+    definition set_of_ide :: "'e setcat.arr \<Rightarrow> 'e set"
+    where "set_of_ide a \<equiv> elem_of ` set a"
+
+    definition ide_of_set :: "'e set \<Rightarrow> 'e setcat.arr"
+    where "ide_of_set A \<equiv> mkIde (arr_of ` A)"
+
+    lemma bij_betw_ide_set:
+    shows "set_of_ide \<in> Collect ide \<rightarrow> Collect Setp"
+    and "ide_of_set \<in> Collect Setp \<rightarrow> Collect ide"
+    and [simp]: "ide a \<Longrightarrow> ide_of_set (set_of_ide a) = a"
+    and [simp]: "Setp A \<Longrightarrow> set_of_ide (ide_of_set A) = A"
+    and "bij_betw set_of_ide (Collect ide) (Collect Setp)"
+    and "bij_betw ide_of_set (Collect Setp) (Collect ide)"
+    proof -
+      show 1: "set_of_ide \<in> Collect ide \<rightarrow> Collect Setp"
+        using setp_set_ide set_of_ide_def by auto
+      show 2: "ide_of_set \<in> Collect Setp \<rightarrow> Collect ide"
+      proof
+        fix A :: "'e set"
+        assume A: "A \<in> Collect Setp"
+        have "arr_of ` A \<subseteq> Univ"
+          using A arr_of_mapsto by auto
+        moreover have "Setp (elem_of ` arr_of ` A)"
+          using A elem_of_arr_of Setp_respects_subset by simp
+        ultimately have "ide (mkIde (arr_of ` A))"
+          using ide_mkIde by blast
+        thus "ide_of_set A \<in> Collect ide"
+          using ide_of_set_def by simp
+      qed
+      show 3: "\<And>a. ide a \<Longrightarrow> ide_of_set (set_of_ide a) = a"
+        using arr_of_img_elem_of_img ide_of_set_def mkIde_set set_of_ide_def setp_set_ide
+        by presburger
+      show 4: "\<And>A. Setp A \<Longrightarrow> set_of_ide (ide_of_set A) = A"
+      proof -
+        fix A :: "'e set"
+        assume A: "Setp A"
+        have "elem_of ` set (mkIde (arr_of ` A)) = elem_of ` arr_of ` A"
+        proof -
+          have "arr_of ` A \<subseteq> Univ"
+            using A arr_of_mapsto by blast
+          moreover have "Setp (elem_of ` arr_of ` A)"
+            using A by simp
+          ultimately have "set (mkIde (arr_of ` A)) = arr_of ` A"
+            using A set_mkIde by blast
+          thus ?thesis by auto
+        qed
+        also have "... = A"
+          using A elem_of_arr_of by force
+        finally show "set_of_ide (ide_of_set A) = A"
+          using ide_of_set_def set_of_ide_def by simp
+      qed
+      show "bij_betw set_of_ide (Collect ide) (Collect Setp)"
+        using 1 2 3 4
+        by (intro bij_betwI) blast+
+      show "bij_betw ide_of_set (Collect Setp) (Collect ide)"
+        using 1 2 3 4
+        by (intro bij_betwI) blast+
+    qed
+
+    definition fun_of_arr :: "'e setcat.arr \<Rightarrow> 'e \<Rightarrow> 'e"
+    where "fun_of_arr f \<equiv> restrict (elem_of o Fun f o arr_of) (elem_of `Dom f)"
+
+    definition arr_of_fun :: "'e set \<Rightarrow> 'e set \<Rightarrow> ('e \<Rightarrow> 'e) \<Rightarrow> 'e setcat.arr"
+    where "arr_of_fun A B F \<equiv> mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of)"
+
+    lemma bij_betw_hom_fun:
+    shows "fun_of_arr \<in> hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
+    and "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow> arr_of_fun A B \<in> (A \<rightarrow> B) \<rightarrow> hom (ide_of_set A) (ide_of_set B)"
+    and "f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
+    and "\<lbrakk>Setp A; Setp B; F \<in> A \<rightarrow> B; F \<in> extensional A\<rbrakk> \<Longrightarrow> fun_of_arr (arr_of_fun A B F) = F"
+    and "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> bij_betw fun_of_arr (hom a b)
+                             (extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b))"
+    and "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
+            bij_betw (arr_of_fun A B)
+                     (extensional A \<inter> (A \<rightarrow> B)) (hom (ide_of_set A) (ide_of_set B))"
+    proof -
+      show 1: "\<And>a b. fun_of_arr \<in>
+                        hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
+      proof
+        fix a b f
+        assume f: "f \<in> hom a b"
+        have Dom: "Dom f = arr_of ` set_of_ide a"
+          using f set_of_ide_def
+          by (metis (mono_tags, lifting) arr_dom arr_mkIde bij_betw_ide_set(3)
+              ide_dom ide_of_set_def in_homE mem_Collect_eq set_mkIde)
+        have Cod: "Cod f = arr_of ` set_of_ide b"
+          using f set_of_ide_def
+          by (metis (mono_tags, lifting) arr_cod arr_mkIde bij_betw_ide_set(3)
+              ide_cod ide_of_set_def in_homE mem_Collect_eq set_mkIde)
+        have "fun_of_arr f \<in> set_of_ide a \<rightarrow> set_of_ide b"
+        proof
+          fix x
+          assume x: "x \<in> set_of_ide a"
+          have 1: "arr_of x \<in> Dom f"
+            using x Dom by blast
+          hence "Fun f (arr_of x) \<in> Cod f"
+            using f Fun_mapsto Cod by blast
+          hence "elem_of (Fun f (arr_of x)) \<in> set_of_ide b"
+            using Cod by auto
+          hence "restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f) x \<in> set_of_ide b"
+            using 1 by force
+          thus "fun_of_arr f x \<in> set_of_ide b"
+            unfolding fun_of_arr_def by auto
+        qed
+        moreover have "fun_of_arr f \<in> extensional (set_of_ide a)"
+          unfolding fun_of_arr_def
+          using set_of_ide_def f by blast
+        ultimately show "fun_of_arr f \<in> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
+          by blast
+      qed
+      show 2: "\<And>A B. \<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
+                        arr_of_fun A B \<in> (A \<rightarrow> B) \<rightarrow> hom (ide_of_set A) (ide_of_set B)"
+      proof
+        fix x and A B :: "'e set"
+        assume A: "Setp A" and B: "Setp B"
+        assume x: "x \<in> A \<rightarrow> B"
+        show "arr_of_fun A B x \<in> hom (ide_of_set A) (ide_of_set B)"
+        proof
+          show "\<guillemotleft>arr_of_fun A B x : ide_of_set A \<rightarrow> ide_of_set B\<guillemotright>"
+          proof
+            show 1: "arr (arr_of_fun A B x)"
+            proof -
+              have "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
+                using A arr_of_mapsto elem_of_arr_of
+                by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2)
+                    ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
+              moreover have "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
+                using B arr_of_mapsto elem_of_arr_of
+                by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2)
+                    ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
+              moreover have "arr_of \<circ> x \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` B"
+                using x by auto
+              ultimately show ?thesis
+                unfolding arr_of_fun_def by blast
+            qed
+            show "dom (arr_of_fun A B x) = ide_of_set A"
+              using 1 dom_mkArr ide_of_set_def arr_of_fun_def by simp
+            show "cod (arr_of_fun A B x) = ide_of_set B"
+              using 1 cod_mkArr ide_of_set_def arr_of_fun_def by simp
+          qed
+        qed
+      qed
+      show 3: "\<And>a b f. f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
+      proof -
+        fix a b f
+        assume f: "f \<in> hom a b"
+        have 1: "Dom f = set a \<and> Cod f = set b"
+          using f by blast
+        have Dom: "Dom f \<subseteq> Univ \<and> Setp (elem_of ` Dom f)"
+          using setp_set_ide f ide_dom by blast
+        have Cod: "Cod f \<subseteq> Univ \<and> Setp (elem_of ` Cod f)"
+          using setp_set_ide f ide_cod by blast
+        have "mkArr (set a) (set b)
+                    (arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) =
+              mkArr (Dom f) (Cod f)
+                    (arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of)"
+          using 1 by simp
+        also have "... = mkArr (Dom f) (Cod f) (Fun f)"
+        proof (intro mkArr_eqI')
+          show 2: "\<And>x. x \<in> Dom f \<Longrightarrow>
+                         (arr_of \<circ>
+                            restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
+                              elem_of) x =
+                         Fun f x"
+          proof -
+            fix x
+            assume x: "x \<in> Dom f"
+            hence 1: "elem_of x \<in> elem_of ` Dom f"
+              by blast
+            have "(arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) x =
+                  arr_of (restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f) (elem_of x))"
+              by auto
+            also have "... = arr_of ((elem_of o Fun f o arr_of) (elem_of x))"
+              using 1 by auto
+            also have "... = arr_of (elem_of (Fun f (arr_of (elem_of x))))"
+              by auto
+            also have "... = arr_of (elem_of (Fun f x))"
+              using x arr_of_elem_of \<open>Dom f \<subseteq> Univ \<and> Setp (elem_of ` Dom f)\<close> by auto
+            also have "... = Fun f x"
+              using x f Dom Cod Fun_mapsto arr_of_elem_of [of "Fun f x"] by blast
+            finally show "(arr_of \<circ>
+                             restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
+                               elem_of) x =
+                          Fun f x"
+              by blast
+          qed
+          have "arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of
+                  \<in> Dom f \<rightarrow> Cod f"
+          proof
+            fix x
+            assume x: "x \<in> Dom f"
+            have "(arr_of \<circ> restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ> elem_of) x =
+                  Fun f x"
+              using 2 x by blast
+            moreover have "... \<in> Cod f"
+              using f x Fun_mapsto by blast
+            ultimately show "(arr_of \<circ>
+                                restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
+                                  elem_of) x
+                               \<in> Cod f"
+              by argo
+          qed
+          thus "arr (mkArr (Dom f) (Cod f)
+                           (arr_of \<circ>
+                              restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
+                                elem_of))"
+            using Dom Cod by blast
+        qed
+        finally have "mkArr (set a) (set b)
+                            (arr_of \<circ>
+                               restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) \<circ>
+                                 elem_of) = f"
+          using f mkArr_Fun
+          by (metis (no_types, lifting) in_homE mem_Collect_eq)
+        thus "arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
+          using 1 f
+          by (metis (no_types, lifting) Cod Dom arr_of_img_elem_of_img arr_of_fun_def
+              fun_of_arr_def set_of_ide_def)
+      qed
+      show 4: "\<And>A B F. \<lbrakk>Setp A; Setp B; F \<in> A \<rightarrow> B; F \<in> extensional A\<rbrakk>
+                          \<Longrightarrow> fun_of_arr (arr_of_fun A B F) = F"
+      proof
+        fix F and A B :: "'e set"
+        assume A: "Setp A" and B: "Setp B"
+        assume F: "F \<in> A \<rightarrow> B" and ext: "F \<in> extensional A"
+        have 4: "arr (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of))"
+        proof -
+          have "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
+            using A
+            by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
+                ide_of_set_def incl_def mem_Collect_eq)
+          moreover have "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
+            using B
+            by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
+                ide_of_set_def incl_def mem_Collect_eq)
+          moreover have "arr_of \<circ> F \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` B"
+            using F by auto
+          ultimately show ?thesis by blast
+        qed
+        show "\<And>x. fun_of_arr (arr_of_fun A B F) x = F x"
+        proof -
+          fix x
+          have "fun_of_arr (arr_of_fun A B F) x =
+                restrict (elem_of \<circ>
+                            Fun (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) \<circ>
+                              arr_of) A x"
+          proof -
+            have "elem_of ` Dom (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) = A"
+              using A 4 elem_of_arr_of dom_mkArr set_of_ide_def bij_betw_ide_set(4) ide_of_set_def
+              by auto
+            thus ?thesis
+              using arr_of_fun_def fun_of_arr_def by auto
+          qed
+          also have "... = F x"
+          proof (cases "x \<in> A")
+            show "x \<notin> A \<Longrightarrow> ?thesis"
+              using ext extensional_arb by fastforce
+            assume x: "x \<in> A"
+            show "restrict
+                    (elem_of \<circ>
+                       Fun (mkArr (arr_of ` A) (arr_of ` B) (arr_of \<circ> F \<circ> elem_of)) \<circ>
+                         arr_of) A x =
+                  F x"
+              using x 4 Fun_mkArr by simp
+          qed
+          finally show "fun_of_arr (arr_of_fun A B F) x = F x"
+            by blast
+        qed
+      qed
+      show "\<lbrakk>Setp A; Setp B\<rbrakk> \<Longrightarrow>
+               bij_betw (arr_of_fun A B) (extensional A \<inter> (A \<rightarrow> B))
+                        (hom (ide_of_set A) (ide_of_set B))"
+      proof -
+        assume A: "Setp A" and B: "Setp B"
+        have "ide (ide_of_set A) \<and> ide (ide_of_set B)"
+          using A B bij_betw_ide_set(2) by auto
+        have "set_of_ide (ide_of_set A) = A \<and> set_of_ide (ide_of_set B) = B"
+          using A B by simp
+        show ?thesis
+          using A B 1 [of "ide_of_set A" "ide_of_set B"] 2 3 4
+          apply (intro bij_betwI)
+             apply auto
+           apply blast
+          by fastforce
+      qed
+      show "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> bij_betw fun_of_arr (hom a b)
+                                (extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b))"
+      proof (intro bij_betwI)
+        assume a: "ide a" and b: "ide b"
+        show "fun_of_arr \<in> hom a b \<rightarrow> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b)"
+          using 1 by blast
+        show "arr_of_fun (set_of_ide a) (set_of_ide b) \<in>
+               extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b) \<rightarrow> hom a b"
+          using a b 2 [of "set_of_ide a" "set_of_ide b"] setp_set_ide set_of_ide_def
+                bij_betw_ide_set(3)
+          by auto
+        show "\<And>f. f \<in> hom a b \<Longrightarrow> arr_of_fun (set_of_ide a) (set_of_ide b) (fun_of_arr f) = f"
+          using a b 3 by blast
+        show "\<And>F. F \<in> extensional (set_of_ide a) \<inter> (set_of_ide a \<rightarrow> set_of_ide b) \<Longrightarrow>
+                    fun_of_arr (arr_of_fun (set_of_ide a) (set_of_ide b) F) = F"
+          using a b 4 [of "set_of_ide a" "set_of_ide b"]
+          by (metis (no_types, lifting) IntE set_of_ide_def setp_set_ide)
+      qed
+    qed
+
+    lemma fun_of_arr_ide:
+    assumes "ide a"
+    shows "fun_of_arr a = restrict id (elem_of ` Dom a)"
+    proof
+      fix x
+      show "fun_of_arr a x = restrict id (elem_of ` Dom a) x"
+      proof (cases "x \<in> elem_of ` Dom a")
+        show "x \<notin> elem_of ` Dom a \<Longrightarrow> ?thesis"
+          using fun_of_arr_def extensional_arb by auto
+        assume x: "x \<in> elem_of ` Dom a"
+        have "fun_of_arr a x = restrict (elem_of \<circ> Fun a \<circ> arr_of) (elem_of ` Dom a) x"
+          using x fun_of_arr_def by simp
+        also have "... = elem_of (Fun a (arr_of x))"
+          using x by auto
+        also have "... = elem_of ((\<lambda>x\<in>set a. x) (arr_of x))"
+          using assms x Fun_ide by auto
+        also have "... = elem_of (arr_of x)"
+        proof -
+          have "x \<in> elem_of ` set a"
+            using assms x ideD(2) by force
+          hence "arr_of x \<in> set a"
+            by (metis (mono_tags, lifting) arr_of_img_elem_of_img assms image_eqI setp_set_ide)
+          thus ?thesis by simp
+        qed
+        also have "... = x"
+          by simp
+        also have "... = restrict id (elem_of ` Dom a) x"
+          using x by auto
+        finally show ?thesis by blast
+      qed
+    qed
+
+    lemma arr_of_fun_id:
+    assumes "Setp A"
+    shows "arr_of_fun A A (restrict id A) = ide_of_set A"
+    proof -
+      have A: "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
+        using assms elem_of_arr_of
+        by (metis (no_types, lifting) PiE arr_mkIde bij_betw_ide_set(2) ide_implies_incl
+            ide_of_set_def incl_def mem_Collect_eq)
+      have "arr_of_fun A A (restrict id A) =
+            mkArr (arr_of ` A) (arr_of ` A) (arr_of \<circ> restrict id A \<circ> elem_of)"
+        unfolding arr_of_fun_def by simp
+      also have "... = mkArr (arr_of ` A) (arr_of ` A) (\<lambda>x. x)"
+        using A arr_mkArr
+        by (intro mkArr_eqI') auto
+      also have "... = ide_of_set A"
+        using A ide_of_set_def mkIde_as_mkArr by simp
+      finally show ?thesis by blast
+    qed
+
+    lemma fun_of_arr_comp:
+    assumes "f \<in> hom a b" and "g \<in> hom b c"
+    shows "fun_of_arr (comp g f) = restrict (fun_of_arr g \<circ> fun_of_arr f) (set_of_ide a)"
+    proof -
+      have 1: "seq g f"
+        using assms by blast
+      have "fun_of_arr (comp g f) =
+            restrict (elem_of \<circ> Fun (comp g f) \<circ> arr_of) (elem_of ` Dom (comp g f))"
+        unfolding fun_of_arr_def by blast
+      also have "... = restrict (elem_of \<circ> Fun (comp g f) \<circ> arr_of) (elem_of ` Dom f)"
+        using assms dom_comp seqI' by auto
+      also have "... = restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of)
+                                (elem_of ` Dom f)"
+        using 1 Fun_comp by auto
+      also have "... = restrict (restrict (elem_of o Fun g o arr_of) (elem_of ` Dom g) \<circ>
+                                   restrict (elem_of o Fun f o arr_of) (elem_of ` Dom f))
+                                (elem_of ` Dom f)"
+      proof
+        fix x
+        show "restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of) (elem_of ` Dom f) x =
+              restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
+                          restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
+                       (elem_of ` Dom f) x"
+        proof (cases "x \<in> elem_of ` Dom f")
+          show "x \<notin> elem_of ` Dom f \<Longrightarrow> ?thesis"
+            by auto
+          assume x: "x \<in> elem_of ` Dom f"
+          have 2: "arr_of x \<in> Dom f"
+          proof -
+            have "arr_of x \<in> arr_of ` elem_of ` Dom f"
+              using x by simp
+            thus ?thesis
+              by (metis (no_types, lifting) 1 arr_of_img_elem_of_img ide_dom seqE setp_set_ide)
+          qed
+          have 3: "Dom g = Cod f"
+            using assms by fastforce
+          have "restrict (elem_of \<circ> restrict (Fun g \<circ> Fun f) (Dom f) \<circ> arr_of) (elem_of ` Dom f) x =
+                elem_of (Fun g (Fun f (arr_of x)))"
+            using x 2 by simp
+          also have "... = restrict
+                             (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
+                                restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
+                             (elem_of ` Dom f) x"
+          proof -
+            have "restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
+                              restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
+                           (elem_of ` Dom f) x =
+                  elem_of (Fun g (Fun f (arr_of x)))"
+            proof -
+              have "restrict (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) \<circ>
+                                restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f))
+                             (elem_of ` Dom f) x =
+                    (restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g) o
+                       restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f)) x"
+                using 2 by force
+              also have "... = restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g)
+                                 (restrict (elem_of \<circ> Fun f \<circ> arr_of) (elem_of ` Dom f) x)"
+                by simp
+              also have "... = restrict (elem_of \<circ> Fun g \<circ> arr_of) (elem_of ` Dom g)
+                                 (elem_of (Fun f (arr_of x)))"
+                using 2 by force
+              also have "... = (elem_of o Fun g o arr_of) (elem_of (Fun f (arr_of x)))"
+              proof -
+                have "elem_of (Fun f (arr_of x)) \<in> elem_of ` Dom g"
+                  using assms 2 3 Fun_mapsto [of f] by blast
+                thus ?thesis by simp
+              qed
+              also have "... = elem_of (Fun g (arr_of (elem_of (Fun f (arr_of x)))))"
+                by simp
+              also have "... = elem_of (Fun g (Fun f (arr_of x)))"
+              proof -
+                have "Fun f (arr_of x) \<in> Univ"
+                  using assms 2 setp_set_ide ide_cod Fun_mapsto by blast
+                thus ?thesis
+                  using 2 by simp
+              qed
+              finally show ?thesis by blast
+            qed
+            thus ?thesis by simp
+          qed
+          finally show ?thesis by blast
+        qed
+      qed
+      also have "... = restrict (fun_of_arr g o fun_of_arr f) (elem_of ` Dom f)"
+        unfolding fun_of_arr_def by blast
+      finally show ?thesis
+        unfolding set_of_ide_def
+        using assms by blast
+    qed
+
+    lemma arr_of_fun_comp:
+    assumes "Setp A" and "Setp B" and "Setp C"
+    and "F \<in> extensional A \<inter> (A \<rightarrow> B)" and "G \<in> extensional B \<inter> (B \<rightarrow> C)"
+    shows "arr_of_fun A C (G o F) = comp (arr_of_fun B C G) (arr_of_fun A B F)"
+    proof -
+      have A: "arr_of ` A \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` A)"
+        using assms elem_of_arr_of
+        by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
+            ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
+      have B: "arr_of ` B \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` B)"
+        using assms elem_of_arr_of
+        by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
+            ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
+      have C: "arr_of ` C \<subseteq> Univ \<and> Setp (elem_of ` arr_of ` C)"
+        using assms elem_of_arr_of
+        by (metis (no_types, lifting) Pi_iff arr_mkIde bij_betw_ide_set(2)
+            ide_implies_incl ide_of_set_def incl_def mem_Collect_eq)
+      have "arr_of_fun A C (G o F) = mkArr (arr_of ` A) (arr_of ` C) (arr_of \<circ> (G \<circ> F) \<circ> elem_of)"
+        unfolding arr_of_fun_def by simp
+      also have "... = mkArr (arr_of ` A) (arr_of ` C)
+                             ((arr_of \<circ> G \<circ> elem_of) o (arr_of o F \<circ> elem_of))"
+      proof (intro mkArr_eqI')
+        show "arr (mkArr (arr_of ` A) (arr_of ` C) (arr_of \<circ> (G \<circ> F) \<circ> elem_of))"
+        proof -
+          have "arr_of \<circ> (G \<circ> F) \<circ> elem_of \<in> arr_of ` A \<rightarrow> arr_of ` C"
+            using assms by force
+          thus ?thesis
+            using A B C by blast
+        qed
+        show "\<And>x. x \<in> arr_of ` A \<Longrightarrow>
+                    (arr_of \<circ> (G \<circ> F) \<circ> elem_of) x =
+                    ((arr_of \<circ> G \<circ> elem_of) o (arr_of o F \<circ> elem_of)) x"
+          by simp
+      qed
+      also have "... = comp (mkArr (arr_of ` B) (arr_of ` C) (arr_of \<circ> G \<circ> elem_of))
+                            (mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of))"
+      proof -
+        have "arr (mkArr (arr_of ` B) (arr_of ` C) (arr_of \<circ> G \<circ> elem_of))"
+          using assms B C elem_of_arr_of by fastforce
+        moreover have "arr (mkArr (arr_of ` A) (arr_of ` B) (arr_of o F o elem_of))"
+          using assms A B elem_of_arr_of by fastforce
+        ultimately show ?thesis
+          using comp_mkArr by auto
+      qed
+      also have "... = comp (arr_of_fun B C G) (arr_of_fun A B F)"
+        using arr_of_fun_def by presburger
+      finally show ?thesis by blast
     qed
 
   end
 
-  sublocale setcat \<subseteq> set_category comp \<AA>
-    using is_set_category by simp
-  sublocale setcat \<subseteq> concrete_set_category comp \<AA> UNIV UP
-    using is_concrete_set_category by simp
-
   text\<open>
-    By using a large enough cardinal, we can effectively eliminate the cardinality constraint
-    on the sets that determine objects and thereby obtain a set category that is replete.
-    This is the normal use case, which we want to streamline as much as possible,
+    When there is no restriction on the sets that determine objects, the resulting set category
+    is replete.  This is the normal use case, which we want to streamline as much as possible,
     so it is useful to introduce a special locale for this purpose.
   \<close>
 
   locale replete_setcat =
   fixes dummy :: 'e
   begin
 
-    interpretation SC: setcat dummy
-                         \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
+    interpretation SC: setcat dummy \<open>\<lambda>_. True\<close>
     proof
-      show "Card_order (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)) \<and>
-            infinite (Field (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)))"
-      by (metis Card_order_cmax Field_natLeq cardSuc_Card_order cardSuc_finite
-          card_of_Card_order finite_cmax infinite_UNIV_char_0 natLeq_Card_order)
+      show True by blast
     qed
 
-    text\<open>
-      We don't want to expose the concrete details of the construction used to obtain
-      the interpretation \<open>SC\<close>; instead, we want any facts proved about it to be derived
-      solely from the assumptions of the @{locale set_category} locales.
-      So we create another level of definitions here.
-    \<close>
-
     definition comp
     where "comp \<equiv> SC.comp"
 
-    definition UP
-    where "UP \<equiv> SC.UP"
-
-    definition DOWN
-    where "DOWN \<equiv> SC.DOWN"
-
-    sublocale set_category comp \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
-      using SC.is_set_category comp_def by simp
+    definition arr_of
+    where "arr_of \<equiv> SC.arr_of"
 
-    sublocale concrete_set_category comp
-                \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close> UNIV UP
-      using SC.is_concrete_set_category comp_def UP_def by simp
-
-    sublocale replete_set_category comp ..
+    definition elem_of
+    where "elem_of \<equiv> SC.elem_of"
 
-    lemma UP_mapsto:
-    shows "UP \<in> UNIV \<rightarrow> Univ"
-      using SC.UP_mapsto
-      by (simp add: UP_def comp_def)
+    sublocale replete_set_category comp
+      unfolding comp_def
+      using SC.set_img_Collect_ide_iff SC.set_category_given_img_axioms
+      by unfold_locales auto
 
-    lemma DOWN_mapsto:
-    shows "DOWN \<in> Univ \<rightarrow> UNIV"
+    sublocale concrete_set_category comp setp UNIV arr_of
+      using SC.is_concrete_set_category comp_def SC.set_img_Collect_ide_iff arr_of_def
       by auto
 
-    lemma DOWN_UP [simp]:
-    shows "DOWN (UP x) = x"
-      by (simp add: DOWN_def UP_def)
+    lemma bij_arr_of:
+    shows "bij_betw arr_of UNIV Univ"
+      using SC.bij_arr_of comp_def arr_of_def by presburger
 
-    lemma UP_DOWN [simp]:
-    assumes "t \<in> Univ"
-    shows "UP (DOWN t) = t"
-      using assms DOWN_def UP_def
-      by (simp add: DOWN_def UP_def comp_def)
-
-    lemma inj_UP:
-    shows "inj UP"
-      by (metis DOWN_UP injI)
-
-    lemma bij_UP:
-    shows "bij_betw UP UNIV Univ"
-      by (metis SC.bij_UP UP_def comp_def)
+    lemma bij_elem_of:
+    shows "bij_betw elem_of Univ UNIV"
+      using SC.bij_elem_of comp_def elem_of_def by auto
 
   end
 
 end
 
diff --git a/thys/Category3/SetCategory.thy b/thys/Category3/SetCategory.thy
--- a/thys/Category3/SetCategory.thy
+++ b/thys/Category3/SetCategory.thy
@@ -1,2475 +1,2676 @@
 (*  Title:       SetCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter SetCategory
 
 theory SetCategory
-imports Category Functor "HOL-Cardinals.Cardinals"
+imports Category Functor Subcategory
 begin
 
   text\<open>
     This theory defines a locale \<open>set_category\<close> that axiomatizes the notion
     ``category of @{typ 'a}-sets and functions between them'' in the context of HOL.
     A primary reason for doing this is to make it possible to prove results
     (such as the Yoneda Lemma) that use such categories without having to commit to a
     particular element type @{typ 'a} and without having the results depend on the
     concrete details of a particular construction.
     The axiomatization given here is categorical, in the sense that if categories
     @{term S} and @{term S'} each interpret the \<open>set_category\<close> locale,
     then a bijection between the sets of terminal objects of @{term S} and @{term S'}
     extends to an isomorphism of @{term S} and @{term S'} as categories.
 
     The axiomatization is based on the following idea: if, for some type @{typ 'a},
     category @{term S} is the category of all @{typ 'a}-sets and functions between
     them, then the elements of type @{typ 'a} are in bijective correspondence with
     the terminal objects of category @{term S}.  In addition, if @{term unity}
     is an arbitrarily chosen terminal object of @{term S}, then for each object @{term a},
     the hom-set @{term "hom unity a"} (\emph{i.e.} the set of ``points'' or
     ``global elements'' of @{term a}) is in bijective correspondence with a subset
     of the terminal objects of @{term S}.  By making a specific, but arbitrary,
     choice of such a correspondence, we can then associate with each object @{term a}
     of @{term S} a set @{term "set a"} that consists of all terminal objects @{term t}
     that correspond to some point @{term x} of @{term a}.  Each arrow @{term f}
     then induces a function \<open>Fun f \<in> set (dom f) \<rightarrow> set (cod f)\<close>,
     defined on terminal objects of @{term S} by passing to points of @{term "dom f"},
     composing with @{term f}, then passing back from points of @{term "cod f"}
     to terminal objects.  Once we can associate a set with each object of @{term S}
     and a function with each arrow, we can force @{term S} to be isomorphic to the
     category of @{typ 'a}-sets by imposing suitable extensionality and completeness axioms.
 \<close>
  
   section "Some Lemmas about Restriction"
 
     text\<open>
       \sloppypar
       The development of the \<open>set_category\<close> locale makes heavy use of the
       theory @{theory "HOL-Library.FuncSet"}.  However, in some cases, I found that
       that theory did not provide results about restriction in the form that was
       most useful to me. I used the following additional results in various places.
 \<close>
 
   (* This variant of FuncSet.restrict_ext is sometimes useful. *)
 
   lemma restr_eqI:
   assumes "A = A'" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
   shows "restrict F A = restrict F' A'"
     using assms by force
 
   (* This rule avoided a long proof in at least one instance
      where FuncSet.restrict_apply did not work.
    *)
   lemma restr_eqE [elim]:
   assumes "restrict F A = restrict F' A" and "x \<in> A"
   shows "F x = F' x"
     using assms restrict_def by metis
 
   (* This seems more useful than compose_eq in FuncSet. *)
   lemma compose_eq' [simp]:
   shows "compose A G F = restrict (G o F) A"
     unfolding compose_def restrict_def by auto
 
   section "Set Categories"
 
   text\<open>
     We first define the locale \<open>set_category_data\<close>, which sets out the basic
     data and definitions for the \<open>set_category\<close> locale, without imposing any conditions
     other than that @{term S} is a category and that @{term img} is a function defined
     on the arrow type of @{term S}.  The function @{term img} should be thought of
     as a mapping that takes a point @{term "x \<in> hom unity a"} to a corresponding
     terminal object @{term "img x"}.  Eventually, assumptions will be introduced so
-    that this is in fact the case.
+    that this is in fact the case.  The set of terminal objects of the category will
+    serve as abstract ``elements'' of sets; we will refer to the set of \emph{all}
+    terminal objects as the \emph{universe}.
 \<close>
 
   locale set_category_data = category S
   for S :: "'s comp"      (infixr "\<cdot>" 55)
   and img :: "'s \<Rightarrow> 's"
   begin
 
     notation in_hom       ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text\<open>
       Call the set of all terminal objects of S the ``universe''.
 \<close>
     abbreviation Univ :: "'s set"
     where "Univ \<equiv> Collect terminal"
   
     text\<open>
       Choose an arbitrary element of the universe and call it @{term unity}.
 \<close>
     definition unity :: 's
     where "unity = (SOME t. terminal t)"
     
     text\<open>
       Each object @{term a} determines a subset @{term "set a"} of the universe,
       consisting of all those terminal objects @{term t} such that @{term "t = img x"}
       for some @{term "x \<in> hom unity a"}.
 \<close>
     definition set :: "'s \<Rightarrow> 's set"
     where "set a = img ` hom unity a"
 
   end
 
   text\<open>
     Next, we define a locale \<open>set_category_given_img\<close> that augments the
     \<open>set_category_data\<close> locale with assumptions that serve to define
     the notion of a set category with a chosen correspondence between points
     and terminal objects.  The assumptions require that the universe be nonempty
     (so that the definition of @{term unity} makes sense), that the map
     @{term img} is a locally injective map taking points to terminal objects,
     that each terminal object @{term t} belongs to @{term "set t"},
     that two objects of @{term S} are equal if they determine the same set,
     that two parallel arrows of @{term S} are equal if they determine the same
-    function, that there is an object corresponding to each subset of the universe
-    whose cardinality is less than a specified cardinal \<open>\<AA>\<close>, and that for any objects
-    @{term a} and @{term b} and function @{term "F \<in> hom unity a \<rightarrow> hom unity b"}
-    there is an arrow @{term "f \<in> hom a b"} whose action under the composition
-    of @{term S} coincides with the function @{term F}.
+    function, and that for any objects @{term a} and @{term b} and function
+    @{term "F \<in> hom unity a \<rightarrow> hom unity b"} there is an arrow @{term "f \<in> hom a b"}
+    whose action under the composition of @{term S} coincides with the function @{term F}.
 
-    The cardinal \<open>\<AA>\<close>, which is given as a parameter to the locale, has been introduced
-    because most of the familiar properties of a set category do not depend on
-    there being an object corresponding to \emph{every} subset of the universe,
-    and we would like to consider such situations; for example, the situation in
-    which there only \emph{finite} subsets determine objects.
+    The parameter @{term setp} is a predicate that determines which subsets of the
+    universe are to be regarded as defining objects of the category.  This parameter
+    has been introduced because most of the characteristic properties of a category
+    of sets and functions do not depend on there being an object corresponding to
+    \emph{every} subset of the universe, and we intend to consider in particular the
+    cases in which only finite subsets or only ``small'' subsets of the universe
+    determine objects.  Accordingly, we assume that there is an object corresponding
+    to each subset of the universe that satisfies @{term setp}.
+    It is also necessary to assume some basic regularity properties of the predicate
+    @{term setp}; namely, that it holds for all subsets of the universe corresponding
+    to objects of @{term S}, and that it respects subset and union.
 \<close>
     
   locale set_category_given_img = set_category_data S img
   for S :: "'s comp"      (infixr "\<cdot>" 55)
   and img :: "'s \<Rightarrow> 's"
-  and \<AA> :: "'t rel" +
-  assumes nonempty_Univ: "Univ \<noteq> {}"
-  and img_mapsto: "ide a \<Longrightarrow> img \<in> hom unity a \<rightarrow> Univ"
-  and card_points: "ide a \<Longrightarrow> |hom unity a| <o \<AA>"
+  and setp :: "'s set \<Rightarrow> bool" +
+  assumes setp_imp_subset_Univ: "setp A \<Longrightarrow> A \<subseteq> Univ"
+  and setp_set_ide: "ide a \<Longrightarrow> setp (set a)"
+  and setp_respects_subset: "A' \<subseteq> A \<Longrightarrow> setp A \<Longrightarrow> setp A'"
+  and setp_respects_union: "\<lbrakk> setp A; setp B \<rbrakk> \<Longrightarrow> setp (A \<union> B)"
+  and nonempty_Univ: "Univ \<noteq> {}"
   and inj_img: "ide a \<Longrightarrow> inj_on img (hom unity a)"
   and stable_img: "terminal t \<Longrightarrow> t \<in> img ` hom unity t"
   and extensional_set: "\<lbrakk> ide a; ide b; set a = set b \<rbrakk> \<Longrightarrow> a = b"
   and extensional_arr: "\<lbrakk> par f f'; \<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x \<rbrakk> \<Longrightarrow> f = f'"
-  and set_complete: "\<lbrakk> A \<subseteq> Univ; |A| <o \<AA> \<rbrakk> \<Longrightarrow> \<exists>a. ide a \<and> set a = A"
-  and fun_complete1: "\<lbrakk> ide a; ide b; F \<in> hom unity a \<rightarrow> hom unity b \<rbrakk>
-                          \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
-  and cardinal: "Card_order \<AA> \<and> infinite (Field \<AA>)"
+  and set_complete: "setp A \<Longrightarrow> \<exists>a. ide a \<and> set a = A"
+  and fun_complete_ax: "\<lbrakk> ide a; ide b; F \<in> hom unity a \<rightarrow> hom unity b \<rbrakk>
+                            \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
   begin
 
-    text\<open>
-      The inverse of the map @{term set} is a map @{term mkIde} that takes each subset
-      of the universe of cardinality less than \<open>\<AA>\<close> to an identity of @{term[source=true] S}.
-\<close>
-    definition mkIde :: "'s set \<Rightarrow> 's"
-    where "mkIde A = (if A \<subseteq> Univ \<and> |A| <o \<AA> then inv_into (Collect ide) set A else null)"
+    lemma setp_singleton:
+    assumes "terminal a"
+    shows "setp {a}"
+      using assms
+      by (metis setp_set_ide Set.set_insert Un_upper1 insert_is_Un set_def
+          setp_respects_subset stable_img terminal_def)
+
+    lemma setp_empty:
+    shows "setp {}"
+      using setp_singleton setp_respects_subset nonempty_Univ by blast
+
+    lemma finite_imp_setp:
+    assumes "A \<subseteq> Univ" and "finite A"
+    shows "setp A"
+      using setp_empty setp_singleton setp_respects_union
+      by (metis assms(1-2) finite_subset_induct insert_is_Un mem_Collect_eq)
 
     text\<open>
       Each arrow @{term "f \<in> hom a b"} determines a function @{term "Fun f \<in> Univ \<rightarrow> Univ"},
       by passing from @{term Univ} to @{term "hom a unity"}, composing with @{term f},
       then passing back to @{term Univ}.
 \<close>
 
     definition Fun :: "'s \<Rightarrow> 's \<Rightarrow> 's"
     where "Fun f = restrict (img o S f o inv_into (hom unity (dom f)) img) (set (dom f))"
 
     lemma comp_arr_point:
     assumes "arr f" and "\<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright>"
     shows "f \<cdot> x = inv_into (hom unity (cod f)) img (Fun f (img x))"
     proof -
       have "\<guillemotleft>f \<cdot> x : unity \<rightarrow> cod f\<guillemotright>"
         using assms by blast
       thus ?thesis
         using assms Fun_def inj_img set_def by simp
     qed
       
     text\<open>
       Parallel arrows that determine the same function are equal.
 \<close>
 
     lemma arr_eqI:
     assumes "par f f'" and "Fun f = Fun f'"
     shows "f = f'"
       using assms comp_arr_point extensional_arr by metis
 
     lemma terminal_unity:
     shows "terminal unity"
       using unity_def nonempty_Univ by (simp add: someI_ex)
 
     lemma ide_unity [simp]:
     shows "ide unity"
       using terminal_unity terminal_def by blast
 
-    lemma set_subset_Univ [simp]:
+    lemma setp_set' [simp]:
     assumes "ide a"
-    shows "set a \<subseteq> Univ"
-      using assms set_def img_mapsto by auto
+    shows "setp (set a)"
+      using assms setp_set_ide by auto
   
     lemma inj_on_set:
     shows "inj_on set (Collect ide)"
       using extensional_set by (intro inj_onI, auto)
       
     text\<open>
-      The mapping @{term mkIde}, which takes subsets of the universe to identities,
-      and @{term set}, which takes identities to subsets of the universe, are inverses.
+      The inverse of the map @{term set} is a map @{term mkIde} that takes each subset
+      of the universe to an identity of @{term[source=true] S}.
 \<close>
-
-    lemma set_card:
-    assumes "ide a"
-    shows "|set a| <o \<AA>"
-      using assms card_points set_def
-      by (metis card_of_image ordLeq_ordLess_trans)
+    definition mkIde :: "'s set \<Rightarrow> 's"
+    where "mkIde A = (if setp A then inv_into (Collect ide) set A else null)"
 
     lemma mkIde_set [simp]:
     assumes "ide a"
     shows "mkIde (set a) = a"
-      using assms mkIde_def inj_on_set inv_into_f_f set_card
-      by (simp add: ordLess_imp_ordLeq)
+      by (simp add: assms inj_on_set mkIde_def)
 
-    lemma set_mkIde:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma set_mkIde [simp]:
+    assumes "setp A"
     shows "set (mkIde A) = A"
       using assms mkIde_def set_complete someI_ex [of "\<lambda>a. a \<in> Collect ide \<and> set a = A"]
-      by (metis set_category_given_img.mkIde_set set_category_given_img_axioms)
+            mkIde_set
+      by metis
       
-    lemma ide_mkIde:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma ide_mkIde [simp]:
+    assumes "setp A"
     shows "ide (mkIde A)"
       using assms mkIde_def mkIde_set set_complete by metis
 
-    text\<open>
-      Because we have assumed the cardinal \<open>\<AA>\<close> to be infinite, there is an object corresponding
-      to every finite subset of the universe.
-    \<close>
-
-    lemma ide_mkIde_finite:
-    assumes "A \<subseteq> Univ" and "finite A"
-    shows "ide (mkIde A)"
-      by (meson assms card_of_Field_ordIso cardinal finite_ordLess_infinite2 ide_mkIde
-          ordLess_ordIso_trans)
-
-    lemma arr_mkIde:
-    shows "arr (mkIde A) \<longleftrightarrow> A \<subseteq> Univ \<and> |A| <o \<AA>"
-      using ide_mkIde mkIde_def not_arr_null by force
+    lemma arr_mkIde [iff]:
+    shows "arr (mkIde A) \<longleftrightarrow> setp A"
+      using not_arr_null mkIde_def ide_mkIde by auto
     
-    lemma dom_mkIde:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma dom_mkIde [simp]:
+    assumes "setp A"
     shows "dom (mkIde A) = mkIde A"
       using assms ide_mkIde by simp
     
-    lemma cod_mkIde:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma cod_mkIde [simp]:
+    assumes "setp A"
     shows "cod (mkIde A) = mkIde A"
       using assms ide_mkIde by simp
       
     text\<open>
       Each arrow @{term f} determines an extensional function from
       @{term "set (dom f)"} to @{term "set (cod f)"}.
 \<close>
 
     lemma Fun_mapsto:
     assumes "arr f"
     shows "Fun f \<in> extensional (set (dom f)) \<inter> (set (dom f) \<rightarrow> set (cod f))"
     proof
       show "Fun f \<in> extensional (set (dom f))" using Fun_def by fastforce
       show "Fun f \<in> set (dom f) \<rightarrow> set (cod f)"
       proof
         fix t
         assume t: "t \<in> set (dom f)"
         have "Fun f t = img (f \<cdot> inv_into (hom unity (dom f)) img t)"
           using assms t Fun_def comp_def by simp
         moreover have "... \<in> set (cod f)"
           using assms t set_def inv_into_into [of t img "hom unity (dom f)"] by blast
         ultimately show "Fun f t \<in> set (cod f)" by auto
       qed
     qed
     
     text\<open>
       Identities of @{term[source=true] S} correspond to restrictions of the identity function.
 \<close>
 
     lemma Fun_ide:
     assumes "ide a"
     shows "Fun a = restrict (\<lambda>x. x) (set a)"
       using assms Fun_def inj_img set_def comp_cod_arr by fastforce
     
-    lemma Fun_mkIde:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma Fun_mkIde [simp]:
+    assumes "setp A"
     shows "Fun (mkIde A) = restrict (\<lambda>x. x) A"
       using assms ide_mkIde set_mkIde Fun_ide by simp
     
     text\<open>
       Composition in @{term S} corresponds to extensional function composition.
 \<close>
 
     lemma Fun_comp [simp]:
     assumes "seq g f"
     shows "Fun (g \<cdot> f) = restrict (Fun g o Fun f) (set (dom f))"
     proof -
       have "restrict (img o S (g \<cdot> f) o (inv_into (hom unity (dom (g \<cdot> f))) img))
                      (set (dom (g \<cdot> f)))
               = restrict (Fun g o Fun f) (set (dom f))"
       proof -
         let ?img' = "\<lambda>a. \<lambda>t. inv_into (hom unity a) img t"
         have 1: "set (dom (g \<cdot> f)) = set (dom f)"
           using assms by auto
         moreover have "\<And>t. t \<in> set (dom (g \<cdot> f)) \<Longrightarrow>
                            (img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = (Fun g o Fun f) t"
         proof -
           fix t
           assume "t \<in> set (dom (g \<cdot> f))"
           hence t: "t \<in> set (dom f)" by (simp add: 1)
           have "(img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = img (g \<cdot> f \<cdot> ?img' (dom f) t)"
             using assms dom_comp comp_assoc by simp
           also have "... = img (g \<cdot> ?img' (dom g) (Fun f t))"
           proof -
             have "\<And>a x. x \<in> hom unity a \<Longrightarrow> ?img' a (img x) = x"
               using assms inj_img ide_cod inv_into_f_eq
               by (metis arrI in_homE mem_Collect_eq)
             thus ?thesis
               using assms t Fun_def set_def comp_arr_point by auto
           qed
           also have "... = Fun g (Fun f t)"
           proof -
             have "Fun f t \<in> img ` hom unity (cod f)"
               using assms t Fun_mapsto set_def by fast
-            thus ?thesis using assms by (auto simp add: set_def Fun_def)
+            thus ?thesis
+              using assms by (auto simp add: set_def Fun_def)
           qed
           finally show "(img o S (g \<cdot> f) o ?img' (dom (g \<cdot> f))) t = (Fun g o Fun f) t"
             by auto
         qed
         ultimately show ?thesis by auto
       qed
       thus ?thesis using Fun_def by auto
     qed
 
     text\<open>
       The constructor @{term mkArr} is used to obtain an arrow given subsets
       @{term A} and @{term B} of the universe and a function @{term "F \<in> A \<rightarrow> B"}.
 \<close>
     
     definition mkArr :: "'s set \<Rightarrow> 's set \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> 's"
-    where "mkArr A B F = (if A \<subseteq> Univ \<and> |A| <o \<AA> \<and> B \<subseteq> Univ \<and> |B| <o \<AA> \<and> F \<in> A \<rightarrow> B
+    where "mkArr A B F = (if setp A \<and> setp B \<and> F \<in> A \<rightarrow> B
                           then (THE f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F A)
                           else null)"
 
     text\<open>
       Each function @{term "F \<in> set a \<rightarrow> set b"} determines a unique arrow @{term "f \<in> hom a b"},
       such that @{term "Fun f"} is the restriction of @{term F} to @{term "set a"}.
 \<close>
 
     lemma fun_complete:
     assumes "ide a" and "ide b" and "F \<in> set a \<rightarrow> set b"
     shows "\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> Fun f = restrict F (set a)"
     proof -
       let ?P = "\<lambda>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> Fun f = restrict F (set a)"
       show "\<exists>!f. ?P f"
       proof
         have "\<exists>f. ?P f"
         proof -
           let ?F' = "\<lambda>x. inv_into (hom unity b) img (F (img x))"
           have "?F' \<in> hom unity a \<rightarrow> hom unity b"
           proof
             fix x
             assume x: "x \<in> hom unity a"
             have "F (img x) \<in> set b" using assms(3) x set_def by auto
             thus "inv_into (hom unity b) img (F (img x)) \<in> hom unity b"
-              using assms inj_img set_def by auto
+              using assms setp_set_ide inj_img set_def by auto
           qed
           hence "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = ?F' x)"
-            using assms fun_complete1 [of a b] by force
+            using assms fun_complete_ax [of a b] by force
           from this obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = ?F' x)"
             by blast
           let ?img' = "\<lambda>a. \<lambda>t. inv_into (hom unity a) img t"
           have "Fun f = restrict F (set a)"
           proof (unfold Fun_def, intro restr_eqI)
             show "set (dom f) = set a" using f by auto
             show "\<And>t. t \<in> set (dom f) \<Longrightarrow> (img \<circ> S f \<circ> ?img' (dom f)) t = F t"
             proof -
               fix t
               assume t: "t \<in> set (dom f)"
               have "(img \<circ> S f \<circ> ?img' (dom f)) t = img (f \<cdot> ?img' (dom f) t)"
                 by simp
               also have "... = img (?F' (?img' (dom f) t))"
                 by (metis f in_homE inv_into_into set_def mem_Collect_eq t)
               also have "... = img (?img' (cod f) (F t))"
                 using f t set_def inj_img by auto
               also have "... = F t"
               proof -
                 have "F t \<in> set (cod f)"
                   using assms f t by auto
                 thus ?thesis
                   using f t set_def inj_img by auto
               qed
               finally show "(img \<circ> S f \<circ> ?img' (dom f)) t = F t" by auto
             qed
           qed
           thus ?thesis using f by blast
         qed
         thus F: "?P (SOME f. ?P f)" using someI_ex [of ?P] by fast
         show "\<And>f'. ?P f' \<Longrightarrow> f' = (SOME f. ?P f)"
           using F arr_eqI
           by (metis (no_types, lifting) in_homE)
       qed
     qed
                           
     lemma mkArr_in_hom:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>" and "B \<subseteq> Univ" and "|B| <o \<AA>" and "F \<in> A \<rightarrow> B"
+    assumes "setp A" and "setp B" and "F \<in> A \<rightarrow> B"
     shows "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>"
       using assms mkArr_def fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde
             theI' [of "\<lambda>f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F A"]
+            setp_imp_subset_Univ
       by simp
 
     text\<open>
       The ``only if'' direction of the next lemma can be achieved only if there exists a
       non-arrow element of type @{typ 's}, which can be used as the value of @{term "mkArr A B F"}
       in cases where @{term "F \<notin> A \<rightarrow> B"}.  Nevertheless, it is essential to have this,
       because without the ``only if'' direction, we can't derive any useful
       consequences from an assumption of the form @{term "arr (mkArr A B F)"};
       instead we have to obtain @{term "F \<in> A \<rightarrow> B"} some other way.
       This is is usually highly inconvenient and it makes the theory very weak and almost
       unusable in practice.  The observation that having a non-arrow value of type @{typ 's}
       solves this problem is ultimately what led me to incorporate @{term null} first into the
       definition of the \<open>set_category\<close> locale and then, ultimately, into the definition
       of the \<open>category\<close> locale.  I believe this idea is critical to the usability of the
       entire development.
 \<close>
 
-    (* TODO: This gets used as an introduction rule, but the conjunction on the right-hand side
-       is not very convenient. *)
-    lemma arr_mkArr:
-    shows "arr (mkArr A B F) \<longleftrightarrow>
-           A \<subseteq> Univ \<and> |A| <o \<AA> \<and> B \<subseteq> Univ \<and> |B| <o \<AA> \<and> F \<in> A \<rightarrow> B"
+    lemma arr_mkArr [iff]:
+    shows "arr (mkArr A B F) \<longleftrightarrow> setp A \<and> setp B \<and> F \<in> A \<rightarrow> B"
     proof
-      show "arr (mkArr A B F) \<Longrightarrow>
-              A \<subseteq> Univ \<and> |A| <o \<AA> \<and> B \<subseteq> Univ \<and> |B| <o \<AA> \<and> F \<in> A \<rightarrow> B"
-        using mkArr_def domains_null codomains_null has_domain_iff_arr has_codomain_iff_arr
-              not_arr_null
-        by (intro conjI) metis+
-      show "A \<subseteq> Univ \<and> |A| <o \<AA> \<and> B \<subseteq> Univ \<and> |B| <o \<AA> \<and> F \<in> A \<rightarrow> B
-               \<Longrightarrow> arr (mkArr A B F)"
+      show "arr (mkArr A B F) \<Longrightarrow> setp A \<and> setp B \<and> F \<in> A \<rightarrow> B"
+        using mkArr_def not_arr_null ex_un_null someI_ex [of "\<lambda>f. \<not>arr f"] setp_imp_subset_Univ
+        by metis
+      show "setp A \<and> setp B \<and> F \<in> A \<rightarrow> B \<Longrightarrow> arr (mkArr A B F)"
         using mkArr_in_hom by auto
     qed
     
+    lemma arr_mkArrI [intro]:
+    assumes "setp A" and "setp B" and "F \<in> A \<rightarrow> B"
+    shows "arr (mkArr A B F)"
+      using assms arr_mkArr by blast
+
     lemma Fun_mkArr':
     assumes "arr (mkArr A B F)"
     shows "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>"
     and "Fun (mkArr A B F) = restrict F A"
     proof -
-      have 1: "A \<subseteq> Univ \<and> |A| <o \<AA> \<and> B \<subseteq> Univ \<and> |B| <o \<AA> \<and> F \<in> A \<rightarrow> B"
-        using assms arr_mkArr by simp
+      have 1: "setp A \<and> setp B \<and> F \<in> A \<rightarrow> B" using assms by fast
       have 2: "mkArr A B F \<in> hom (mkIde A) (mkIde B) \<and>
                      Fun (mkArr A B F) = restrict F (set (mkIde A))"
       proof -
         have "\<exists>!f. f \<in> hom (mkIde A) (mkIde B) \<and> Fun f = restrict F (set (mkIde A))"
           using 1 fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde by simp
         thus ?thesis using 1 mkArr_def theI' set_mkIde by simp
       qed
       show "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>" using 1 2 by auto
       show "Fun (mkArr A B F) = restrict F A" using 1 2 set_mkIde by auto
     qed
 
     lemma mkArr_Fun:
     assumes "arr f"
     shows "mkArr (set (dom f)) (set (cod f)) (Fun f) = f"
     proof -
-      have 1: "set (dom f) \<subseteq> Univ \<and> |set (dom f)| <o \<AA> \<and>
-               set (cod f) \<subseteq> Univ \<and> |set (cod f)| <o \<AA> \<and>
-               ide (dom f) \<and> ide (cod f) \<and>
+      have 1: "setp (set (dom f)) \<and> setp (set (cod f)) \<and> ide (dom f) \<and> ide (cod f) \<and>
                Fun f \<in> extensional (set (dom f)) \<inter> (set (dom f) \<rightarrow> set (cod f))"
-        using assms Fun_mapsto set_def set_card set_subset_Univ by auto
+        using Fun_mapsto assms ide_cod ide_dom setp_set' by presburger
       hence "\<exists>!f'. f' \<in> hom (dom f) (cod f) \<and> Fun f' = restrict (Fun f) (set (dom f))"
         using fun_complete by force
       moreover have "f \<in> hom (dom f) (cod f) \<and> Fun f = restrict (Fun f) (set (dom f))"
         using assms 1 extensional_restrict by force
       ultimately have "f = (THE f'. f' \<in> hom (dom f) (cod f) \<and>
                                     Fun f' = restrict (Fun f) (set (dom f)))"
         using theI' [of "\<lambda>f'. f' \<in> hom (dom f) (cod f) \<and> Fun f' = restrict (Fun f) (set (dom f))"]
         by blast
       also have "... = mkArr (set (dom f)) (set (cod f)) (Fun f)"
         using assms 1 mkArr_def mkIde_set by simp
       finally show ?thesis by auto
     qed
     
     lemma dom_mkArr [simp]:
     assumes "arr (mkArr A B F)"
     shows "dom (mkArr A B F) = mkIde A"
       using assms Fun_mkArr' by auto
         
     lemma cod_mkArr [simp]:
     assumes "arr (mkArr A B F)"
     shows "cod (mkArr A B F) = mkIde B"
       using assms Fun_mkArr' by auto
      
     lemma Fun_mkArr [simp]:
     assumes "arr (mkArr A B F)"
     shows "Fun (mkArr A B F) = restrict F A"
       using assms Fun_mkArr' by auto
 
     text\<open>
       The following provides the basic technique for showing that arrows
       constructed using @{term mkArr} are equal.
 \<close>
 
     lemma mkArr_eqI [intro]:
     assumes "arr (mkArr A B F)"
     and "A = A'" and "B = B'" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
     shows "mkArr A B F = mkArr A' B' F'"
-      using assms arr_mkArr Fun_mkArr
+      using assms Fun_mkArr
       by (intro arr_eqI, auto simp add: Pi_iff)
 
     text\<open>
       This version avoids trivial proof obligations when the domain and codomain
       sets are identical from the context.
 \<close>
     
     lemma mkArr_eqI' [intro]:
     assumes "arr (mkArr A B F)" and "\<And>x. x \<in> A \<Longrightarrow> F x = F' x"
     shows "mkArr A B F = mkArr A B F'"
-      using assms mkArr_eqI arr_mkArr by simp
+      using assms mkArr_eqI by simp
     
     lemma mkArr_restrict_eq:
     assumes "arr (mkArr A B F)"
     shows "mkArr A B (restrict F A) = mkArr A B F"
-      using assms arr_mkArr by (intro mkArr_eqI', auto)
+      using assms by (intro mkArr_eqI', auto)
       
     lemma mkArr_restrict_eq':
     assumes "arr (mkArr A B (restrict F A))"
     shows "mkArr A B (restrict F A) = mkArr A B F"
       using assms by (intro mkArr_eqI', auto)
       
-    lemma mkIde_as_mkArr:
-    assumes "A \<subseteq> Univ" and "|A| <o \<AA>"
+    lemma mkIde_as_mkArr [simp]:
+    assumes "setp A"
     shows "mkArr A A (\<lambda>x. x) = mkIde A"
-      using assms arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
+      using assms arr_mkIde dom_mkIde cod_mkIde Fun_mkIde
       by (intro arr_eqI, auto)
 
     lemma comp_mkArr:
     assumes "arr (mkArr A B F)" and "arr (mkArr B C G)"
     shows "mkArr B C G \<cdot> mkArr A B F = mkArr A C (G \<circ> F)"
     proof (intro arr_eqI)
       have 1: "seq (mkArr B C G) (mkArr A B F)" using assms by force
-      have 2: "G o F \<in> A \<rightarrow> C" using assms arr_mkArr by auto
+      have 2: "G o F \<in> A \<rightarrow> C" using assms by auto
       show "par (mkArr B C G \<cdot> mkArr A B F) (mkArr A C (G \<circ> F))"
-        using assms 1 2 arr_mkArr
+        using assms 1 2
         by (intro conjI) simp_all
       show "Fun (mkArr B C G \<cdot> mkArr A B F) = Fun (mkArr A C (G \<circ> F))"
-        using 1 2 arr_mkArr set_mkIde by fastforce
+        using 1 2 by fastforce
     qed
     
     text\<open>
       The locale assumption @{prop stable_img} forces @{term "t \<in> set t"} in case
       @{term t} is a terminal object.  This is very convenient, as it results in the
       characterization of terminal objects as identities @{term t} for which
       @{term "set t = {t}"}.  However, it is not absolutely necessary to have this.
       The following weaker characterization of terminal objects can be proved without
       the @{prop stable_img} assumption.
 \<close>
 
     lemma terminal_char1:
     shows "terminal t \<longleftrightarrow> ide t \<and> (\<exists>!x. x \<in> set t)"
     proof -
       have "terminal t \<Longrightarrow> ide t \<and> (\<exists>!x. x \<in> set t)"
       proof -
         assume t: "terminal t"
         have "ide t" using t terminal_def by auto
         moreover have "\<exists>!x. x \<in> set t"
         proof -
           have "\<exists>!x. x \<in> hom unity t"
             using t terminal_unity terminal_def by auto
           thus ?thesis using set_def by auto
         qed
         ultimately show "ide t \<and> (\<exists>!x. x \<in> set t)" by auto
       qed
       moreover have "ide t \<and> (\<exists>!x. x \<in> set t) \<Longrightarrow> terminal t"
       proof -
         assume t: "ide t \<and> (\<exists>!x. x \<in> set t)"
         from this obtain t' where "set t = {t'}" by blast
-        hence t': "set t = {t'} \<and> {t'} \<subseteq> Univ \<and> t = mkIde {t'}"
-          using t set_subset_Univ mkIde_set by metis
+        hence t': "set t = {t'} \<and> setp {t'} \<and> t = mkIde {t'}"
+          using t setp_set_ide mkIde_set by metis
         show "terminal t"
         proof
           show "ide t" using t by simp
           show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
           proof -
             fix a
             assume a: "ide a"
             show "\<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
             proof
               show 1: "\<guillemotleft>mkArr (set a) {t'} (\<lambda>x. t') : a \<rightarrow> t\<guillemotright>"
-                by (metis Pi_I a mkIde_set set_card mkArr_in_hom set_subset_Univ
-                    singletonD t t')
+                using a t t' mkArr_in_hom
+                by (metis Pi_I' mkIde_set setp_set_ide singletonD)
               show "\<And>f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright> \<Longrightarrow> f = mkArr (set a) {t'} (\<lambda>x. t')"
               proof -
                 fix f
                 assume f: "\<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
                 show "f = mkArr (set a) {t'} (\<lambda>x. t')"
                 proof (intro arr_eqI)
                   show 1: "par f (mkArr (set a) {t'} (\<lambda>x. t'))" using 1 f in_homE by metis
                   show "Fun f = Fun (mkArr (set a) {t'} (\<lambda>x. t'))"
                   proof -
                     have "Fun (mkArr (set a) {t'} (\<lambda>x. t')) = (\<lambda>x\<in>set a. t')"
                       using 1 Fun_mkArr by simp
                     also have "... = Fun f"
                     proof -
                       have "\<And>x. x \<in> set a \<Longrightarrow> Fun f x = t'"
                         using f t' Fun_def mkArr_Fun arr_mkArr
                         by (metis PiE in_homE singletonD)
                       moreover have "\<And>x. x \<notin> set a \<Longrightarrow> Fun f x = undefined"
                         using f Fun_def by auto
                       ultimately show ?thesis by auto
                     qed
                     finally show ?thesis by force
                   qed
                 qed
               qed
             qed
           qed
         qed
       qed
       ultimately show ?thesis by blast
     qed
     
     text\<open>
       As stated above, in the presence of the @{prop stable_img} assumption we have
       the following stronger characterization of terminal objects.
 \<close>
 
     lemma terminal_char2:
     shows "terminal t \<longleftrightarrow> ide t \<and> set t = {t}"
     proof
       assume t: "terminal t"
       show "ide t \<and> set t = {t}"
       proof
         show "ide t" using t terminal_char1 by auto
         show "set t = {t}"
         proof -
           have "\<exists>!x. x \<in> hom unity t" using t terminal_def terminal_unity by force
           moreover have "t \<in> img ` hom unity t" using t stable_img set_def by simp
           ultimately show ?thesis using set_def by auto
         qed
       qed
       next
       assume "ide t \<and> set t = {t}"
       thus "terminal t" using terminal_char1 by force
     qed
 
   end
 
   text\<open>
     At last, we define the \<open>set_category\<close> locale by existentially quantifying
     out the choice of a particular @{term img} map.  We need to know that such a map
     exists, but it does not matter which one we choose.
 \<close>
 
   locale set_category = category S
   for S :: "'s comp"      (infixr "\<cdot>" 55)
-  and \<AA> :: "'t rel" +
-  assumes ex_img: "\<exists>img. set_category_given_img S img \<AA>"
+  and setp :: "'s set \<Rightarrow> bool" +
+  assumes ex_img: "\<exists>img. set_category_given_img S img setp"
   begin
 
     notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
   
     definition some_img
-    where "some_img = (SOME img. set_category_given_img S img \<AA>)"
+    where "some_img = (SOME img. set_category_given_img S img setp)"
    
+    sublocale set_category_given_img S some_img setp
+    proof -
+      have "\<exists>img. set_category_given_img S img setp" using ex_img by auto
+      thus "set_category_given_img S some_img setp"
+        using someI_ex [of "\<lambda>img. set_category_given_img S img setp"] some_img_def
+        by metis
+    qed
+
   end
   
-  sublocale set_category \<subseteq> set_category_given_img S some_img \<AA>
-  proof -
-    have "\<exists>img. set_category_given_img S img \<AA>" using ex_img by auto
-    thus "set_category_given_img S some_img \<AA>"
-      using someI_ex [of "\<lambda>img. set_category_given_img S img \<AA>"] some_img_def
-      by metis
-  qed
-
-  text\<open>
-    For a set category, if the cardinal \<open>\<AA>\<close> is large enough, then it imposes no constraint
-    on what subsets of the universe determine objects.  In this case, we call the set category
-    \emph{replete} and we can eliminate the cardinality assumptions from various facts.
-  \<close>
+  text\<open>We call a set category \emph{replete} if there is an object corresponding to
+    every subset of the universe.
+\<close>
 
   locale replete_set_category =
-    set_category S \<open>cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)\<close>
+    category S +
+    set_category S \<open>\<lambda>A. A \<subseteq> Collect terminal\<close>
   for S :: "'s comp"      (infixr "\<cdot>" 55)
   begin
 
-    lemma card_of_leq:
-    assumes "A \<subseteq> Univ"
-    shows "|A| <o cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)"
-    proof -
-      have "|A| \<le>o cmax (card_of (UNIV :: 's set)) natLeq"
-        using assms card_of_Card_order natLeq_Card_order ordLeq_cmax1
-              ordLeq_transitive
-        by (metis card_of_UNIV)
-      thus ?thesis
-        by (simp add: Card_order_cmax natLeq_Card_order)
-    qed
-
-    lemma set_mkIde [simp]:
-    assumes "A \<subseteq> Univ"
-    shows "set (mkIde A) = A"
-      using assms card_of_leq set_mkIde by simp
-
-    lemma ide_mkIde [simp]:
-    assumes "A \<subseteq> Univ"
-    shows "ide (mkIde A)"
-      using assms card_of_leq ide_mkIde by simp
-
-    lemma arr_mkIde [iff]:
-    shows "arr (mkIde A) \<longleftrightarrow> A \<subseteq> Univ"
-      using card_of_leq arr_mkIde by auto
-
-    lemma dom_mkIde [simp]:
-    assumes "A \<subseteq> Univ"
-    shows "dom (mkIde A) = mkIde A"
-      using assms ide_mkIde by simp
-
-    lemma cod_mkIde [simp]:
-    assumes "A \<subseteq> Univ"
-    shows "cod (mkIde A) = mkIde A"
-      using assms ide_mkIde by simp
-
-    lemma Fun_mkIde [simp]:
-    assumes "A \<subseteq> Univ"
-    shows "Fun (mkIde A) = restrict (\<lambda>x. x) A"
-      using assms set_mkIde ide_mkIde Fun_ide by simp
-
-    lemma mkArr_in_hom [intro]:
-    assumes "A \<subseteq> Univ" and "B \<subseteq> Univ" and "F \<in> A \<rightarrow> B"
-    shows "\<guillemotleft>mkArr A B F : mkIde A \<rightarrow> mkIde B\<guillemotright>"
-      using assms card_of_leq arr_mkArr by auto
-
-    lemma arr_mkArr:
-    shows "arr (mkArr A B F) \<longleftrightarrow> A \<subseteq> Univ \<and> B \<subseteq> Univ \<and> F \<in> A \<rightarrow> B"
-      using card_of_leq arr_mkArr by auto
-
-    lemma mkIde_as_mkArr:
-    assumes "A \<subseteq> Univ"
-    shows "mkArr A A (\<lambda>x. x) = mkIde A"
-      using assms card_of_leq set_mkIde arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
-      by (intro arr_eqI, auto)
+    abbreviation setp
+    where "setp \<equiv> \<lambda>A. A \<subseteq> Univ"
 
   end
 
   context set_category
   begin
 
     text\<open>
       The arbitrary choice of @{term img} induces a system of arrows corresponding
       to inclusions of subsets.
 \<close>
 
     definition incl :: "'s \<Rightarrow> bool"
     where "incl f = (arr f \<and> set (dom f) \<subseteq> set (cod f) \<and>
                      f = mkArr (set (dom f)) (set (cod f)) (\<lambda>x. x))"
 
     lemma Fun_incl:
     assumes "incl f"
     shows "Fun f = (\<lambda>x \<in> set (dom f). x)"
       using assms incl_def by (metis Fun_mkArr)
 
     lemma ex_incl_iff_subset:
     assumes "ide a" and "ide b"
     shows "(\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f) \<longleftrightarrow> set a \<subseteq> set b"
     proof
       show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f \<Longrightarrow> set a \<subseteq> set b"
         using incl_def by auto
       show "set a \<subseteq> set b \<Longrightarrow> \<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> incl f"
       proof
         assume 1: "set a \<subseteq> set b"
         show "\<guillemotleft>mkArr (set a) (set b) (\<lambda>x. x) : a \<rightarrow> b\<guillemotright> \<and> incl (mkArr (set a) (set b) (\<lambda>x. x))"
         proof
           show "\<guillemotleft>mkArr (set a) (set b) (\<lambda>x. x) : a \<rightarrow> b\<guillemotright>"
-            by (metis 1 assms image_ident image_subset_iff_funcset mkIde_set set_card
-                mkArr_in_hom set_subset_Univ)
+            by (metis 1 assms image_ident image_subset_iff_funcset mkIde_set
+                mkArr_in_hom setp_set_ide)
           thus "incl (mkArr (set a) (set b) (\<lambda>x. x))"
             using 1 incl_def by force
         qed
       qed
     qed
 
   end
 
   section "Categoricity"
 
   text\<open>
     In this section we show that the \<open>set_category\<close> locale completely characterizes
     the structure of its interpretations as categories, in the sense that for any two
-    interpretations @{term S} and @{term S'} for the same cardinal \<open>\<AA>\<close>,
-    a bijection between the universe of @{term S} and the universe of @{term S'} extends
+    interpretations @{term S} and @{term S'}, a @{term setp}-respecting bijection
+    between the universe of @{term S} and the universe of @{term S'} extends
     to an isomorphism of @{term S} and @{term S'}.
 \<close>
   
   locale two_set_categories_bij_betw_Univ =
-    S: set_category S \<AA> +
-    S': set_category S' \<AA>
+    S: set_category S setp +
+    S': set_category S' setp'
   for S :: "'s comp"      (infixr "\<cdot>" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and S' :: "'t comp"     (infixr "\<cdot>\<acute>" 55)
-  and \<AA> :: "'u rel"
+  and setp' :: "'t set \<Rightarrow> bool"
   and \<phi> :: "'s \<Rightarrow> 't" +
   assumes bij_\<phi>: "bij_betw \<phi> S.Univ S'.Univ"
+  and \<phi>_respects_setp: "A \<subseteq> S.Univ \<Longrightarrow> setp' (\<phi> ` A) \<longleftrightarrow> setp A"
   begin
 
     notation S.in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation S'.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>'' _\<guillemotright>")
 
     abbreviation \<psi>
     where "\<psi> \<equiv> inv_into S.Univ \<phi>"
 
     lemma \<psi>_\<phi>:
     assumes "t \<in> S.Univ"
     shows "\<psi> (\<phi> t) = t"
       using assms bij_\<phi> bij_betw_inv_into_left by metis
 
     lemma \<phi>_\<psi>:
     assumes "t' \<in> S'.Univ"
     shows "\<phi> (\<psi> t') = t'"
       using assms bij_\<phi> bij_betw_inv_into_right by metis
     
     lemma \<psi>_img_\<phi>_img:
     assumes "A \<subseteq> S.Univ"
     shows "\<psi> ` \<phi> ` A = A"
       using assms bij_\<phi> by (simp add: bij_betw_def)
       
     lemma \<phi>_img_\<psi>_img:
     assumes "A' \<subseteq> S'.Univ"
     shows "\<phi> ` \<psi> ` A' = A'"
       using assms bij_\<phi> by (simp add: bij_betw_def image_inv_into_cancel)
   
     text\<open>
       We define the object map @{term \<Phi>o} of a functor from @{term[source=true] S}
       to @{term[source=true] S'}.
 \<close>
 
     definition \<Phi>o
     where "\<Phi>o = (\<lambda>a \<in> Collect S.ide. S'.mkIde (\<phi> ` S.set a))"
 
     lemma set_\<Phi>o:
     assumes "S.ide a"
     shows "S'.set (\<Phi>o a) = \<phi> ` S.set a"
-    proof -
-      from assms have "S.set a \<subseteq> S.Univ \<and> |S.set a| <o \<AA>"
-        by (simp add: S.set_card)
-      moreover have "|\<phi> ` S.set a| <o \<AA>"
-        by (meson calculation card_of_image ordLeq_ordLess_trans)
-      ultimately show ?thesis
-        using S'.set_mkIde \<Phi>o_def assms bij_\<phi> bij_betw_def image_mono mem_Collect_eq restrict_def
-        by (metis (no_types, lifting))
-    qed
+      by (simp add: S.setp_imp_subset_Univ \<Phi>o_def \<phi>_respects_setp assms)
 
     lemma \<Phi>o_preserves_ide:
     assumes "S.ide a"
     shows "S'.ide (\<Phi>o a)"
-      using assms S'.ide_mkIde S.set_subset_Univ bij_\<phi> bij_betw_def image_mono restrict_apply'
+      using assms S'.ide_mkIde bij_\<phi> bij_betw_def image_mono restrict_apply' S.setp_set'
+            \<phi>_respects_setp S.setp_imp_subset_Univ
       unfolding \<Phi>o_def
-      by (metis (no_types, lifting) S.set_card card_of_image mem_Collect_eq ordLeq_ordLess_trans)
+      by simp
       
     text\<open>
       The map @{term \<Phi>a} assigns to each arrow @{term f} of @{term[source=true] S} the function on
       the universe of @{term[source=true] S'} that is the same as the function induced by @{term f}
       on the universe of @{term[source=true] S}, up to the bijection @{term \<phi>} between the two
       universes.
 \<close>
 
     definition \<Phi>a
     where "\<Phi>a = (\<lambda>f. \<lambda>x' \<in> \<phi> ` S.set (S.dom f). \<phi> (S.Fun f (\<psi> x')))"
     
     lemma \<Phi>a_mapsto:
     assumes "S.arr f"
     shows "\<Phi>a f \<in> S'.set (\<Phi>o (S.dom f)) \<rightarrow> S'.set (\<Phi>o (S.cod f))"
     proof -
       have "\<Phi>a f \<in> \<phi> ` S.set (S.dom f) \<rightarrow> \<phi> ` S.set (S.cod f)"
       proof
         fix x
         assume x: "x \<in> \<phi> ` S.set (S.dom f)"
         have "\<psi> x \<in> S.set (S.dom f)"
-          using assms x \<psi>_img_\<phi>_img [of "S.set (S.dom f)"] S.set_subset_Univ by auto
+          using assms x \<psi>_img_\<phi>_img [of "S.set (S.dom f)"] S.setp_imp_subset_Univ by auto
         hence "S.Fun f (\<psi> x) \<in> S.set (S.cod f)" using assms S.Fun_mapsto by auto
         hence "\<phi> (S.Fun f (\<psi> x)) \<in> \<phi> ` S.set (S.cod f)" by simp
         thus "\<Phi>a f x \<in> \<phi> ` S.set (S.cod f)" using x \<Phi>a_def by auto
       qed
       thus ?thesis using assms set_\<Phi>o \<Phi>o_preserves_ide by auto
     qed
     
     text\<open>
       The map @{term \<Phi>a} takes composition of arrows to extensional
       composition of functions.
 \<close>
 
     lemma \<Phi>a_comp:
     assumes gf: "S.seq g f"
     shows "\<Phi>a (g \<cdot> f) = restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f)))"
     proof -
       have "\<Phi>a (g \<cdot> f) = (\<lambda>x' \<in> \<phi> ` S.set (S.dom f). \<phi> (S.Fun (S g f) (\<psi> x')))"
         using gf \<Phi>a_def by auto
       also have "... = (\<lambda>x' \<in> \<phi> ` S.set (S.dom f).
                            \<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')))"
         using gf set_\<Phi>o S.Fun_comp by simp
       also have "... = restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f)))"
       proof -
         have "\<And>x'. x' \<in> \<phi> ` S.set (S.dom f)
                  \<Longrightarrow> \<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')) = \<Phi>a g (\<Phi>a f x')"
         proof -
           fix x'
           assume X': "x' \<in> \<phi> ` S.set (S.dom f)"
           hence 1: "\<psi> x' \<in> S.set (S.dom f)"
-            using gf \<psi>_img_\<phi>_img [of "S.set (S.dom f)"] S.set_subset_Univ S.ide_dom by blast
+            using gf \<psi>_img_\<phi>_img S.setp_imp_subset_Univ S.ide_dom S.setp_set_ide
+            by blast
           hence "\<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x'))
                    = \<phi> (S.Fun g (S.Fun f (\<psi> x')))"
             using restrict_apply by auto
           also have "... = \<phi> (S.Fun g (\<psi> (\<phi> (S.Fun f (\<psi> x')))))"
           proof -
             have "S.Fun f (\<psi> x') \<in> S.set (S.cod f)"
               using gf 1 S.Fun_mapsto by fast
             hence "\<psi> (\<phi> (S.Fun f (\<psi> x'))) = S.Fun f (\<psi> x')"
-              using assms bij_\<phi> S.set_subset_Univ bij_betw_def inv_into_f_f subsetCE S.ide_cod
+              using assms bij_\<phi> S.setp_imp_subset_Univ bij_betw_def inv_into_f_f subsetCE
+                    S.ide_cod S.setp_set_ide
               by (metis S.seqE)
             thus ?thesis by auto
           qed
           also have "... = \<Phi>a g (\<Phi>a f x')"
           proof -
             have "\<Phi>a f x' \<in> \<phi> ` S.set (S.cod f)"
               using gf S.ide_dom S.ide_cod X' \<Phi>a_mapsto [of f] set_\<Phi>o [of "S.dom f"]
                     set_\<Phi>o [of "S.cod f"]
               by blast
             thus ?thesis using gf X' \<Phi>a_def by auto
           qed
           finally show "\<phi> (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (\<psi> x')) =
                         \<Phi>a g (\<Phi>a f x')"
             by auto
         qed
         thus ?thesis using assms set_\<Phi>o by fastforce
       qed
       finally show ?thesis by auto
     qed
     
     text\<open>
       Finally, we use @{term \<Phi>o} and @{term \<Phi>a} to define a functor @{term \<Phi>}.
 \<close>
 
     definition \<Phi>
     where "\<Phi> f = (if S.arr f then
                      S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f)
                    else S'.null)"
     
     lemma \<Phi>_in_hom:
     assumes "S.arr f"
     shows "\<Phi> f \<in> S'.hom (\<Phi>o (S.dom f)) (\<Phi>o (S.cod f))"
     proof -
       have "\<guillemotleft>\<Phi> f : S'.dom (\<Phi> f) \<rightarrow>' S'.cod (\<Phi> f)\<guillemotright>"
-        using assms \<Phi>_def [of f] \<Phi>a_mapsto [of f] \<Phi>o_preserves_ide S'.set_card S'.arr_mkArr
+        using assms \<Phi>_def \<Phi>a_mapsto \<Phi>o_preserves_ide
         by (intro S'.in_homI) auto
       thus ?thesis
-        using assms \<Phi>_def \<Phi>a_mapsto \<Phi>o_preserves_ide S'.set_card S'.arr_mkArr S'.mkIde_set
-        by auto
+        using assms \<Phi>_def \<Phi>a_mapsto \<Phi>o_preserves_ide by auto
     qed
 
     lemma \<Phi>_ide [simp]:
     assumes "S.ide a"
     shows "\<Phi> a = \<Phi>o a"
     proof -
       have "\<Phi> a = S'.mkArr (S'.set (\<Phi>o a)) (S'.set (\<Phi>o a)) (\<lambda>x'. x')"
       proof -
         have "\<guillemotleft>\<Phi> a : \<Phi>o a \<rightarrow>' \<Phi>o a\<guillemotright>"
           using assms \<Phi>_in_hom S.ide_in_hom by fastforce
         moreover have "\<Phi>a a = restrict (\<lambda>x'. x') (S'.set (\<Phi>o a))"
         proof -
           have "\<Phi>a a = (\<lambda>x' \<in> \<phi> ` S.set a. \<phi> (S.Fun a (\<psi> x')))"
             using assms \<Phi>a_def restrict_apply by auto
           also have "... = (\<lambda>x' \<in> S'.set (\<Phi>o a). \<phi> (\<psi> x'))"
           proof -
-            have "S.Fun a = (\<lambda>x \<in> S.set a. x)" using assms S.Fun_ide by simp
+            have "S.Fun a = (\<lambda>x \<in> S.set a. x)"
+              using assms S.Fun_ide by auto
             moreover have "\<And>x'. x' \<in> \<phi> ` S.set a \<Longrightarrow> \<psi> x' \<in> S.set a"
-              using assms bij_\<phi> S.set_subset_Univ image_iff by (metis \<psi>_img_\<phi>_img)
+              using assms bij_\<phi> S.setp_imp_subset_Univ image_iff S.setp_set_ide
+              by (metis \<psi>_img_\<phi>_img)
             ultimately show ?thesis
               using assms set_\<Phi>o by auto
           qed
           also have "... = restrict (\<lambda>x'. x') (S'.set (\<Phi>o a))"
-            using assms S'.set_subset_Univ \<Phi>o_preserves_ide \<phi>_\<psi>
+            using assms S'.setp_imp_subset_Univ S'.setp_set_ide \<Phi>o_preserves_ide \<phi>_\<psi>
             by (meson restr_eqI subsetCE)
           ultimately show ?thesis by auto
         qed
         ultimately show ?thesis
           using assms \<Phi>_def \<Phi>o_preserves_ide S'.mkArr_restrict_eq'
           by (metis S'.arrI S.ide_char)
       qed
       thus ?thesis
-        using assms S'.mkIde_as_mkArr \<Phi>o_preserves_ide \<Phi>_in_hom S'.set_card S'.mkIde_set
+        using assms S'.mkIde_as_mkArr \<Phi>o_preserves_ide \<Phi>_in_hom S'.mkIde_set
         by simp
     qed
     
     lemma set_dom_\<Phi>:
     assumes "S.arr f"
     shows "S'.set (S'.dom (\<Phi> f)) = \<phi> ` (S.set (S.dom f))"
       using assms S.ide_dom \<Phi>_in_hom \<Phi>_ide set_\<Phi>o by fastforce
     
     lemma \<Phi>_comp:
     assumes "S.seq g f"
     shows "\<Phi> (g \<cdot> f) = \<Phi> g \<cdot>\<acute> \<Phi> f"
     proof -
       have "\<Phi> (g \<cdot> f) = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a (S g f))"
         using \<Phi>_def assms by auto
       also have "... = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g)))
                                 (restrict (\<Phi>a g o \<Phi>a f) (S'.set (\<Phi>o (S.dom f))))"
         using assms \<Phi>a_comp set_\<Phi>o by force
       also have "... = S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a g o \<Phi>a f)"
         by (metis S'.mkArr_restrict_eq' \<Phi>_in_hom assms calculation S'.in_homE mem_Collect_eq)
       also have "... = S' (S'.mkArr (S'.set (\<Phi>o (S.dom g))) (S'.set (\<Phi>o (S.cod g))) (\<Phi>a g))
                           (S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f))"
-        by (metis S'.comp_mkArr S.seqE \<Phi>_def \<Phi>_in_hom assms S'.in_homE mem_Collect_eq)
+      proof -
+        have "S'.arr (S'.mkArr (S'.set (\<Phi>o (S.dom f))) (S'.set (\<Phi>o (S.cod f))) (\<Phi>a f))"
+          using assms \<Phi>a_mapsto set_\<Phi>o S.ide_dom S.ide_cod \<Phi>o_preserves_ide
+                S'.arr_mkArr S'.setp_imp_subset_Univ S'.setp_set_ide S.seqE
+          by metis
+        moreover have "S'.arr (S'.mkArr (S'.set (\<Phi>o (S.dom g))) (S'.set (\<Phi>o (S.cod g)))
+                              (\<Phi>a g))"
+          using assms \<Phi>a_mapsto set_\<Phi>o S.ide_dom S.ide_cod \<Phi>o_preserves_ide S'.arr_mkArr
+                S'.setp_imp_subset_Univ S'.setp_set_ide S.seqE
+          by metis
+        ultimately show ?thesis using assms S'.comp_mkArr by auto
+      qed
       also have "... = \<Phi> g \<cdot>\<acute> \<Phi> f" using assms \<Phi>_def by force
       finally show ?thesis by fast
     qed
       
     interpretation \<Phi>: "functor" S S' \<Phi>
       apply unfold_locales
       using \<Phi>_def
           apply simp
       using \<Phi>_in_hom \<Phi>_comp
       by auto
 
     lemma \<Phi>_is_functor:
     shows "functor S S' \<Phi>" ..
       
     lemma Fun_\<Phi>:
     assumes "S.arr f" and "x \<in> S.set (S.dom f)"
     shows "S'.Fun (\<Phi> f) (\<phi> x) = \<Phi>a f (\<phi> x)"
       using assms \<Phi>_def \<Phi>.preserves_arr set_\<Phi>o by auto
       
     lemma \<Phi>_acts_elementwise:
     assumes "S.ide a"
     shows "S'.set (\<Phi> a) = \<Phi> ` S.set a"
     proof
       have 0: "S'.set (\<Phi> a) = \<phi> ` S.set a"
         using assms \<Phi>_ide set_\<Phi>o by simp
       have 1: "\<And>x. x \<in> S.set a \<Longrightarrow> \<Phi> x = \<phi> x"
       proof -
         fix x
         assume x: "x \<in> S.set a"
-        have 1: "S.terminal x" using assms x S.set_subset_Univ by blast
+        have 1: "S.terminal x" using assms x S.setp_imp_subset_Univ S.setp_set_ide by blast
         hence 2: "S'.terminal (\<phi> x)"
           by (metis CollectD CollectI bij_\<phi> bij_betw_def image_iff)
         have "\<Phi> x = \<Phi>o x"
           using assms x 1 \<Phi>_ide S.terminal_def by auto
         also have "... = \<phi> x"
         proof -
           have "\<Phi>o x = S'.mkIde (\<phi> ` S.set x)"
             using assms 1 x \<Phi>o_def S.terminal_def by auto
           moreover have "S'.mkIde (\<phi> ` S.set x) = \<phi> x"
             using assms x 1 2 S.terminal_char2 S'.terminal_char2 S'.mkIde_set bij_\<phi>
-            by (metis image_empty image_insert)
+            by (metis (no_types, lifting) empty_is_image image_insert)
           ultimately show ?thesis by auto
         qed
         finally show "\<Phi> x = \<phi> x" by auto
       qed
       show "S'.set (\<Phi> a) \<subseteq> \<Phi> ` S.set a" using 0 1 by force
       show "\<Phi> ` S.set a \<subseteq> S'.set (\<Phi> a)" using 0 1 by force
     qed
 
     lemma \<Phi>_preserves_incl:
     assumes "S.incl m"
     shows "S'.incl (\<Phi> m)"
     proof -
       have 1: "S.arr m \<and> S.set (S.dom m) \<subseteq> S.set (S.cod m) \<and>
                m = S.mkArr (S.set (S.dom m)) (S.set (S.cod m)) (\<lambda>x. x)"
         using assms S.incl_def by blast
       have "S'.arr (\<Phi> m)" using 1 by auto
       moreover have 2: "S'.set (S'.dom (\<Phi> m)) \<subseteq> S'.set (S'.cod (\<Phi> m))"
-        using 1 \<Phi>.preserves_dom \<Phi>.preserves_cod \<Phi>_acts_elementwise
-        by (metis (full_types) S.ide_cod S.ide_dom image_mono)
+        using 1 \<Phi>.preserves_dom \<Phi>.preserves_cod \<Phi>_acts_elementwise by auto
       moreover have "\<Phi> m =
                      S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<lambda>x'. x')"
       proof -
         have "\<Phi> m = S'.mkArr (S'.set (\<Phi>o (S.dom m))) (S'.set (\<Phi>o (S.cod m))) (\<Phi>a m)"
           using 1 \<Phi>_def by simp
         also have "... = S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<Phi>a m)"
           using 1 \<Phi>_ide by auto
         finally have 3: "\<Phi> m =
                          S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<Phi>a m)"
           by auto
         also have "... = S'.mkArr (S'.set (S'.dom (\<Phi> m))) (S'.set (S'.cod (\<Phi> m))) (\<lambda>x'. x')"
         proof -
           have 4: "S.Fun m = restrict (\<lambda>x. x) (S.set (S.dom m))"
             using assms S.incl_def by (metis (full_types) S.Fun_mkArr)
           hence "\<Phi>a m = restrict (\<lambda>x'. x') (\<phi> ` (S.set (S.dom m)))"
           proof -
+            have 5: "\<And>x'. x' \<in> \<phi> ` S.set (S.dom m) \<Longrightarrow> \<phi> (\<psi> x') = x'"
+              by (meson 1 S.ide_dom S.setp_imp_subset_Univ S.setp_set' f_inv_into_f
+                        image_mono subset_eq)
             have "\<Phi>a m = restrict (\<lambda>x'. \<phi> (S.Fun m (\<psi> x'))) (\<phi> ` S.set (S.dom m))"
               using \<Phi>a_def by simp
             also have "... = restrict (\<lambda>x'. x') (\<phi> ` S.set (S.dom m))"
             proof -
               have "\<And>x. x \<in> \<phi> ` (S.set (S.dom m)) \<Longrightarrow> \<phi> (S.Fun m (\<psi> x)) = x"
               proof -
                 fix x
                 assume x: "x \<in> \<phi> ` (S.set (S.dom m))"
                 hence "\<psi> x \<in> S.set (S.dom m)"
-                  using 1 S.ide_dom S.set_subset_Univ \<psi>_img_\<phi>_img image_eqI by metis
-                moreover have "\<And>x'. x' \<in> \<phi> ` S.set (S.dom m) \<Longrightarrow> \<phi> (\<psi> x') = x'"
-                  by (metis 1 S'.set_subset_Univ S.ide_dom \<Phi>o_preserves_ide \<phi>_\<psi> set_\<Phi>o subsetD)
-                ultimately show "\<phi> (S.Fun m (\<psi> x)) = x" using 1 4 x by simp
+                  using 1 S.ide_dom S.setp_imp_subset_Univ S.setp_set_ide \<psi>_img_\<phi>_img image_eqI
+                  by metis
+                thus "\<phi> (S.Fun m (\<psi> x)) = x" using 1 4 5 x by simp
               qed
               thus ?thesis by auto
             qed
             finally show ?thesis by auto
           qed
           hence "\<Phi>a m = restrict (\<lambda>x'. x') (S'.set (S'.dom (\<Phi> m)))"
             using 1 set_dom_\<Phi> by auto
           thus ?thesis
             using 2 3 \<open>S'.arr (\<Phi> m)\<close> S'.mkArr_restrict_eq S'.ide_cod S'.ide_dom S'.incl_def
             by (metis S'.arr_mkArr image_restrict_eq image_subset_iff_funcset)
         qed
         finally show ?thesis by auto
       qed
       ultimately show ?thesis using S'.incl_def by blast
     qed
 
+    lemma \<psi>_respects_sets:
+    assumes "A' \<subseteq> S'.Univ"
+    shows "setp (\<psi> ` A') \<longleftrightarrow> setp' A'"
+      using assms \<phi>_respects_setp \<phi>_img_\<psi>_img bij_\<phi>
+      by (metis \<psi>_img_\<phi>_img bij_betw_def image_mono order_refl)
+
     text\<open>
       Interchange the role of @{term \<phi>} and @{term \<psi>} to obtain a functor \<open>\<Psi>\<close>
       from @{term[source=true] S'} to @{term[source=true] S}.
 \<close>
 
-    interpretation INV: two_set_categories_bij_betw_Univ S' S \<AA> \<psi>
-      apply unfold_locales by (simp add: bij_\<phi> bij_betw_inv_into)
+    interpretation INV: two_set_categories_bij_betw_Univ S' setp' S setp \<psi>
+      using \<psi>_respects_sets bij_\<phi> bij_betw_inv_into
+      by unfold_locales auto
 
     abbreviation \<Psi>o
     where "\<Psi>o \<equiv> INV.\<Phi>o"
 
     abbreviation \<Psi>a
     where "\<Psi>a \<equiv> INV.\<Phi>a"
 
     abbreviation \<Psi>
     where "\<Psi> \<equiv> INV.\<Phi>"
 
     interpretation \<Psi>: "functor" S' S \<Psi>
       using INV.\<Phi>_is_functor by auto
 
     text\<open>
       The functors @{term \<Phi>} and @{term \<Psi>} are inverses.
 \<close>
 
     lemma Fun_\<Psi>:
     assumes "S'.arr f'" and "x' \<in> S'.set (S'.dom f')"
     shows "S.Fun (\<Psi> f') (\<psi> x') = \<Psi>a f' (\<psi> x')"
       using assms INV.Fun_\<Phi> by blast
           
     lemma \<Psi>o_\<Phi>o:
     assumes "S.ide a"
     shows "\<Psi>o (\<Phi>o a) = a"
       using assms \<Phi>o_def INV.\<Phi>o_def \<psi>_img_\<phi>_img \<Phi>o_preserves_ide set_\<Phi>o S.mkIde_set
-      by force
+      by (simp add: S.setp_imp_subset_Univ)
      
     lemma \<Phi>\<Psi>:
     assumes "S.arr f"
     shows "\<Psi> (\<Phi> f) = f"
     proof (intro S.arr_eqI)
       show par: "S.par (\<Psi> (\<Phi> f)) f"
         using assms \<Phi>o_preserves_ide \<Psi>o_\<Phi>o by auto
       show "S.Fun (\<Psi> (\<Phi> f)) = S.Fun f"
       proof -
         have "S.arr (\<Psi> (\<Phi> f))" using assms by auto
         moreover have "\<Psi> (\<Phi> f) = S.mkArr (S.set (S.dom f)) (S.set (S.cod f)) (\<Psi>a (\<Phi> f))"
           using assms INV.\<Phi>_def \<Phi>_in_hom \<Psi>o_\<Phi>o by auto
         moreover have "\<Psi>a (\<Phi> f) = (\<lambda>x \<in> S.set (S.dom f). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
         proof -
           have "\<Psi>a (\<Phi> f) = (\<lambda>x \<in> \<psi> ` S'.set (S'.dom (\<Phi> f)). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
           proof -
             have "\<And>x. x \<in> \<psi> ` S'.set (S'.dom (\<Phi> f)) \<Longrightarrow> INV.\<psi> x = \<phi> x"
-              using assms S.ide_dom S.set_subset_Univ \<Psi>.preserves_reflects_arr par bij_\<phi>
+              using assms S.ide_dom S.setp_imp_subset_Univ \<Psi>.preserves_reflects_arr par bij_\<phi>
                     inv_into_inv_into_eq subsetCE INV.set_dom_\<Phi>
-              by metis
+              by (metis (no_types) S.setp_set')
             thus ?thesis
               using INV.\<Phi>a_def by auto
           qed
           moreover have "\<psi> ` S'.set (S'.dom (\<Phi> f)) = S.set (S.dom f)"
             using assms by (metis par \<Psi>.preserves_reflects_arr INV.set_dom_\<Phi>)
           ultimately show ?thesis by auto
         qed
         ultimately have 1: "S.Fun (\<Psi> (\<Phi> f)) = (\<lambda>x \<in> S.set (S.dom f). \<psi> (S'.Fun (\<Phi> f) (\<phi> x)))"
           using S'.Fun_mkArr by simp
         show ?thesis
         proof
           fix x
           have "x \<notin> S.set (S.dom f) \<Longrightarrow> S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x"
             using 1 assms extensional_def S.Fun_mapsto S.Fun_def by auto
           moreover have "x \<in> S.set (S.dom f) \<Longrightarrow> S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x"
           proof -
             assume x: "x \<in> S.set (S.dom f)"
             have "S.Fun (\<Psi> (\<Phi> f)) x = \<psi> (\<phi> (S.Fun f (\<psi> (\<phi> x))))"
               using assms x 1 Fun_\<Phi> bij_\<phi> \<Phi>a_def by auto
             also have "... = S.Fun f x"
             proof -
               have 2: "\<And>x. x \<in> S.Univ \<Longrightarrow> \<psi> (\<phi> x) = x"
                 using bij_\<phi> bij_betw_inv_into_left by fast
               have "S.Fun f (\<psi> (\<phi> x)) = S.Fun f x"
-                using assms x 2
-                by (metis S.ide_dom S.set_subset_Univ subsetCE)
+                using assms x 2 S.ide_dom S.setp_imp_subset_Univ
+                by (metis S.setp_set' subsetD)
               moreover have "S.Fun f x \<in> S.Univ"
-                using x assms S.Fun_mapsto S.set_subset_Univ S.ide_cod by blast
+                using x assms S.Fun_mapsto S.setp_imp_subset_Univ S.setp_set' S.ide_cod
+                by blast
               ultimately show ?thesis using 2 by auto
             qed
             finally show ?thesis by auto
           qed
           ultimately show "S.Fun (\<Psi> (\<Phi> f)) x = S.Fun f x" by auto
         qed
       qed
     qed
 
     lemma \<Phi>o_\<Psi>o:
     assumes "S'.ide a'"
     shows "\<Phi>o (\<Psi>o a') = a'"
       using assms \<Phi>o_def INV.\<Phi>o_def \<phi>_img_\<psi>_img INV.\<Phi>o_preserves_ide \<psi>_\<phi> INV.set_\<Phi>o
-            S'.mkIde_set
+            S'.mkIde_set S'.setp_imp_subset_Univ
       by force
 
     lemma \<Psi>\<Phi>:
     assumes "S'.arr f'"
     shows "\<Phi> (\<Psi> f') = f'"
     proof (intro S'.arr_eqI)
       show par: "S'.par (\<Phi> (\<Psi> f')) f'"
         using assms \<Phi>.preserves_ide \<Psi>.preserves_ide \<Phi>_ide INV.\<Phi>_ide \<Phi>o_\<Psi>o by auto
       show "S'.Fun (\<Phi> (\<Psi> f')) = S'.Fun f'"
       proof -
         have "S'.arr (\<Phi> (\<Psi> f'))" using assms by blast
         moreover have "\<Phi> (\<Psi> f') =
                        S'.mkArr (S'.set (S'.dom f')) (S'.set (S'.cod f')) (\<Phi>a (\<Psi> f'))"
           using assms \<Phi>_def INV.\<Phi>_in_hom \<Phi>o_\<Psi>o by simp
         moreover have "\<Phi>a (\<Psi> f') = (\<lambda>x' \<in> S'.set (S'.dom f'). \<phi> (S.Fun (\<Psi> f') (\<psi> x')))"
           unfolding \<Phi>a_def
           using assms par \<Psi>.preserves_arr set_dom_\<Phi> by metis
         ultimately have 1: "S'.Fun (\<Phi> (\<Psi> f')) =
                             (\<lambda>x' \<in> S'.set (S'.dom f'). \<phi> (S.Fun (\<Psi> f') (\<psi> x')))"
           using S'.Fun_mkArr by simp
         show ?thesis
         proof
           fix x'
           have "x' \<notin> S'.set (S'.dom f') \<Longrightarrow> S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'"
             using 1 assms S'.Fun_mapsto extensional_def by (simp add: S'.Fun_def)
           moreover have "x' \<in> S'.set (S'.dom f') \<Longrightarrow> S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'"
           proof -
             assume x': "x' \<in> S'.set (S'.dom f')"
             have "S'.Fun (\<Phi> (\<Psi> f')) x' = \<phi> (S.Fun (\<Psi> f') (\<psi> x'))"
               using x' 1 by auto
             also have "... = \<phi> (\<Psi>a f' (\<psi> x'))"
-              using Fun_\<Psi> x' assms S'.set_subset_Univ bij_\<phi> by metis
+              using Fun_\<Psi> x' assms S'.setp_imp_subset_Univ bij_\<phi> by metis
             also have "... = \<phi> (\<psi> (S'.Fun f' (\<phi> (\<psi> x'))))"
             proof -
               have "\<phi> (\<Psi>a f' (\<psi> x')) = \<phi> (\<psi> (S'.Fun f' x'))"
               proof -
                 have "x' \<in> S'.Univ"
-                  by (meson S'.ide_dom S'.set_subset_Univ assms subsetCE x')
+                  by (meson S'.ide_dom S'.setp_imp_subset_Univ S'.setp_set_ide assms subsetCE x')
                 thus ?thesis
                   by (simp add: INV.\<Phi>a_def INV.\<psi>_\<phi> x')
               qed
               also have "... = \<phi> (\<psi> (S'.Fun f' (\<phi> (\<psi> x'))))"
-                using assms x' \<phi>_\<psi> S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
+                using assms x' \<phi>_\<psi> S'.setp_imp_subset_Univ S'.setp_set_ide S'.ide_dom
+                by (metis subsetCE)
               finally show ?thesis by auto
             qed
             also have "... = S'.Fun f' x'"
             proof -
               have 2: "\<And>x'. x' \<in> S'.Univ \<Longrightarrow> \<phi> (\<psi> x') = x'"
                 using bij_\<phi> bij_betw_inv_into_right by fast
               have "S'.Fun f' (\<phi> (\<psi> x')) = S'.Fun f' x'"
-                using assms x' 2 S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
+                using assms x' 2 S'.setp_imp_subset_Univ S'.setp_set_ide S'.ide_dom
+                by (metis subsetCE)
               moreover have "S'.Fun f' x' \<in> S'.Univ"
-                using x' assms S'.Fun_mapsto S'.set_subset_Univ S'.ide_cod by blast
+                using x' assms S'.Fun_mapsto S'.setp_imp_subset_Univ S'.setp_set_ide S'.ide_cod
+                by blast
               ultimately show ?thesis using 2 by auto
             qed
             finally show ?thesis by auto
           qed
           ultimately show "S'.Fun (\<Phi> (\<Psi> f')) x' = S'.Fun f' x'" by auto
         qed
       qed
     qed
           
     lemma inverse_functors_\<Phi>_\<Psi>:
     shows "inverse_functors S S' \<Psi> \<Phi>"
     proof -
       interpret \<Phi>\<Psi>: composite_functor S S' S \<Phi> \<Psi> ..
       have inv: "\<Psi> o \<Phi> = S.map"
         using \<Phi>\<Psi> S.map_def \<Phi>\<Psi>.is_extensional by auto
     
       interpret \<Psi>\<Phi>: composite_functor S' S S' \<Psi> \<Phi> ..
       have inv': "\<Phi> o \<Psi> = S'.map"
         using \<Psi>\<Phi> S'.map_def \<Psi>\<Phi>.is_extensional by auto
     
       show ?thesis
         using inv inv' by (unfold_locales, auto)
     qed
       
     lemma are_isomorphic:
     shows "\<exists>\<Phi>. invertible_functor S S' \<Phi> \<and> (\<forall>m. S.incl m \<longrightarrow> S'.incl (\<Phi> m))"
     proof -
       interpret inverse_functors S S' \<Psi> \<Phi>
         using inverse_functors_\<Phi>_\<Psi> by auto
       have 1: "inverse_functors S S' \<Psi> \<Phi>" ..
       interpret invertible_functor S S' \<Phi>
         apply unfold_locales using 1 by auto
       have "invertible_functor S S' \<Phi>" ..
       thus ?thesis using \<Phi>_preserves_incl by auto
     qed
     
   end
   
   text\<open>
     The main result: @{locale set_category} is categorical, in the following (logical) sense:
-    If \<open>S\<close> and \<open>S'\<close> are two ``set categories'' for the same cardinal \<open>\<AA>\<close>,
-    and if the sets of terminal objects of \<open>S\<close> and \<open>S'\<close> are in bijective correspondence,
-    then \<open>S\<close> and \<open>S'\<close> are isomorphic as categories, via a functor that preserves inclusion maps,
-    hence the inclusion relation between sets.
-  \<close>
+    If \<open>S\<close> and \<open>S'\<close> are two "set categories", and if the sets of terminal objects of \<open>S\<close> and \<open>S'\<close>
+    are in correspondence via a @{term setp}-preserving bijection, then \<open>S\<close> and \<open>S'\<close> are
+    isomorphic as categories, via a functor that preserves inclusion maps, hence also the
+    inclusion relation between sets.
+\<close>
 
   theorem set_category_is_categorical:
-  assumes "set_category S \<AA>" and "set_category S' \<AA>"
+  assumes "set_category S setp" and "set_category S' setp'"
   and "bij_betw \<phi> (set_category_data.Univ S) (set_category_data.Univ S')"
+  and "\<And>A. A \<subseteq> set_category_data.Univ S \<Longrightarrow> setp' (\<phi> ` A) \<longleftrightarrow> setp A"
   shows "\<exists>\<Phi>. invertible_functor S S' \<Phi> \<and>
-             (\<forall>m. set_category.incl S \<AA> m \<longrightarrow> set_category.incl S' \<AA> (\<Phi> m))"
+             (\<forall>m. set_category.incl S setp m \<longrightarrow> set_category.incl S' setp' (\<Phi> m))"
   proof -
-    interpret S: set_category S using assms(1) by auto
-    interpret S': set_category S' using assms(2) by auto
-    interpret two_set_categories_bij_betw_Univ S S' \<AA> \<phi>
-      apply (unfold_locales) using assms(3) by auto
+    interpret S: set_category S setp using assms(1) by auto
+    interpret S': set_category S' setp' using assms(2) by auto
+    interpret two_set_categories_bij_betw_Univ S setp S' setp' \<phi>
+      apply (unfold_locales) using assms(3-4) by auto
     show ?thesis using are_isomorphic by auto
   qed
   
   section "Further Properties of Set Categories"
 
   text\<open>
     In this section we further develop the consequences of the \<open>set_category\<close>
     axioms, and establish characterizations of a number of standard category-theoretic
     notions for a \<open>set_category\<close>.
 \<close>
 
   context set_category
   begin
   
     abbreviation Dom
     where "Dom f \<equiv> set (dom f)"
     
     abbreviation Cod
     where "Cod f \<equiv> set (cod f)"
 
     subsection "Initial Object"
 
     text\<open>
       The object corresponding to the empty set is an initial object.
 \<close>
 
     definition empty
     where "empty = mkIde {}"
 
     lemma initial_empty:
     shows "initial empty"
     proof
       show 0: "ide empty"
-        using empty_def ide_mkIde
-        by (simp add: ide_mkIde_finite)
+        using empty_def by (simp add: setp_empty)
       show "\<And>b. ide b \<Longrightarrow> \<exists>!f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright>"
       proof -
         fix b
         assume b: "ide b"
         show "\<exists>!f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright>"
         proof
           show 1: "\<guillemotleft>mkArr {} (set b) (\<lambda>x. x) : empty \<rightarrow> b\<guillemotright>"
-            using 0 b empty_def mkArr_in_hom mkIde_set set_subset_Univ arr_mkIde
-            by (metis (no_types, lifting) Pi_I empty_iff ide_def mkIde_def)
+            using 0 b empty_def mkArr_in_hom mkIde_set setp_imp_subset_Univ arr_mkIde
+            by (metis Pi_I empty_iff ide_def mkIde_def)
           show "\<And>f. \<guillemotleft>f : empty \<rightarrow> b\<guillemotright> \<Longrightarrow> f = mkArr {} (set b) (\<lambda>x. x)"
             by (metis "1" arr_mkArr empty_iff in_homE empty_def mkArr_Fun mkArr_eqI set_mkIde)
         qed
       qed
     qed
 
     subsection "Identity Arrows"
     
     text\<open>
       Identity arrows correspond to restrictions of the identity function.
 \<close>
 
     lemma ide_char:
     assumes "arr f"
     shows "ide f \<longleftrightarrow> Dom f = Cod f \<and> Fun f = (\<lambda>x \<in> Dom f. x)"
       using assms mkIde_as_mkArr mkArr_Fun Fun_ide in_homE ide_cod mkArr_Fun mkIde_set
       by (metis ide_char)
 
     lemma ideI:
     assumes "arr f" and "Dom f = Cod f" and "\<And>x. x \<in> Dom f \<Longrightarrow> Fun f x = x"
     shows "ide f"
     proof -
       have "Fun f = (\<lambda>x \<in> Dom f. x)"
         using assms Fun_def by auto
       thus ?thesis using assms ide_char by blast
     qed
 
     subsection "Inclusions"
     
     lemma ide_implies_incl:
     assumes "ide a"
     shows "incl a"
-      by (simp add: assms set_card incl_def mkIde_as_mkArr)
+      by (simp add: assms incl_def)
     
     definition incl_in :: "'s \<Rightarrow> 's \<Rightarrow> bool"
     where "incl_in a b = (ide a \<and> ide b \<and> set a \<subseteq> set b)"
     
     abbreviation incl_of
     where "incl_of a b \<equiv> mkArr (set a) (set b) (\<lambda>x. x)"
 
     lemma elem_set_implies_set_eq_singleton:
     assumes "a \<in> set b"
     shows "set a = {a}"
     proof -
       have "ide b" using assms set_def by auto
-      thus ?thesis using assms set_subset_Univ terminal_char2
-        by (metis mem_Collect_eq subsetCE)
+      thus ?thesis using assms setp_imp_subset_Univ terminal_char2
+        by (metis setp_set' insert_subset mem_Collect_eq mk_disjoint_insert)
     qed
 
     lemma elem_set_implies_incl_in:
     assumes "a \<in> set b"
     shows "incl_in a b"
     proof -
       have b: "ide b" using assms set_def by auto
-      hence "set b \<subseteq> Univ" by simp
+      hence "setp (set b)" by simp
       hence "a \<in> Univ \<and> set a \<subseteq> set b"
-        using assms elem_set_implies_set_eq_singleton by auto
+        using setp_imp_subset_Univ assms elem_set_implies_set_eq_singleton by auto
       hence "ide a \<and> set a \<subseteq> set b"
         using b terminal_char1 by simp
       thus ?thesis using b incl_in_def by simp
     qed
     
     lemma incl_incl_of [simp]:
     assumes "incl_in a b"
     shows "incl (incl_of a b)"
     and "\<guillemotleft>incl_of a b : a \<rightarrow> b\<guillemotright>"
     proof -
       show "\<guillemotleft>incl_of a b : a \<rightarrow> b\<guillemotright>"
-        using assms incl_in_def mkArr_in_hom mkIde_set set_subset_Univ
-        by (metis image_ident image_subset_iff_funcset set_card)
+        using assms incl_in_def mkArr_in_hom
+        by (metis image_ident image_subset_iff_funcset mkIde_set setp_set_ide)
       thus "incl (incl_of a b)"
         using assms incl_def incl_in_def by fastforce
     qed
     
     text\<open>
       There is at most one inclusion between any pair of objects.
 \<close>
 
     lemma incls_coherent:
     assumes "par f f'" and "incl f" and "incl f'"
     shows "f = f'"
       using assms incl_def fun_complete by auto
 
     text\<open>
       The set of inclusions is closed under composition.
 \<close>
 
     lemma incl_comp [simp]:
     assumes "incl f" and "incl g" and "cod f = dom g"
     shows "incl (g \<cdot> f)"
     proof -
       have 1: "seq g f" using assms incl_def by auto
       moreover have 2: "Dom (g \<cdot> f) \<subseteq> Cod (g \<cdot> f)"
         using assms 1 incl_def by auto
       moreover have "g \<cdot> f = mkArr (Dom f) (Cod g) (restrict (\<lambda>x. x) (Dom f))"
       proof (intro arr_eqI)
         have 3: "arr (mkArr (Dom f) (Cod g) (\<lambda>x\<in>Dom f. x))"
           by (metis 1 2 cod_comp dom_comp ide_cod ide_dom incl_def incl_in_def
               incl_incl_of(1) mkArr_restrict_eq)
         show 4: "par (g \<cdot> f) (mkArr (Dom f) (Cod g) (\<lambda>x\<in>Dom f. x))"
           using assms 1 3 mkIde_set by auto
         show "Fun (g \<cdot> f) = Fun (mkArr (Dom f) (Cod g) (\<lambda>x\<in>Dom f. x))"
           using assms 3 4 Fun_comp Fun_mkArr
-          by (metis Fun_ide comp_cod_arr ide_cod mkArr_restrict_eq' incl_def)
+          by (metis comp_cod_arr dom_cod ide_cod ide_implies_incl incl_def mkArr_restrict_eq')
       qed
-      ultimately show ?thesis using incl_def arr_mkArr set_mkIde by force
+      ultimately show ?thesis using incl_def by force
     qed
 
     subsection "Image Factorization"
 
     text\<open>
       The image of an arrow is the object that corresponds to the set-theoretic
       image of the domain set under the function induced by the arrow.
 \<close>
 
     abbreviation Img
     where "Img f \<equiv> Fun f ` Dom f"
 
     definition img
     where "img f = mkIde (Img f)"
 
     lemma ide_img [simp]:
     assumes "arr f"
     shows "ide (img f)"
     proof -
       have "Fun f ` Dom f \<subseteq> Cod f" using assms Fun_mapsto by blast
-      moreover have "Cod f \<subseteq> Univ \<and> |Cod f| <o \<AA>"
-        using assms by (simp add: set_card)
-      ultimately have "Fun f ` Dom f \<subseteq> Univ \<and> |Fun f ` Dom f| <o \<AA>"
-        by (meson assms card_of_image ide_dom ordLeq_ordLess_trans set_card subset_eq)
-      thus ?thesis using img_def ide_mkIde by simp
+      moreover have "setp (Cod f)" using assms by simp
+      ultimately show ?thesis using img_def setp_respects_subset by auto
     qed
     
     lemma set_img [simp]:
     assumes "arr f"
     shows "set (img f) = Img f"
     proof -
-      have "Fun f ` set (dom f) \<subseteq> set (cod f) \<and> set (cod f) \<subseteq> Univ"
+      have 1: "Img f \<subseteq> Cod f \<and> setp (set (cod f))"
         using assms Fun_mapsto by auto
-      hence "Fun f ` set (dom f) \<subseteq> Univ \<and> |Fun f ` Dom f| <o \<AA>"
-        by (metis assms ide_def ide_img img_def mkIde_def)
-      thus ?thesis using assms img_def set_mkIde by auto
+      hence "Fun f ` set (dom f) \<subseteq> Univ"
+        using setp_imp_subset_Univ by blast
+      thus ?thesis
+        using assms 1 img_def set_mkIde setp_respects_subset by auto
     qed
 
     lemma img_point_in_Univ:
     assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
     shows "img x \<in> Univ"
     proof -
       have "set (img x) = {Fun x unity}"
         using assms terminal_char2 terminal_unity by auto
       thus "img x \<in> Univ" using assms terminal_char1 by auto
     qed
 
     lemma incl_in_img_cod:
     assumes "arr f"
     shows "incl_in (img f) (cod f)"
     proof (unfold img_def)
-      have 1: "Img f \<subseteq> Cod f \<and> Cod f \<subseteq> Univ \<and> |Cod f| <o \<AA>"
-        using assms Fun_mapsto
-        by (metis arr_mkArr image_subset_iff_funcset mkArr_Fun)
+      have 1: "Img f \<subseteq> Cod f \<and> setp (Cod f)"
+        using assms Fun_mapsto by auto
       hence 2: "ide (mkIde (Img f))"
-        using assms ide_img img_def by auto
+        using setp_respects_subset by auto
+      moreover have "ide (cod f)" using assms by auto
       moreover have "set (mkIde (Img f)) \<subseteq> Cod f"
-        using 1 2
-        by (metis ideD(1) arr_mkIde set_mkIde)
+        using 1 2 using setp_respects_subset by force
       ultimately show "incl_in (mkIde (Img f)) (cod f)"
         using assms incl_in_def ide_cod by blast
     qed
 
     lemma img_point_elem_set:
     assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
     shows "img x \<in> set a"
       by (metis assms img_point_in_Univ in_homE incl_in_img_cod insert_subset
           mem_Collect_eq incl_in_def terminal_char2)
 
     text\<open>
       The corestriction of an arrow @{term f} is the arrow
       @{term "corestr f \<in> hom (dom f) (img f)"} that induces the same function
       on the universe as @{term f}.
 \<close>
 
     definition corestr
     where "corestr f = mkArr (Dom f) (Img f) (Fun f)"
     
     lemma corestr_in_hom:
     assumes "arr f"
     shows "\<guillemotleft>corestr f : dom f \<rightarrow> img f\<guillemotright>"
-    proof -
-      have "Fun f \<in> Dom f \<rightarrow> Fun f ` Dom f \<and> Dom f \<subseteq> Univ"
-        using assms by auto
-      moreover have "Fun f ` Dom f \<subseteq> Univ"
-        by (metis assms ide_img set_img set_subset_Univ)
-      moreover have "|Fun f ` Dom f| <o \<AA>"
-        using assms by (metis ide_img set_card set_img)
-      ultimately have "mkArr (Dom f) (Fun f ` Dom f) (Fun f) \<in> hom (dom f) (img f)"
-        using assms img_def mkArr_in_hom [of "Dom f" "Fun f ` Dom f" "Fun f"] mkIde_set
-        by (simp add: set_card)
-      thus ?thesis using corestr_def by fastforce
-    qed
+      by (metis assms corestr_def equalityD2 ide_dom ide_img image_subset_iff_funcset
+          mkIde_set set_img mkArr_in_hom setp_set_ide)
     
     text\<open>
       Every arrow factors as a corestriction followed by an inclusion.
 \<close>
 
     lemma img_fact:
     assumes "arr f"
     shows "S (incl_of (img f) (cod f)) (corestr f) = f"
     proof (intro arr_eqI)
       have 1: "\<guillemotleft>corestr f : dom f \<rightarrow> img f\<guillemotright>"
         using assms corestr_in_hom by blast
       moreover have 2: "\<guillemotleft>incl_of (img f) (cod f) : img f \<rightarrow> cod f\<guillemotright>"
         using assms incl_in_img_cod incl_incl_of by fast
       ultimately show P: "par (incl_of (img f) (cod f) \<cdot> corestr f) f"
         using assms in_homE by blast
       show "Fun (incl_of (img f) (cod f) \<cdot> corestr f) = Fun f"
-      proof -
-        have "Fun (incl_of (img f) (cod f) \<cdot> corestr f)
-                 = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
-          using Fun_comp 1 2 P by auto
-        also have "... = Fun f"
-          by (metis 1 2 Fun_comp Fun_ide P comp_cod_arr corestr_def ide_img in_homE
-              mkArr_Fun Fun_mkArr)
-        finally show ?thesis by auto
-      qed
+        by (metis (no_types, lifting) 1 2 Fun_comp Fun_ide Fun_mkArr P comp_cod_arr
+            corestr_def ide_img in_homE mkArr_Fun)
     qed
 
     lemma Fun_corestr:
     assumes "arr f"
     shows "Fun (corestr f) = Fun f"
-    proof -
-      have 1: "f = incl_of (img f) (cod f) \<cdot> corestr f"
-        using assms img_fact by auto
-      hence 2: "Fun f = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
-        using assms by (metis Fun_comp dom_comp)
-      also have "... = restrict (Fun (corestr f)) (Dom f)"
-        using assms by (metis 1 2 Fun_mkArr seqE mkArr_Fun corestr_def)
-      also have "... = Fun (corestr f)"
-        using assms 1 by (metis Fun_def dom_comp extensional_restrict restrict_extensional)
-      finally show ?thesis by auto
-    qed
+      by (metis Fun_mkArr arrI assms corestr_def corestr_in_hom mkArr_Fun)
     
     subsection "Points and Terminal Objects"
 
     text\<open>
       To each element @{term t} of @{term "set a"} is associated a point
       @{term "mkPoint a t \<in> hom unity a"}.  The function induced by such
       a point is the constant-@{term t} function on the set @{term "{unity}"}.
 \<close>
 
     definition mkPoint
     where "mkPoint a t \<equiv> mkArr {unity} (set a) (\<lambda>_. t)"
 
     lemma mkPoint_in_hom:
     assumes "ide a" and "t \<in> set a"
     shows "\<guillemotleft>mkPoint a t : unity \<rightarrow> a\<guillemotright>"
-      using assms mkArr_in_hom mkIde_set set_subset_Univ terminal_char2 terminal_unity
-            mkPoint_def set_card
-      by (metis Pi_I)
+      using assms mkArr_in_hom
+      by (metis Pi_I mkIde_set setp_set_ide terminal_char2 terminal_unity mkPoint_def)
 
     lemma Fun_mkPoint:
     assumes "ide a" and "t \<in> set a"
     shows "Fun (mkPoint a t) = (\<lambda>_ \<in> {unity}. t)"
-      using assms mkPoint_def mkPoint_in_hom Fun_mkArr by force
+      using assms mkPoint_def terminal_unity mkPoint_in_hom by fastforce
 
     text\<open>
       For each object @{term a} the function @{term "mkPoint a"} has as its inverse
       the restriction of the function @{term img} to @{term "hom unity a"}
 \<close>
 
     lemma mkPoint_img:
     shows "img \<in> hom unity a \<rightarrow> set a"
     and "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkPoint a (img x) = x"
     proof -
       show "img \<in> hom unity a \<rightarrow> set a"
         using img_point_elem_set by simp
       show "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkPoint a (img x) = x"
       proof -
         fix x
         assume x: "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
         show "mkPoint a (img x) = x"
         proof (intro arr_eqI)
           have 0: "img x \<in> set a"
             using x img_point_elem_set by metis
           hence 1: "mkPoint a (img x) \<in> hom unity a"
             using x mkPoint_in_hom by force
           thus 2: "par (mkPoint a (img x)) x"
             using x by fastforce
           have "Fun (mkPoint a (img x)) = (\<lambda>_ \<in> {unity}. img x)"
             using 1 mkPoint_def by auto
           also have "... = Fun x"
-          proof
-            fix z
-            have "z \<noteq> unity \<Longrightarrow> (\<lambda>_ \<in> {unity}. img x) z = Fun x z"
-              using x Fun_mapsto Fun_def restrict_apply singletonD terminal_char2 terminal_unity
-              by auto
-            moreover have "(\<lambda>_ \<in> {unity}. img x) unity = Fun x unity"
-              by (metis (no_types, lifting) 0 image_empty image_insert in_homE insertI1
-                  restrict_apply elem_set_implies_set_eq_singleton set_img terminal_char2
-                  terminal_unity the_elem_eq x)
-            ultimately show "(\<lambda>_ \<in> {unity}. img x) z = Fun x z" by auto
-          qed
+            by (metis 0 Fun_corestr calculation elem_set_implies_set_eq_singleton
+                ide_cod ide_unity in_homE mem_Collect_eq Fun_mkPoint corestr_in_hom
+                img_point_in_Univ mkPoint_in_hom singletonI terminalE x)
           finally show "Fun (mkPoint a (img x)) = Fun x" by auto
         qed
       qed
     qed
 
     lemma img_mkPoint:
     assumes "ide a"
     shows "mkPoint a \<in> set a \<rightarrow> hom unity a"
     and "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
     proof -
       show "mkPoint a \<in> set a \<rightarrow> hom unity a"
         using assms(1) mkPoint_in_hom by simp
       show "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
         proof -
         fix t
         assume t: "t \<in> set a"
         show "img (mkPoint a t) = t"
         proof -
           have 1: "arr (mkPoint a t)"
             using assms t mkPoint_in_hom by auto
           have "Fun (mkPoint a t) ` {unity} = {t}"
             using 1 mkPoint_def by simp
           thus ?thesis
             by (metis in_homE img_def mkIde_set mkPoint_in_hom elem_set_implies_incl_in
                 elem_set_implies_set_eq_singleton incl_in_def t terminal_char2 terminal_unity)
         qed
       qed
     qed
 
     text\<open>
       For each object @{term a} the elements of @{term "hom unity a"} are therefore in
       bijective correspondence with @{term "set a"}.
 \<close>
 
     lemma bij_betw_points_and_set:
     assumes "ide a"
     shows "bij_betw img (hom unity a) (set a)"
     proof (intro bij_betwI)
       show "img \<in> hom unity a \<rightarrow> set a"
         using assms mkPoint_img by auto
       show "mkPoint a \<in> set a \<rightarrow> hom unity a"
         using assms img_mkPoint by auto
       show "\<And>x. x \<in> hom unity a \<Longrightarrow> mkPoint a (img x) = x"
         using assms mkPoint_img by auto
       show "\<And>t. t \<in> set a \<Longrightarrow> img (mkPoint a t) = t"
         using assms img_mkPoint by auto
     qed
 
+    lemma setp_img_points:
+    assumes "ide a"
+    shows "setp (img ` hom unity a)"
+      using assms
+      by (metis image_subset_iff_funcset mkPoint_img(1) setp_respects_subset setp_set_ide)
+
     text\<open>
       The function on the universe induced by an arrow @{term f} agrees, under the bijection
       between @{term "hom unity (dom f)"} and @{term "Dom f"}, with the action of @{term f}
       by composition on @{term "hom unity (dom f)"}.
 \<close>
 
     lemma Fun_point:
     assumes "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
     shows "Fun x = (\<lambda>_ \<in> {unity}. img x)"
       using assms mkPoint_img img_mkPoint Fun_mkPoint [of a "img x"] img_point_elem_set
       by auto
 
     lemma comp_arr_mkPoint:
     assumes "arr f" and "t \<in> Dom f"
     shows "f \<cdot> mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
     proof (intro arr_eqI)
       have 0: "seq f (mkPoint (dom f) t)"
         using assms mkPoint_in_hom [of "dom f" t] by auto
       have 1: "\<guillemotleft>f \<cdot> mkPoint (dom f) t : unity \<rightarrow> cod f\<guillemotright>"
         using assms mkPoint_in_hom [of "dom f" t] by auto
       show "par (f \<cdot> mkPoint (dom f) t) (mkPoint (cod f) (Fun f t))"
       proof -
         have "\<guillemotleft>mkPoint (cod f) (Fun f t) : unity \<rightarrow> cod f\<guillemotright>"
           using assms Fun_mapsto mkPoint_in_hom [of "cod f" "Fun f t"] by auto
         thus ?thesis using 1 by fastforce
       qed
       show "Fun (f \<cdot> mkPoint (dom f) t) = Fun (mkPoint (cod f) (Fun f t))"
       proof -
         have "Fun (f \<cdot> mkPoint (dom f) t) = restrict (Fun f o Fun (mkPoint (dom f) t)) {unity}"
           using assms 0 1 Fun_comp terminal_char2 terminal_unity by auto
         also have "... = (\<lambda>_ \<in> {unity}. Fun f t)"
           using assms Fun_mkPoint by auto
         also have "... = Fun (mkPoint (cod f) (Fun f t))"
           using assms Fun_mkPoint [of "cod f" "Fun f t"] Fun_mapsto by fastforce
         finally show ?thesis by auto
       qed
     qed
 
     lemma comp_arr_point:
     assumes "arr f" and "\<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright>"
     shows "f \<cdot> x = mkPoint (cod f) (Fun f (img x))"
       by (metis assms comp_arr_mkPoint img_point_elem_set mkPoint_img(2))
 
     text\<open>
       This agreement allows us to express @{term "Fun f"} in terms of composition.
 \<close>
 
     lemma Fun_in_terms_of_comp:
     assumes "arr f"
     shows "Fun f = restrict (img o S f o mkPoint (dom f)) (Dom f)"
     proof
       fix t
       have "t \<notin> Dom f \<Longrightarrow> Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
         using assms by (simp add: Fun_def)
       moreover have "t \<in> Dom f \<Longrightarrow>
                      Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
       proof -
         assume t: "t \<in> Dom f"
         have 1: "f \<cdot> mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
           using assms t comp_arr_mkPoint by simp
         hence "img (f \<cdot> mkPoint (dom f) t) = img (mkPoint (cod f) (Fun f t))" by simp
         thus ?thesis
         proof -
           have "Fun f t \<in> Cod f" using assms t Fun_mapsto by auto
           thus ?thesis using assms t 1 img_mkPoint by auto
         qed
       qed
       ultimately show "Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t" by auto
     qed
 
     text\<open>
       We therefore obtain a rule for proving parallel arrows equal by showing
       that they have the same action by composition on points.
 \<close>
 
     (*
      * TODO: Find out why attempts to use this as the main rule for a proof loop
      * unless the specific instance is given.
      *)
     lemma arr_eqI':
     assumes "par f f'" and "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
     shows "f = f'"
       using assms Fun_in_terms_of_comp mkPoint_in_hom by (intro arr_eqI, auto)
 
     text\<open>
       An arrow can therefore be specified by giving its action by composition on points.
       In many situations, this is more natural than specifying it as a function on the universe.
 \<close>
 
     definition mkArr'
     where "mkArr' a b F = mkArr (set a) (set b) (img o F o mkPoint a)"
 
     lemma mkArr'_in_hom:
     assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
     shows "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright>"
     proof -
       have "img o F o mkPoint a \<in> set a \<rightarrow> set b"
-      proof
-        fix t
-        assume t: "t \<in> set a"
-        thus "(img o F o mkPoint a) t \<in> set b"
-          using assms mkPoint_in_hom img_point_elem_set [of "F (mkPoint a t)" b]
-          by auto
-      qed
+        using assms(1,3) img_mkPoint(1) mkPoint_img(1) by fastforce
       thus ?thesis
-        using assms mkArr'_def mkArr_in_hom [of "set a" "set b"] set_card mkIde_set by simp
+        using assms mkArr'_def mkArr_in_hom [of "set a" "set b"] mkIde_set by simp
     qed
 
     lemma comp_point_mkArr':
     assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
     shows "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkArr' a b F \<cdot> x = F x"
     proof -
       fix x
       assume x: "\<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
       have "Fun (mkArr' a b F) (img x) = img (F x)"
         unfolding mkArr'_def
-        using assms x Fun_mkArr arr_mkArr img_point_elem_set mkPoint_img mkPoint_in_hom
-        by (simp add: set_card Pi_iff)
+        using assms x Fun_mkArr img_point_elem_set mkPoint_img mkPoint_in_hom
+        by (simp add: Pi_iff)
       hence "mkArr' a b F \<cdot> x = mkPoint b (img (F x))"
         using assms x mkArr'_in_hom [of a b F] comp_arr_point by auto
       thus "mkArr' a b F \<cdot> x = F x"
         using assms x mkPoint_img(2) by auto
     qed
 
     text\<open>
       A third characterization of terminal objects is as those objects whose set of
       points is a singleton.
 \<close>
 
     lemma terminal_char3:
     assumes "\<exists>!x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright>"
     shows "terminal a"
     proof -
       have a: "ide a"
         using assms ide_cod mem_Collect_eq by blast
       hence "bij_betw img (hom unity a) (set a)"
         using assms bij_betw_points_and_set by auto
       hence "img ` (hom unity a) = set a"
         by (simp add: bij_betw_def)
       moreover have "hom unity a = {THE x. x \<in> hom unity a}"
         using assms theI' [of "\<lambda>x. x \<in> hom unity a"] by auto
       ultimately have "set a = {img (THE x. x \<in> hom unity a)}"
         by (metis image_empty image_insert)
       thus ?thesis using a terminal_char1 by simp
     qed
 
     text\<open>
       The following is an alternative formulation of functional completeness, which says that
       any function on points uniquely determines an arrow.
 \<close>
 
     lemma fun_complete':
     assumes "ide a" and "ide b" and "F \<in> hom unity a \<rightarrow> hom unity b"
     shows "\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
     proof
       have 1: "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright>" using assms mkArr'_in_hom by auto
       moreover have 2: "\<And>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<Longrightarrow> mkArr' a b F \<cdot> x = F x"
         using assms comp_point_mkArr' by auto
       ultimately show "\<guillemotleft>mkArr' a b F : a \<rightarrow> b\<guillemotright> \<and>
                        (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> mkArr' a b F \<cdot> x = F x)" by blast
       fix f
       assume f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> a\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
       show "f = mkArr' a b F"
         using f 1 2 by (intro arr_eqI' [of f "mkArr' a b F"], fastforce, auto)
     qed
 
     subsection "The `Determines Same Function' Relation on Arrows"
 
     text\<open>
       An important part of understanding the structure of a category of sets and functions
       is to characterize when it is that two arrows ``determine the same function''.
       The following result provides one answer to this: two arrows with a common domain
       determine the same function if and only if they can be rendered equal by composing with
       a cospan of inclusions.
 \<close>
 
     lemma eq_Fun_iff_incl_joinable:
     assumes "span f f'"
     shows "Fun f = Fun f' \<longleftrightarrow>
            (\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f')"
     proof
       assume ff': "Fun f = Fun f'"
       let ?b = "mkIde (Cod f \<union> Cod f')"
       let ?m = "incl_of (cod f) ?b"
       let ?m' = "incl_of (cod f') ?b"
-      have 1: "|Cod f \<union> Cod f'| <o \<AA>"
-        using assms set_card cardinal card_order_infinite_isLimOrd by simp
       have incl_m: "incl ?m"
-        using assms 1 incl_incl_of [of "cod f" ?b] incl_in_def ide_mkIde set_mkIde by simp
+        using assms incl_incl_of [of "cod f" ?b] incl_in_def setp_respects_union by simp
       have incl_m': "incl ?m'"
-        using assms 1 incl_incl_of [of "cod f'" ?b] incl_in_def ide_mkIde set_mkIde by simp
+        using assms incl_incl_of [of "cod f'" ?b] incl_in_def setp_respects_union by simp
       have m: "?m = mkArr (Cod f) (Cod f \<union> Cod f') (\<lambda>x. x)"
-        by (simp add: assms 1 set_mkIde)
+        using setp_respects_union by (simp add: assms)
       have m': "?m' = mkArr (Cod f') (Cod f \<union> Cod f') (\<lambda>x. x)"
-        by (simp add: assms 1 set_mkIde)
+        using setp_respects_union by (simp add: assms)
       have seq: "seq ?m f \<and> seq ?m' f'"
-        using assms m m'
-        by (metis ide_cod incl_m incl_m' mkIde_set seqI incl_def dom_mkArr)
+        using assms m m' using setp_respects_union by simp
       have "?m \<cdot> f = ?m' \<cdot> f'"
-        by (metis assms comp_mkArr ff' incl_m incl_m' mkArr_Fun incl_def)
+        by (metis assms comp_mkArr ff' incl_def incl_m incl_m' mkArr_Fun)
       hence "incl ?m \<and> incl ?m' \<and> seq ?m f \<and> seq ?m' f' \<and> ?m \<cdot> f = ?m' \<cdot> f'"
         using seq \<open>incl ?m\<close> \<open>incl ?m'\<close> by simp
       thus "\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f'" by auto
       next
       assume ff': "\<exists>m m'. incl m \<and> incl m' \<and> seq m f \<and> seq m' f' \<and> m \<cdot> f = m' \<cdot> f'"
       show "Fun f = Fun f'"
         using ff'
         by (metis Fun_comp Fun_ide comp_cod_arr ide_cod seqE Fun_incl)
     qed
 
     text\<open>
       Another answer to the same question: two arrows with a common domain determine the
       same function if and only if their corestrictions are equal.
 \<close>
 
     lemma eq_Fun_iff_eq_corestr:
     assumes "span f f'"
     shows "Fun f = Fun f' \<longleftrightarrow> corestr f = corestr f'"
       using assms corestr_def Fun_corestr by metis
 
     subsection "Retractions, Sections, and Isomorphisms"
 
     text\<open>
       An arrow is a retraction if and only if its image coincides with its codomain.
 \<close>
 
     lemma retraction_if_Img_eq_Cod:
     assumes "arr g" and "Img g = Cod g"
     shows "retraction g"
     and "ide (g \<cdot> mkArr (Cod g) (Dom g) (inv_into (Dom g) (Fun g)))"
     proof -
       let ?F = "inv_into (Dom g) (Fun g)"
       let ?f = "mkArr (Cod g) (Dom g) ?F"
       have f: "arr ?f"
-        by (simp add: assms inv_into_into set_card arr_mkArr)
+        by (simp add: assms inv_into_into)
       show "ide (g \<cdot> ?f)"
       proof -
         have "g = mkArr (Dom g) (Cod g) (Fun g)" using assms mkArr_Fun by auto
         hence "g \<cdot> ?f = mkArr (Cod g) (Cod g) (Fun g o ?F)"
           using assms(1) f comp_mkArr by metis
         moreover have "mkArr (Cod g) (Cod g) (\<lambda>y. y) = ..."
         proof (intro mkArr_eqI')
           show "arr (mkArr (Cod g) (Cod g) (\<lambda>y. y))"
-            using assms arr_cod_iff_arr set_card arr_mkArr by auto
+            using assms arr_cod_iff_arr by auto
           show "\<And>y. y \<in> Cod g \<Longrightarrow> y = (Fun g o ?F) y"
             using assms by (simp add: f_inv_into_f)
         qed
         ultimately show ?thesis
-          using assms f mkIde_as_mkArr arr_mkArr mkIde_set by auto
+          using assms f mkIde_as_mkArr by auto
       qed
       thus "retraction g" by auto
     qed
 
     lemma retraction_char:
     shows "retraction g \<longleftrightarrow> arr g \<and> Img g = Cod g"
     proof
       assume G: "retraction g"
       show "arr g \<and> Img g = Cod g"
       proof
         show "arr g" using G by blast
         show "Img g = Cod g"
         proof -
           from G obtain f where f: "ide (g \<cdot> f)" by blast
           have "Fun g ` Fun f ` Cod g = Cod g"
           proof -
             have "restrict (Fun g o Fun f) (Cod g) = restrict (\<lambda>x. x) (Cod g)"
               using f Fun_comp Fun_ide ide_compE by metis
             thus ?thesis
               by (metis image_comp image_ident image_restrict_eq)
           qed
           moreover have "Fun f ` Cod g \<subseteq> Dom g"
             using f Fun_mapsto arr_mkArr mkArr_Fun funcset_image
             by (metis seqE ide_compE ide_compE)
           moreover have "Img g \<subseteq> Cod g"
             using f Fun_mapsto by blast
           ultimately show ?thesis by blast
         qed
       qed
       next
       assume "arr g \<and> Img g = Cod g"
       thus "retraction g" using retraction_if_Img_eq_Cod by blast
     qed
 
     text\<open>
       Every corestriction is a retraction.
 \<close>
 
     lemma retraction_corestr:
     assumes "arr f"
     shows "retraction (corestr f)"
       using assms retraction_char Fun_corestr corestr_in_hom in_homE set_img
       by metis
 
     text\<open>
       An arrow is a section if and only if it induces an injective function on its
       domain, except in the special case that it has an empty domain set and a
       nonempty codomain set.
 \<close>
 
     lemma section_if_inj:
     assumes "arr f" and "inj_on (Fun f) (Dom f)" and "Dom f = {} \<longrightarrow> Cod f = {}"
     shows "section f"
     and "ide (mkArr (Cod f) (Dom f)
                     (\<lambda>y. if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
                          else SOME x. x \<in> Dom f)
                 \<cdot> f)"
     proof -
       let ?P= "\<lambda>y. \<lambda>x. x \<in> Dom f \<and> Fun f x = y"
       let ?G = "\<lambda>y. if y \<in> Img f then SOME x. ?P y x else SOME x. x \<in> Dom f"
       let ?g = "mkArr (Cod f) (Dom f) ?G"
       have g: "arr ?g"
       proof -
-        have 1: "Cod f \<subseteq> Univ" using assms by simp
-        have 2: "Dom f \<subseteq> Univ" using assms by simp
-        have 3: "|Cod f| <o \<AA> \<and> |Dom f| <o \<AA>"
-          using assms set_card by simp
-        have 4: "?G \<in> Cod f \<rightarrow> Dom f"
+        have 1: "setp (Cod f)" using assms by simp
+        have 2: "setp (Dom f)" using assms by simp
+        have 3: "?G \<in> Cod f \<rightarrow> Dom f"
         proof
           fix y
           assume Y: "y \<in> Cod f"
           show "?G y \<in> Dom f"
           proof (cases "y \<in> Img f")
             assume "y \<in> Img f"
             hence "(\<exists>x. ?P y x) \<and> ?G y = (SOME x. ?P y x)" using Y by auto
             hence "?P y (?G y)" using someI_ex [of "?P y"] by argo
             thus "?G y \<in> Dom f" by auto
             next
             assume "y \<notin> Img f"
             hence "(\<exists>x. x \<in> Dom f) \<and> ?G y = (SOME x. x \<in> Dom f)" using assms Y by auto
             thus "?G y \<in> Dom f" using someI_ex [of "\<lambda>x. x \<in> Dom f"] by argo
           qed
         qed
-        show ?thesis using 1 2 3 4 arr_mkArr by simp
+        show ?thesis using 1 2 3 by simp
       qed
       show "ide (?g \<cdot> f)"
       proof -
         have "f = mkArr (Dom f) (Cod f) (Fun f)" using assms mkArr_Fun by auto
         hence "?g \<cdot> f = mkArr (Dom f) (Dom f) (?G o Fun f)"
           using assms(1) g comp_mkArr [of "Dom f" "Cod f" "Fun f" "Dom f" ?G] by argo
         moreover have "mkArr (Dom f) (Dom f) (\<lambda>x. x) = ..."
         proof (intro mkArr_eqI')
           show "arr (mkArr (Dom f) (Dom f) (\<lambda>x. x))"
-            using assms set_card arr_mkArr by auto
+            using assms by auto
           show "\<And>x. x \<in> Dom f \<Longrightarrow> x = (?G o Fun f) x"
           proof -
             fix x
             assume x: "x \<in> Dom f"
             have "Fun f x \<in> Img f" using x by blast
             hence *: "(\<exists>x'. ?P (Fun f x) x') \<and> ?G (Fun f x) = (SOME x'. ?P (Fun f x) x')"
               by auto
             then have "?P (Fun f x) (?G (Fun f x))"
               using someI_ex [of "?P (Fun f x)"] by argo
             with * have "x = ?G (Fun f x)"
               using assms x inj_on_def [of "Fun f" "Dom f"] by simp
             thus "x = (?G o Fun f) x" by simp
           qed
         qed
         ultimately show ?thesis
-          using assms set_card mkIde_as_mkArr mkIde_set by auto
+          using assms mkIde_as_mkArr mkIde_set by auto
       qed
       thus "section f" by auto
     qed
 
     lemma section_char:
     shows "section f \<longleftrightarrow> arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
     proof
       assume f: "section f"
       from f obtain g where g: "ide (g \<cdot> f)" using section_def by blast
       show "arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
       proof -
         have "arr f" using f by blast
         moreover have "Dom f = {} \<longrightarrow> Cod f = {}"
         proof -
           have "Cod f \<noteq> {} \<longrightarrow> Dom f \<noteq> {}"
           proof
             assume "Cod f \<noteq> {}"
             from this obtain y where "y \<in> Cod f" by blast
             hence "Fun g y \<in> Dom f"
               using g Fun_mapsto
               by (metis seqE ide_compE image_eqI retractionI retraction_char)
             thus "Dom f \<noteq> {}" by blast
           qed
           thus ?thesis by auto
         qed
         moreover have "inj_on (Fun f) (Dom f)"
           by (metis Fun_comp Fun_ide g ide_compE inj_on_id2 inj_on_imageI2 inj_on_restrict_eq)
         ultimately show ?thesis by auto
       qed
       next
       assume F: "arr f \<and> (Dom f = {} \<longrightarrow> Cod f = {}) \<and> inj_on (Fun f) (Dom f)"
       thus "section f" using section_if_inj by auto
     qed
 
     text\<open>
       Section-retraction pairs can also be characterized by an inverse relationship
       between the functions they induce.
 \<close>
 
     lemma section_retraction_char:
     shows "ide (g \<cdot> f) \<longleftrightarrow> antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)"
       by (metis Fun_comp cod_comp compose_eq' dom_comp ide_char ide_compE seqE)
 
     text\<open>
       Antiparallel arrows @{term f} and @{term g} are inverses if the functions
       they induce are inverses.
 \<close>
 
     lemma inverse_arrows_char:
     shows "inverse_arrows f g \<longleftrightarrow>
              antipar f g \<and> compose (Dom f) (Fun g) (Fun f) = (\<lambda>x \<in> Dom f. x)
                          \<and> compose (Dom g) (Fun f) (Fun g) = (\<lambda>y \<in> Dom g. y)"
       using section_retraction_char by blast
 
     text\<open>
       An arrow is an isomorphism if and only if the function it induces is a bijection.
 \<close>
 
     lemma iso_char:
     shows "iso f \<longleftrightarrow> arr f \<and> bij_betw (Fun f) (Dom f) (Cod f)"
       by (metis bij_betw_def image_empty iso_iff_section_and_retraction retraction_char
           section_char)
 
     text\<open>
       The inverse of an isomorphism is constructed by inverting the induced function.
 \<close>
 
     lemma inv_char:
     assumes "iso f"
     shows "inv f = mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
     proof -
       let ?g = "mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
       have "ide (f \<cdot> ?g)"
         using assms iso_is_retraction retraction_char retraction_if_Img_eq_Cod by simp
       moreover have "ide (?g \<cdot> f)"
       proof -
         let ?g' = "mkArr (Cod f) (Dom f)
                          (\<lambda>y. if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
                               else SOME x. x \<in> Dom f)"
         have 1: "ide (?g' \<cdot> f)"
           using assms iso_is_section section_char section_if_inj by simp
         moreover have "?g' = ?g"
         proof
           show "arr ?g'" using 1 ide_compE by blast
           show "\<And>y. y \<in> Cod f \<Longrightarrow> (if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
                                                   else SOME x. x \<in> Dom f)
                                      = inv_into (Dom f) (Fun f) y"
           proof -
             fix y
             assume "y \<in> Cod f"
             hence "y \<in> Img f" using assms iso_is_retraction retraction_char by metis
             thus "(if y \<in> Img f then SOME x. x \<in> Dom f \<and> Fun f x = y
                    else SOME x. x \<in> Dom f)
                      = inv_into (Dom f) (Fun f) y"
               using inv_into_def by metis
           qed
         qed
         ultimately show ?thesis by auto
       qed
       ultimately have "inverse_arrows f ?g" by auto
       thus ?thesis using inverse_unique by blast
     qed
 
     lemma Fun_inv:
     assumes "iso f"
     shows "Fun (inv f) = restrict (inv_into (Dom f) (Fun f)) (Cod f)"
       using assms inv_in_hom inv_char iso_inv_iso iso_is_arr Fun_mkArr by metis
 
     subsection "Monomorphisms and Epimorphisms"
 
     text\<open>
       An arrow is a monomorphism if and only if the function it induces is injective.
 \<close>
 
     lemma mono_char:
     shows "mono f \<longleftrightarrow> arr f \<and> inj_on (Fun f) (Dom f)"
     proof
       assume f: "mono f"
       hence "arr f" using mono_def by auto
       moreover have "inj_on (Fun f) (Dom f)"
       proof (intro inj_onI)
         have 0: "inj_on (S f) (hom unity (dom f))"
         proof -
           have "hom unity (dom f) \<subseteq> {g. seq f g}"
             using f mono_def arrI by auto
           hence "\<exists>A. hom unity (dom f) \<subseteq> A \<and> inj_on (S f) A"
             using f mono_def by auto
           thus ?thesis
             by (meson subset_inj_on)
         qed
         fix x x'
         assume x: "x \<in> Dom f" and x': "x' \<in> Dom f" and xx': "Fun f x = Fun f x'"
         have "mkPoint (dom f) x \<in> hom unity (dom f) \<and>
               mkPoint (dom f) x' \<in> hom unity (dom f)"
           using x x' \<open>arr f\<close> mkPoint_in_hom by simp
         moreover have "f \<cdot> mkPoint (dom f) x = f \<cdot> mkPoint (dom f) x'"
           using \<open>arr f\<close> x x' xx' comp_arr_mkPoint by simp
         ultimately have "mkPoint (dom f) x = mkPoint (dom f) x'"
           using 0 inj_onD [of "S f" "hom unity (dom f)" "mkPoint (dom f) x"] by simp
         thus "x = x'"
           using \<open>arr f\<close> x x' img_mkPoint(2) img_mkPoint(2) ide_dom by metis
       qed
       ultimately show "arr f \<and> inj_on (Fun f) (Dom f)" by auto
       next
       assume f: "arr f \<and> inj_on (Fun f) (Dom f)"
       show "mono f"
       proof
         show "arr f" using f by auto
         show "\<And>g g'. seq f g \<and> seq f g' \<and> f \<cdot> g = f \<cdot> g' \<Longrightarrow> g = g'"
         proof -
           fix g g'
           assume gg': "seq f g \<and> seq f g' \<and> f \<cdot> g = f \<cdot> g'"
           show "g = g'"
           proof (intro arr_eqI)
             show par: "par g g'"
               using gg' dom_comp by (metis seqE)
             show "Fun g = Fun g'"
             proof
               fix x
               have "x \<notin> Dom g \<Longrightarrow> Fun g x = Fun g' x"
                 using gg' by (simp add: par Fun_def)
               moreover have "x \<in> Dom g \<Longrightarrow> Fun g x = Fun g' x"
               proof -
                 assume x: "x \<in> Dom g"
                 have "Fun f (Fun g x) = Fun (f \<cdot> g) x"
                   using gg' x Fun_comp [of f g] by auto
                 also have "... = Fun f (Fun g' x)"
                   using par f gg' x monoE by simp
                 finally have "Fun f (Fun g x) = Fun f (Fun g' x)" by auto
                 moreover have "Fun g x \<in> Dom f \<and> Fun g' x \<in> Dom f"
                   using par gg' x Fun_mapsto by fastforce
                 ultimately show "Fun g x = Fun g' x"
                   using f gg' inj_onD [of "Fun f" "Dom f" "Fun g x" "Fun g' x"]
                   by simp
               qed
               ultimately show "Fun g x = Fun g' x" by auto
             qed
           qed
         qed
       qed
     qed
 
     text\<open>
       Inclusions are monomorphisms.
 \<close>
 
     lemma mono_imp_incl:
     assumes "incl f"
     shows "mono f"
       using assms incl_def Fun_incl mono_char by auto
 
     text\<open>
       A monomorphism is a section, except in case it has an empty domain set and
       a nonempty codomain set.
 \<close>
 
     lemma mono_imp_section:
     assumes "mono f" and "Dom f = {} \<longrightarrow> Cod f = {}"
     shows "section f"
       using assms mono_char section_char by auto
 
     text\<open>
       An arrow is an epimorphism if and only if either its image coincides with its
       codomain, or else the universe has only a single element (in which case all arrows
       are epimorphisms).
 \<close>
 
     lemma epi_char:
     shows "epi f \<longleftrightarrow> arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
     proof
       assume epi: "epi f"
       show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
       proof -
         have f: "arr f" using epi epi_implies_arr by auto
         moreover have "\<not>(\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t') \<Longrightarrow> Img f = Cod f"
         proof -
           assume "\<not>(\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')"
           from this obtain tt and ff
             where B: "tt \<in> Univ \<and> ff \<in> Univ \<and> tt \<noteq> ff" by blast
           show "Img f = Cod f"
           proof
             show "Img f \<subseteq> Cod f" using f Fun_mapsto by auto
             show "Cod f \<subseteq> Img f"
             proof
               let ?g = "mkArr (Cod f) {ff, tt} (\<lambda>y. tt)"
               let ?g' = "mkArr (Cod f) {ff, tt} (\<lambda>y. if \<exists>x. x \<in> Dom f \<and> Fun f x = y
                                                      then tt else ff)"
               let ?b = "mkIde {ff, tt}"
               have b: "ide ?b"
-                using B ide_mkIde_finite by simp
+                by (metis B finite.emptyI finite_imp_setp finite_insert ide_mkIde
+                    insert_subset setp_imp_subset_Univ setp_singleton mem_Collect_eq)
               have g: "\<guillemotleft>?g : cod f \<rightarrow> ?b\<guillemotright> \<and> Fun ?g = (\<lambda>y \<in> Cod f. tt)"
-              proof -
-                have "arr ?g"
-                proof -
-                  have "arr (mkIde {ff, tt})"
-                    using b ideD(1) by presburger
-                  thus ?thesis
-                    by (simp add: f set_card arr_mkIde arr_mkArr)
-                qed
-                thus ?thesis
-                  using f b B in_homI [of ?g] mkIde_set by simp
-              qed
+                using f B in_homI [of ?g "cod f" "mkIde {ff, tt}"] finite_imp_setp by simp
               have g': "?g' \<in> hom (cod f) ?b \<and>
                         Fun ?g' = (\<lambda>y \<in> Cod f. if \<exists>x. x \<in> Dom f \<and> Fun f x = y then tt else ff)"
-              proof -
-                have "arr ?g"
-                proof -
-                  have "arr (mkIde {ff, tt})"
-                    using b ideD(1) by presburger
-                  thus ?thesis
-                    by (simp add: f set_card arr_mkIde arr_mkArr)
-                qed
-                thus ?thesis
-                  using f b B in_homI [of ?g'] arr_mkArr mkIde_set by simp
-              qed
+                using f B in_homI [of ?g'] finite_imp_setp by simp
               have "?g \<cdot> f = ?g' \<cdot> f"
               proof (intro arr_eqI)
                 show "par (?g \<cdot> f) (?g' \<cdot> f)"
-                  using f g g' arr_mkArr by auto
+                  using f g g' by auto
                 show "Fun (?g \<cdot> f) = Fun (?g' \<cdot> f)"
                   using f g g' Fun_comp comp_mkArr by fastforce
               qed
               hence gg': "?g = ?g'"
                 by (metis (no_types, lifting) epiE epi f g in_homE seqI)
               fix y
               assume y: "y \<in> Cod f"
               have "Fun ?g' y = tt" using gg' g y by simp
               hence "(if \<exists>x. x \<in> Dom f \<and> Fun f x = y then tt else ff) = tt"
                 using g' y by simp
               hence "\<exists>x. x \<in> Dom f \<and> Fun f x = y"
                 using B by argo
               thus "y \<in> Img f" by blast
             qed
           qed
         qed
         ultimately show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))"
           by fast
       qed
       next
       show "arr f \<and> (Img f = Cod f \<or> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')) \<Longrightarrow> epi f"
       proof -
         have "arr f \<and> Img f = Cod f \<Longrightarrow> epi f"
           using retraction_char retraction_is_epi by presburger
         moreover have "arr f \<and> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t') \<Longrightarrow> epi f"
         proof -
           assume f: "arr f \<and> (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t')"
           have "\<And>f f'. par f f' \<Longrightarrow> f = f'"
           proof -
             fix f f'
             assume ff': "par f f'"
             show "f = f'"
             proof (intro arr_eqI)
               show "par f f'" using ff' by simp
               have "\<And>t t'. t \<in> Cod f \<and> t' \<in> Cod f \<Longrightarrow> t = t'"
-                using f ff' set_subset_Univ ide_cod subsetD by blast
+                using f ff' setp_imp_subset_Univ setp_set_ide ide_cod subsetD by blast
               thus "Fun f = Fun f'"
                 using ff' Fun_mapsto [of f] Fun_mapsto [of f']
                       extensional_arb [of "Fun f" "Dom f"] extensional_arb [of "Fun f'" "Dom f"]
                 by fastforce
             qed
           qed
           moreover have "\<And>g g'. par (g \<cdot> f) (g' \<cdot> f) \<Longrightarrow> par g g'"
             by force
           ultimately show "epi f"
             using f by (intro epiI; metis)
         qed
         ultimately show "arr f \<and> (Img f = Cod f \<or>  (\<forall>t t'. t \<in> Univ \<and> t' \<in> Univ \<longrightarrow> t = t'))
                            \<Longrightarrow> epi f"
           by auto
       qed
     qed
 
     text\<open>
       An epimorphism is a retraction, except in the case of a degenerate universe with only
       a single element.
 \<close>
 
     lemma epi_imp_retraction:
     assumes "epi f" and "\<exists>t t'. t \<in> Univ \<and> t' \<in> Univ \<and> t \<noteq> t'"
     shows "retraction f"
       using assms epi_char retraction_char by auto
 
     text\<open>
       Retraction/inclusion factorization is unique (not just up to isomorphism -- remember
       that the notion of inclusion is not categorical but depends on the arbitrarily chosen
       @{term img}).
 \<close>
 
     lemma unique_retr_incl_fact:
     assumes "seq m e" and "seq m' e'" and "m \<cdot> e = m' \<cdot> e'"
     and "incl m" and "incl m'" and "retraction e" and "retraction e'"
     shows "m = m'" and "e = e'"
     proof -
       have 1: "cod m = cod m' \<and> dom e = dom e'"
         using assms(1-3) by (metis dom_comp cod_comp)
       hence 2: "span e e'" using assms(1-2) by blast
       hence 3: "Fun e = Fun e'"
         using assms eq_Fun_iff_incl_joinable by meson
       hence "img e = img e'" using assms 1 img_def by auto
       moreover have "img e = cod e \<and> img e' = cod e'"
         using assms(6-7) retraction_char img_def mkIde_set by simp
       ultimately have "par e e'" using 2 by simp
       thus "e = e'" using 3 arr_eqI by blast
       hence "par m m'" using assms(1) assms(2) 1 by fastforce
       thus "m = m'" using assms(4) assms(5) incls_coherent by blast
     qed
 
   end
 
   section "Concrete Set Categories"
 
   text\<open>
     The \<open>set_category\<close> locale is useful for stating results that depend on a
     category of @{typ 'a}-sets and functions, without having to commit to a particular
     element type @{typ 'a}.  However, in applications we often need to work with a
     category of sets and functions that is guaranteed to contain sets corresponding
     to the subsets of some extrinsically given type @{typ 'a}.
     A \emph{concrete set category} is a set category \<open>S\<close> that is equipped
     with an injective function @{term \<iota>} from type @{typ 'a} to \<open>S.Univ\<close>.
     The following locale serves to facilitate some of the technical aspects of passing
     back and forth between elements of type @{typ 'a} and the elements of \<open>S.Univ\<close>.
 \<close>
 
-  locale concrete_set_category = set_category S \<AA>
+  locale concrete_set_category = set_category S setp
     for S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
-    and \<AA> :: "'t rel"
+    and setp :: "'s set \<Rightarrow> bool"
     and U :: "'a set"
     and \<iota> :: "'a \<Rightarrow> 's" +
-    assumes \<iota>_mapsto: "\<iota> \<in> U \<rightarrow> Univ"
-    and inj_\<iota>: "inj_on \<iota> U"
+    assumes UP_mapsto: "\<iota> \<in> U \<rightarrow> Univ"
+    and inj_UP: "inj_on \<iota> U"
   begin
 
-    abbreviation \<o>
-    where "\<o> \<equiv> inv_into U \<iota>"
+    abbreviation UP
+    where "UP \<equiv> \<iota>"
 
-    lemma \<o>_mapsto:
-    shows "\<o> \<in> \<iota> ` U \<rightarrow> U"
+    abbreviation DN
+    where "DN \<equiv> inv_into U UP"
+
+    lemma DN_mapsto:
+    shows "DN \<in> UP ` U \<rightarrow> U"
       by (simp add: inv_into_into)
 
-    lemma \<o>_\<iota> [simp]:
+    lemma DN_UP [simp]:
     assumes "x \<in> U"
-    shows "\<o> (\<iota> x) = x"
-      using assms inj_\<iota> inv_into_f_f by simp
+    shows "DN (UP x) = x"
+      using assms inj_UP inv_into_f_f by simp
       
-    lemma \<iota>_\<o> [simp]:
-    assumes "t \<in> \<iota> ` U"
-    shows "\<iota> (\<o> t) = t"
-      using assms o_def inj_\<iota> by auto
+    lemma UP_DN [simp]:
+    assumes "t \<in> UP ` U"
+    shows "UP (DN t) = t"
+      using assms o_def inj_UP by auto
+
+    lemma bij_UP:
+    shows "bij_betw UP U (UP ` U)"
+      using inj_UP inj_on_imp_bij_betw by blast
+
+    lemma bij_DN:
+    shows "bij_betw DN (UP ` U) U"
+      using bij_UP bij_betw_inv_into by blast
 
   end
 
   locale replete_concrete_set_category =
     replete_set_category S +
-    concrete_set_category S \<open>cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)\<close> U \<iota>
+    concrete_set_category S \<open>\<lambda>A. A \<subseteq> Univ\<close> U UP
     for S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
     and U :: "'a set"
-    and \<iota> :: "'a \<Rightarrow> 's"
+    and UP :: "'a \<Rightarrow> 's"
+
+  section "Sub-Set Categories"
+
+  text\<open>
+    In this section, we show that a full subcategory of a set category, obtained
+    by imposing suitable further restrictions on the subsets of the universe
+    that correspond to objects, is again a set category.
+\<close>
+
+  locale sub_set_category =
+    S: set_category +
+  fixes ssetp :: "'a set \<Rightarrow> bool"
+  assumes ssetp_singleton: "\<And>t. t \<in> S.Univ \<Longrightarrow> ssetp {t}"
+  and subset_closed: "\<And>B A. \<lbrakk>B \<subseteq> A; ssetp A\<rbrakk> \<Longrightarrow> ssetp B"
+  and union_closed: "\<And>A B. \<lbrakk>ssetp A; ssetp B\<rbrakk> \<Longrightarrow> ssetp (A \<union> B)"
+  and containment: "\<And>A. ssetp A \<Longrightarrow> setp A"
+  begin
+
+    sublocale full_subcategory S \<open>\<lambda>a. S.ide a \<and> ssetp (S.set a)\<close>
+      by unfold_locales auto
+
+    lemma is_full_subcategory:
+    shows "full_subcategory S (\<lambda>a. S.ide a \<and> ssetp (S.set a))"
+      ..
+
+    lemma ide_char:
+    shows "ide a \<longleftrightarrow> S.ide a \<and> ssetp (S.set a)"
+      using ide_char arr_char by fastforce
+
+    lemma terminal_unity:
+    shows "terminal S.unity"
+    proof
+      show "ide S.unity"
+        using S.terminal_unity S.terminal_def [of S.unity] S.terminal_char2 ide_char
+              ssetp_singleton
+        by force
+      thus "\<And>a. ide a \<Longrightarrow> \<exists>!f. in_hom f a S.unity"
+        using S.terminal_unity S.terminal_def ide_char ide_char' in_hom_char
+        by (metis (no_types, lifting))
+    qed
+
+    lemma terminal_char:
+    shows "terminal t \<longleftrightarrow> S.terminal t"
+    proof
+      fix t
+      assume t: "S.terminal t"
+      have "ide t"
+        using t ssetp_singleton ide_char S.terminal_char2 by force
+      thus "terminal t"
+        using t in_hom_char ide_char arr_char S.terminal_def terminalI by auto
+      next
+      assume t: "terminal t"
+      have 1: "S.ide t"
+        using t ide_char terminal_def by simp
+      moreover have "card (S.set t) = 1"
+      proof -
+        have "card (S.set t) = card (S.hom S.unity t)"
+          using S.set_def S.inj_img
+          by (metis 1 S.bij_betw_points_and_set bij_betw_same_card)
+        also have "... = card (hom S.unity t)"
+          using t in_hom_char terminal_def terminal_unity by auto
+        also have "... = 1"
+        proof -
+          have "\<exists>!f. f \<in> hom S.unity t"
+            using t terminal_def terminal_unity by force
+          moreover have "\<And>A. card A = 1 \<longleftrightarrow> (\<exists>!a. a \<in> A)"
+            apply (intro iffI)
+               apply (metis card_1_singletonE empty_iff insert_iff)
+            using card_1_singleton_iff by auto
+          ultimately show ?thesis by auto
+        qed
+        finally show ?thesis by blast
+      qed
+      ultimately show "S.terminal t"
+        using 1 S.terminal_char1 card_1_singleton_iff
+        by (metis One_nat_def singleton_iff)
+    qed
+
+    sublocale set_category comp ssetp
+    proof
+      text\<open>
+        Here things are simpler if we define \<open>img\<close> appropriately so that we have
+        \<open>set = T.set\<close> after accounting for the definition \<open>unity \<equiv> SOME t. terminal t\<close>,
+        which is different from that of S.unity.
+\<close>
+      have 1: "terminal (SOME t. terminal t)"
+        using terminal_unity someI_ex [of terminal] by blast
+      obtain i where i: "\<guillemotleft>i : S.unity \<rightarrow> SOME t. terminal t\<guillemotright>"
+        using terminal_unity someI_ex [of terminal] in_hom_char terminal_def
+        by auto
+      obtain i' where i': "\<guillemotleft>i' : (SOME t. terminal t) \<rightarrow> S.unity\<guillemotright>"
+        using terminal_unity someI_ex [of S.terminal] S.terminal_def
+        by (metis (no_types, lifting) 1 terminal_def)
+      have ii': "inverse_arrows i i'"
+      proof
+        have "i' \<cdot> i = S.unity"
+          using i i' terminal_unity
+          by (metis (no_types, lifting) S.comp_in_homI' S.ide_in_hom S.ide_unity S.in_homE
+              S.terminalE S.terminal_unity in_hom_char)
+        thus 2: "ide (comp i' i)"
+          by (metis (no_types, lifting) cod_comp comp_simp i i' ide_char' in_homE seqI')
+        have "i \<cdot> i' = (SOME t. terminal t)"
+          using 1
+          by (metis (no_types, lifting) 2 comp_simp i' ide_compE in_homE inverse_arrowsE
+              iso_iff_mono_and_retraction point_is_mono retractionI section_retraction_of_iso(2))
+        thus "ide (comp i i')"
+          using comp_char
+          by (metis (no_types, lifting) 2 ide_char' dom_comp i' ide_compE in_homE seq_char)
+      qed
+      interpret set_category_data comp \<open>\<lambda>x. S.some_img (x \<cdot> i)\<close> ..
+      have i_in_hom: "\<guillemotleft>i : S.unity \<rightarrow> unity\<guillemotright>"
+        using i unity_def by simp
+      have i'_in_hom: "\<guillemotleft>i' : unity \<rightarrow> S.unity\<guillemotright>"
+        using i' unity_def by simp
+      have "\<And>a. ide a \<Longrightarrow> set a = S.set a"
+      proof -
+        fix a
+        assume a: "ide a"
+        have "set a = (\<lambda>x. S.some_img (x \<cdot> i)) ` hom unity a"
+          using set_def by simp
+        also have "... = S.some_img ` S.hom S.unity a"
+        proof
+          show "(\<lambda>x. S.some_img (x \<cdot> i)) ` hom unity a \<subseteq> S.some_img ` S.hom S.unity a"
+            using i in_hom_char i_in_hom by auto
+          show "S.some_img ` S.hom S.unity a \<subseteq> (\<lambda>x. S.some_img (x \<cdot> i)) ` hom unity a"
+          proof
+            fix b
+            assume b: "b \<in> S.some_img ` S.hom S.unity a"
+            obtain x where x: "x \<in> S.hom S.unity a \<and> S.some_img x = b"
+              using b by blast
+            have "x \<cdot> i' \<in> hom unity a"
+              using x in_hom_char S.comp_in_homI a i' ideD(1) unity_def by force
+            moreover have "S.some_img ((x \<cdot> i') \<cdot> i) = b"
+              by (metis (no_types, lifting) i ii' x S.comp_assoc calculation comp_simp
+                  ide_compE in_homE inverse_arrowsE mem_Collect_eq S.comp_arr_ide seqI'
+                  seq_char S.ide_unity unity_def)
+            ultimately show "b \<in> (\<lambda>x. S.some_img (x \<cdot> i)) ` hom unity a" by blast
+          qed
+        qed
+        also have "... = S.set a"
+          using S.set_def by auto
+        finally show "set a = S.set a" by blast
+      qed
+      interpret T: set_category_given_img comp \<open>\<lambda>x. S.some_img (x \<cdot> i)\<close> ssetp
+      proof
+        show "Collect terminal \<noteq> {}"
+          using terminal_unity by blast
+        show "\<And>A' A. \<lbrakk>A' \<subseteq> A; ssetp A\<rbrakk> \<Longrightarrow> ssetp A'"
+          using subset_closed by blast
+        show "\<And>A B. \<lbrakk>ssetp A; ssetp B\<rbrakk> \<Longrightarrow> ssetp (A \<union> B)"
+          using union_closed by simp
+        show "\<And>A. ssetp A \<Longrightarrow> A \<subseteq> Univ"
+          using S.setp_imp_subset_Univ containment terminal_char by presburger
+        show "\<And>a b. \<lbrakk>ide a; ide b; set a = set b\<rbrakk> \<Longrightarrow> a = b"
+          using ide_char \<open>\<And>a. ide a \<Longrightarrow> set a = S.set a\<close> S.extensional_set by auto
+        show "\<And>a. ide a \<Longrightarrow> ssetp (set a)"
+          using \<open>\<And>a. ide a \<Longrightarrow> set a = S.set a\<close> ide_char by force
+        show "\<And>A. ssetp A \<Longrightarrow> \<exists>a. ide a \<and> set a = A"
+          using S.set_complete \<open>\<And>a. ide a \<Longrightarrow> set a = S.set a\<close> containment ide_char by blast
+        show "\<And>t. terminal t \<Longrightarrow> t \<in> (\<lambda>x. S.some_img (x \<cdot> i)) ` hom unity t"
+          using S.set_def S.stable_img \<open>\<And>a. ide a \<Longrightarrow> set a = S.set a\<close> set_def
+                terminal_char terminal_def
+          by force
+        show "\<And>a. ide a \<Longrightarrow> inj_on (\<lambda>x. S.some_img (x \<cdot> i)) (hom unity a)"
+        proof -
+          fix a
+          assume a: "ide a"
+          show "inj_on (\<lambda>x. S.some_img (x \<cdot> i)) (hom unity a)"
+          proof
+            fix x y
+            assume x: "x \<in> hom unity a" and y: "y \<in> hom unity a"
+            and eq: "S.some_img (x \<cdot> i) = S.some_img (y \<cdot> i)"
+            have "x \<cdot> i = y \<cdot> i"
+            proof -
+              have "x \<cdot> i \<in> S.hom S.unity a \<and> y \<cdot> i \<in> S.hom S.unity a"
+                using in_hom_char \<open>\<guillemotleft>i : S.unity \<rightarrow> unity\<guillemotright>\<close> x y by blast
+              thus ?thesis
+                using a eq ide_char S.inj_img [of a] inj_on_def [of S.some_img] by simp
+            qed
+            have "x = (x \<cdot> i) \<cdot> i'"
+              by (metis (no_types, lifting) S.comp_arr_ide S.comp_assoc S.inverse_arrowsE
+                  S.match_4 i i' ii' inclusion_preserves_inverse mem_Collect_eq seqI'
+                  seq_char unity_def x)
+            also have "... = (y \<cdot> i) \<cdot> i'"
+              using \<open>x \<cdot> i = y \<cdot> i\<close> by simp
+            also have "... = y"
+              by (metis (no_types, lifting) S.comp_arr_ide S.comp_assoc S.inverse_arrowsE
+                  S.match_4 i i' ii' inclusion_preserves_inverse mem_Collect_eq seqI'
+                  seq_char unity_def y)
+            finally show "x = y" by simp
+          qed
+        qed
+        show "\<And>f f'. \<lbrakk>par f f'; \<And>x. in_hom x unity (dom f) \<Longrightarrow> comp f x = comp f' x\<rbrakk>
+                        \<Longrightarrow> f = f'"
+        proof -
+          fix f f'
+          assume par: "par f f'"
+          assume eq: "\<And>x. in_hom x unity (dom f) \<Longrightarrow> comp f x = comp f' x"
+          have "S.par f f'"
+            using par arr_char dom_char cod_char by auto
+          moreover have "\<And>x. S.in_hom x S.unity (S.dom f) \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
+          proof -
+            fix x
+            assume x: "S.in_hom x S.unity (S.dom f)"
+            have "S.in_hom (x \<cdot> i') unity (S.dom f)"
+              using i'_in_hom in_hom_char x by blast
+            hence 1: "in_hom (x \<cdot> i') unity (dom f)"
+              using arr_dom dom_simp i in_hom_char par unity_def by force
+            hence "comp f (x \<cdot> i') = comp f' (x \<cdot> i')"
+              using eq by blast
+            hence "(f \<cdot> (x \<cdot> i')) \<cdot> i = (f' \<cdot> (x \<cdot> i')) \<cdot> i"
+              using comp_char
+              by (metis (no_types, lifting) 1 comp_simp in_homE seqI par)
+            thus "f \<cdot> x = f' \<cdot> x"
+              by (metis (no_types, lifting) S.comp_arr_dom S.comp_assoc S.comp_inv_arr
+                  S.in_homE i_in_hom ii' in_hom_char inclusion_preserves_inverse x)
+          qed
+          ultimately show "f = f'"
+            using S.extensional_arr by blast
+        qed
+        show "\<And>a b F. \<lbrakk>ide a; ide b; F \<in> hom unity a \<rightarrow> hom unity b\<rbrakk>
+                        \<Longrightarrow> \<exists>f. in_hom f a b \<and>
+                                (\<forall>x. in_hom x unity (dom f) \<longrightarrow> comp f x = F x)"
+        proof -
+          fix a b F
+          assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
+          have "S.ide a"
+            using a ide_char by blast
+          have "S.ide b"
+            using b ide_char by blast
+          have 1: "(\<lambda>x. F (x \<cdot> i') \<cdot> i) \<in> S.hom S.unity a \<rightarrow> S.hom S.unity b"
+          proof
+            fix x
+            assume x: "x \<in> S.hom S.unity a"
+            have "x \<cdot> i' \<in> S.hom unity a"
+              using i'_in_hom in_hom_char x by blast
+            hence "x \<cdot> i' \<in> hom unity a"
+              using a in_hom_char
+              by (metis (no_types, lifting) ideD(1) i'_in_hom in_hom_char mem_Collect_eq)
+            hence "F (x \<cdot> i') \<in> hom unity b"
+              using a b F by blast
+            hence "F (x \<cdot> i') \<in> S.hom unity b"
+              using b in_hom_char by blast
+            thus "F (x \<cdot> i') \<cdot> i \<in> S.hom S.unity b"
+              using i in_hom_char unity_def by auto
+          qed
+          obtain f where f: "S.in_hom f a b \<and> (\<forall>x. S.in_hom x S.unity (S.dom f)
+                               \<longrightarrow> f \<cdot> x = (\<lambda>x. F (x \<cdot> i') \<cdot> i) x)"
+            using 1 S.fun_complete_ax \<open>S.ide a\<close> \<open>S.ide b\<close> by presburger
+          show "\<exists>f. in_hom f a b \<and> (\<forall>x. in_hom x unity (dom f) \<longrightarrow> comp f x = F x)"
+          proof -
+            have "in_hom f a b"
+              using f in_hom_char ideD(1) a b by presburger
+            moreover have "\<forall>x. in_hom x unity (dom f) \<longrightarrow> comp f x = F x"
+            proof (intro allI impI)
+              fix x
+              assume x: "in_hom x unity (dom f)"
+              have xi: "S.in_hom (x \<cdot> i) S.unity (S.dom f)"
+                using f x i in_hom_char dom_char
+                by (metis (no_types, lifting) in_homE unity_def calculation S.comp_in_homI)
+              hence 1: "f \<cdot> (x \<cdot> i) = F ((x \<cdot> i) \<cdot> i') \<cdot> i"
+                using f by blast
+              hence "((f \<cdot> x) \<cdot> i) \<cdot> i' = (F x \<cdot> i) \<cdot> i'"
+                by (metis (no_types, lifting) xi S.comp_assoc S.inverse_arrowsE
+                    S.seqI' i' ii' in_hom_char inclusion_preserves_inverse S.comp_arr_ide)
+              hence "f \<cdot> x = F x"
+                by (metis (no_types, lifting) xi 1 S.invert_side_of_triangle(2) S.match_2 S.match_3
+                    S.seqI arr_char calculation S.in_homE S.inverse_unique S.isoI
+                    ii' in_homE inclusion_preserves_inverse)
+              thus "comp f x = F x"
+                using comp_char
+                by (metis (no_types, lifting) comp_simp in_homE seqI calculation x)
+            qed
+            ultimately show ?thesis by blast
+          qed
+        qed
+      qed
+      show "\<exists>img. set_category_given_img comp img ssetp"
+        using T.set_category_given_img_axioms by blast
+    qed
+
+    lemma is_set_category:
+    shows "set_category comp ssetp"
+      ..
+
+  end
 
 end
diff --git a/thys/Category3/Subcategory.thy b/thys/Category3/Subcategory.thy
--- a/thys/Category3/Subcategory.thy
+++ b/thys/Category3/Subcategory.thy
@@ -1,427 +1,431 @@
 (*  Title:       Subcategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "Subcategory"
 
   text\<open>
     In this chapter we give a construction of the subcategory of a category
     defined by a predicate on arrows subject to closure conditions.  The arrows of
     the subcategory are directly identified with the arrows of the ambient category.
     We also define the related notions of full subcategory and inclusion functor.
 \<close>
 
 theory Subcategory
 imports Functor
 begin
 
   locale subcategory =
     C: category C
     for C :: "'a comp"      (infixr "\<cdot>\<^sub>C" 55)
     and Arr :: "'a \<Rightarrow> bool" +
     assumes inclusion: "Arr f \<Longrightarrow> C.arr f"
     and dom_closed: "Arr f \<Longrightarrow> Arr (C.dom f)"
     and cod_closed: "Arr f \<Longrightarrow> Arr (C.cod f)"
     and comp_closed: "\<lbrakk> Arr f; Arr g; C.cod f = C.dom g \<rbrakk> \<Longrightarrow> Arr (g \<cdot>\<^sub>C f)"
   begin
 
     no_notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation C.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
 
     definition comp         (infixr "\<cdot>" 55)
     where "g \<cdot> f = (if Arr f \<and> Arr g \<and> C.cod f = C.dom g then g \<cdot>\<^sub>C f else C.null)"
 
     interpretation partial_magma comp
     proof
       show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
       proof
         show 1: "\<forall>f. C.null \<cdot> f = C.null \<and> f \<cdot> C.null = C.null"
           by (metis C.comp_null(1) C.ex_un_null comp_def)
         show "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = C.null"
           using 1 C.ex_un_null by metis
       qed
     qed
 
     lemma null_char [simp]:
     shows "null = C.null"
     proof -
       have "\<forall>f. C.null \<cdot> f = C.null \<and> f \<cdot> C.null = C.null"
         by (metis C.comp_null(1) C.ex_un_null comp_def)
       thus ?thesis using ex_un_null by (metis comp_null(2))
     qed
 
     lemma ideI:
     assumes "Arr a" and "C.ide a"
     shows "ide a"
       unfolding ide_def
       using assms null_char C.ide_def comp_def by auto
 
     lemma Arr_iff_dom_in_domain:
     shows "Arr f \<longleftrightarrow> C.dom f \<in> domains f"
     proof
       show "C.dom f \<in> domains f \<Longrightarrow> Arr f"
         using domains_def comp_def ide_def by fastforce
       show "Arr f \<Longrightarrow> C.dom f \<in> domains f"
       proof -
         assume f: "Arr f"
         have "ide (C.dom f)"
           using f inclusion C.dom_in_domains C.has_domain_iff_arr C.domains_def
                 dom_closed ideI
           by auto
         moreover have "f \<cdot> C.dom f \<noteq> null"
           using f comp_def dom_closed null_char inclusion C.comp_arr_dom by force
         ultimately show ?thesis
           using domains_def by simp
       qed
     qed
 
     lemma Arr_iff_cod_in_codomain:
     shows "Arr f \<longleftrightarrow> C.cod f \<in> codomains f"
     proof
       show "C.cod f \<in> codomains f \<Longrightarrow> Arr f"
         using codomains_def comp_def ide_def by fastforce
       show "Arr f \<Longrightarrow> C.cod f \<in> codomains f"
       proof -
         assume f: "Arr f"
         have "ide (C.cod f)"
           using f inclusion C.cod_in_codomains C.has_codomain_iff_arr C.codomains_def
                 cod_closed ideI
           by auto
         moreover have "C.cod f \<cdot> f \<noteq> null"
           using f comp_def cod_closed null_char inclusion C.comp_cod_arr by force
         ultimately show ?thesis
           using codomains_def by simp
       qed
     qed
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> Arr f"
     proof
       show "Arr f \<Longrightarrow> arr f"
         using arr_def comp_def Arr_iff_dom_in_domain Arr_iff_cod_in_codomain by auto
       show "arr f \<Longrightarrow> Arr f"
       proof -
         assume f: "arr f"
         obtain a where a: "a \<in> domains f \<or> a \<in> codomains f"
           using f arr_def by auto
         have "f \<cdot> a \<noteq> C.null \<or> a \<cdot> f \<noteq> C.null"
           using a domains_def codomains_def null_char by auto
         thus "Arr f"
           using comp_def by metis
       qed
     qed
 
     lemma arrI [intro]:
     assumes "Arr f"
     shows "arr f"
       using assms arr_char by simp
 
     lemma arrE [elim]:
     assumes "arr f"
     shows "Arr f"
       using assms arr_char by simp
 
     interpretation category comp
       using comp_def null_char inclusion comp_closed dom_closed cod_closed
       apply unfold_locales
            apply auto[1]
           apply (metis Arr_iff_dom_in_domain Arr_iff_cod_in_codomain arr_char arr_def emptyE)
     proof -
       fix f g h
       assume gf: "seq g f" and hg: "seq h g"
       show 1: "seq (h \<cdot> g) f"
         using gf hg inclusion comp_closed comp_def by auto
       show "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
         using gf hg 1 C.not_arr_null inclusion comp_def arr_char
         by (metis (full_types) C.cod_comp C.comp_assoc)
       next
       fix f g h
       assume hg: "seq h g" and hgf: "seq (h \<cdot> g) f"
       show "seq g f"
         using hg hgf comp_def null_char inclusion arr_char comp_closed
         by (metis (full_types) C.dom_comp)
       next
       fix f g h
       assume hgf: "seq h (g \<cdot> f)" and gf: "seq g f"
       show "seq h g"
         using hgf gf comp_def null_char arr_char comp_closed
         by (metis C.seqE C.ext C.match_2)
     qed
 
     theorem is_category:
     shows "category comp" ..
 
     notation in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     lemma dom_simp:
     assumes "arr f"
     shows "dom f = C.dom f"
     proof -
       have "ide (C.dom f)"
         using assms ideI
         by (meson C.ide_dom arr_char dom_closed inclusion)
       moreover have "f \<cdot> C.dom f \<noteq> null"
         using assms inclusion comp_def null_char dom_closed not_arr_null C.comp_arr_dom arr_char
         by auto
       ultimately show ?thesis
         using dom_eqI ext by blast
     qed
 
     lemma dom_char:
     shows "dom f = (if arr f then C.dom f else C.null)"
       using dom_simp dom_def arr_def arr_char by auto
 
     lemma cod_simp:
     assumes "arr f"
     shows "cod f = C.cod f"
     proof -
       have "ide (C.cod f)"
         using assms ideI
         by (meson C.ide_cod arr_char cod_closed inclusion)
       moreover have "C.cod f \<cdot> f \<noteq> null"
         using assms inclusion comp_def null_char cod_closed not_arr_null C.comp_cod_arr arr_char
         by auto
       ultimately show ?thesis
         using cod_eqI ext by blast
     qed
 
     lemma cod_char:
     shows "cod f = (if arr f then C.cod f else C.null)"
       using cod_simp cod_def arr_def by auto
 
     lemma in_hom_char:
     shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> arr a \<and> arr b \<and> arr f \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>"
       using inclusion arr_char cod_closed dom_closed
       by (metis C.arr_iff_in_hom C.in_homE arr_iff_in_hom cod_simp dom_simp in_homE)
 
     lemma ide_char:
     shows "ide a \<longleftrightarrow> arr a \<and> C.ide a"
       using ide_in_hom C.ide_in_hom in_hom_char by simp
 
     lemma seq_char:
     shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> C.seq g f"
     proof
       show "arr f \<and> arr g \<and> C.seq g f \<Longrightarrow> seq g f"
         using arr_char dom_char cod_char by (intro seqI, auto)
       show "seq g f \<Longrightarrow> arr f \<and> arr g \<and> C.seq g f"
         apply (elim seqE, auto)
         using inclusion arr_char dom_simp cod_simp by auto
     qed
 
     lemma hom_char:
     shows "hom a b = C.hom a b \<inter> Collect Arr"
     proof
       show "hom a b \<subseteq> C.hom a b \<inter> Collect Arr"
         using in_hom_char by auto
       show "C.hom a b \<inter> Collect Arr \<subseteq> hom a b"
         using arr_char dom_char cod_char by force
     qed
 
     lemma comp_char:
     shows "g \<cdot> f = (if arr f \<and> arr g \<and> C.seq g f then g \<cdot>\<^sub>C f else C.null)"
       using arr_char comp_def comp_closed C.ext by force
 
     lemma comp_simp:
     assumes "seq g f"
     shows "g \<cdot> f = g \<cdot>\<^sub>C f"
       using assms comp_char seq_char by metis
 
     lemma inclusion_preserves_inverse:
     assumes "inverse_arrows f g"
     shows "C.inverse_arrows f g"
       using assms ide_char comp_simp arr_char
       by (intro C.inverse_arrowsI, auto)
 
     lemma iso_char:
     shows "iso f \<longleftrightarrow> C.iso f \<and> arr f \<and> arr (C.inv f)"
     proof
       assume f: "iso f"
       show "C.iso f \<and> arr f \<and> arr (C.inv f)"
       proof -
         have 1: "inverse_arrows f (inv f)"
           using f inv_is_inverse by auto
         have 2: "C.inverse_arrows f (inv f)"
           using 1 inclusion_preserves_inverse by blast
         moreover have "arr (inv f)"
           using 1 iso_is_arr by blast
         moreover have "inv f = C.inv f"
           using 1 2 C.inv_is_inverse C.inverse_arrow_unique by blast
         ultimately show ?thesis using f 2 iso_is_arr by auto
       qed
       next
       assume f: "C.iso f \<and> arr f \<and> arr (C.inv f)"
       show "iso f"
       proof
         have 1: "C.inverse_arrows f (C.inv f)"
           using f C.inv_is_inverse by blast
         show "inverse_arrows f (C.inv f)"
         proof
           have 2: "C.inv f \<cdot> f = C.inv f \<cdot>\<^sub>C f \<and> f \<cdot> C.inv f = f \<cdot>\<^sub>C C.inv f"
             using f 1 comp_char by fastforce
           have 3: "antipar f (C.inv f)"
             using f C.seqE seqI dom_simp cod_simp by simp
           show "ide (C.inv f \<cdot> f)"
             using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
           show "ide (f \<cdot> C.inv f)"
             using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
         qed
       qed
     qed
 
     lemma inv_char:
     assumes "iso f"
     shows "inv f = C.inv f"
     proof -
       have "C.inverse_arrows f (inv f)"
       proof
         have 1: "inverse_arrows f (inv f)"
           using assms iso_char inv_is_inverse by blast
         show "C.ide (inv f \<cdot>\<^sub>C f)"
         proof -
           have "inv f \<cdot> f = inv f \<cdot>\<^sub>C f"
             using assms 1 inv_in_hom iso_char [of f] comp_char [of "inv f" f] seq_char by auto
           thus ?thesis
             using 1 ide_char arr_char by force
         qed
         show "C.ide (f \<cdot>\<^sub>C inv f)"
         proof -
           have "f \<cdot> inv f = f \<cdot>\<^sub>C inv f"
             using assms 1 inv_in_hom iso_char [of f] comp_char [of f "inv f"] seq_char by auto
           thus ?thesis
             using 1 ide_char arr_char by force
         qed
       qed
       thus ?thesis using C.inverse_arrow_unique C.inv_is_inverse by blast
     qed
 
   end
 
   sublocale subcategory \<subseteq> category comp
     using is_category by auto
 
   section "Full Subcategory"
 
   locale full_subcategory =
     C: category C
     for C :: "'a comp"
     and Ide :: "'a \<Rightarrow> bool" +
     assumes inclusion: "Ide f \<Longrightarrow> C.ide f"
 
   sublocale full_subcategory \<subseteq> subcategory C "\<lambda>f. C.arr f \<and> Ide (C.dom f) \<and> Ide (C.cod f)"
       by (unfold_locales; simp)
 
   context full_subcategory
   begin
 
+    lemma in_hom_char:
+    shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> arr a \<and> arr b \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>"
+      using arr_char in_hom_char by auto
+
     text \<open>
       Isomorphisms in a full subcategory are inherited from the ambient category.
 \<close>
 
     lemma iso_char:
     shows "iso f \<longleftrightarrow> arr f \<and> C.iso f"
     proof
       assume f: "iso f"
       obtain g where g: "inverse_arrows f g" using f by blast
       show "arr f \<and> C.iso f"
       proof -
         have "C.inverse_arrows f g"
           using g apply (elim inverse_arrowsE, intro C.inverse_arrowsI)
           using comp_simp ide_char arr_char by auto
         thus ?thesis
           using f iso_is_arr by blast
       qed
       next
       assume f: "arr f \<and> C.iso f"
       obtain g where g: "C.inverse_arrows f g" using f by blast
       have "inverse_arrows f g"
       proof
         show "ide (comp g f)"
           using f g
           by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
               arr_char dom_simp ide_dom comp_def)
         show "ide (comp f g)"
           using f g C.inverse_arrows_sym [of f g]
           by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
               arr_char dom_simp ide_dom comp_def)
       qed
       thus "iso f" by auto
     qed
 
   end
 
   section "Inclusion Functor"
 
   text \<open>
     If \<open>S\<close> is a subcategory of \<open>C\<close>, then there is an inclusion functor
     from \<open>S\<close> to \<open>C\<close>.  Inclusion functors are faithful embeddings.
 \<close>
 
   locale inclusion_functor =
     C: category C +
     S: subcategory C Arr
   for C :: "'a comp"
   and Arr :: "'a \<Rightarrow> bool"
   begin
 
     interpretation "functor" S.comp C S.map
       using S.map_def S.arr_char S.inclusion S.dom_char S.cod_char
             S.dom_closed S.cod_closed S.comp_closed S.arr_char S.comp_char
       apply unfold_locales
           apply auto[4]
       by (elim S.seqE, auto)
 
     lemma is_functor:
     shows "functor S.comp C S.map" ..
 
     interpretation faithful_functor S.comp C S.map
       apply unfold_locales by simp
 
     lemma is_faithful_functor:
     shows "faithful_functor S.comp C S.map" ..
 
     interpretation embedding_functor S.comp C S.map
       apply unfold_locales by simp
 
     lemma is_embedding_functor:
     shows "embedding_functor S.comp C S.map" ..
 
   end
 
   sublocale inclusion_functor \<subseteq> faithful_functor S.comp C S.map
     using is_faithful_functor by auto
   sublocale inclusion_functor \<subseteq> embedding_functor S.comp C S.map
     using is_embedding_functor by auto
 
   text \<open>
     The inclusion of a full subcategory is a special case.
     Such functors are fully faithful.
 \<close>
 
   locale full_inclusion_functor =
     C: category C +
     S: full_subcategory C Ide
   for C :: "'a comp"
   and Ide :: "'a \<Rightarrow> bool"
 
   sublocale full_inclusion_functor \<subseteq>
               inclusion_functor C "\<lambda>f. C.arr f \<and> Ide (C.dom f) \<and> Ide (C.cod f)" ..
 
   context full_inclusion_functor
   begin
 
     interpretation full_functor S.comp C S.map
       apply unfold_locales
       using S.ide_in_hom
       by (metis (no_types, lifting) C.in_homE S.arr_char S.in_hom_char S.map_simp)
 
     lemma is_full_functor:
     shows "full_functor S.comp C S.map" ..
 
   end
 
   sublocale full_inclusion_functor \<subseteq> full_functor S.comp C S.map
     using is_full_functor by auto
   sublocale full_inclusion_functor \<subseteq> fully_faithful_functor S.comp C S.map ..
 
 end
diff --git a/thys/Category3/Yoneda.thy b/thys/Category3/Yoneda.thy
--- a/thys/Category3/Yoneda.thy
+++ b/thys/Category3/Yoneda.thy
@@ -1,1088 +1,1080 @@
 (*  Title:       Yoneda
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter Yoneda
 
 theory Yoneda
 imports DualCategory SetCat FunctorCategory
 begin
 
   text\<open>
     This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
     In traditional developments of category theory based on set theories such as ZFC,
     hom-functors are normally defined to be functors into the large category \textbf{Set}
     whose objects are of \emph{all} sets and whose arrows are functions between sets.
     However, in HOL there does not exist a single ``type of all sets'', so the notion of
     the category of \emph{all} sets and functions does not make sense.  To work around this,
     we consider a more general setting consisting of a category @{term C} together with
     a set category @{term S} and a function @{term "\<phi> :: 'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"} such that
     whenever @{term b} and @{term a} are objects of C then @{term "\<phi> (b, a)"} maps
     \<open>C.hom b a\<close> injectively to \<open>S.Univ\<close>.  We show that these data induce
     a binary functor \<open>Hom\<close> from \<open>Cop\<times>C\<close> to @{term S} in such a way that @{term \<phi>}
     is rendered natural in @{term "(b, a)"}.  The Yoneda lemma is then proved for the
     Yoneda functor determined by \<open>Hom\<close>.
 \<close>
 
   section "Hom-Functors"
 
   text\<open>
     A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
     as objects of a category @{term S} of sets and functions.  Any description of a
     hom-functor for @{term C} must therefore specify the category @{term S} and provide
     some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
     If we are to think of each hom-set \<open>C.hom b a\<close> of \<open>C\<close> as corresponding
     to an object \<open>Hom (b, a)\<close> of @{term S} then at a minimum it ought to be the
     case that the correspondence between arrows and elements is bijective between
     \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.  The \<open>hom_functor\<close> locale defined
     below captures this idea by assuming a set category @{term S} and a function @{term \<phi>}
     taking arrows of @{term C} to elements of \<open>S.Univ\<close>, such that @{term \<phi>} is injective
     on each set \<open>C.hom b a\<close>.  We show that these data induce a functor \<open>Hom\<close>
     from \<open>Cop\<times>C\<close> to \<open>S\<close> in such a way that @{term \<phi>} becomes a natural
     bijection between \<open>C.hom b a\<close> and \<open>Hom (b, a)\<close>.
 \<close>
 
   locale hom_functor =
     C: category C +
-    Cop: dual_category C +
-    CopxC: product_category Cop.comp C +
-    S: replete_set_category S
+    S: set_category S setp
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's" +
   assumes maps_arr_to_Univ: "C.arr f \<Longrightarrow> \<phi> (C.dom f, C.cod f) f \<in> S.Univ"
   and local_inj: "\<lbrakk> C.ide b; C.ide a \<rbrakk> \<Longrightarrow> inj_on (\<phi> (b, a)) (C.hom b a)"
+  and small_homs: "\<lbrakk> C.ide b; C.ide a \<rbrakk> \<Longrightarrow> setp (\<phi> (b, a) ` C.hom b a)"
   begin
 
+    sublocale Cop: dual_category C ..
+    sublocale CopxC: product_category Cop.comp C ..
+
     notation S.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
     notation CopxC.comp   (infixr "\<odot>" 55)
     notation CopxC.in_hom ("\<guillemotleft>_ : _ \<rightleftharpoons> _\<guillemotright>")
 
     definition set
     where "set ba \<equiv> \<phi> (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"
 
     lemma set_subset_Univ:
     assumes "C.ide b" and "C.ide a"
     shows "set (b, a) \<subseteq> S.Univ"
       using assms set_def maps_arr_to_Univ CopxC.ide_char by auto
 
     definition \<psi> :: "'c * 'c \<Rightarrow> 's \<Rightarrow> 'c"
     where "\<psi> ba = inv_into (C.hom (fst ba) (snd ba)) (\<phi> ba)"
 
     lemma \<phi>_mapsto:
     assumes "C.ide b" and "C.ide a"
     shows "\<phi> (b, a) \<in> C.hom b a \<rightarrow> set (b, a)"
       using assms set_def maps_arr_to_Univ by auto
 
     lemma \<psi>_mapsto:
     assumes "C.ide b" and "C.ide a"
     shows "\<psi> (b, a) \<in> set (b, a) \<rightarrow> C.hom b a"
       using assms set_def \<psi>_def local_inj by auto
 
     lemma \<psi>_\<phi> [simp]:
     assumes "\<guillemotleft>f : b \<rightarrow> a\<guillemotright>"
     shows "\<psi> (b, a) (\<phi> (b, a) f) = f"
       using assms local_inj [of b a] \<psi>_def by fastforce
 
     lemma \<phi>_\<psi> [simp]:
     assumes "C.ide b" and "C.ide a"
     and "x \<in> set (b, a)"
     shows "\<phi> (b, a) (\<psi> (b, a) x) = x"
       using assms set_def local_inj \<psi>_def by auto
 
     lemma \<psi>_img_set:
     assumes "C.ide b" and "C.ide a"
     shows "\<psi> (b, a) ` set (b, a) = C.hom b a"
       using assms \<psi>_def set_def local_inj by auto
 
     text\<open>
       A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
       to the arrow of the set category @{term[source=true] S} corresponding to the function
       that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
       obtained by precomposing with @{term g} and postcomposing with @{term f}.
 \<close>
 
     definition map
     where "map gf =
              (if CopxC.arr gf then
                 S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
                         (\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf))
               else S.null)"
 
     lemma arr_map:
     assumes "CopxC.arr gf"
     shows "S.arr (map gf)"
     proof -
       have "\<phi> (CopxC.cod gf) o (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) o \<psi> (CopxC.dom gf)
               \<in> set (CopxC.dom gf) \<rightarrow> set (CopxC.cod gf)"
         using assms \<phi>_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
               \<psi>_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
         by fastforce
       thus ?thesis
-        using assms map_def S.arr_mkArr set_subset_Univ S.card_of_leq by simp
+        using assms map_def set_subset_Univ small_homs
+        by (simp add: set_def)
     qed
 
     lemma map_ide [simp]:
     assumes "C.ide b" and "C.ide a"
     shows "map (b, a) = S.mkIde (set (b, a))"
     proof -
       have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
                                  (\<phi> (b, a) o (\<lambda>h. a \<cdot> h \<cdot> b) o \<psi> (b, a))"
         using assms map_def by auto
       also have "... = S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h)"
       proof -
         have "S.mkArr (set (b, a)) (set (b, a)) (\<lambda>h. h) = ..."
-          using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
-                S.card_of_leq S.arr_mkIde
+          using assms set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
+                S.arr_mkIde small_homs
           by (intro S.mkArr_eqI', simp, fastforce)
         thus ?thesis by auto
       qed
       also have "... = S.mkIde (set (b, a))"
-        using assms S.mkIde_as_mkArr set_subset_Univ by simp
+        using assms S.mkIde_as_mkArr set_subset_Univ small_homs
+        by (simp add: set_def)
       finally show ?thesis by auto
     qed
 
     lemma set_map:
     assumes "C.ide a" and "C.ide b"
     shows "S.set (map (b, a)) = set (b, a)"
-      using assms map_ide S.set_mkIde set_subset_Univ by simp
+      using assms map_ide set_subset_Univ small_homs set_def by simp
 
     text\<open>
       The definition does in fact yield a functor.
 \<close>
 
-    interpretation "functor" CopxC.comp S map
+    sublocale "functor" CopxC.comp S map
     proof
       fix gf
       assume "\<not>CopxC.arr gf"
       thus "map gf = S.null" using map_def by auto
       next
       fix gf
       assume gf: "CopxC.arr gf"
       thus arr: "S.arr (map gf)" using gf arr_map by blast
       show "S.dom (map gf) = map (CopxC.dom gf)"
         using arr gf local.map_def map_ide by auto
       show "S.cod (map gf) = map (CopxC.cod gf)"
-        using gf set_subset_Univ \<psi>_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
-              arr map_ide
+        using gf set_subset_Univ \<psi>_mapsto map_def set_def S.arr_mkIde arr map_ide
         by auto
       next
       fix gf gf'
       assume gf': "CopxC.seq gf' gf"
       hence seq: "C.arr (fst gf) \<and> C.arr (snd gf) \<and> C.dom (snd gf') = C.cod (snd gf) \<and>
                   C.arr (fst gf') \<and> C.arr (snd gf') \<and> C.dom (fst gf) = C.cod (fst gf')"
         by (elim CopxC.seqE C.seqE, auto)
       have 0: "S.arr (map (CopxC.comp gf' gf))"
         using gf' arr_map by blast
       have 1: "map (gf' \<odot> gf) =
                     S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                             (\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                                o \<psi> (CopxC.dom gf))"
         using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
       also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                                (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf')
                                 \<circ>
                                (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                              (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                                 \<circ> \<psi> (CopxC.dom gf)))"
           using 0 1 by simp
         show "\<And>x. x \<in> set (CopxC.dom gf) \<Longrightarrow>
                      (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                       \<psi> (CopxC.dom gf)) x =
                      (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                       (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
         proof -
           fix x
           assume "x \<in> set (CopxC.dom gf)"
           hence x: "x \<in> set (C.cod (fst gf), C.dom (snd gf))"
             by (simp add: seq)
           show "(\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf)) \<circ>
                  \<psi> (CopxC.dom gf)) x =
                 (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                  (\<phi> (CopxC.cod gf) \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf))) x"
           proof -
             have "(\<phi> (CopxC.cod gf') o (\<lambda>h. snd (gf' \<odot> gf) \<cdot> h \<cdot> fst (gf' \<odot> gf))
                                      o \<psi> (CopxC.dom gf)) x =
                   \<phi> (CopxC.cod gf') (snd (gf' \<odot> gf) \<cdot> \<psi> (CopxC.dom gf) x \<cdot> fst (gf' \<odot> gf))"
               by simp
             also have "... = \<phi> (CopxC.cod gf')
                                (((\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                                  (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf)))
                                 (\<psi> (CopxC.dom gf) x))"
             proof -
               have "C.ide (C.cod (fst gf)) \<and> C.ide (C.dom (snd gf))"
                 using gf' by (elim CopxC.seqE, auto)
               hence "\<guillemotleft>\<psi> (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf) \<rightarrow> C.dom (snd gf)\<guillemotright>"
                 using x \<psi>_mapsto by auto
               hence "\<guillemotleft>snd gf \<cdot> \<psi> (C.cod (fst gf), C.dom (snd gf)) x \<cdot> fst gf :
                         C.cod (fst gf') \<rightarrow> C.dom (snd gf')\<guillemotright>"
                 using x seq by auto
               thus ?thesis
                 using seq \<psi>_\<phi> C.comp_assoc by auto
             qed
             also have "... = (\<phi> (CopxC.cod gf') \<circ> (\<lambda>h. snd gf' \<cdot> h \<cdot> fst gf') \<circ> \<psi> (CopxC.dom gf') \<circ>
                               (\<phi> (CopxC.dom gf') \<circ> (\<lambda>h. snd gf \<cdot> h \<cdot> fst gf) \<circ> \<psi> (CopxC.dom gf)))
                               x"
               by auto
             finally show ?thesis using seq by simp
           qed
         qed
       qed
       also have "... = map gf' \<cdot>\<^sub>S map gf"
         using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
       finally show "map (gf' \<odot> gf) = map gf' \<cdot>\<^sub>S map gf"
         using seq gf' by auto
     qed
 
-    interpretation binary_functor Cop.comp C S map ..
+    lemma is_functor:
+    shows "functor CopxC.comp S map" ..
+
+    sublocale binary_functor Cop.comp C S map ..
 
     lemma is_binary_functor:
     shows "binary_functor Cop.comp C S map" ..
 
-  end
-
-  sublocale hom_functor \<subseteq> binary_functor Cop.comp C S map
-    using is_binary_functor by auto
-
-  context hom_functor
-  begin
-
     text\<open>
       The map @{term \<phi>} determines a bijection between @{term "C.hom b a"} and
       @{term "set (b, a)"} which is natural in @{term "(b, a)"}.
 \<close>
 
     lemma \<phi>_local_bij:
     assumes "C.ide b" and "C.ide a"
     shows "bij_betw (\<phi> (b, a)) (C.hom b a) (set (b, a))"
       using assms local_inj inj_on_imp_bij_betw set_def by auto
 
     lemma \<phi>_natural:
     assumes "C.arr g" and "C.arr f" and "h \<in> C.hom (C.cod g) (C.dom f)"
     shows "\<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g) = S.Fun (map (g, f)) (\<phi> (C.cod g, C.dom f) h)"
     proof -
       let ?\<phi>h = "\<phi> (C.cod g, C.dom f) h"
       have \<phi>h: "?\<phi>h \<in> set (C.cod g, C.dom f)"
         using assms \<phi>_mapsto set_def by simp
       have gf: "CopxC.arr (g, f)" using assms by simp
       have "map (g, f) =
                S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
                        (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))"
         using assms map_def by simp
       moreover have "S.arr (map (g, f))" using gf by simp
       ultimately have
           "S.Fun (map (g, f)) =
                restrict (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f))
                         (set (C.cod g, C.dom f))"
         using S.Fun_mkArr by simp
       hence "S.Fun (map (g, f)) ?\<phi>h =
                 (\<phi> (C.dom g, C.cod f) \<circ> (\<lambda>h. f \<cdot> h \<cdot> g) \<circ> \<psi> (C.cod g, C.dom f)) ?\<phi>h"
         using \<phi>h by simp
       also have "... = \<phi> (C.dom g, C.cod f) (f \<cdot> h \<cdot> g)"
         using assms(3) by simp
       finally show ?thesis by auto
     qed
 
     lemma Dom_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
-      using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
+      using assms map_def preserves_arr by auto
 
     lemma Cod_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Cod (map (g, f)) = set (C.dom g, C.cod f)"
-      using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto
+      using assms map_def preserves_arr by auto
 
     lemma Fun_map:
     assumes "C.arr g" and "C.arr f"
     shows "S.Fun (map (g, f)) =
              restrict (\<phi> (C.dom g, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> g) o \<psi> (C.cod g, C.dom f))
                       (set (C.cod g, C.dom f))"
       using assms map_def preserves_arr by force
 
     lemma map_simp_1:
     assumes "C.arr g" and "C.ide a"
     shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                 (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
     proof -
       have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                     (\<phi> (C.dom g, a) o (\<lambda>h. a \<cdot> h \<cdot> g) o \<psi> (C.cod g, a))"
         using assms map_def by force
       also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                (\<phi> (C.dom g, a) o Cop.comp g o \<psi> (C.cod g, a))"
         using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
         by (intro S.mkArr_eqI) auto
      finally show ?thesis by blast
     qed
 
     lemma map_simp_2:
     assumes "C.ide b" and "C.arr f"
     shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                 (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
     proof -
       have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                     (\<phi> (b, C.cod f) o (\<lambda>h. f \<cdot> h \<cdot> b) o \<psi> (b, C.dom f))"
         using assms map_def by force
       also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                (\<phi> (b, C.cod f) o C f o \<psi> (b, C.dom f))"
         using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
         by (intro S.mkArr_eqI) auto
       finally show ?thesis by blast
     qed
 
   end
 
   text\<open>
     Every category @{term C} has a hom-functor: take @{term S} to be the replete set category
     generated by the arrow type \<open>'a\<close> of @{term C} and take @{term "\<phi> (b, a)"} to be the map
     \<open>S.UP :: 'a \<Rightarrow> 'a SC.arr\<close>.
 \<close>
 
   context category
   begin
 
     interpretation Cop: dual_category C ..
     interpretation CopxC: product_category Cop.comp C ..
     interpretation S: replete_setcat \<open>undefined :: 'a\<close> .
 
     lemma has_hom_functor:
-    shows "hom_functor C (S.comp :: 'a setcat.arr comp) (\<lambda>_. S.UP)"
+    shows "hom_functor C S.comp S.setp (\<lambda>_. S.UP)"
     proof
       show "\<And>f. arr f \<Longrightarrow> S.UP f \<in> S.Univ"
         using S.UP_mapsto by auto
+      thus "\<And>b a. \<lbrakk>ide b; ide a\<rbrakk> \<Longrightarrow> S.UP ` hom b a \<subseteq> S.Univ"
+        by force
       show "\<And>b a. \<lbrakk>ide b; ide a\<rbrakk> \<Longrightarrow> inj_on S.UP (hom b a)"
         by (meson S.inj_UP injD inj_onI)
     qed
 
   end
 
   text\<open>
     The locales \<open>set_valued_functor\<close> and \<open>set_valued_transformation\<close> provide some
     abbreviations that are convenient when working with functors and natural transformations
     into a set category.
 \<close>
 
   locale set_valued_functor =
     C: category C +
-    S: replete_set_category S +
+    S: set_category S setp +
     "functor" C S F
     for C :: "'c comp"
     and S :: "'s comp"
+    and setp :: "'s set \<Rightarrow> bool"
     and F :: "'c \<Rightarrow> 's"
   begin
 
     abbreviation SET :: "'c \<Rightarrow> 's set"
     where "SET a \<equiv> S.set (F a)"
     
     abbreviation DOM :: "'c \<Rightarrow> 's set"
     where "DOM f \<equiv> S.Dom (F f)"
     
     abbreviation COD :: "'c \<Rightarrow> 's set"
     where "COD f \<equiv> S.Cod (F f)"
 
     abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
     where "FUN f \<equiv> S.Fun (F f)"
 
   end
 
   locale set_valued_transformation =
     C: category C +
-    S: replete_set_category S +
-    F: set_valued_functor C S F +
-    G: set_valued_functor C S G +
+    S: set_category S setp +
+    F: set_valued_functor C S setp F +
+    G: set_valued_functor C S setp G +
     natural_transformation C S F G \<tau>
   for C :: "'c comp"
   and S :: "'s comp"
+  and setp :: "'s set \<Rightarrow> bool"
   and F :: "'c \<Rightarrow> 's"
   and G :: "'c \<Rightarrow> 's"
   and \<tau> :: "'c \<Rightarrow> 's"
   begin
   
     abbreviation DOM :: "'c \<Rightarrow> 's set"
     where "DOM f \<equiv> S.Dom (\<tau> f)"
     
     abbreviation COD :: "'c \<Rightarrow> 's set"
     where "COD f \<equiv> S.Cod (\<tau> f)"
 
     abbreviation FUN :: "'c \<Rightarrow> 's \<Rightarrow> 's"
     where "FUN f \<equiv> S.Fun (\<tau> f)"
 
   end
 
   section "Yoneda Functors"
     
   text\<open>
     A Yoneda functor is the functor from @{term C} to \<open>[Cop, S]\<close> obtained by ``currying''
     a hom-functor in its first argument.
 \<close>
 
   locale yoneda_functor =
     C: category C +
     Cop: dual_category C +
     CopxC: product_category Cop.comp C +
-    S: replete_set_category S +
-    Hom: hom_functor C S \<phi> +
-    Cop_S: functor_category Cop.comp S +
-    curried_functor' Cop.comp C S Hom.map
+    S: set_category S setp +
+    Hom: hom_functor C S setp \<phi>
   for C :: "'c comp"      (infixr "\<cdot>" 55)
   and S :: "'s comp"      (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   begin
 
+    sublocale Cop_S: functor_category Cop.comp S ..
+    sublocale curried_functor' Cop.comp C S Hom.map ..
+
     notation Cop_S.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] _\<guillemotright>")
 
     abbreviation \<psi>
     where "\<psi> \<equiv> Hom.\<psi>"
 
     text\<open>
       An arrow of the functor category \<open>[Cop, S]\<close> consists of a natural transformation
       bundled together with its domain and codomain functors.  However, when considering
       a Yoneda functor from @{term[source=true] C} to \<open>[Cop, S]\<close> we generally are only
       interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
       to the corresponding natural transformation @{term "Y f"}.  The domain and codomain functors
       are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
 \<close>
 
     definition Y
     where "Y f \<equiv> Cop_S.Map (map f)"
 
     lemma Y_simp [simp]:
     assumes "C.arr f"
     shows "Y f = (\<lambda>g. Hom.map (g, f))"
       using assms preserves_arr Y_def by simp
 
     lemma Y_ide_is_functor:
     assumes "C.ide a"
     shows "functor Cop.comp S (Y a)"
       using assms Y_def Hom.fixing_ide_gives_functor_2 by force
 
     lemma Y_arr_is_transformation:
     assumes "C.arr f"
     shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
       using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
             preserves_dom preserves_cod by fastforce
 
     lemma Y_ide_arr [simp]:
     assumes a: "C.ide a" and "\<guillemotleft>g : b' \<rightarrow> b\<guillemotright>"
     shows "\<guillemotleft>Y a g : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b', a)\<guillemotright>"
     and "Y a g =
          S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (\<phi> (b', a) o Cop.comp g o \<psi> (b, a))"
       using assms Hom.map_simp_1 by (fastforce, auto)
 
     lemma Y_arr_ide [simp]:
     assumes "C.ide b" and "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>"
     shows "\<guillemotleft>Y f b : Hom.map (b, a) \<rightarrow>\<^sub>S Hom.map (b, a')\<guillemotright>"
     and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (\<phi> (b, a') o C f o \<psi> (b, a))"
       using assms apply fastforce
       using assms Hom.map_simp_2 by auto
 
   end
 
   locale yoneda_functor_fixed_object =
-    yoneda_functor C S \<phi>
-  for C :: "'c comp" (infixr "\<cdot>" 55)
-  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
-  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
-  and a :: 'c +
+    yoneda_functor +
+  fixes a
   assumes ide_a: "C.ide a"
+  begin
   
-  sublocale yoneda_functor_fixed_object \<subseteq> "functor" Cop.comp S "(Y a)"
-    using ide_a Y_ide_is_functor by auto
-  sublocale yoneda_functor_fixed_object \<subseteq> set_valued_functor Cop.comp S "(Y a)" ..
+    sublocale "functor" Cop.comp S \<open>Y a\<close>
+      using ide_a Y_ide_is_functor by auto
+    sublocale set_valued_functor Cop.comp S setp \<open>Y a\<close> ..
+
+  end
 
   text\<open>
     The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
     from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
     the set of natural transformations from the contravariant functor @{term "Y a"}
     to @{term F} is in bijective correspondence with the set \<open>F.SET a\<close>
     of elements of @{term "F a"}.
 
     Explicitly, if @{term e} is an arbitrary element of the set \<open>F.SET a\<close>,
     then the functions \<open>\<lambda>x. F.FUN (\<psi> (b, a) x) e\<close> are the components of a
     natural transformation from @{term "Y a"} to @{term F}.
     Conversely, if @{term \<tau>} is a natural transformation from @{term "Y a"} to @{term F},
     then the component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
     is completely determined by the single arrow \<open>\<tau>.FUN a (\<phi> (a, a) a)))\<close>,
     which is the the element of \<open>F.SET a\<close> that corresponds to the image of the
     identity @{term a} under the function \<open>\<tau>.FUN a\<close>.
     Then @{term "\<tau> b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
     to the function \<open>\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a)))\<close>
     from \<open>S.set (Y a b)\<close> to \<open>F.SET b\<close>.
    
     The above expressions look somewhat more complicated than the usual versions due to the
     need to account for the coercions @{term \<phi>} and @{term \<psi>}.
 \<close>
 
   locale yoneda_lemma =
-    C: category C +
-    Cop: dual_category C +
-    S: replete_set_category S +
-    F: set_valued_functor Cop.comp S F +
-    yoneda_functor_fixed_object C S \<phi> a
+    yoneda_functor_fixed_object C S setp \<phi> a +
+    F: set_valued_functor Cop.comp S setp F
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
   and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   begin
 
     text\<open>
       The mapping that evaluates the component @{term "\<tau> a"} at @{term a} of a
       natural transformation @{term \<tau>} from @{term Y} to @{term F} on the element
       @{term "\<phi> (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
 \<close>
 
     definition \<E> :: "('c \<Rightarrow> 's) \<Rightarrow> 's"
     where "\<E> \<tau> = S.Fun (\<tau> a) (\<phi> (a, a) a)"
 
     text\<open>
       The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
       a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
       @{term[source=true] S} corresponding to the function
       @{term "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"}.
 \<close>
 
-    definition \<T>o :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
-    where "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
+    definition \<T>\<^sub>o :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
+    where "\<T>\<^sub>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
 
-    lemma \<T>o_e_ide:
+    lemma \<T>\<^sub>o_in_hom:
     assumes e: "e \<in> S.set (F a)" and b: "C.ide b"
-    shows "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
-    and "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
+    shows "\<guillemotleft>\<T>\<^sub>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
     proof -
-      show "\<T>o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
-        using \<T>o_def by auto
-      moreover have "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"
+      have "(\<lambda>x. F.FUN (\<psi> (b, a) x) e) \<in> Hom.set (b, a) \<rightarrow> F.SET b"
       proof
         fix x
         assume x: "x \<in> Hom.set (b, a)"
         thus "F.FUN (\<psi> (b, a) x) e \<in> F.SET b"
           using assms e ide_a Hom.\<psi>_mapsto S.Fun_mapsto [of "F (\<psi> (b, a) x)"] by force
       qed
-      ultimately show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
+      thus ?thesis
         using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
-              S.mkIde_set
-        by force
+              S.mkIde_set \<T>\<^sub>o_def
+        by (metis C.ideD(1) Cop.ide_char F.preserves_ide Hom.set_map S.setp_set_ide
+            preserves_ide Y_simp)
     qed
 
     text\<open>
-      For each @{term "e \<in> F.SET a"}, the mapping @{term "\<T>o e"} gives the components
+      For each @{term "e \<in> F.SET a"}, the mapping @{term "\<T>\<^sub>o e"} gives the components
       of a natural transformation @{term \<T>} from @{term "Y a"} to @{term F}.
 \<close>
 
-    lemma \<T>o_e_induces_transformation:
+    lemma \<T>\<^sub>o_induces_transformation:
     assumes e: "e \<in> S.set (F a)"
-    shows "transformation_by_components Cop.comp S (Y a) F (\<T>o e)"
+    shows "transformation_by_components Cop.comp S (Y a) F (\<T>\<^sub>o e)"
     proof
       fix b :: 'c
       assume b: "Cop.ide b"
-      show "\<guillemotleft>\<T>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
-        using ide_a b e \<T>o_e_ide by simp
+      show "\<guillemotleft>\<T>\<^sub>o e b : Y a b \<rightarrow>\<^sub>S F b\<guillemotright>"
+        using ide_a b e \<T>\<^sub>o_in_hom by simp
       next
       fix g :: 'c
       assume g: "Cop.arr g"
       let ?b = "Cop.dom g"
       let ?b' = "Cop.cod g"
-      show "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
+      show "\<T>\<^sub>o e (Cop.cod g) \<cdot>\<^sub>S Y a g = F g \<cdot>\<^sub>S \<T>\<^sub>o e (Cop.dom g)"
       proof -
-        have 1: "\<T>o e (Cop.cod g) \<cdot>\<^sub>S Y a g
+        have 1: "\<T>\<^sub>o e (Cop.cod g) \<cdot>\<^sub>S Y a g
                    = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                              ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                 o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)))"
         proof -
           have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) \<and>
                 S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = Y a (Cop.cod g) \<and>
                 S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                       (\<lambda>s. F.FUN (\<psi> (Cop.cod g, a) s) e)) = F (Cop.cod g)"
-            using Cop.cod_char \<T>o_e_ide [of e ?b'] \<T>o_e_ide [of e ?b'] e g
+            using Cop.cod_char \<T>\<^sub>o_def \<T>\<^sub>o_in_hom [of e ?b'] e g
             by (metis Cop.ide_char Cop.ide_cod S.in_homE)
           moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
                                          (\<phi> (Cop.cod g, a) \<circ> Cop.comp g \<circ> \<psi> (Cop.dom g, a))"
             using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
           ultimately show ?thesis
-            using ide_a e g Y_ide_arr Cop.cod_char \<T>o_e_ide
+            using ide_a e g Y_ide_arr Cop.cod_char \<T>\<^sub>o_def
                   S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
                                    "\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)"
                                    "F.SET ?b'" "\<lambda>x. F.FUN (\<psi> (?b', a) x) e"]
-            by (metis C.ide_dom Cop.arr_char preserves_arr)
+            by (metis preserves_arr)
         qed
         also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                  (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e))"
         proof (intro S.mkArr_eqI')
           have "(\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                    o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a)) \<in> Hom.set (?b, a) \<rightarrow> F.SET ?b'"
           proof -
-            have "S.arr (S (\<T>o e ?b') (Y a g))"
-              using ide_a e g \<T>o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
+            have "S.arr (S (\<T>\<^sub>o e ?b') (Y a g))"
+              using ide_a e g \<T>\<^sub>o_in_hom [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
                     Cop.ide_char Cop.ide_cod
               by blast
-            thus ?thesis using 1 S.arr_mkArr by simp
+            thus ?thesis using 1 by simp
           qed
           thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                                   o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))))"
-            using ide_a e g Hom.set_subset_Univ S.arr_mkArr by force
+            using ide_a e g Hom.set_subset_Univ S.arr_mkArr
+            by (metis C.dom_dom C.ide_dom Cop.arr_char Cop.cod_char Cop.comp_cod_arr
+                Cop.comp_in_homI' Cop.seqE S.seqI' \<T>\<^sub>o_in_hom calculation preserves_hom)
           show "\<And>x. x \<in> Hom.set (?b, a) \<Longrightarrow>
                         ((\<lambda>x. F.FUN (\<psi> (?b', a) x) e) o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                         = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
           proof -
             fix x
             assume x: "x \<in> Hom.set (?b, a)"
             have "((\<lambda>x. (F.FUN o \<psi> (?b', a)) x e)
                        o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                     = F.FUN (\<psi> (?b', a) (\<phi> (?b', a) (C (\<psi> (?b, a) x) g))) e"
               by simp
             also have "... = (F.FUN g o (F.FUN o \<psi> (?b, a)) x) e"
             proof -
               have 1: "\<guillemotleft>\<psi> (Cop.dom g, a) x : Cop.dom g \<rightarrow> a\<guillemotright>"
                 using ide_a x g Hom.\<psi>_mapsto [of ?b a] by auto
               moreover have "S.seq (F g) (F (\<psi> (C.cod g, a) x))"
                 using 1 g by (intro S.seqI', auto)
               moreover have "\<psi> (C.dom g, a) (\<phi> (C.dom g, a) (C (\<psi> (C.cod g, a) x) g)) =
                              C (\<psi> (C.cod g, a) x) g"
                 using g 1 Hom.\<psi>_\<phi> [of "C (\<psi> (?b, a) x) g" ?b' a] by fastforce
               ultimately show ?thesis
                 using assms F.preserves_comp by fastforce
             qed
             also have "... = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x" by fastforce
             finally show "((\<lambda>x. F.FUN (\<psi> (?b', a) x) e)
                              o (\<phi> (?b', a) o Cop.comp g o \<psi> (?b, a))) x
                             = (F.FUN g o (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)) x"
               by simp
           qed
         qed
-        also have "... = F g \<cdot>\<^sub>S \<T>o e (Cop.dom g)"
+        also have "... = F g \<cdot>\<^sub>S \<T>\<^sub>o e (Cop.dom g)"
         proof -
           have "S.arr (F g) \<and> F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
             using g S.mkArr_Fun [of "F g"] by simp
           moreover have
-              "S.arr (\<T>o e ?b) \<and>
-               \<T>o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)"
-            using e g \<T>o_e_ide
+              "S.arr (\<T>\<^sub>o e ?b) \<and>
+               \<T>\<^sub>o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (\<lambda>x. F.FUN (\<psi> (?b, a) x) e)"
+            using e g \<T>\<^sub>o_def \<T>\<^sub>o_in_hom
             by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
           ultimately show ?thesis
             using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "\<lambda>x. F.FUN (\<psi> (?b, a) x) e"
                                    "F.SET ?b'" "F.FUN g"]
             by metis
         qed
         finally show ?thesis by blast
       qed
     qed
 
-    abbreviation \<T> :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
-    where "\<T> e \<equiv> transformation_by_components.map Cop.comp S (Y a) (\<T>o e)"
+    definition \<T> :: "'s \<Rightarrow> 'c \<Rightarrow> 's"
+    where "\<T> e \<equiv> transformation_by_components.map Cop.comp S (Y a) (\<T>\<^sub>o e)"
 
   end
 
   locale yoneda_lemma_fixed_e =
-    yoneda_lemma C S \<phi> F a
-  for C :: "'c comp" (infixr "\<cdot>" 55)
-  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
-  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
-  and F :: "'c \<Rightarrow> 's"
-  and a :: 'c
-  and e :: 's +
+    yoneda_lemma +
+  fixes e
   assumes E: "e \<in> F.SET a"
   begin
 
-    interpretation \<T>e: transformation_by_components Cop.comp S \<open>Y a\<close> F \<open>\<T>o e\<close>
-      using E \<T>o_e_induces_transformation by auto
+    interpretation \<T>e: transformation_by_components Cop.comp S \<open>Y a\<close> F \<open>\<T>\<^sub>o e\<close>
+      using E \<T>\<^sub>o_induces_transformation by auto
+    sublocale \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> e\<close>
+      unfolding \<T>_def ..
 
     lemma natural_transformation_\<T>e:
     shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
 
     lemma \<T>e_ide:
     assumes "Cop.ide b"
     shows "S.arr (\<T> e b)"
     and "\<T> e b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. F.FUN (\<psi> (b, a) x) e)"
       using assms apply fastforce
-      using assms \<T>o_def by auto
+      using assms \<T>\<^sub>o_def \<T>_def by auto
 
   end
 
   locale yoneda_lemma_fixed_\<tau> =
-    yoneda_lemma C S \<phi> F a +
-    \<tau>: set_valued_transformation Cop.comp S "Y a" F \<tau>
-  for C :: "'c comp" (infixr "\<cdot>" 55)
-  and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
-  and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
-  and F :: "'c \<Rightarrow> 's"
-  and a :: 'c
-  and \<tau> :: "'c \<Rightarrow> 's"
+    yoneda_lemma +
+    \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>
+  for \<tau>
   begin
 
+    sublocale \<tau>: set_valued_transformation Cop.comp S setp \<open>Y a\<close> F \<tau> ..
+
     text\<open>
       The key lemma: The component @{term "\<tau> b"} of @{term \<tau>} at an arbitrary object @{term b}
       is completely determined by the single element @{term "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"}.
 \<close>
 
     lemma \<tau>_ide:
     assumes b: "Cop.ide b"
     shows "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b)
                          (\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a (\<phi> (a, a) a))))"
     proof -
       let ?\<phi>a = "\<phi> (a, a) a"
       have \<phi>a: "\<phi> (a, a) a \<in> Hom.set (a, a)" using ide_a Hom.\<phi>_mapsto [of a a] by fastforce
       have 1: "\<tau> b = S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b)"
         using ide_a b S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
       also have
           "... = S.mkArr (Hom.set (b, a)) (F.SET b) (\<lambda>x. (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a)))"
       proof (intro S.mkArr_eqI')
         show "S.arr (S.mkArr (Hom.set (b, a)) (F.SET b) (\<tau>.FUN b))"
           using ide_a b 1 S.mkArr_Fun [of "\<tau> b"] Hom.set_map by auto
         show "\<And>x. x \<in> Hom.set (b, a) \<Longrightarrow> \<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
         proof -
           fix x
           assume x: "x \<in> Hom.set (b, a)"
           let ?\<psi>x = "\<psi> (b, a) x"
           have \<psi>x: "\<guillemotleft>?\<psi>x : b \<rightarrow> a\<guillemotright>"
             using ide_a b x Hom.\<psi>_mapsto [of b a] by auto
           show "\<tau>.FUN b x = (F.FUN (\<psi> (b, a) x) (\<tau>.FUN a ?\<phi>a))"
           proof -
             have "\<tau>.FUN b x = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
             proof -
               have "\<tau>.FUN b x = \<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)"
                 using ide_a b x \<psi>x Hom.\<phi>_\<psi>
                by (metis C.comp_cod_arr C.in_homE C.ide_dom Cop.comp_def comp_apply)
               also have "\<tau>.FUN b ((\<phi> (b, a) o Cop.comp ?\<psi>x) a)
                            = (\<tau>.FUN b o (\<phi> (b, a) o Cop.comp ?\<psi>x o \<psi> (a, a))) ?\<phi>a"
                 using ide_a b C.ide_in_hom by simp
               also have "... = S.Fun (\<tau> b \<cdot>\<^sub>S Y a ?\<psi>x) ?\<phi>a"
               proof -
                 have "S.arr (Y a ?\<psi>x)"
                   using ide_a \<psi>x preserves_arr by (elim C.in_homE, auto)
                 moreover have "Y a ?\<psi>x = S.mkArr (Hom.set (a, a)) (SET b)
                                                  (\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a))"
                   using ide_a b \<psi>x preserves_hom Y_ide_arr Hom.set_map C.arrI by auto
                 moreover have "S.arr (\<tau> b) \<and> \<tau> b = S.mkArr (SET b) (F.SET b) (\<tau>.FUN b)"
                   using ide_a b S.mkArr_Fun [of "\<tau> b"] by simp
                 ultimately have
                      "S.seq (\<tau> b) (Y a ?\<psi>x) \<and>
                       \<tau> b \<cdot>\<^sub>S Y a ?\<psi>x =
                          S.mkArr (Hom.set (a, a)) (F.SET b)
                                  (\<tau>.FUN b o (\<phi> (b, a) \<circ> Cop.comp ?\<psi>x \<circ> \<psi> (a, a)))"
                   using 1 S.comp_mkArr S.seqI
                   by (metis S.cod_mkArr S.dom_mkArr)
                 thus ?thesis
                   using ide_a b x Hom.\<phi>_mapsto S.Fun_mkArr by force
               qed
               finally show ?thesis by auto
             qed
             also have "... = S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) ?\<phi>a"
               using ide_a b \<psi>x \<tau>.naturality [of ?\<psi>x] by force
             also have "... = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
             proof -
               have "restrict (S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)) (Hom.set (a, a))
                                = restrict (F.FUN (\<psi> (b, a) x) o \<tau>.FUN a) (Hom.set (a, a))"
               proof -
                 have
                   "S.arr (F ?\<psi>x \<cdot>\<^sub>S \<tau> a) \<and>
                    F ?\<psi>x \<cdot>\<^sub>S \<tau> a = S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
                 proof
                   show 1: "S.seq (F ?\<psi>x) (\<tau> a)"
                     using \<psi>x ide_a \<tau>.preserves_cod F.preserves_dom by (elim C.in_homE, auto)
                   have "\<tau> a = S.mkArr (Hom.set (a, a)) (F.SET a) (\<tau>.FUN a)"
                     using ide_a 1 S.mkArr_Fun [of "\<tau> a"] Hom.set_map by auto
                   moreover have "F ?\<psi>x = S.mkArr (F.SET a) (F.SET b) (F.FUN ?\<psi>x)"
                     using x \<psi>x 1 S.mkArr_Fun [of "F ?\<psi>x"] by fastforce
                   ultimately show "F ?\<psi>x \<cdot>\<^sub>S \<tau> a =
                                    S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?\<psi>x o \<tau>.FUN a)"
                     using 1 S.comp_mkArr [of "Hom.set (a, a)" "F.SET a" "\<tau>.FUN a"
                                              "F.SET b" "F.FUN ?\<psi>x"]
                     by (elim S.seqE, auto)
                 qed
                 thus ?thesis by force
               qed
               thus "S.Fun (F (\<psi> (b, a) x) \<cdot>\<^sub>S \<tau> a) ?\<phi>a = F.FUN ?\<psi>x (\<tau>.FUN a ?\<phi>a)"
                  using ide_a \<phi>a restr_eqE [of "S.Fun (F ?\<psi>x \<cdot>\<^sub>S \<tau> a)"
                                            "Hom.set (a, a)" "F.FUN ?\<psi>x o \<tau>.FUN a"]
                  by simp
             qed
             finally show ?thesis by simp
           qed
         qed
       qed
       finally show ?thesis by auto
     qed
 
     text\<open>
       Consequently, if @{term \<tau>'} is any natural transformation from @{term "Y a"} to @{term F}
       that agrees with @{term \<tau>} at @{term a}, then @{term "\<tau>' = \<tau>"}.
 \<close>
 
     lemma eqI:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>'" and "\<tau>' a = \<tau> a"
     shows "\<tau>' = \<tau>"
     proof (intro NaturalTransformation.eqI)
       interpret \<tau>': natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>' using assms by auto
-      interpret T': yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau>' ..
+      interpret T': yoneda_lemma_fixed_\<tau> C S setp \<phi> F a \<tau>' ..
       show "natural_transformation Cop.comp S (Y a) F \<tau>" ..
       show "natural_transformation Cop.comp S (Y a) F \<tau>'" ..
       show "\<And>b. Cop.ide b \<Longrightarrow> \<tau>' b = \<tau> b"
         using assms(2) \<tau>_ide T'.\<tau>_ide by simp
     qed
 
   end
 
   context yoneda_lemma
   begin
 
     text\<open>
       One half of the Yoneda lemma:
       The mapping @{term \<T>} is an injection, with left inverse @{term \<E>},
       from the set @{term "F.SET a"} to the set of natural transformations from
       @{term "Y a"} to @{term F}.
 \<close>
 
     lemma \<T>_is_injection:
     assumes "e \<in> F.SET a"
     shows "natural_transformation Cop.comp S (Y a) F (\<T> e)" and "\<E> (\<T> e) = e"
     proof -
-      interpret yoneda_lemma_fixed_e C S \<phi> F a e
+      interpret yoneda_lemma_fixed_e C S setp \<phi> F a e
         using assms by (unfold_locales, auto)
-      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> e\<close>
-        using natural_transformation_\<T>e by auto
       show "natural_transformation Cop.comp S (Y a) F (\<T> e)" ..
       show "\<E> (\<T> e) = e"
         unfolding \<E>_def
         using assms \<T>e_ide S.Fun_mkArr Hom.\<phi>_mapsto Hom.\<psi>_\<phi> ide_a
               F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
         by (auto simp add: Pi_iff)
     qed
 
-    lemma \<E>\<tau>_in_Fa:
+    lemma \<E>\<tau>_mapsto:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
     shows "\<E> \<tau> \<in> F.SET a"
     proof -
-      interpret \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
-      interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
+      interpret \<tau>: natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>
+        using assms by auto
+      interpret yoneda_lemma_fixed_\<tau> C S setp \<phi> F a \<tau> ..
       show ?thesis
       proof (unfold \<E>_def)
         have "S.arr (\<tau> a) \<and> S.Dom (\<tau> a) = Hom.set (a, a) \<and> S.Cod (\<tau> a) = F.SET a"
           using ide_a Hom.set_map by auto
         hence "\<tau>.FUN a \<in> Hom.set (a, a) \<rightarrow> F.SET a"
           using S.Fun_mapsto by blast
         thus "\<tau>.FUN a (\<phi> (a, a) a) \<in> F.SET a"
           using ide_a Hom.\<phi>_mapsto by fastforce
       qed
     qed
 
     text\<open>
       The other half of the Yoneda lemma:
       The mapping @{term \<T>} is a surjection, with right inverse @{term \<E>},
       taking natural transformations from @{term "Y a"} to @{term F}
       to elements of @{term "F.SET a"}.
 \<close>
 
     lemma \<T>_is_surjection:
     assumes "natural_transformation Cop.comp S (Y a) F \<tau>"
-    shows "\<E> \<tau> \<in> F.SET a" and "\<T> (\<E> \<tau>) = \<tau>"
+    shows "\<T> (\<E> \<tau>) = \<tau>"
     proof -
-      interpret natural_transformation Cop.comp S \<open>Y a\<close> F \<tau> using assms by auto
-      interpret yoneda_lemma_fixed_\<tau> C S \<phi> F a \<tau> ..
-      show 1: "\<E> \<tau> \<in> F.SET a" using assms \<E>\<tau>_in_Fa by auto
-      interpret yoneda_lemma_fixed_e C S \<phi> F a \<open>\<E> \<tau>\<close>
-        using 1 by (unfold_locales, auto)
-      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> F \<open>\<T> (\<E> \<tau>)\<close>
-        using natural_transformation_\<T>e by auto
+      interpret natural_transformation Cop.comp S \<open>Y a\<close> F \<tau>
+        using assms by auto
+      interpret yoneda_lemma_fixed_\<tau> C S setp \<phi> F a \<tau> ..
+      interpret yoneda_lemma_fixed_e C S setp \<phi> F a \<open>\<E> \<tau>\<close>
+        using assms \<E>\<tau>_mapsto by unfold_locales auto
       show "\<T> (\<E> \<tau>) = \<tau>"
       proof (intro eqI)
         show "natural_transformation Cop.comp S (Y a) F (\<T> (\<E> \<tau>))" ..
         show "\<T> (\<E> \<tau>) a = \<tau> a"
           using ide_a \<tau>_ide [of a] \<T>e_ide \<E>_def by simp
       qed
     qed
      
     text\<open>
       The main result.
 \<close>
 
     theorem yoneda_lemma:
     shows "bij_betw \<T> (F.SET a) {\<tau>. natural_transformation Cop.comp S (Y a) F \<tau>}"
-      using \<T>_is_injection \<T>_is_surjection by (intro bij_betwI, auto)
+      using \<E>\<tau>_mapsto \<T>_is_injection \<T>_is_surjection
+      by (intro bij_betwI, auto)
 
   end
 
   text\<open>
     We now consider the special case in which @{term F} is the contravariant
     functor @{term "Y a'"}.  Then for any @{term e} in \<open>Hom.set (a, a')\<close>
     we have @{term "\<T> e = Y (\<psi> (a, a') e)"}, and @{term \<T>} is a bijection from
     \<open>Hom.set (a, a')\<close> to the set of natural transformations from @{term "Y a"}
     to @{term "Y a'"}.  It then follows that that the Yoneda functor @{term Y}
     is a fully faithful functor from @{term C} to the functor category \<open>[Cop, S]\<close>.
 \<close>
 
   locale yoneda_lemma_for_hom =
-    C: category C +
-    Cop: dual_category C +
-    S: replete_set_category S +
-    yoneda_functor_fixed_object C S \<phi> a +
-    Ya': yoneda_functor_fixed_object C S \<phi> a' +
-    yoneda_lemma C S \<phi> "Y a'" a
+    yoneda_functor_fixed_object C S setp \<phi> a +
+    Ya': yoneda_functor_fixed_object C S setp \<phi> a' +
+    yoneda_lemma C S setp \<phi> "Y a'" a
   for C :: "'c comp" (infixr "\<cdot>" 55)
   and S :: "'s comp" (infixr "\<cdot>\<^sub>S" 55)
+  and setp :: "'s set \<Rightarrow> bool"
   and \<phi> :: "'c * 'c \<Rightarrow> 'c \<Rightarrow> 's"
-  and F :: "'c \<Rightarrow> 's"
   and a :: 'c
   and a' :: 'c +
   assumes ide_a': "C.ide a'"
   begin
 
     text\<open>
       In case @{term F} is the functor @{term "Y a'"}, for any @{term "e \<in> Hom.set (a, a')"}
       the induced natural transformation @{term "\<T> e"} from @{term "Y a"} to @{term "Y a'"}
       is just @{term "Y (\<psi> (a, a') e)"}.
 \<close>
 
-    lemma \<T>_equals_Yo\<psi>:
+    lemma app_\<T>_equals:
     assumes e: "e \<in> Hom.set (a, a')"
     shows "\<T> e = Y (\<psi> (a, a') e)"
     proof -
       let ?\<psi>e = "\<psi> (a, a') e"
       have \<psi>e: "\<guillemotleft>?\<psi>e : a \<rightarrow> a'\<guillemotright>" using ide_a ide_a' e Hom.\<psi>_mapsto [of a a'] by auto
       interpret Ye: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>Y ?\<psi>e\<close>
         using Y_arr_is_transformation [of ?\<psi>e] \<psi>e by (elim C.in_homE, auto)
-      interpret yoneda_lemma_fixed_e C S \<phi> \<open>Y a'\<close> a e
-        using ide_a ide_a' e S.set_mkIde Hom.set_map
+      interpret yoneda_lemma_fixed_e C S setp \<phi> \<open>Y a'\<close> a e
+        using ide_a ide_a' e Hom.set_map
         by (unfold_locales, simp_all)
-      interpret \<T>e: natural_transformation Cop.comp S \<open>Y a\<close> \<open>Y a'\<close> \<open>\<T> e\<close>
-        using natural_transformation_\<T>e by auto
-      interpret yoneda_lemma_fixed_\<tau> C S \<phi> \<open>Y a'\<close> a \<open>\<T> e\<close> ..
+      interpret yoneda_lemma_fixed_\<tau> C S setp \<phi> \<open>Y a'\<close> a \<open>\<T> e\<close> ..
       have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?\<psi>e)" ..
       moreover have "natural_transformation Cop.comp S (Y a) (Y a') (\<T> e)" ..
       moreover have "\<T> e a = Y ?\<psi>e a"
       proof -
         have 1: "S.arr (\<T> e a)"
           using ide_a e \<T>e.preserves_reflects_arr by simp
         have 2: "\<T> e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e)"
-          using ide_a \<T>o_def \<T>e_ide by simp
+          using ide_a \<T>\<^sub>o_def \<T>e_ide by simp
         also have
             "... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a))"
         proof (intro S.mkArr_eqI)
           show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (\<lambda>x. Ya'.FUN (\<psi> (a, a) x) e))"
             using ide_a e 1 2 by simp
           show "Hom.set (a, a) = Hom.set (a, a)" ..
           show 3: "Ya'.SET a = Hom.set (a, a')"
             using ide_a ide_a' Y_simp Hom.set_map by simp
           show "\<And>x. x \<in> Hom.set (a, a) \<Longrightarrow>
                       Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x"
           proof -
             fix x
             assume x: "x \<in> Hom.set (a, a)"
             have \<psi>x: "\<guillemotleft>\<psi> (a, a) x : a \<rightarrow> a\<guillemotright>" using ide_a x Hom.\<psi>_mapsto [of a a] by auto
             have "S.arr (Y a' (\<psi> (a, a) x)) \<and>
                   Y a' (\<psi> (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
                                               (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a'))"
               using Y_ide_arr ide_a ide_a' \<psi>x by blast
             hence "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') \<circ> Cop.comp (\<psi> (a, a) x) \<circ> \<psi> (a, a')) e"
               using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of "\<psi> (a, a) x"] by simp
             also have "... = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by simp
             finally show "Ya'.FUN (\<psi> (a, a) x) e = (\<phi> (a, a') o C ?\<psi>e o \<psi> (a, a)) x" by auto
           qed
         qed
         also have "... = Y ?\<psi>e a"
           using ide_a ide_a' Y_arr_ide \<psi>e by simp
         finally show "\<T> e a = Y ?\<psi>e a" by auto
       qed
       ultimately show ?thesis using eqI by auto
     qed
 
-    lemma Y_injective_on_homs:
-    assumes "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright>" and "\<guillemotleft>f' : a \<rightarrow> a'\<guillemotright>" and "map f = map f'"
-    shows "f = f'"
-    proof -
-      have "f = \<psi> (a, a') (\<phi> (a, a') f)"
-        using assms ide_a Hom.\<psi>_\<phi> by simp
-      also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f)))"
-        using ide_a ide_a' assms(1) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
-        by (elim C.in_homE, simp add: Pi_iff)
-      also have "... = \<psi> (a, a') (\<E> (Y (\<psi> (a, a') (\<phi> (a, a') f))))"
-        using assms Hom.\<phi>_mapsto [of a a'] \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f"] by force
-      also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f')))"
-        using assms Hom.\<phi>_mapsto [of a a'] ide_a Hom.\<psi>_\<phi> Y_def
-              \<T>_equals_Yo\<psi> [of "\<phi> (a, a') f'"]
-        by fastforce
-      also have "... = \<psi> (a, a') (\<phi> (a, a') f')"
-        using ide_a ide_a' assms(2) \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
-        by (elim C.in_homE, simp add: Pi_iff)
-      also have "... = f'"
-        using assms ide_a Hom.\<psi>_\<phi> by simp
-      finally show "f = f'" by auto
+    lemma is_injective_on_homs:
+    shows "inj_on map (C.hom a a')"
+    proof (intro inj_onI)
+      fix f f'
+      assume f: "f \<in> C.hom a a'" and f': "f' \<in> C.hom a a'"
+      assume eq: "map f = map f'"
+      show "f = f'"
+      proof -
+        have "f = \<psi> (a, a') (\<phi> (a, a') f)"
+          using f ide_a Hom.\<psi>_\<phi> by simp
+        also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f)))"
+          using ide_a ide_a' f \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
+          by (metis C.ideD(1) PiE Y_simp mem_Collect_eq)
+        also have "... = \<psi> (a, a') (\<E> (Y (\<psi> (a, a') (\<phi> (a, a') f))))"
+          using f Hom.\<phi>_mapsto app_\<T>_equals [of "\<phi> (a, a') f"] by force
+        also have "... = \<psi> (a, a') (\<E> (\<T> (\<phi> (a, a') f')))"
+          using f f' eq Hom.\<phi>_mapsto [of a a'] ide_a Hom.\<psi>_\<phi> Y_def
+                app_\<T>_equals [of "\<phi> (a, a') f'"]
+          by fastforce
+        also have "... = \<psi> (a, a') (\<phi> (a, a') f')"
+          using ide_a ide_a' f' \<T>_is_injection Hom.\<phi>_mapsto Hom.set_map
+          by (metis C.ideD(1) PiE Y_simp mem_Collect_eq)
+        also have "... = f'"
+          using f' ide_a Hom.\<psi>_\<phi> by simp
+        finally show "f = f'" by auto
+      qed
     qed
 
-    lemma Y_surjective_on_homs:
-    assumes \<tau>: "natural_transformation Cop.comp S (Y a) (Y a') \<tau>"
-    shows "Y (\<psi> (a, a') (\<E> \<tau>)) = \<tau>"
-      using ide_a ide_a' \<tau> \<T>_is_surjection \<T>_equals_Yo\<psi> \<E>\<tau>_in_Fa Hom.set_map by simp
-
   end
 
   context yoneda_functor
   begin
 
     lemma is_faithful_functor:
     shows "faithful_functor C Cop_S.comp map"
     proof
       fix f :: 'c and f' :: 'c
       assume par: "C.par f f'" and ff': "map f = map f'"
       show "f = f'"
       proof -
-        interpret Ya': yoneda_functor_fixed_object C S \<phi> \<open>C.cod f\<close>
+        interpret Ya': yoneda_functor_fixed_object C S setp \<phi> \<open>C.cod f\<close>
           using par by (unfold_locales, auto)
-        interpret yoneda_lemma_for_hom C S \<phi> \<open>Y (C.cod f)\<close> \<open>C.dom f\<close> \<open>C.cod f\<close>
+        interpret yoneda_lemma_for_hom C S setp \<phi> \<open>C.dom f\<close> \<open>C.cod f\<close>
           using par by (unfold_locales, auto)
-        show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
+        show "f = f'"
+          using par ff' is_injective_on_homs inj_on_def [of map "C.hom (C.dom f) (C.cod f)"]
+          by force
       qed
     qed
 
     lemma is_full_functor:
     shows "full_functor C Cop_S.comp map"
     proof
       fix a :: 'c and a' :: 'c and t
       assume a: "C.ide a" and a': "C.ide a'"
       assume t: "\<guillemotleft>t : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
       show "\<exists>e. \<guillemotleft>e : a \<rightarrow> a'\<guillemotright> \<and> map e = t"
       proof
-        interpret Ya': yoneda_functor_fixed_object C S \<phi> a'
+        interpret Ya': yoneda_functor_fixed_object C S setp \<phi> a'
           using a' by (unfold_locales, auto)
-        interpret yoneda_lemma_for_hom C S \<phi> \<open>Y a'\<close> a a'
+        interpret yoneda_lemma_for_hom C S setp \<phi> a a'
           using a a' by (unfold_locales, auto)
         have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
           using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
                 Cop_S.in_homE Cop_S.arrE
           by metis
         hence 1: "\<E> (Cop_S.Map t) \<in> Hom.set (a, a')"
-          using \<E>\<tau>_in_Fa ide_a ide_a' Hom.set_map by simp
+          using \<E>\<tau>_mapsto ide_a ide_a' Hom.set_map by simp
         moreover have "map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
         proof (intro Cop_S.arr_eqI)
           have 2: "\<guillemotleft>map (\<psi> (a, a') (\<E> (Cop_S.Map t))) : map a \<rightarrow>\<^sub>[\<^sub>C\<^sub>o\<^sub>p\<^sub>,\<^sub>S\<^sub>] map a'\<guillemotright>"
             using 1 ide_a ide_a' Hom.\<psi>_mapsto [of a a'] by blast
           show "Cop_S.arr t" using t by blast
           show "Cop_S.arr (map (\<psi> (a, a') (\<E> (Cop_S.Map t))))" using 2 by blast
           show 3: "Cop_S.Map (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Map t"
-            using NT Y_surjective_on_homs Y_def by simp
+            using NT 1 Y_def \<T>_is_surjection app_\<T>_equals \<E>\<tau>_mapsto by metis
           show 4: "Cop_S.Dom (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Dom t"
             using t 2 functor_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
           show "Cop_S.Cod (map (\<psi> (a, a') (\<E> (Cop_S.Map t)))) = Cop_S.Cod t"
             using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
         qed
         ultimately show "\<guillemotleft>\<psi> (a, a') (\<E> (Cop_S.Map t)) : a \<rightarrow> a'\<guillemotright> \<and>
                          map (\<psi> (a, a') (\<E> (Cop_S.Map t))) = t"
           using ide_a ide_a' Hom.\<psi>_mapsto by auto
       qed
     qed
 
   end
 
   sublocale yoneda_functor \<subseteq> faithful_functor C Cop_S.comp map
     using is_faithful_functor by auto
   sublocale yoneda_functor \<subseteq> full_functor C Cop_S.comp map using is_full_functor by auto
   sublocale yoneda_functor \<subseteq> fully_faithful_functor C Cop_S.comp map ..
 
 end
 
diff --git a/thys/Category3/ZFC_SetCat.thy b/thys/Category3/ZFC_SetCat.thy
new file mode 100644
--- /dev/null
+++ b/thys/Category3/ZFC_SetCat.thy
@@ -0,0 +1,1012 @@
+(*  Title:       ZFC_SetCat
+    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2022
+    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
+*)
+
+chapter "ZFC SetCat"
+
+text\<open>
+  In the statement and proof of the Yoneda Lemma given in theory \<open>Yoneda\<close>,
+  we sidestepped the issue, of not having a category of ``all'' sets, by axiomatizing
+  the notion of a ``set category'', showing that for every category we could obtain
+  a hom-functor into a set category at a higher type, and then proving the Yoneda
+  lemma for that particular hom-functor.  This is perhaps the best we can do within HOL,
+  because HOL does not provide any type that contains a universe of sets with the closure
+  properties usually associated with a category \<open>Set\<close> of sets and functions between them.
+  However, a significant aspect of category theory involves considering ``all''
+  algebraic structures of a particular kind as the objects of a ``large'' category having
+  nice closure or completeness properties.  Being able to consider a category of sets that
+  is ``small-complete'', or a cartesian closed category of sets and functions that includes
+  some infinite sets as objects, are basic examples of this kind of situation.
+
+  The purpose of this section is to demonstrate that, although it cannot be done in
+  pure HOL, if we are willing to accept the existence of a type \<open>V\<close> whose inhabitants
+  correspond to sets satisfying the axioms of ZFC, then it is possible to construct,
+  for example, the ``large'' category of sets and functions as it is usually understood
+  in category theory.  Moreover, assuming the existence of such a type is essentially
+  all we have to do; all the category theory we have developed so far still applies.
+  Specifically, what we do in this section is to use theory \<open>ZFC_in_HOL\<close>, which provides
+  an axiomatization of a set-theoretic universe \<open>V\<close>, to construct a ``set category''
+  \<open>ZFC_SetCat\<close>, whose objects correspond to \<open>V\<close>-sets, whose arrows correspond to functions
+  between \<open>V\<close>-sets, and which has the small-completeness property traditionally ascribed
+  to the category of all small sets and functions between them.
+\<close>
+
+theory ZFC_SetCat
+imports ZFC_in_HOL.ZFC_Cardinals Limit
+begin
+
+  text\<open>
+    The following locale constructs the category of classes and functions between them
+    and shows that it is small complete.  The category is obtained simply as the replete
+    set category at type \<open>V\<close>.  This is not yet the category of sets we want, because it
+    contains objects corresponding to ``large'' \<open>V\<close>-sets.
+  \<close>
+
+  locale ZFC_class_cat
+  begin
+
+    sublocale replete_setcat \<open>undefined :: V\<close> .
+
+    lemma admits_small_V_tupling:
+    assumes "small (I :: V set)"
+    shows "admits_tupling I"
+    proof (unfold admits_tupling_def)
+      let ?\<pi> = "\<lambda>f. UP (VLambda (ZFC_in_HOL.set I) (DN o f))"
+      have "?\<pi> \<in> (I \<rightarrow> Univ) \<inter> extensional' I \<rightarrow> Univ"
+        using UP_mapsto by force
+      moreover have "inj_on ?\<pi> ((I \<rightarrow> Univ) \<inter> extensional' I)"
+      proof
+        fix f g
+        assume f: "f \<in> (I \<rightarrow> Univ) \<inter> extensional' I"
+        assume g: "g \<in> (I \<rightarrow> Univ) \<inter> extensional' I"
+        assume eq: "UP (VLambda (ZFC_in_HOL.set I) (DN \<circ> f)) =
+                    UP (VLambda (ZFC_in_HOL.set I) (DN \<circ> g))"
+        have 1: "VLambda (ZFC_in_HOL.set I) (DN \<circ> f) = VLambda (ZFC_in_HOL.set I) (DN \<circ> g)"
+          using f g eq
+          by (meson injD inj_UP)
+        show "f = g"
+        proof
+          fix x
+          have "x \<notin> I \<Longrightarrow> f x = g x"
+            using f g extensional'_def [of I] by auto
+          moreover have "x \<in> I \<Longrightarrow> f x = g x"
+          proof -
+            assume x: "x \<in> I"
+            hence "(DN o f) x = (DN o g) x"
+              using assms 1 x elts_of_set VLambda_eq_D2 by fastforce
+            thus "f x = g x"
+              using f g x comp_apply UP_DN
+              by (metis IntD1 PiE bij_arr_of bij_betw_imp_surj_on)
+          qed
+          ultimately show "f x = g x" by blast
+        qed
+      qed
+      ultimately show "\<exists>\<pi>. \<pi> \<in> (I \<rightarrow> Univ) \<inter> extensional' I \<rightarrow> Univ \<and>
+                           inj_on \<pi> ((I \<rightarrow> Univ) \<inter> extensional' I)"
+        by blast
+    qed
+
+    corollary admits_small_tupling:
+    assumes "small I"
+    shows "admits_tupling I"
+    proof -
+      obtain \<phi> where \<phi>: "inj_on \<phi> I \<and> \<phi> ` I \<in> range elts"
+        using assms small_def by metis
+      have "admits_tupling (\<phi> ` I)"
+        using \<phi> admits_small_V_tupling by fastforce
+      moreover have inv: "bij_betw (inv_into I \<phi>) (\<phi> ` I) I"
+        by (simp add: \<phi> bij_betw_inv_into inj_on_imp_bij_betw)
+      ultimately show ?thesis
+        using admits_tupling_respects_bij by blast
+    qed
+
+    lemma has_small_products:
+    assumes "small (I :: 'i set)" and "I \<noteq> UNIV"
+    shows "has_products I"
+    proof -
+      have 1: "\<And>I :: V set. small I \<Longrightarrow> has_products I"
+        using big_UNIV
+        by (metis admits_small_tupling has_products_iff_admits_tupling)
+      obtain V_of where V_of: "inj_on V_of I \<and> V_of ` I \<in> range elts"
+        using assms small_def by metis
+      have "bij_betw (inv_into I V_of) (V_of ` I) I"
+        using V_of bij_betw_inv_into bij_betw_imageI by metis
+      moreover have "small (V_of ` I)"
+        using assms by auto
+      ultimately show ?thesis
+        using assms 1 has_products_preserved_by_bijection by blast
+    qed
+
+    theorem has_small_limits:
+    assumes "small (UNIV :: 'i set)"
+    shows "has_limits (undefined :: 'i)"
+    proof -
+      have "\<forall>I :: 'i set. I \<noteq> UNIV \<longrightarrow> admits_tupling I"
+        using assms smaller_than_small subset_UNIV admits_small_tupling by auto
+      thus ?thesis
+        using assms has_limits_iff_admits_tupling by blast
+    qed
+
+  end
+
+  text\<open>
+    We now construct the desired category of small sets and functions between them,
+    as a full subcategory of the category of classes and functions.  To show that this
+    subcategory is small complete, we show that the inclusion creates small products;
+    that is, a small product of objects corresponding to small sets itself corresponds
+    to a small set.
+  \<close>
+
+  locale ZFC_set_cat
+  begin
+
+    interpretation Cls: ZFC_class_cat .
+
+    sublocale sub_set_category Cls.comp \<open>\<lambda>A. A \<subseteq> Cls.Univ\<close> \<open>\<lambda>A. A \<subseteq> Cls.Univ \<and> small A\<close>
+      using small_Un smaller_than_small
+      apply unfold_locales
+         apply simp_all
+       apply force
+      by auto
+
+    abbreviation setp
+    where "setp A \<equiv> A \<subseteq> Cls.Univ \<and> small A"
+
+    lemma is_set_category:
+    shows "set_category comp setp"
+      ..
+
+    lemma is_full_subcategory:
+    shows "full_subcategory Cls.comp (\<lambda>a. Cls.ide a \<and> setp (Cls.set a))"
+      using full_subcategory_axioms by blast
+
+    interpretation incl: full_inclusion_functor Cls.comp \<open>\<lambda>a. Cls.ide a \<and> setp (Cls.set a)\<close>
+      ..
+
+    text\<open>
+      The following functions establish a bijection between the identities of the category
+      and the elements of type \<open>V\<close>; which in turn are in bijective correspondence with
+      small \<open>V\<close>-sets.
+    \<close>
+
+    definition V_of_ide :: "V setcat.arr \<Rightarrow> V"
+    where "V_of_ide a \<equiv> ZFC_in_HOL.set (Cls.DN ` Cls.set a)"
+
+    definition ide_of_V :: "V \<Rightarrow> V setcat.arr"
+    where "ide_of_V A \<equiv> Cls.mkIde (Cls.UP ` elts A)"
+
+    lemma bij_betw_ide_V:
+    shows "V_of_ide \<in> Collect ide \<rightarrow> UNIV"
+    and "ide_of_V \<in> UNIV \<rightarrow> Collect ide"
+    and [simp]: "ide a \<Longrightarrow> ide_of_V (V_of_ide a) = a"
+    and [simp]: "V_of_ide (ide_of_V A) = A"
+    and "bij_betw V_of_ide (Collect ide) UNIV"
+    and "bij_betw ide_of_V UNIV (Collect ide)"
+    proof -
+      have "Univ = Cls.Univ"
+        using terminal_char by presburger
+      show 1: "V_of_ide \<in> Collect ide \<rightarrow> UNIV"
+        by blast
+      show 2: "ide_of_V \<in> UNIV \<rightarrow> Collect ide"
+      proof
+        fix A :: V
+        have "small (elts A)"
+          by blast
+        have "Cls.UP ` elts A \<subseteq> Univ \<and> small (Cls.UP ` elts A)"
+          using Cls.UP_mapsto terminal_char by blast
+        hence "ide (mkIde (Cls.UP ` elts A))"
+          using ide_mkIde \<open>Univ = Cls.Univ\<close> by auto
+        thus "ide_of_V A \<in> Collect ide"
+          using ide_of_V_def ide_char
+          by (metis (no_types, lifting) Cls.ide_mkIde Cls.set_mkIde arr_mkIde ide_char'
+              mem_Collect_eq)
+      qed
+      show 3: "\<And>a. ide a \<Longrightarrow> ide_of_V (V_of_ide a) = a"
+      proof -
+        fix a
+        assume a: "ide a"
+        have "ide_of_V (V_of_ide a) =
+              Cls.mkIde (Cls.UP ` elts (ZFC_in_HOL.set (Cls.DN ` Cls.set a)))"
+          unfolding ide_of_V_def V_of_ide_def by simp
+        also have "... = Cls.mkIde (Cls.UP ` Cls.DN ` Cls.set a)"
+          using setp_set_ide a ide_char by force
+        also have "... = Cls.mkIde (Cls.set a)"
+        proof -
+          have "Cls.set a \<subseteq> Cls.Univ"
+            using a ide_char by blast
+          hence "Cls.UP ` Cls.DN ` Cls.set a = Cls.set a"
+          proof -
+            have "\<And>x. x \<in> Cls.set a \<Longrightarrow> x \<in> Cls.UP ` Cls.DN ` Cls.set a"
+              using Cls.UP_DN \<open>Cls.set a \<subseteq> Cls.Univ\<close>
+              by (metis Cls.bij_arr_of bij_betw_def image_inv_into_cancel)
+            moreover have "\<And>x. x \<in> Cls.UP ` Cls.DN ` Cls.set a \<Longrightarrow> x \<in> Cls.set a"
+              using \<open>Cls.set a \<subseteq> Cls.Univ\<close>
+              by (metis Cls.bij_arr_of bij_betw_def image_inv_into_cancel)
+            ultimately show ?thesis by blast
+          qed
+          thus ?thesis by argo
+        qed
+        also have "... = a"
+          using a Cls.mkIde_set ide_char by blast
+        finally show "ide_of_V (V_of_ide a) = a" by simp
+      qed
+      show 4: "\<And>A. V_of_ide (ide_of_V A) = A"
+      proof -
+        fix A
+        have "V_of_ide (ide_of_V A) =
+              ZFC_in_HOL.set (Cls.DN ` Cls.set (Cls.mkIde (Cls.UP ` elts A)))"
+          unfolding V_of_ide_def ide_of_V_def by simp
+        also have "... = ZFC_in_HOL.set (Cls.DN ` Cls.UP ` elts A)"
+          using Cls.set_mkIde [of "Cls.UP ` elts A"] Cls.UP_mapsto by fastforce
+        also have "... = ZFC_in_HOL.set (elts A)"
+          using Cls.DN_UP by force
+        also have "... = A" by simp
+        finally show "V_of_ide (ide_of_V A) = A" by blast
+      qed
+      show "bij_betw V_of_ide (Collect ide) UNIV"
+        using 1 2 3 4
+        by (intro bij_betwI) auto
+      show "bij_betw ide_of_V UNIV (Collect ide)"
+        using 1 2 3 4
+        by (intro bij_betwI) blast+
+    qed
+
+    text\<open>
+      Next, we establish bijections between the hom-sets of the category and certain
+      subsets of \<open>V\<close> whose elements represent functions.
+    \<close>
+
+    definition V_of_arr :: "V setcat.arr \<Rightarrow> V"
+    where "V_of_arr f \<equiv> VLambda (V_of_ide (dom f)) (Cls.DN o Cls.Fun f o Cls.UP)"
+
+    definition arr_of_V :: "V setcat.arr \<Rightarrow> V setcat.arr \<Rightarrow> V \<Rightarrow> V setcat.arr"
+    where "arr_of_V a b F \<equiv> Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP o app F o Cls.DN)"
+
+    definition vfun
+    where "vfun A B f \<equiv> f \<in> elts (VPow (vtimes A B)) \<and> elts A = Domain (pairs f) \<and>
+                        single_valued (pairs f)"
+
+    lemma small_Collect_vfun:
+    shows "small (Collect (vfun A B))"
+      unfolding vfun_def
+      by (metis (full_types) small_Collect small_elts)
+
+    lemma vfunI:
+    assumes "f \<in> elts A \<rightarrow> elts B"
+    shows "vfun A B (VLambda A f)"
+    proof (unfold vfun_def, intro conjI)
+      show "VLambda A f \<in> elts (VPow (vtimes A B))"
+        using assms VLambda_def by auto
+      show "elts A = Domain (pairs (VLambda A f))"
+        using assms VLambda_def [of A f]
+        by (metis Domain_fst fst_pairs_VLambda)
+      show "single_valued (pairs (VLambda A f))"
+        using assms VLambda_def single_valued_def pairs_iff_elts by fastforce
+    qed
+
+    lemma app_vfun_mapsto:
+    assumes "vfun A B F"
+    shows "app F \<in> elts A \<rightarrow> elts B"
+    proof
+      have "F \<in> elts (VPow (vtimes A B)) \<and> elts A = Domain (pairs F) \<and> single_valued (pairs F)"
+        using assms vfun_def by simp
+      hence 1: "F \<in> elts (VPi A (\<lambda>_. B)) \<and> elts A = Domain (pairs F) \<and> single_valued (pairs F)"
+        unfolding VPi_def
+        by (metis (no_types, lifting) down elts_of_set mem_Collect_eq subsetI)
+      fix x
+      assume x: "x \<in> elts A"
+      have "x \<in> Domain (pairs F)"
+        using assms x vfun_def by blast
+      thus "app F x \<in> elts B"
+        using x 1 VPi_D [of F A "\<lambda>_. B" x] by blast
+    qed
+
+    lemma bij_betw_hom_vfun:
+    shows "V_of_arr \<in> hom a b \<rightarrow> Collect (vfun (V_of_ide a) (V_of_ide b))"
+    and "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> arr_of_V a b \<in> Collect (vfun (V_of_ide a) (V_of_ide b)) \<rightarrow> hom a b"
+    and "f \<in> hom a b \<Longrightarrow> arr_of_V a b (V_of_arr f) = f"
+    and "\<lbrakk>ide a; ide b; F \<in> Collect (vfun (V_of_ide a) (V_of_ide b))\<rbrakk>
+            \<Longrightarrow> V_of_arr (arr_of_V a b F) = F"
+    and "\<lbrakk>ide a; ide b\<rbrakk>
+            \<Longrightarrow> bij_betw V_of_arr (hom a b) (Collect (vfun (V_of_ide a) (V_of_ide b)))"
+    and "\<lbrakk>ide a; ide b\<rbrakk>
+            \<Longrightarrow> bij_betw (arr_of_V a b) (Collect (vfun (V_of_ide a) (V_of_ide b))) (hom a b)"
+    proof -
+      show 1: "\<And>a b. V_of_arr \<in> hom a b \<rightarrow> Collect (vfun (V_of_ide a) (V_of_ide b))"
+      proof
+        fix a b f
+        assume f: "f \<in> hom a b"
+        have "V_of_arr f = VLambda (V_of_ide (dom f)) (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP)"
+          unfolding V_of_arr_def by simp
+        moreover have "vfun (V_of_ide a) (V_of_ide b) ..."
+        proof -
+          have "Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP \<in> elts (V_of_ide a) \<rightarrow> elts (V_of_ide b)"
+          proof
+            fix x
+            assume x: "x \<in> elts (V_of_ide a)"
+            have "(Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) x = Cls.DN (Cls.Fun f (Cls.UP x))"
+              by simp
+            moreover have "... \<in> elts (V_of_ide b)"
+            proof -
+              have "Cls.UP x \<in> Cls.Dom f"
+                by (metis (no_types, lifting) Cls.arr_dom_iff_arr Cls.arr_mkIde Cls.set_mkIde
+                    bij_betw_ide_V(3) arr_char dom_simp f ide_char ide_of_V_def image_eqI
+                    in_homE mem_Collect_eq x)
+              hence "Cls.DN (Cls.Fun f (Cls.UP x)) \<in> Cls.DN ` Cls.Cod f"
+                using f in_hom_char arr_char Cls.Fun_mapsto [of f] by blast
+              thus "Cls.DN (Cls.Fun f (Cls.UP x)) \<in> elts (V_of_ide b)"
+                unfolding V_of_ide_def
+                using f ide_char in_hom_char
+                by (metis (no_types, lifting) arr_char cod_simp elts_of_set in_homE
+                    mem_Collect_eq replacement)
+            qed
+            ultimately show "(Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) x \<in> elts (V_of_ide b)" by argo
+          qed
+          thus ?thesis
+            using f vfunI by blast
+        qed
+        ultimately show "V_of_arr f \<in> Collect (vfun (V_of_ide a) (V_of_ide b))" by simp
+      qed
+      show 2: "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk>
+                        \<Longrightarrow> arr_of_V a b \<in> Collect (vfun (V_of_ide a) (V_of_ide b)) \<rightarrow> hom a b"
+      proof -
+        fix a b
+        assume a: "ide a" and b: "ide b"
+        show "arr_of_V a b \<in> Collect (vfun (V_of_ide a) (V_of_ide b)) \<rightarrow> hom a b"
+        proof
+          fix F
+          assume F: "F \<in> Collect (vfun (V_of_ide a) (V_of_ide b))"
+          have 3: "app F \<in> elts (V_of_ide a) \<rightarrow> elts (V_of_ide b)"
+            using F app_vfun_mapsto [of "V_of_ide a" "V_of_ide b" F] by blast
+          have 4: "app F \<in> Cls.DN ` (Cls.set a) \<rightarrow> Cls.DN ` (Cls.set b)"
+            using 3 V_of_ide_def a b ide_char by auto
+          have "arr_of_V a b F = Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN)"
+            unfolding arr_of_V_def by simp
+          moreover have "... \<in> hom a b"
+          proof
+            show "\<guillemotleft>Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN) : a \<rightarrow> b\<guillemotright>"
+            proof
+              have 4: "Cls.arr (Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN))"
+              proof -
+                have "Cls.set a \<subseteq> Cls.Univ \<and> Cls.set b \<subseteq> Cls.Univ"
+                  using a b ide_char by blast
+                moreover have "Cls.UP \<circ> app F \<circ> Cls.DN \<in> Cls.set a \<rightarrow> Cls.set b"
+                proof
+                  fix x
+                  assume x: "x \<in> Cls.set a"
+                  have "(Cls.UP \<circ> app F \<circ> Cls.DN) x = Cls.UP (app F (Cls.DN x))"
+                    by simp
+                  moreover have "... \<in> Cls.set b"
+                    by (metis (no_types, lifting) 4 Cls.arr_mkIde Cls.ide_char' Cls.set_mkIde
+                        PiE V_of_ide_def bij_betw_ide_V(3) b elts_of_set ide_char
+                        ide_of_V_def replacement rev_image_eqI x)
+                  ultimately show "(Cls.UP \<circ> app F \<circ> Cls.DN) x \<in> Cls.set b"
+                    by auto
+                qed
+                ultimately show ?thesis by blast
+              qed
+              show 5: "arr (Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN))"
+                using a b 4 arr_char ide_char by auto
+              show "dom (Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN)) = a"
+                using a 4 5 dom_char ide_char by auto
+              show "cod (Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN)) = b"
+                using b 4 5 cod_char ide_char by auto
+            qed
+          qed
+          ultimately show "arr_of_V a b F \<in> hom a b" by auto
+        qed
+      qed
+      show 3: "\<And>a b f. f \<in> hom a b \<Longrightarrow> arr_of_V a b (V_of_arr f) = f"
+      proof -
+        fix a b f
+        assume f: "f \<in> hom a b"
+        have 4: "\<And>x. x \<in> Cls.set a
+                        \<Longrightarrow> (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x = Cls.Fun f x"
+        proof - 
+          fix x
+          assume x: "x \<in> Cls.set a"
+          have "(Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x =
+                Cls.UP (Cls.DN (Cls.Fun f (Cls.UP (Cls.DN x))))"
+            by simp
+          also have "... = Cls.UP (Cls.DN (Cls.Fun f x))"
+            using x Cls.UP_DN
+            by (metis (no_types, lifting) Cls.elem_set_implies_incl_in Cls.incl_in_def
+                Cls.setp_set_ide bij_betw_def replete_setcat.bij_arr_of subset_eq)
+          also have "... = Cls.Fun f x"
+          proof -
+            have "x \<in> Cls.Dom f"
+              using x f dom_char by fastforce
+            hence "Cls.Fun f x \<in> Cls.Cod f"
+              using x f Cls.Fun_mapsto in_hom_char by blast
+            hence "Cls.Fun f x \<in> Cls.Univ"
+              using f cod_char in_hom_char
+              by (metis (no_types, lifting) Cls.elem_set_implies_incl_in Cls.incl_in_def
+                  Cls.setp_set_ide subsetD)
+            thus ?thesis
+              by (meson bij_betw_inv_into_right replete_setcat.bij_arr_of)
+          qed
+          finally show "(Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x = Cls.Fun f x"
+            by blast
+        qed
+        have 5: "Cls.arr (Cls.mkArr (Cls.set a) (Cls.set b)
+                                    (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN))"
+        proof -
+          have "Cls.set a \<subseteq> Cls.Univ \<and> Cls.set b \<subseteq> Cls.Univ"
+            using f ide_char codomains_def domains_def in_hom_def by force
+          moreover have "Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN
+                           \<in> Cls.set a \<rightarrow> Cls.set b"
+          proof
+            fix x
+            assume x: "x \<in> Cls.set a"
+            hence 6: "x \<in> Cls.Dom f"
+              using f by (metis (no_types, lifting) dom_char in_homE mem_Collect_eq)
+            have "(Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x = Cls.Fun f x"
+              using 4 f x by blast
+            moreover have "... \<in> Cls.Cod f"
+              using 4 6 f Cls.Fun_mapsto
+              by (metis (no_types, lifting) Cls.arr_dom_iff_arr Cls.elem_set_implies_incl_in
+                  Cls.ideD(1) Cls.incl_in_def IntE PiE)
+            moreover have "... = Cls.set b"
+              using f by (metis (no_types, lifting) cod_char in_homE mem_Collect_eq)
+            ultimately show "(Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x \<in> Cls.set b"
+              by auto
+          qed
+          ultimately show ?thesis by blast
+        qed
+        have "arr_of_V a b (V_of_arr f) =
+              Cls.mkArr (Cls.set a) (Cls.set b)
+                        (Cls.UP \<circ> app (VLambda (V_of_ide (dom f)) (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                                \<circ> Cls.DN)"
+          unfolding arr_of_V_def V_of_arr_def by simp
+        also have "... = Cls.mkArr (Cls.set a) (Cls.set b)
+                                   (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN)"
+        proof (intro Cls.mkArr_eqI')
+          show 6: "\<And>x. x \<in> Cls.set a \<Longrightarrow>
+                         (Cls.UP \<circ> app (VLambda (V_of_ide (dom f)) (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                                 \<circ> Cls.DN) x =
+                         (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x"
+          proof -
+            fix x
+            assume x: "x \<in> Cls.set a"
+            have "(Cls.UP \<circ> app (VLambda (V_of_ide (dom f)) (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                          \<circ> Cls.DN) x =
+                   Cls.UP (app (VLambda (V_of_ide (dom f)) (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                               (Cls.DN x))"
+              by simp
+            also have "... = (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x"
+            proof -
+              have "Cls.DN x \<in> elts (V_of_ide (dom f))"
+                using f
+                by (metis (no_types, lifting) V_of_ide_def elts_of_set ide_char ide_dom image_eqI
+                    in_homE mem_Collect_eq replacement x)
+              thus ?thesis
+                using beta by auto
+            qed
+            ultimately show "(Cls.UP \<circ> app (VLambda (V_of_ide (dom f))
+                                                    (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                                     \<circ> Cls.DN) x =
+                             (Cls.UP \<circ> (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP) \<circ> Cls.DN) x"
+              by argo
+          qed
+          show "Cls.arr (Cls.mkArr (Cls.set a) (Cls.set b)
+                        (Cls.UP \<circ> app (VLambda (V_of_ide (local.dom f))
+                                               (Cls.DN \<circ> Cls.Fun f \<circ> Cls.UP))
+                                \<circ> Cls.DN))"
+            using 5 6 Cls.mkArr_eqI by auto
+        qed
+        also have "... = Cls.mkArr (Cls.set a) (Cls.set b) (Cls.Fun f)"
+          using 4 5 by force
+        also have "... = f"
+          using f Cls.mkArr_Fun
+          by (metis (no_types, lifting) arr_char cod_simp dom_char in_homE mem_Collect_eq)
+        finally show "arr_of_V a b (V_of_arr f) = f" by blast
+      qed
+      show 4: "\<And>a b F. \<lbrakk>ide a; ide b; F \<in> Collect (vfun (V_of_ide a) (V_of_ide b))\<rbrakk>
+                          \<Longrightarrow> V_of_arr (arr_of_V a b F) = F"
+      proof -
+        fix a b F
+        assume a: "ide a" and b: "ide b"
+        assume F: "F \<in> Collect (vfun (V_of_ide a) (V_of_ide b))"
+        have "F \<in> elts (VPow (vtimes (V_of_ide a) (V_of_ide b))) \<and>
+              elts (V_of_ide a) = Domain (pairs F) \<and> single_valued (pairs F)"
+          using F vfun_def by simp
+        hence 5: "F \<in> elts (VPi (V_of_ide a) (\<lambda>_. V_of_ide b))"
+          unfolding VPi_def
+          by (metis (no_types, lifting) down elts_of_set mem_Collect_eq subsetI)
+        let ?f = "Cls.mkArr (Cls.set a) (Cls.set b) (Cls.UP \<circ> app F \<circ> Cls.DN)"
+        have 6: "Cls.arr ?f"
+        proof -
+          have "Cls.set a \<subseteq> Cls.Univ \<and> Cls.set b \<subseteq> Cls.Univ"
+            using a b ide_char by blast
+          moreover have "Cls.UP \<circ> app F \<circ> Cls.DN \<in> Cls.set a \<rightarrow> Cls.set b"
+          proof
+            fix x
+            assume x: "x \<in> Cls.set a"
+            have "(Cls.UP \<circ> app F \<circ> Cls.DN) x = Cls.UP (app F (Cls.DN x))"
+              by simp
+            moreover have "... \<in> Cls.set b"
+            proof -
+              have "app F (Cls.DN x) \<in> Cls.DN ` Cls.set b"
+                using a b ide_char x F app_vfun_mapsto [of "V_of_ide a" "V_of_ide b" F] V_of_ide_def
+                by auto
+              thus ?thesis
+                using \<open>Cls.set a \<subseteq> Cls.Univ \<and> Cls.set b \<subseteq> Cls.Univ\<close>
+                by (metis Cls.bij_arr_of bij_betw_def imageI image_inv_into_cancel)
+            qed
+            ultimately show "(Cls.UP \<circ> app F \<circ> Cls.DN) x \<in> Cls.set b" by auto
+          qed
+          ultimately show ?thesis by blast
+        qed
+        have "V_of_arr (arr_of_V a b F) = VLambda (V_of_ide (dom ?f)) (Cls.DN \<circ> Cls.Fun ?f \<circ> Cls.UP)"
+          unfolding V_of_arr_def arr_of_V_def by simp
+        also have "... = VLambda (V_of_ide a) (Cls.DN \<circ> Cls.Fun ?f \<circ> Cls.UP)"
+          unfolding V_of_ide_def
+          using a b 6 ide_char V_of_ide_def dom_char Cls.dom_mkArr arrI by auto
+        also have "... = VLambda (V_of_ide a)
+                                 (Cls.DN \<circ>
+                                    restrict (Cls.UP \<circ> app F \<circ> Cls.DN) (Cls.set a) \<circ> Cls.UP)"
+          using 6 Cls.Fun_mkArr by simp
+        also have "... = VLambda (V_of_ide a) (app F)"
+        proof -
+          have 7: "\<And>x. x \<in> elts (V_of_ide a) \<Longrightarrow>
+                         (Cls.DN \<circ> restrict (Cls.UP \<circ> app F \<circ> Cls.DN) (Cls.set a) \<circ> Cls.UP) x =
+                         app F x"
+            unfolding V_of_ide_def
+            using a
+            apply simp
+            by (metis (no_types, lifting) Cls.bij_arr_of a bij_betw_def empty_iff ide_char
+                image_eqI image_inv_into_cancel)
+          have 8: "\<And>x. x \<in> elts (V_of_ide a) \<Longrightarrow>
+                         (Cls.DN \<circ> restrict (Cls.UP \<circ> app F \<circ> Cls.DN) (Cls.set a) \<circ> Cls.UP) x
+                            \<in> elts (V_of_ide b)"
+            using 5 7 VPi_D by fastforce
+          have "VLambda (V_of_ide a) (app F) \<in> elts (VPi (V_of_ide a) (\<lambda>_. V_of_ide b))"
+            using 5 VPi_I VPi_D by auto
+          moreover have "VLambda (V_of_ide a)
+                                 (Cls.DN \<circ>
+                                    restrict (Cls.UP \<circ> app F \<circ> Cls.DN) (Cls.set a) \<circ> Cls.UP)
+                           \<in> elts (VPi (V_of_ide a) (\<lambda>_. V_of_ide b))"
+            using 8 VPi_I by auto
+          moreover have "\<And>x. x \<in> elts (V_of_ide a) \<Longrightarrow>
+                               app (VLambda (V_of_ide a)
+                                   (Cls.DN \<circ>
+                                      restrict (Cls.UP \<circ> app F \<circ> Cls.DN) (Cls.set a) \<circ>
+                                        Cls.UP)) x =
+                               app F x"
+            using 7 beta by auto
+          ultimately show ?thesis
+            using fun_ext by simp
+        qed
+        also have "... = F"
+          using 5 eta [of F "V_of_ide a" "\<lambda>_. V_of_ide b"] by auto
+        finally show "V_of_arr (arr_of_V a b F) = F" by blast
+      qed
+      show "\<lbrakk>ide a; ide b\<rbrakk>
+               \<Longrightarrow> bij_betw V_of_arr (hom a b) (Collect (vfun (V_of_ide a) (V_of_ide b)))"
+        using 1 2 3 4
+        apply (intro bij_betwI)
+           apply blast
+          apply blast
+        by auto
+      show "\<lbrakk>ide a; ide b\<rbrakk>
+               \<Longrightarrow> bij_betw (arr_of_V a b) (Collect (vfun (V_of_ide a) (V_of_ide b))) (hom a b)"
+        using 1 2 3 4
+        apply (intro bij_betwI)
+           apply blast
+          apply blast
+        by auto
+    qed
+
+    lemma small_hom:
+    shows "small (hom a b)"
+    proof (cases "ide a \<and> ide b")
+      assume 1: "\<not> (ide a \<and> ide b)"
+      have "\<And>f. \<not> \<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
+        using 1 in_hom_def ide_cod ide_dom by blast
+      hence "hom a b = {}"
+        by blast
+      thus ?thesis by simp
+      next
+      assume 1: "ide a \<and> ide b"
+      show ?thesis
+        using 1 bij_betw_hom_vfun(5) small_Collect_vfun small_def
+        by (metis (no_types, lifting) bij_betw_def small_iff_range)
+    qed
+
+    text\<open>
+      We can now show that the inclusion of the subcategory into the ambient category \<open>Cls\<close>
+      creates small products.  To do this, we consider a product in \<open>Cls\<close> of objects of the
+      subcategory indexed by a small set \<open>I\<close>.  Since \<open>Cls\<close> is a replete set category,
+      by a previous result we know that the elements of a product object \<open>p\<close> in \<open>Cls\<close>
+      correspond to its points; that is, to the elements of \<open>hom unity p\<close>.
+      The elements of \<open>hom unity p\<close> in turn correspond to \<open>I\<close>-tuples.  By carrying out
+      the construction of the set of \<open>I\<close>-tuples in \<open>V\<close> and exploiting the bijections between
+      homs of the subcatgory and \<open>V\<close>-sets, we can obtain an injection of \<open>hom unity p\<close>
+      to the extension of a \<open>V\<close>-set, thus showing \<open>hom unity p\<close> is small.
+      Since \<open>hom unity p\<close> is small, it determines an object of the subcategory,
+      which must then be a product in the subcategory, in view of the fact that the
+      subcategory is full.
+    \<close>
+
+    lemma has_small_V_products:
+    assumes "small (I :: V set)"
+    shows "has_products I"
+    proof (unfold has_products_def, intro conjI impI allI)
+      show "I \<noteq> UNIV"
+        using assms big_UNIV by blast
+      fix J D
+      assume D: "discrete_diagram J comp D \<and> Collect (partial_magma.arr J) = I"
+      interpret J: category J
+        using D discrete_diagram_def by blast
+      interpret D: discrete_diagram J comp D
+        using D by blast
+      interpret incloD: composite_functor J comp Cls.comp D map ..
+      interpret incloD: discrete_diagram J Cls.comp incloD.map
+        using D.is_discrete
+        by unfold_locales auto
+      interpret incloD: diagram_in_set_category J Cls.comp \<open>\<lambda>A. A \<subseteq> Cls.Univ\<close> incloD.map
+        ..
+      have 1: "small (Collect J.ide)"
+        using assms D D.is_discrete by argo
+      show "\<exists>a. has_as_product J D a"
+      proof -
+        have 2: "\<exists>a. Cls.has_as_product J incloD.map a"
+        proof -
+          have "Collect J.ide \<noteq> UNIV"
+            using J.ide_def by blast
+          thus ?thesis
+            using 1 D.is_discrete Cls.has_small_products [of "Collect J.ide"]
+                  Cls.has_products_def [of "Collect J.ide"] incloD.discrete_diagram_axioms
+            by presburger
+        qed
+        obtain \<Pi>D where \<Pi>D: "Cls.has_as_product J incloD.map \<Pi>D"
+          using 2 by blast
+        interpret \<Pi>D: constant_functor J Cls.comp \<Pi>D
+          using \<Pi>D Cls.product_is_ide
+          by unfold_locales auto
+        obtain \<pi> where \<pi>: "product_cone J Cls.comp incloD.map \<Pi>D \<pi>"
+          using \<Pi>D Cls.has_as_product_def by blast
+        interpret \<pi>: product_cone J Cls.comp incloD.map \<Pi>D \<pi>
+          using \<pi> by blast
+        have "small (Cls.hom Cls.unity \<Pi>D)"
+        proof -
+          obtain \<phi> where \<phi>: "bij_betw \<phi> (Cls.hom Cls.unity \<Pi>D) (incloD.cones Cls.unity)"
+            using incloD.limits_are_sets_of_cones \<pi>.limit_cone_axioms by blast
+          let ?J = "ZFC_in_HOL.set (Collect J.arr)"
+          let ?V_of_point = "\<lambda>x. VLambda ?J (\<lambda>j. V_of_arr (\<phi> x j))"
+          let ?Tuples = "VPi ?J (\<lambda>j. ZFC_in_HOL.set (V_of_arr ` hom Cls.unity (D j)))"
+          have V_of_point: "?V_of_point \<in> Cls.hom Cls.unity \<Pi>D \<rightarrow> elts ?Tuples"
+          proof
+            fix x
+            assume x: "x \<in> Cls.hom Cls.unity \<Pi>D"
+            have \<phi>x: "\<phi> x \<in> incloD.cones Cls.unity"
+              using \<phi> x
+              unfolding bij_betw_def by blast
+            interpret \<phi>x: cone J Cls.comp incloD.map Cls.unity \<open>\<phi> x\<close>
+              using \<phi>x by blast
+            have "\<And>j. J.arr j \<Longrightarrow> V_of_arr (\<phi> x j)
+                                    \<in> elts (ZFC_in_HOL.set (V_of_arr ` hom Cls.unity (D j)))"
+            proof -
+              fix j
+              assume j: "J.arr j"
+              have "\<phi> x j \<in> hom Cls.unity (D j)"
+                by (metis (mono_tags, lifting) D.preserves_ide \<phi>x.component_in_hom cod_simp
+                    ideD(1,3) in_hom_char incloD.is_discrete incloD.preserves_cod j map_simp
+                    mem_Collect_eq o_apply terminal_char2 terminal_unity)
+              moreover have "V_of_arr ` hom Cls.unity (D j) =
+                             elts (ZFC_in_HOL.set (V_of_arr ` hom Cls.unity (D j)))"
+                using small_hom replacement by simp
+              ultimately show "V_of_arr (\<phi> x j)
+                                 \<in> elts (ZFC_in_HOL.set (V_of_arr ` hom Cls.unity (D j)))"
+                using j \<phi>x bij_betw_hom_vfun(1) by blast
+            qed
+            thus "?V_of_point x \<in> elts ?Tuples"
+              using VPi_I by fastforce
+          qed
+          have "?V_of_point ` Cls.hom Cls.unity \<Pi>D \<in> range elts"
+          proof -
+            have "?V_of_point ` Cls.hom Cls.unity \<Pi>D \<subseteq> elts ?Tuples"
+              using V_of_point by blast
+            thus ?thesis
+              using smaller_than_small down_raw by auto
+          qed
+          moreover have "inj_on ?V_of_point (Cls.hom Cls.unity \<Pi>D)"
+          proof
+            fix x y
+            assume x: "x \<in> Cls.hom Cls.unity \<Pi>D" and y: "y \<in> Cls.hom Cls.unity \<Pi>D"
+            and eq: "?V_of_point x = ?V_of_point y"
+            have \<phi>x: "\<phi> x \<in> incloD.cones Cls.unity"
+              using \<phi> x
+              unfolding bij_betw_def by blast
+            have \<phi>y: "\<phi> y \<in> incloD.cones Cls.unity"
+              using \<phi> y
+              unfolding bij_betw_def by blast
+            interpret \<phi>x: cone J Cls.comp incloD.map Cls.unity \<open>\<phi> x\<close>
+              using \<phi>x by blast
+            interpret \<phi>y: cone J Cls.comp incloD.map Cls.unity \<open>\<phi> y\<close>
+              using \<phi>y by blast
+            have "\<phi> x = \<phi> y"
+            proof -
+              have "\<And>j. j \<in> elts ?J \<Longrightarrow> \<phi> x j = \<phi> y j"
+              proof -
+                fix j
+                assume j: "j \<in> elts ?J"
+                hence 3: "J.arr j"
+                  by (simp add: 1 incloD.is_discrete)
+                have 4: "ide (D j)"
+                  using 3 incloD.is_discrete D.preserves_ide by force
+                have 5:"ide Cls.unity"
+                  using Cls.terminal_unity terminal_char terminal_def by auto
+                have \<phi>xj: "\<phi> x j \<in> hom Cls.unity (D j)"
+                  using 3 4 5 incloD.is_discrete \<phi>x.preserves_hom \<phi>x.A.map_simp in_hom_char
+                  by (metis (no_types, lifting) J.ide_char \<phi>x.component_in_hom ideD(1) map_simp
+                      mem_Collect_eq o_apply)
+                have \<phi>yj: "\<phi> y j \<in> hom Cls.unity (D j)"
+                  using 3 4 5 incloD.is_discrete \<phi>y.preserves_hom \<phi>x.A.map_simp in_hom_char
+                  by (metis (no_types, lifting) J.ide_char \<phi>y.component_in_hom ideD(1) map_simp
+                      mem_Collect_eq o_apply)
+                show "\<phi> x j = \<phi> y j"
+                proof -
+                  have "\<And>j. j \<in> elts ?J \<Longrightarrow> V_of_arr (\<phi> x j) = V_of_arr (\<phi> y j)"
+                    using x eq VLambda_eq_D2 by blast
+                  thus ?thesis
+                    using V_of_arr_def
+                    by (metis (mono_tags, lifting) j \<phi>xj \<phi>yj bij_betw_hom_vfun(3) mem_Collect_eq)
+                qed
+              qed
+              moreover have "elts ?J = Collect J.arr"
+                by (simp add: 1 incloD.is_discrete)
+              ultimately show ?thesis
+                using \<phi>x.is_extensional \<phi>y.is_extensional
+                by (metis HOL.ext mem_Collect_eq)
+            qed
+            thus "x = y"
+              using x y \<phi> bij_betw_imp_inj_on inj_on_def
+              by (metis (no_types, lifting))
+          qed
+          ultimately show "small (Cls.hom Cls.unity \<Pi>D)"
+            using small_def by blast
+        qed
+        hence "small (Cls.set \<Pi>D)"
+          by (simp add: Cls.set_def)
+        hence 2: "ide \<Pi>D"
+          using ide_char Cls.setp_set_ide Cls.product_is_ide \<Pi>D by blast
+        interpret \<Pi>D': constant_functor J comp \<Pi>D
+          using 2 by unfold_locales
+        interpret \<pi>': cone J comp D \<Pi>D \<pi>
+        proof -
+          have "\<And>j. J.arr j \<Longrightarrow> \<guillemotleft>\<pi> j : \<Pi>D \<rightarrow> D j\<guillemotright>"
+          proof
+            fix j
+            assume j: "J.arr j"
+            show 3: "arr (\<pi> j)"
+              by (metis (mono_tags, lifting) 2 D.as_nat_trans.preserves_cod D.is_discrete
+                  D.preserves_ide \<pi>.component_in_hom ideD(1) ideD(3) in_homE in_hom_char
+                  j map_simp o_apply)
+            show "dom (\<pi> j) = \<Pi>D"
+              using 3 arr_char dom_char \<pi>.preserves_dom by auto
+            show "cod (\<pi> j) = D j"
+              using 3 arr_char cod_char \<pi>.preserves_cod
+              by (metis (no_types, lifting) Cls.ideD(3) D.preserves_arr functor.preserves_ide
+                  incloD.is_discrete incloD.is_functor incloD.preserves_cod j map_simp o_apply)
+          qed
+          moreover have "D.mkCone \<pi> = \<pi>"
+            using \<pi>.is_extensional null_char by auto
+          ultimately show "cone J comp D \<Pi>D \<pi>"
+            using 2 D.cone_mkCone [of \<Pi>D \<pi>] by simp
+        qed
+        interpret \<pi>': product_cone J comp D \<Pi>D \<pi>
+        proof
+          fix a \<chi>'
+          assume \<chi>': "D.cone a \<chi>'"
+          interpret \<chi>': cone J comp D a \<chi>'
+            using \<chi>' by blast
+          have a: "Cls.ide a"
+            using ide_char \<chi>'.A.value_is_ide by blast
+          moreover have "\<And>j. J.arr j \<Longrightarrow> Cls.in_hom (\<chi>' j) a (incloD.map j)"
+          proof -
+            fix j
+            assume j: "J.arr j"
+            have "\<guillemotleft>\<chi>' j : a \<rightarrow> D j\<guillemotright>"
+              using j D.is_discrete \<chi>'.component_in_hom by force
+            thus "Cls.in_hom (\<chi>' j) a (incloD.map j)"
+              using a j D.is_discrete in_hom_char map_simp by auto
+          qed
+          ultimately have 3: "incloD.cone a (incloD.mkCone \<chi>')"
+            using incloD.cone_mkCone [of a \<chi>'] by blast
+          interpret \<chi>: cone J Cls.comp incloD.map a \<open>incloD.mkCone \<chi>'\<close>
+            using 3 by blast
+          have univ: "\<exists>!f. Cls.in_hom f a \<Pi>D \<and> incloD.cones_map f \<pi> = incloD.mkCone \<chi>'"
+            using \<chi>.cone_axioms \<pi>.is_universal [of a "incloD.mkCone \<chi>'"] by blast
+          have 4: "incloD.mkCone \<chi>' = \<chi>'"
+            using D.as_nat_trans.preserves_reflects_arr D.preserves_arr Limit.cone_def
+                  \<chi>' \<chi>'.is_extensional identity_functor.intro identity_functor.map_def
+                  incloD.as_nat_trans.is_extensional o_apply
+            by fastforce
+          have 5: "D.mkCone \<pi> = \<pi>"
+            using \<pi>.is_extensional null_char by auto
+          have 6: "\<And>f. Cls.in_hom f a \<Pi>D \<Longrightarrow> incloD.cones_map f \<pi> = D.cones_map f \<pi>"
+          proof -
+            fix f
+            assume f: "Cls.in_hom f a \<Pi>D"
+            have "incloD.cones_map f \<pi> = (\<lambda>j. if J.arr j then Cls.comp (\<pi> j) f else Cls.null)"
+              using f \<pi>.cone_axioms by auto
+            also have "... = (\<lambda>j. if J.arr j then comp (\<pi> j) f else null)"
+            proof -
+              have "\<And>j. J.arr j \<Longrightarrow> Cls.comp (\<pi> j) f = comp (\<pi> j) f"
+                using f 2 comp_char in_hom_char seq_char
+                by (metis (no_types, lifting) Cls.ext Cls.in_homE \<chi>'.ide_apex
+                    \<pi>'.preserves_reflects_arr arr_char ide_char)
+              thus ?thesis
+                using null_char by auto
+            qed
+            also have "... = D.cones_map f \<pi>"
+            proof -
+              have "\<pi> \<in> D.cones (cod f)"
+              proof -
+                have "\<guillemotleft>f : a \<rightarrow> \<Pi>D\<guillemotright>"
+                  using f 2 in_hom_char \<chi>'.ide_apex ideD(1) by presburger
+                thus ?thesis
+                  using f \<pi>'.cone_axioms by blast
+              qed
+              thus ?thesis
+                using \<open>\<pi> \<in> D.cones (cod f)\<close> by simp
+            qed
+            finally show "incloD.cones_map f \<pi> = D.cones_map f \<pi>" by blast
+          qed
+          moreover have "\<And>f. \<guillemotleft>f : a \<rightarrow> \<Pi>D\<guillemotright> \<Longrightarrow> Cls.in_hom f a \<Pi>D"
+            using in_hom_char by blast
+          show "\<exists>!f. \<guillemotleft>f : a \<rightarrow> \<Pi>D\<guillemotright> \<and> D.cones_map f \<pi> = \<chi>'"
+          proof -
+            have "\<exists>f. \<guillemotleft>f : a \<rightarrow> \<Pi>D\<guillemotright> \<and> D.cones_map f \<pi> = \<chi>'"
+              using 2 4 5 6 univ \<chi>'.ide_apex ideD(1) in_hom_char
+              by (metis (no_types, lifting))
+            moreover have "\<And>f g. \<lbrakk>\<guillemotleft>f : a \<rightarrow> \<Pi>D\<guillemotright> \<and> D.cones_map f \<pi> = \<chi>';
+                                   \<guillemotleft>g : a \<rightarrow> \<Pi>D\<guillemotright> \<and> D.cones_map g \<pi> = \<chi>'\<rbrakk>
+                                     \<Longrightarrow> f = g"
+              using 2 4 5 6 univ \<chi>'.ide_apex ideD(1) in_hom_char by auto
+            ultimately show ?thesis by blast
+          qed
+        qed
+        show ?thesis
+          using \<pi>'.product_cone_axioms has_as_product_def by blast
+      qed
+    qed
+
+    corollary has_small_products:
+    assumes "small I" and "I \<noteq> UNIV"
+    shows "has_products I"
+    proof -
+      have 1: "\<And>I :: V set. small I \<Longrightarrow> has_products I"
+        using has_small_V_products by blast
+      obtain \<phi> where \<phi>: "inj_on \<phi> I \<and> \<phi> ` I \<in> range elts"
+        using assms small_def by metis
+      have "bij_betw (inv_into I \<phi>) (\<phi> ` I) I"
+        using \<phi> bij_betw_inv_into bij_betw_imageI by metis
+      moreover have "small (\<phi> ` I)"
+        using assms by auto
+      ultimately show ?thesis
+        using assms 1 has_products_preserved_by_bijection by blast
+    qed
+
+    theorem has_small_limits:
+    assumes "category (J :: 'j comp)" and "small (Collect (partial_magma.arr J))"
+    shows "has_limits_of_shape J"
+    proof -
+      interpret J: category J
+        using assms by blast
+      have "small (Collect J.ide)"
+        using assms smaller_than_small [of "Collect J.arr" "Collect J.ide"] by fastforce
+      moreover have "Collect J.ide \<noteq> UNIV"
+        using J.ide_def by blast
+      moreover have "Collect J.arr \<noteq> UNIV"
+        using J.not_arr_null by blast
+      ultimately show "has_limits_of_shape J"
+        using assms has_small_products has_limits_if_has_products [of J] by blast
+    qed
+
+    sublocale concrete_set_category comp setp UNIV Cls.UP
+    proof
+      show "Cls.UP \<in> UNIV \<rightarrow> Univ"
+        using Cls.UP_mapsto terminal_char by presburger
+      show "inj Cls.UP"
+        using Cls.inj_UP by blast
+    qed
+
+    lemma is_concrete_set_category:
+    shows "concrete_set_category comp setp UNIV Cls.UP"
+      ..
+
+  end
+
+  text\<open>
+    In pure HOL (without ZFC), we were able to show that every category \<open>C\<close> has a ``hom functor'',
+    but there was necessarily a dependence of the target set category of the hom functor
+    on the arrow type of \<open>C\<close>.  Using the construction of the present theory, we can now show
+    that every ``locally small'' category \<open>C\<close> has a hom functor, whose target is the same set
+    category for all such \<open>C\<close>.  To obtain such a hom functor requires a choice, for each hom-set
+    \<open>hom a b\<close> of \<open>C\<close>, of an injection of \<open>hom a b\<close> to the extension of a \<open>V\<close>-set.
+  \<close>
+
+  locale locally_small_category =
+    category +
+    assumes locally_small: "\<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> small (hom b a)"
+  begin
+
+    interpretation Cop: dual_category C ..
+    interpretation CopxC: product_category Cop.comp C ..
+    interpretation S: ZFC_set_cat .
+
+    definition Hom
+    where "Hom \<equiv> \<lambda>(b, a). S.UP o (SOME \<phi>. \<phi> ` hom b a \<in> range elts \<and> inj_on \<phi> (hom b a))"
+
+    interpretation Hom: hom_functor C S.comp S.setp Hom
+    proof
+      have 1: "\<And>a b. Hom (b, a) \<in> hom b a \<rightarrow> S.Univ \<and> inj_on (Hom (b, a)) (hom b a)"
+      proof -
+        fix a b
+        show "Hom (b, a) \<in> hom b a \<rightarrow> S.Univ \<and> inj_on (Hom (b, a)) (hom b a)"
+        proof (cases "ide a \<and> ide b")
+          show "\<not> (ide a \<and> ide b) \<Longrightarrow> ?thesis"
+            using inj_on_def by fastforce
+          assume ab: "ide a \<and> ide b"
+          show ?thesis
+          proof
+            have 1: "\<exists>\<phi>. \<phi> ` hom b a \<in> range elts \<and> inj_on \<phi> (hom b a)"
+              using ab locally_small [of a b] small_def [of "hom b a"] by blast
+            let ?\<phi> = "SOME \<phi>. \<phi> ` hom b a \<in> range elts \<and> inj_on \<phi> (hom b a)"
+            have \<phi>: "?\<phi> ` hom b a \<in> range elts \<and> inj_on ?\<phi> (hom b a)"
+              using 1 someI_ex [of "\<lambda>\<phi>. \<phi> ` hom b a \<in> range elts \<and> inj_on \<phi> (hom b a)"]
+              by blast
+            show "Hom (b, a) \<in> hom b a \<rightarrow> S.Univ"
+              unfolding Hom_def
+              using \<phi> S.UP_mapsto by auto
+            show "inj_on (Hom (b, a)) (hom b a)"
+              unfolding Hom_def
+              apply simp
+              using ab \<phi> S.inj_UP comp_inj_on injD inj_on_def
+              by (metis (no_types, lifting))
+          qed
+        qed
+      qed
+      show "\<And>f. arr f \<Longrightarrow> Hom (dom f, cod f) f \<in> S.Univ"
+        using 1 by blast
+      show "\<And>b a. \<lbrakk>ide b; ide a\<rbrakk> \<Longrightarrow> inj_on (Hom (b, a)) (hom b a)"
+        using 1 by blast
+      show "\<And>b a. \<lbrakk>ide b; ide a\<rbrakk> \<Longrightarrow> Hom (b, a) ` hom b a \<subseteq> S.S.Univ \<and> small (Hom (b, a) ` hom b a)"
+        using 1 locally_small S.terminal_char by force
+    qed
+
+    lemma has_ZFC_hom_functor:
+    shows "hom_functor C S.comp S.setp Hom"
+      ..
+
+    text\<open>
+      Using this result, we can now state a more traditional version of the Yoneda Lemma
+      in which the target category of the Yoneda functor is the same for all locally small
+      categories.
+    \<close>
+
+    interpretation Y: yoneda_functor C S.comp S.setp Hom
+      ..
+
+    theorem ZFC_yoneda_lemma:
+    assumes "ide a" and "functor Cop.comp S.comp F"
+    shows "\<exists>\<phi>. bij_betw \<phi> (S.set (F a)) {\<tau>. natural_transformation Cop.comp S.comp (Y.Y a) F \<tau>}"
+    proof -
+      interpret F: "functor" Cop.comp S.comp F
+        using assms(2) by blast
+      interpret F: set_valued_functor Cop.comp S.comp S.setp F
+        ..
+      interpret Ya: yoneda_functor_fixed_object C S.comp S.setp Hom a
+        using assms(1) by unfold_locales blast
+      interpret Ya: yoneda_lemma C S.comp S.setp Hom F a
+        ..
+      show ?thesis
+        using Ya.yoneda_lemma by blast
+    qed
+
+  end
+
+end
diff --git a/thys/MonoidalCategory/FreeMonoidalCategory.thy b/thys/MonoidalCategory/FreeMonoidalCategory.thy
--- a/thys/MonoidalCategory/FreeMonoidalCategory.thy
+++ b/thys/MonoidalCategory/FreeMonoidalCategory.thy
@@ -1,3473 +1,3473 @@
 (*  Title:       FreeMonoidalCategory
     Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
     Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
 *)
 
 chapter "The Free Monoidal Category"
 
 text_raw\<open>
 \label{fmc-chap}
 \<close>
 
 theory FreeMonoidalCategory
 imports Category3.Subcategory MonoidalFunctor
 begin
 
   text \<open>
     In this theory, we use the monoidal language of a category @{term C} defined in
     @{theory MonoidalCategory.MonoidalCategory} to give a construction of the free monoidal category
     \<open>\<F>C\<close> generated by @{term C}.
     The arrows of \<open>\<F>C\<close> are the equivalence classes of formal arrows obtained
     by declaring two formal arrows to be equivalent if they are parallel and have the
     same diagonalization.
     Composition, tensor, and the components of the associator and unitors are all
     defined in terms of the corresponding syntactic constructs.
     After defining \<open>\<F>C\<close> and showing that it does indeed have the structure of
     a monoidal category, we prove the freeness: every functor from @{term C} to a
     monoidal category @{term D} extends uniquely to a strict monoidal functor from
     \<open>\<F>C\<close> to @{term D}.
 
     We then consider the full subcategory \<open>\<F>\<^sub>SC\<close> of \<open>\<F>C\<close> whose objects
     are the equivalence classes of diagonal identity terms
     ({\em i.e.}~equivalence classes of lists of identity arrows of @{term C}),
     and we show that this category is monoidally equivalent to \<open>\<F>C\<close>.
     In addition, we show that \<open>\<F>\<^sub>SC\<close> is the free strict monoidal category,
     as any functor from \<open>C\<close> to a strict monoidal category @{term D} extends uniquely
     to a strict monoidal functor from \<open>\<F>\<^sub>SC\<close> to @{term D}.
 \<close>
 
   section "Syntactic Construction"
 
   locale free_monoidal_category =
     monoidal_language C
     for C :: "'c comp"
   begin
 
     no_notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation C.in_hom ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")
 
     text \<open>
       Two terms of the monoidal language of @{term C} are defined to be equivalent if
       they are parallel formal arrows with the same diagonalization.
 \<close>
 
     abbreviation equiv
     where "equiv t u \<equiv> Par t u \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
 
     text \<open>
       Arrows of \<open>\<F>C\<close> will be the equivalence classes of formal arrows
       determined by the relation @{term equiv}.  We define here the property of being an
       equivalence class of the relation @{term equiv}.  Later we show that this property
       coincides with that of being an arrow of the category that we will construct.
 \<close>
 
     type_synonym 'a arr = "'a term set"
     definition ARR where "ARR f \<equiv> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = Collect (equiv t))"
 
     lemma not_ARR_empty:
     shows "\<not>ARR {}"
       using ARR_def by simp
 
     lemma ARR_eqI:
     assumes "ARR f" and "ARR g" and "f \<inter> g \<noteq> {}"
     shows "f = g"
       using assms ARR_def by fastforce
         
     text \<open>
       We will need to choose a representative of each equivalence class as a normal form.
       The requirements we have of these representatives are: (1) the normal form of an
       arrow @{term t} is equivalent to @{term t}; (2) equivalent arrows have identical
       normal forms; (3) a normal form is a canonical term if and only if its diagonalization
       is an identity.  It follows from these properties and coherence that a term and its
       normal form have the same evaluation in any monoidal category.  We choose here as a
       normal form for an arrow @{term t} the particular term @{term "Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"}.
       However, the only specific properties of this definition we actually use are the
       three we have just stated.
 \<close>
 
     definition norm  ("\<^bold>\<parallel>_\<^bold>\<parallel>")
     where "\<^bold>\<parallel>t\<^bold>\<parallel> = Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>"
 
     text \<open>
       If @{term t} is a formal arrow, then @{term t} is equivalent to its normal form.
 \<close>
 
     lemma equiv_norm_Arr:
     assumes "Arr t"
     shows "equiv \<^bold>\<parallel>t\<^bold>\<parallel> t"
     proof -
       have "Par t (Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)"
         using assms Diagonalize_in_Hom red_in_Hom Inv_in_Hom Arr_implies_Ide_Dom
                 Arr_implies_Ide_Cod Ide_implies_Arr Can_red
         by auto
       moreover have "\<^bold>\<lfloor>(Inv (Cod t\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<cdot> Dom t\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diagonalize_preserves_Ide
               Diagonalize_in_Hom Diagonalize_Inv [of "Cod t\<^bold>\<down>"] Diag_Diagonalize
               CompDiag_Diag_Dom [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"] CompDiag_Cod_Diag [of "\<^bold>\<lfloor>t\<^bold>\<rfloor>"]
         by (simp add: Diagonalize_red [of "Cod t"] Can_red(1))
       ultimately show ?thesis using norm_def by simp
     qed
 
     text \<open>
       Equivalent arrows have identical normal forms.
 \<close>
 
     lemma norm_respects_equiv:
     assumes "equiv t u"
     shows "\<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
       using assms norm_def by simp
 
     text \<open>
       The normal form of an arrow is canonical if and only if its diagonalization
       is an identity term.
 \<close>
 
     lemma Can_norm_iff_Ide_Diagonalize:
     assumes "Arr t"
     shows "Can \<^bold>\<parallel>t\<^bold>\<parallel> \<longleftrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms norm_def Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
             Inv_preserves_Can Diagonalize_preserves_Can red_in_Hom Diagonalize_in_Hom
             Ide_Diagonalize_Can
       by fastforce
 
     text \<open>
       We now establish various additional properties of normal forms that are consequences
       of the three already proved.  The definition \<open>norm_def\<close> is not used subsequently.
 \<close>
 
     lemma norm_preserves_Can:
     assumes "Can t"
     shows "Can \<^bold>\<parallel>t\<^bold>\<parallel>"
       using assms Can_implies_Arr Can_norm_iff_Ide_Diagonalize Ide_Diagonalize_Can by simp
 
     lemma Par_Arr_norm:
     assumes "Arr t"
     shows "Par \<^bold>\<parallel>t\<^bold>\<parallel> t"
       using assms equiv_norm_Arr by auto
 
     lemma Diagonalize_norm [simp]:
     assumes "Arr t"
     shows " \<^bold>\<lfloor>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
       using assms equiv_norm_Arr by auto
 
     lemma unique_norm:
     assumes "ARR f"
     shows "\<exists>!t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t"
     proof
       have 1: "(SOME t. t \<in> f) \<in> f"
         using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] by auto
       show "\<And>t. \<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = t \<Longrightarrow> t = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
         using assms ARR_def 1 by auto
       show "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
         using assms ARR_def 1 norm_respects_equiv by blast
     qed
 
     lemma Dom_norm:
     assumes "Arr t"
     shows "Dom \<^bold>\<parallel>t\<^bold>\<parallel> = Dom t"
       using assms Par_Arr_norm by metis
 
     lemma Cod_norm:
     assumes "Arr t"
     shows "Cod \<^bold>\<parallel>t\<^bold>\<parallel> = Cod t"
       using assms Par_Arr_norm by metis
 
     lemma norm_in_Hom:
     assumes "Arr t"
     shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> Hom (Dom t) (Cod t)"
       using assms Par_Arr_norm [of t] by simp
 
     text \<open>
       As all the elements of an equivalence class have the same normal form, we can
       use the normal form of an arbitrarily chosen element as a canonical representative.
 \<close>
 
     definition rep where "rep f \<equiv> \<^bold>\<parallel>SOME t. t \<in> f\<^bold>\<parallel>"
 
     lemma rep_in_ARR:
     assumes "ARR f"
     shows "rep f \<in> f"
       using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] equiv_norm_Arr rep_def ARR_def
       by fastforce
 
     lemma Arr_rep_ARR:
     assumes "ARR f"
     shows "Arr (rep f)"
       using assms ARR_def rep_in_ARR by auto
 
     text \<open>
       We next define a function \<open>mkarr\<close> that maps formal arrows to their equivalence classes.
       For terms that are not formal arrows, the function yields the empty set.
 \<close>
 
     definition mkarr where "mkarr t = Collect (equiv t)"
 
     lemma mkarr_extensionality:
     assumes "\<not>Arr t"
     shows "mkarr t = {}"
       using assms mkarr_def by simp
 
     lemma ARR_mkarr:
     assumes "Arr t"
     shows "ARR (mkarr t)"
       using assms ARR_def mkarr_def by auto
 
     lemma mkarr_memb_ARR:
     assumes "ARR f" and "t \<in> f"
     shows "mkarr t = f"
       using assms ARR_def mkarr_def by simp
 
     lemma mkarr_rep_ARR [simp]:
     assumes "ARR f"
     shows "mkarr (rep f) = f"
       using assms rep_in_ARR mkarr_memb_ARR by auto
 
     lemma Arr_in_mkarr:
     assumes "Arr t"
     shows "t \<in> mkarr t"
       using assms mkarr_def by simp
 
     text \<open>
       Two terms are related by @{term equiv} iff they are both formal arrows
       and have identical normal forms.
 \<close>
 
     lemma equiv_iff_eq_norm:
     shows "equiv t u \<longleftrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
     proof
       show "equiv t u \<Longrightarrow> Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel>"
         using mkarr_def Arr_in_mkarr ARR_mkarr unique_norm by blast
       show "Arr t \<and> Arr u \<and> \<^bold>\<parallel>t\<^bold>\<parallel> = \<^bold>\<parallel>u\<^bold>\<parallel> \<Longrightarrow> equiv t u"
         using Par_Arr_norm Diagonalize_norm by metis
     qed
 
     lemma norm_norm [simp]:
     assumes "Arr t"
     shows "\<^bold>\<parallel>\<^bold>\<parallel>t\<^bold>\<parallel>\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>"
     proof -
       have "t \<in> mkarr t"
         using assms Arr_in_mkarr by blast
       moreover have "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> mkarr t"
         using assms equiv_norm_Arr mkarr_def by simp
       ultimately show ?thesis using assms ARR_mkarr unique_norm by auto
     qed
 
     lemma norm_in_ARR:
     assumes "ARR f" and "t \<in> f"
     shows "\<^bold>\<parallel>t\<^bold>\<parallel> \<in> f"
       using assms ARR_def equiv_iff_eq_norm norm_norm Par_Arr_norm by fastforce
 
     lemma norm_rep_ARR [simp]:
     assumes "ARR f"
     shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
       using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] rep_def norm_norm by fastforce
 
     lemma norm_memb_eq_rep_ARR:
     assumes "ARR f" and "t \<in> f"
     shows "norm t = rep f"
       using assms ARR_def someI_ex [of "\<lambda>t. t \<in> f"] unique_norm rep_def by metis
 
     lemma rep_mkarr:
     assumes "Arr f"
     shows "rep (mkarr f) = \<^bold>\<parallel>f\<^bold>\<parallel>"
       using assms ARR_mkarr Arr_in_mkarr norm_memb_eq_rep_ARR by fastforce
 
     text \<open>
       To prove that two terms determine the same equivalence class,
       it suffices to show that they are parallel formal arrows with
       identical diagonalizations.
 \<close>
 
     lemma mkarr_eqI [intro]:
     assumes "Par f g" and "\<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>g\<^bold>\<rfloor>"
     shows "mkarr f = mkarr g"
       using assms by (metis ARR_mkarr equiv_iff_eq_norm rep_mkarr mkarr_rep_ARR)
 
     text \<open>
       We use canonical representatives to lift the formal domain and codomain functions
       from terms to equivalence classes. 
 \<close>
 
     abbreviation DOM where "DOM f \<equiv> Dom (rep f)"
     abbreviation COD where "COD f \<equiv> Cod (rep f)"
 
     lemma DOM_mkarr:
     assumes "Arr t"
     shows "DOM (mkarr t) = Dom t"
       using assms rep_mkarr by (metis Par_Arr_norm)
 
     lemma COD_mkarr:
     assumes "Arr t"
     shows "COD (mkarr t) = Cod t"
       using assms rep_mkarr by (metis Par_Arr_norm)
 
     text \<open>
       A composition operation can now be defined on equivalence classes
       using the syntactic constructor \<open>Comp\<close>.
 \<close>
 
     definition comp      (infixr "\<cdot>" 55)
       where "comp f g \<equiv> (if ARR f \<and> ARR g \<and> DOM f = COD g
                          then mkarr ((rep f) \<^bold>\<cdot> (rep g)) else {})"
 
     text \<open>
       We commence the task of showing that the composition \<open>comp\<close> so defined
       determines a category.
 \<close>
 
     interpretation partial_magma comp
       apply unfold_locales
       using comp_def not_ARR_empty by metis
 
     notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
 
     text \<open>
       The empty set serves as the null for the composition.
 \<close>
 
     lemma null_char:
     shows "null = {}"
     proof -
       let ?P = "\<lambda>n. \<forall>f. f \<cdot> n = n \<and> n \<cdot> f = n"
       have "?P {}" using comp_def not_ARR_empty by simp
       moreover have "\<exists>!n. ?P n" using ex_un_null by metis
       ultimately show ?thesis using null_def theI_unique [of ?P "{}"]
         by (metis comp_null(2))
     qed
 
     lemma ARR_comp:
     assumes "ARR f" and "ARR g" and "DOM f = COD g"
     shows "ARR (f \<cdot> g)"
       using assms comp_def Arr_rep_ARR ARR_mkarr(1) by simp
 
     lemma DOM_comp [simp]:
     assumes "ARR f" and "ARR g" and "DOM f = COD g"
     shows "DOM (f \<cdot> g) = DOM g"
       using assms comp_def ARR_comp Arr_rep_ARR DOM_mkarr by simp
 
     lemma COD_comp [simp]:
     assumes "ARR f" and "ARR g" and "DOM f = COD g"
     shows "COD (f \<cdot> g) = COD f"
       using assms comp_def ARR_comp Arr_rep_ARR COD_mkarr by simp
 
     lemma comp_assoc:
     assumes "g \<cdot> f \<noteq> null" and "h \<cdot> g \<noteq> null"
     shows "h \<cdot> (g \<cdot> f) = (h \<cdot> g) \<cdot> f"
     proof -
       have 1: "ARR f \<and> ARR g \<and> ARR h \<and> DOM h = COD g \<and> DOM g = COD f"
         using assms comp_def not_ARR_empty null_char by metis
       hence 2: "Arr (rep f) \<and> Arr (rep g) \<and> Arr (rep h) \<and>
                 Dom (rep h) = Cod (rep g) \<and> Dom (rep g) = Cod (rep f)"
         using Arr_rep_ARR by simp
       have 3: "h \<cdot> g \<cdot> f = mkarr (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f)))"
         using 1 comp_def ARR_comp COD_comp by simp
       also have "... = mkarr (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
       proof -
         have "equiv (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
         proof -
           have "Par (rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))) (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f)"
             using 1 2 3 DOM_mkarr ARR_comp COD_comp mkarr_extensionality not_ARR_empty
             by (metis Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
             (* Here metis claims it is not using snd_map_prod, but removing it fails. *)
           moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep (mkarr (rep g \<^bold>\<cdot> rep f))\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
             using 1 2 Arr_rep_ARR rep_mkarr rep_in_ARR assms(1) ARR_comp mkarr_extensionality
                   comp_def equiv_iff_eq_norm norm_memb_eq_rep_ARR null_char
             by auto
           ultimately show ?thesis using equiv_iff_eq_norm by blast
         qed
         thus ?thesis
           using mkarr_def by force
       qed
       also have "... = mkarr ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
       proof -
         have "Par (rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
           using 2 by simp
         moreover have "\<^bold>\<lfloor>rep h \<^bold>\<cdot> rep g \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
           using 2 Diag_Diagonalize by (simp add: CompDiag_assoc)
         ultimately show ?thesis
           using equiv_iff_eq_norm by (simp add: mkarr_def)
       qed
       also have "... = mkarr (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f)"
       proof -
         have "equiv (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
         proof -
           have "Par (rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f) ((rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f)"
             using 1 2 Arr_rep_ARR DOM_comp ARR_comp COD_comp comp_def by auto
           moreover have "\<^bold>\<lfloor>rep (mkarr (rep h \<^bold>\<cdot> rep g)) \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>(rep h \<^bold>\<cdot> rep g) \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
             using assms(2) 1 2 ARR_comp Arr_rep_ARR mkarr_extensionality rep_mkarr rep_in_ARR
                   equiv_iff_eq_norm norm_memb_eq_rep_ARR comp_def null_char
             by simp
           ultimately show ?thesis using equiv_iff_eq_norm by blast
         qed
         thus ?thesis
           using mkarr_def by auto
       qed
       also have "... = (h \<cdot> g) \<cdot> f"
         using 1 comp_def ARR_comp DOM_comp by simp
       finally show ?thesis by blast
     qed
 
     lemma Comp_in_comp_ARR:
     assumes "ARR f" and "ARR g" and "DOM f = COD g"
     and "t \<in> f" and "u \<in> g"
     shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
     proof -
       have "equiv (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
       proof -
         have 1: "Par (t \<^bold>\<cdot> u) (rep f \<^bold>\<cdot> rep g)"
           using assms ARR_def Arr_rep_ARR COD_mkarr DOM_mkarr mkarr_memb_ARR
                 mkarr_extensionality
           by (metis (no_types, lifting) Arr.simps(4) Cod.simps(4) Dom.simps(4) snd_map_prod)
           (* Here metis claims it is not using snd_map_prod, but removing it fails. *)
         moreover have "\<^bold>\<lfloor>t \<^bold>\<cdot> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> rep g\<^bold>\<rfloor>"
           using assms 1 rep_in_ARR equiv_iff_eq_norm norm_memb_eq_rep_ARR
           by (metis (no_types, lifting) Arr.simps(4) Diagonalize.simps(4))
         ultimately show ?thesis by simp
       qed
       thus ?thesis
         using assms comp_def mkarr_def by simp
     qed
 
     text \<open>
       Ultimately, we will show that that the identities of the category are those
       equivalence classes, all of whose members diagonalize to formal identity arrows,
       having the further property that their canonical representative is a formal
       endo-arrow.
 \<close>
 
     definition IDE where "IDE f \<equiv> ARR f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>) \<and> DOM f = COD f"
 
     lemma IDE_implies_ARR:
     assumes "IDE f"
     shows "ARR f"
       using assms IDE_def ARR_def by auto
 
     lemma IDE_mkarr_Ide:
     assumes "Ide a"
     shows "IDE (mkarr a)"
     proof -
       have "DOM (mkarr a) = COD (mkarr a)"
         using assms mkarr_def equiv_iff_eq_norm Par_Arr_norm COD_mkarr DOM_mkarr Ide_in_Hom
         by (metis Ide_implies_Can Inv_Ide Ide_implies_Arr Inv_preserves_Can(2))
       moreover have "ARR (mkarr a) \<and> (\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
       proof -
         have "ARR (mkarr a)" using assms ARR_mkarr Ide_implies_Arr by simp
         moreover have "\<forall>t. t \<in> mkarr a \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>"
           using assms mkarr_def Diagonalize_preserves_Ide by fastforce
         ultimately show ?thesis by blast
       qed
       ultimately show ?thesis using IDE_def by blast
     qed
 
     lemma IDE_implies_ide:
     assumes "IDE a"
     shows "ide a"
     proof (unfold ide_def)
       have "a \<cdot> a \<noteq> null"
       proof -
         have "rep a \<^bold>\<cdot> rep a \<in> a \<cdot> a"
           using assms IDE_def comp_def Arr_rep_ARR Arr_in_mkarr by simp
         thus ?thesis
           using null_char by auto
       qed
       moreover have "\<And>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f)"
       proof
         fix f :: "'c arr"
         show "a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f"
         proof
           assume f: "a \<cdot> f \<noteq> null"
           hence "ARR f"
             using comp_def null_char by auto
           have "rep a \<^bold>\<cdot> rep f \<in> a \<cdot> f"
             using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
           moreover have "rep a \<^bold>\<cdot> rep f \<in> f"
           proof -
             have "rep f \<in> f"
               using \<open>ARR f\<close> rep_in_ARR by auto
             moreover have "equiv (rep a \<^bold>\<cdot> rep f) (rep f)"
             proof -
               have 1: "Par (rep a \<^bold>\<cdot> rep f) (rep f)"
                 using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
                 by (metis Cod.simps(4) Dom.simps(4))
               moreover have "\<^bold>\<lfloor>rep a \<^bold>\<cdot> rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
                 using assms f 1 comp_def IDE_def CompDiag_Ide_Diag Diag_Diagonalize(1)
                       Diag_Diagonalize(2) Diag_Diagonalize(3) rep_in_ARR
                 by auto
               ultimately show ?thesis by auto
             qed
             ultimately show ?thesis
               using \<open>ARR f\<close> ARR_def by auto
           qed
           ultimately show "a \<cdot> f = f"
             using mkarr_memb_ARR comp_def by auto
         qed
         show "f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f"
         proof
           assume f: "f \<cdot> a \<noteq> null"
           hence "ARR f"
             using comp_def null_char by auto
           have "rep f \<^bold>\<cdot> rep a \<in> f \<cdot> a"
             using assms f Comp_in_comp_ARR comp_def rep_in_ARR null_char by metis
           moreover have "rep f \<^bold>\<cdot> rep a \<in> f"
           proof -
             have "rep f \<in> f"
               using \<open>ARR f\<close> rep_in_ARR by auto
             moreover have "equiv (rep f \<^bold>\<cdot> rep a) (rep f)"
             proof -
               have 1: "Par (rep f \<^bold>\<cdot> rep a) (rep f)"
                 using assms f comp_def mkarr_extensionality Arr_rep_ARR IDE_def null_char
                 by (metis Cod.simps(4) Dom.simps(4))
               moreover have "\<^bold>\<lfloor>rep f \<^bold>\<cdot> rep a\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
                 using assms f 1 comp_def IDE_def CompDiag_Diag_Ide
                       Diag_Diagonalize(1) Diag_Diagonalize(2) Diag_Diagonalize(3)
                       rep_in_ARR
                 by force
               ultimately show ?thesis by auto
             qed
             ultimately show ?thesis
               using \<open>ARR f\<close> ARR_def by auto
           qed
           ultimately show "f \<cdot> a = f"
             using mkarr_memb_ARR comp_def by auto
         qed
       qed
       ultimately show "a \<cdot> a \<noteq> null \<and>
                        (\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"
         by blast
     qed
 
     lemma ARR_iff_has_domain:
     shows "ARR f \<longleftrightarrow> domains f \<noteq> {}"
     proof
       assume f: "domains f \<noteq> {}"
       show "ARR f" using f domains_def comp_def null_char by auto
       next
       assume f: "ARR f"
       have "Ide (DOM f)"
         using f ARR_def by (simp add: Arr_implies_Ide_Dom Arr_rep_ARR)
       hence "IDE (mkarr (DOM f))" using IDE_mkarr_Ide by metis
       hence "ide (mkarr (DOM f))" using IDE_implies_ide by simp
       moreover have "f \<cdot> mkarr (DOM f) = f"
       proof -
         have 1: "rep f \<^bold>\<cdot> DOM f \<in> f \<cdot> mkarr (DOM f)"
           using f Comp_in_comp_ARR
           using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (DOM f))\<close>
                 \<open>Ide (DOM f)\<close> Arr_in_mkarr COD_mkarr
           by fastforce
         moreover have "rep f \<^bold>\<cdot> DOM f \<in> f"
         proof -
           have 2: "rep f \<in> f" using f rep_in_ARR by simp
           moreover have "equiv (rep f \<^bold>\<cdot> DOM f) (rep f)"
             by (metis 1 Arr.simps(4) Arr_rep_ARR COD_mkarr Cod.simps(4)
                 Diagonalize_Comp_Arr_Dom Dom.simps(4) IDE_def Ide_implies_Arr
                 \<open>IDE (mkarr (DOM f))\<close> \<open>Ide (DOM f)\<close> all_not_in_conv DOM_mkarr comp_def)
           ultimately show ?thesis
             using f ARR_eqI 1 \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
         qed
         ultimately show ?thesis
           using f ARR_eqI \<open>ide (mkarr (DOM f))\<close> null_char ide_def by auto
       qed
       ultimately show "domains f \<noteq> {}"
         using f domains_def not_ARR_empty null_char by auto
     qed
 
     lemma ARR_iff_has_codomain:
     shows "ARR f \<longleftrightarrow> codomains f \<noteq> {}"
     proof
       assume f: "codomains f \<noteq> {}"
       show "ARR f" using f codomains_def comp_def null_char by auto
       next
       assume f: "ARR f"
       have "Ide (COD f)"
         using f ARR_def by (simp add: Arr_rep_ARR Arr_implies_Ide_Cod)
       hence "IDE (mkarr (COD f))" using IDE_mkarr_Ide by metis
       hence "ide (mkarr (COD f))" using IDE_implies_ide by simp
       moreover have "mkarr (COD f) \<cdot> f = f"
       proof -
         have 1: "COD f \<^bold>\<cdot> rep f \<in> mkarr (COD f) \<cdot> f"
           using f Comp_in_comp_ARR
           using IDE_implies_ARR Ide_in_Hom rep_in_ARR \<open>IDE (mkarr (COD f))\<close>
                 \<open>Ide (COD f)\<close> Arr_in_mkarr DOM_mkarr
           by fastforce
         moreover have "COD f \<^bold>\<cdot> rep f \<in> f"
           using 1 null_char norm_rep_ARR norm_memb_eq_rep_ARR mkarr_memb_ARR
                 \<open>ide (mkarr (COD f))\<close> emptyE equiv_iff_eq_norm mkarr_extensionality ide_def
           by metis
         ultimately show ?thesis
           using f ARR_eqI \<open>ide (mkarr (COD f))\<close> null_char ide_def by auto
       qed
       ultimately show "codomains f \<noteq> {}"
         using codomains_def f not_ARR_empty null_char by auto
     qed
 
     lemma arr_iff_ARR:
     shows "arr f \<longleftrightarrow> ARR f"
       using arr_def ARR_iff_has_domain ARR_iff_has_codomain by simp
 
     text \<open>
       The arrows of the category are the equivalence classes of formal arrows.
 \<close>
 
     lemma arr_char:
     shows "arr f \<longleftrightarrow> f \<noteq> {} \<and> (\<forall>t. t \<in> f \<longrightarrow> f = mkarr t)"
       using arr_iff_ARR ARR_def mkarr_def by simp
 
     lemma seq_char:
     shows "seq g f \<longleftrightarrow> g \<cdot> f \<noteq> null"
     proof
       show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
         using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
               Arr_rep_ARR arr_iff_ARR
         by auto
       show "seq g f \<Longrightarrow> g \<cdot> f \<noteq> null"
         by auto
     qed
 
     lemma seq_char':
     shows "seq g f \<longleftrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
     proof
       show "ARR f \<and> ARR g \<and> DOM g = COD f \<Longrightarrow> seq g f"
         using comp_def null_char Comp_in_comp_ARR rep_in_ARR ARR_mkarr
               Arr_rep_ARR arr_iff_ARR
         by auto
       have "\<not> (ARR f \<and> ARR g \<and> DOM g = COD f) \<Longrightarrow> g \<cdot> f = null"
         using comp_def null_char by auto
       thus "seq g f \<Longrightarrow> ARR f \<and> ARR g \<and> DOM g = COD f"
         using ext by fastforce
     qed
 
     text \<open>
       Finally, we can show that the composition \<open>comp\<close> determines a category.
 \<close>
 
     interpretation category comp
     proof
       show "\<And>f. domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
         using ARR_iff_has_domain ARR_iff_has_codomain by simp
       show 1: "\<And>f g. g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
         using comp_def ARR_comp null_char arr_iff_ARR by metis
       fix f g h
       show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
         using seq_char' by auto
       show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
         using seq_char' by auto
       show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
         using seq_char' ARR_comp arr_iff_ARR by auto
       show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
         using seq_char comp_assoc by auto
     qed
 
     lemma mkarr_rep [simp]:
     assumes "arr f"
     shows "mkarr (rep f) = f"
       using assms arr_iff_ARR by simp
 
     lemma arr_mkarr [simp]:
     assumes "Arr t"
     shows "arr (mkarr t)"
       using assms by (simp add: ARR_mkarr arr_iff_ARR)
 
     lemma mkarr_memb:
     assumes "t \<in> f" and "arr f"
     shows "Arr t" and "mkarr t = f"
       using assms arr_char mkarr_extensionality by auto
 
     lemma rep_in_arr [simp]:
     assumes "arr f"
     shows "rep f \<in> f"
       using assms by (simp add: rep_in_ARR arr_iff_ARR)
 
     lemma Arr_rep [simp]:
     assumes "arr f"
     shows "Arr (rep f)"
       using assms mkarr_memb rep_in_arr by blast
 
     lemma rep_in_Hom:
     assumes "arr f"
     shows "rep f \<in> Hom (DOM f) (COD f)"
       using assms by simp
 
     lemma norm_memb_eq_rep:
     assumes "arr f" and "t \<in> f"
     shows "\<^bold>\<parallel>t\<^bold>\<parallel> = rep f"
       using assms arr_iff_ARR norm_memb_eq_rep_ARR by auto
 
     lemma norm_rep:
     assumes "arr f"
     shows "\<^bold>\<parallel>rep f\<^bold>\<parallel> = rep f"
       using assms norm_memb_eq_rep by simp
 
     text \<open>
       Composition, domain, and codomain on arrows reduce to the corresponding
       syntactic operations on their representative terms.
 \<close>
 
     lemma comp_mkarr [simp]:
     assumes "Arr t" and "Arr u" and "Dom t = Cod u"
     shows "mkarr t \<cdot> mkarr u = mkarr (t \<^bold>\<cdot> u)"
       using assms
       by (metis (no_types, lifting) ARR_mkarr ARR_comp ARR_def Arr_in_mkarr COD_mkarr
           Comp_in_comp_ARR DOM_mkarr mkarr_def)
 
     lemma dom_char:
     shows "dom f = (if arr f then mkarr (DOM f) else null)"
     proof -
       have "\<not>arr f \<Longrightarrow> ?thesis"
         using dom_def by (simp add: arr_def)
       moreover have "arr f \<Longrightarrow> ?thesis"
       proof -
         assume f: "arr f"
         have "dom f = mkarr (DOM f)"
         proof (intro dom_eqI)
           have 1: "Ide (DOM f)"
             using f arr_char by (metis Arr_rep Arr_implies_Ide_Dom)
           hence 2: "IDE (mkarr (DOM f))"
             using IDE_mkarr_Ide by metis
           thus "ide (mkarr (DOM f))" using IDE_implies_ide by simp
           moreover show "seq f (mkarr (DOM f))"
           proof -
             have "f \<cdot> mkarr (DOM f) \<noteq> null"
               using f 1 2 ARR_def DOM_mkarr IDE_implies_ARR Ide_in_Hom ARR_comp IDE_def
                     ARR_iff_has_codomain ARR_iff_has_domain null_char arr_def
               by (metis (mono_tags, lifting) mem_Collect_eq)
             thus ?thesis using seq_char by simp
           qed
         qed
         thus ?thesis using f by simp
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma dom_simp:
     assumes "arr f"
     shows "dom f = mkarr (DOM f)"
       using assms dom_char by simp
 
     lemma cod_char:
     shows "cod f = (if arr f then mkarr (COD f) else null)"
     proof -
       have "\<not>arr f \<Longrightarrow> ?thesis"
         using cod_def by (simp add: arr_def)
       moreover have "arr f \<Longrightarrow> ?thesis"
       proof -
         assume f: "arr f"
         have "cod f = mkarr (COD f)"
         proof (intro cod_eqI)
           have 1: "Ide (COD f)"
             using f arr_char by (metis Arr_rep Arr_implies_Ide_Cod)
           hence 2: "IDE (mkarr (COD f))"
             using IDE_mkarr_Ide by metis
           thus "ide (mkarr (COD f))" using IDE_implies_ide by simp
           moreover show "seq (mkarr (COD f)) f"
           proof -
             have "mkarr (COD f) \<cdot> f \<noteq> null"
               using f 1 2 ARR_def DOM_mkarr IDE_implies_ARR Ide_in_Hom ARR_comp IDE_def
                     ARR_iff_has_codomain ARR_iff_has_domain null_char arr_def
               by (metis (mono_tags, lifting) mem_Collect_eq)
             thus ?thesis using seq_char by simp
           qed
         qed
         thus ?thesis using f by simp
       qed
       ultimately show ?thesis by blast
     qed
 
     lemma cod_simp:
     assumes "arr f"
     shows "cod f = mkarr (COD f)"
       using assms cod_char by simp
 
     lemma Dom_memb:
     assumes "arr f" and "t \<in> f"
     shows "Dom t = DOM f"
       using assms DOM_mkarr mkarr_extensionality arr_char by fastforce
 
     lemma Cod_memb:
     assumes "arr f" and "t \<in> f"
     shows "Cod t = COD f"
       using assms COD_mkarr mkarr_extensionality arr_char by fastforce
 
     lemma dom_mkarr [simp]:
     assumes "Arr t"
     shows "dom (mkarr t) = mkarr (Dom t)"
       using assms dom_char DOM_mkarr arr_mkarr by auto
 
     lemma cod_mkarr [simp]:
     assumes "Arr t"
     shows "cod (mkarr t) = mkarr (Cod t)"
       using assms cod_char COD_mkarr arr_mkarr by auto
 
     lemma mkarr_in_hom:
     assumes "Arr t"
     shows "\<guillemotleft>mkarr t : mkarr (Dom t) \<rightarrow> mkarr (Cod t)\<guillemotright>"
       using assms arr_mkarr dom_mkarr cod_mkarr by auto
 
     lemma DOM_in_dom [intro]:
     assumes "arr f"
     shows "DOM f \<in> dom f"
       using assms dom_char
       by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_dom not_arr_null null_char)
 
     lemma COD_in_cod [intro]:
     assumes "arr f"
     shows "COD f \<in> cod f"
       using assms cod_char
       by (metis Arr_in_mkarr mkarr_extensionality ideD(1) ide_cod not_arr_null null_char)
 
     lemma DOM_dom:
     assumes "arr f"
     shows "DOM (dom f) = DOM f"
       using assms Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr dom_char rep_mkarr Par_Arr_norm
             Ide_in_Hom
       by simp
 
     lemma DOM_cod:
     assumes "arr f"
     shows "DOM (cod f) = COD f"
       using assms Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr cod_char rep_mkarr Par_Arr_norm
             Ide_in_Hom
       by simp
 
     lemma memb_equiv:
     assumes "arr f" and "t \<in> f" and "u \<in> f"
     shows "Par t u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     proof -
       show "Par t u"
         using assms Cod_memb Dom_memb mkarr_memb(1) by metis
       show "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
         using assms arr_iff_ARR ARR_def by auto
     qed
 
     text \<open>
       Two arrows can be proved equal by showing that they are parallel and
       have representatives with identical diagonalizations.
 \<close>
 
     lemma arr_eqI:
     assumes "par f g" and "t \<in> f" and "u \<in> g" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
     shows "f = g"
     proof -
       have "Arr t \<and> Arr u" using assms mkarr_memb(1) by blast
       moreover have "Dom t = Dom u \<and> Cod t = Cod u"
         using assms Dom_memb Cod_memb comp_def arr_char comp_arr_dom comp_cod_arr
         by (metis (full_types))
       ultimately have "Par t u" by simp
       thus ?thesis
         using assms arr_char by (metis rep_mkarr rep_in_arr equiv_iff_eq_norm)
     qed
 
     lemma comp_char:
     shows "f \<cdot> g = (if seq f g then mkarr (rep f \<^bold>\<cdot> rep g) else null)"
       using comp_def seq_char arr_char by meson
 
     text \<open>
       The mapping that takes identity terms to their equivalence classes is injective.
 \<close>
 
     lemma mkarr_inj_on_Ide:
     assumes "Ide t" and "Ide u" and "mkarr t = mkarr u"
     shows "t = u"
       using assms
       by (metis (mono_tags, lifting) COD_mkarr Ide_in_Hom mem_Collect_eq)
 
     lemma Comp_in_comp [intro]:
     assumes "arr f" and "g \<in> hom (dom g) (dom f)" and "t \<in> f" and "u \<in> g"
     shows "t \<^bold>\<cdot> u \<in> f \<cdot> g"
     proof -
       have "ARR f" using assms arr_iff_ARR by simp
       moreover have "ARR g" using assms arr_iff_ARR by auto
       moreover have "DOM f = COD g"
         using assms dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Cod Arr_implies_Ide_Dom
         by force
       ultimately show ?thesis using assms Comp_in_comp_ARR by simp
     qed
 
     text \<open>
       An arrow is defined to be ``canonical'' if some (equivalently, all) its representatives
       diagonalize to an identity term.
 \<close>
 
     definition can
     where "can f \<equiv> arr f \<and> (\<exists>t. t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
 
     lemma can_def_alt:
     shows "can f \<longleftrightarrow> arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
     proof
       assume "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
       thus "can f" using can_def arr_char by fastforce
       next
       assume f: "can f"
       show "arr f \<and> (\<forall>t. t \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>)"
       proof -
         obtain t where t: "t \<in> f \<and> Ide \<^bold>\<lfloor>t\<^bold>\<rfloor>" using f can_def by auto
         have "ARR f" using f can_def arr_char ARR_def mkarr_def by simp
         hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<parallel>u\<^bold>\<parallel> = \<^bold>\<parallel>t\<^bold>\<parallel>" using t unique_norm by auto
         hence "\<forall>u. u \<in> f \<longrightarrow> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
           using t by (metis \<open>ARR f\<close> equiv_iff_eq_norm arr_iff_ARR mkarr_memb(1))
         hence "\<forall>u. u \<in> f \<longrightarrow> Ide \<^bold>\<lfloor>u\<^bold>\<rfloor>"
           using t by metis
         thus ?thesis using f can_def by blast
       qed
     qed
 
     lemma can_implies_arr:
     assumes "can f"
     shows "arr f"
       using assms can_def by auto
 
     text \<open>
       The identities of the category are precisely the canonical endo-arrows.
 \<close>
 
     lemma ide_char:
     shows "ide f \<longleftrightarrow> can f \<and> dom f = cod f"
     proof
       assume f: "ide f"
       show "can f \<and> dom f = cod f"
         using f can_def arr_char dom_char cod_char IDE_def Arr_implies_Ide_Cod can_def_alt
               Arr_rep IDE_mkarr_Ide
         by (metis ideD(1) ideD(3))
       next
       assume f: "can f \<and> dom f = cod f"
       show "ide f"
       proof -
         have "f = dom f"
         proof (intro arr_eqI)
           show "par f (dom f)" using f can_def by simp
           show "rep f \<in> f" using f can_def by simp
           show "DOM f \<in> dom f" using f can_def by auto
           show "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
           proof -
             have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
               using f can_def Diagonalize_in_Hom by simp
             moreover have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" using f can_def_alt rep_in_arr by simp
             ultimately show ?thesis
               using f can_def Ide_in_Hom by simp
           qed
         qed
         thus ?thesis using f can_implies_arr ide_dom [of f] by auto
       qed
     qed
 
     lemma ide_iff_IDE:
     shows "ide a \<longleftrightarrow> IDE a"
       using ide_char IDE_def can_def_alt arr_iff_ARR dom_char cod_char mkarr_inj_on_Ide
             Arr_implies_Ide_Cod Arr_implies_Ide_Dom Arr_rep
       by auto
 
     lemma ide_mkarr_Ide:
     assumes "Ide a"
     shows "ide (mkarr a)"
       using assms IDE_mkarr_Ide ide_iff_IDE by simp
 
     lemma rep_dom:
     assumes "arr f"
     shows "rep (dom f) = \<^bold>\<parallel>DOM f\<^bold>\<parallel>"
       using assms dom_simp rep_mkarr Arr_rep Arr_implies_Ide_Dom by simp
 
     lemma rep_cod:
     assumes "arr f"
     shows "rep (cod f) = \<^bold>\<parallel>COD f\<^bold>\<parallel>"
       using assms cod_simp rep_mkarr Arr_rep Arr_implies_Ide_Cod by simp
 
     lemma rep_preserves_seq:
     assumes "seq g f"
     shows "Seq (rep g) (rep f)"
       using assms Arr_rep dom_char cod_char mkarr_inj_on_Ide Arr_implies_Ide_Dom
             Arr_implies_Ide_Cod
       by auto
 
     lemma rep_comp:
     assumes "seq g f"
     shows "rep (g \<cdot> f) = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
     proof -
       have "rep (g \<cdot> f) = rep (mkarr (rep g \<^bold>\<cdot> rep f))"
         using assms comp_char by metis
       also have "... = \<^bold>\<parallel>rep g \<^bold>\<cdot> rep f\<^bold>\<parallel>"
         using assms rep_preserves_seq rep_mkarr by simp
       finally show ?thesis by blast
     qed
 
     text \<open>
       The equivalence classes of canonical terms are canonical arrows.
 \<close>
 
     lemma can_mkarr_Can:
     assumes "Can t"
     shows "can (mkarr t)"
       using assms Arr_in_mkarr Can_implies_Arr Ide_Diagonalize_Can arr_mkarr can_def by blast
 
     lemma ide_implies_can:
     assumes "ide a"
     shows "can a"
       using assms ide_char by blast
 
     lemma Can_rep_can:
     assumes "can f"
     shows "Can (rep f)"
     proof -
       have "Can \<^bold>\<parallel>rep f\<^bold>\<parallel>"
         using assms can_def_alt Can_norm_iff_Ide_Diagonalize by auto
       moreover have "rep f = \<^bold>\<parallel>rep f\<^bold>\<parallel>"
         using assms can_implies_arr norm_rep by simp
       ultimately show ?thesis by simp
     qed
 
     text \<open>
       Parallel canonical arrows are identical.
 \<close>
 
     lemma can_coherence:
     assumes "par f g" and "can f" and "can g"
     shows "f = g"
     proof -
       have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
       proof -
         have "\<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>DOM f\<^bold>\<rfloor>"
           using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
         also have "... = \<^bold>\<lfloor>DOM g\<^bold>\<rfloor>"
           using assms dom_char equiv_iff_eq_norm
           by (metis DOM_in_dom mkarr_memb(1) rep_mkarr arr_dom_iff_arr)
         also have "... = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
           using assms Ide_Diagonalize_Can Can_rep_can Diagonalize_in_Hom Ide_in_Hom by force
         finally show ?thesis by blast
       qed
       hence "rep f = rep g"
         using assms rep_in_arr norm_memb_eq_rep equiv_iff_eq_norm
         by (metis (no_types, lifting) arr_eqI)
       thus ?thesis
         using assms arr_eqI [of f g] rep_in_arr [of f] rep_in_arr [of g] by metis
     qed
 
     text \<open>
       Canonical arrows are invertible, and their inverses can be obtained syntactically.
 \<close>
 
     lemma inverse_arrows_can:
     assumes "can f"
     shows "inverse_arrows f (mkarr (Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>))"
     proof
       let ?t = "(Inv (DOM f\<^bold>\<down>) \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> COD f\<^bold>\<down>)"
       have 1: "rep f \<in> f \<and> Arr (rep f) \<and> Can (rep f) \<and> Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms can_def_alt rep_in_arr rep_in_arr(1) Can_rep_can by simp
       hence 2: "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
         using Diagonalize_in_Hom [of "rep f"] Ide_in_Hom by auto
       have 3: "Can ?t"
         using assms 1 2 Can_red Ide_implies_Can Diagonalize_in_Hom Inv_preserves_Can
               Arr_implies_Ide_Cod Arr_implies_Ide_Dom Diag_Diagonalize
         by simp
       have 4: "DOM f = Cod ?t"
         using assms can_def Can_red
         by (simp add: Arr_implies_Ide_Dom Inv_preserves_Can(3))
       have 5: "COD f = Dom ?t"
         using assms can_def Can_red Arr_rep Arr_implies_Ide_Cod by simp
       have 6: "antipar f (mkarr ?t)"
         using assms 3 4 5 dom_char cod_char can_def cod_mkarr dom_mkarr Can_implies_Arr
         by simp
       show "ide (f \<cdot> mkarr ?t)"
       proof -
         have 7: "par (f \<cdot> mkarr ?t) (dom (f \<cdot> mkarr ?t))"
           using assms 6 by auto
         moreover have "can (f \<cdot> mkarr ?t)"
         proof -
           have 8: "Comp (rep f) ?t \<in> (f \<cdot> mkarr ?t)"
             using assms 1 3 4 6 can_implies_arr Arr_in_mkarr COD_mkarr Comp_in_comp_ARR
                   Can_implies_Arr arr_iff_ARR seq_char'
             by meson
           moreover have "Can (rep f \<^bold>\<cdot> ?t)"
             using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
            ultimately show ?thesis
             using can_mkarr_Can 7 mkarr_memb(2) by metis
         qed
         moreover have "can (dom (f \<cdot> mkarr ?t))"
           using 7 ide_implies_can by force
         ultimately have "f \<cdot> mkarr ?t = dom (f \<cdot> mkarr ?t)"
           using can_coherence by meson
         thus ?thesis
           using 7 ide_dom by metis
       qed
       show "ide (mkarr ?t \<cdot> f)"
       proof -
         have 7: "par (mkarr ?t \<cdot> f) (cod (mkarr ?t \<cdot> f))"
           using assms 6 by auto
         moreover have "can (mkarr ?t \<cdot> f)"
         proof -
           have 8: "Comp ?t (rep f) \<in> mkarr ?t \<cdot> f"
             using assms 1 3 6 7 Arr_in_mkarr Comp_in_comp_ARR Can_implies_Arr arr_char
                   comp_def
             by meson
           moreover have "Can (?t \<^bold>\<cdot> rep f)"
             using 1 3 7 8 mkarr_memb(1) by (metis Arr.simps(4) Can.simps(4))
           ultimately show ?thesis
             using can_mkarr_Can 7 mkarr_memb(2) by metis
         qed
         moreover have "can (cod (mkarr ?t \<cdot> f))"
           using 7 ide_implies_can by force
         ultimately have "mkarr ?t \<cdot> f = cod (mkarr ?t \<cdot> f)"
           using can_coherence by meson
         thus ?thesis
           using 7 can_implies_arr ide_cod by metis
       qed
     qed
 
     lemma inv_mkarr [simp]:
     assumes "Can t"
     shows "inv (mkarr t) = mkarr (Inv t)"
     proof -
       have t: "Can t \<and> Arr t \<and> Can (Inv t) \<and> Arr (Inv t) \<and> Ide (Dom t) \<and> Ide (Cod t)"
         using assms Can_implies_Arr Arr_implies_Ide_Dom Arr_implies_Ide_Cod
               Inv_preserves_Can
         by simp
       have "inverse_arrows (mkarr t) (mkarr (Inv t))"
       proof
         show "ide (mkarr t \<cdot> mkarr (Inv t))"
         proof -
           have "mkarr (Cod t) = mkarr (Comp t (Inv t))"
             using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
             by (intro mkarr_eqI, auto)
           also have "... = mkarr t \<cdot> mkarr (Inv t)"
             using t comp_mkarr Inv_in_Hom by simp
           finally have "mkarr (Cod t) = mkarr t \<cdot> mkarr (Inv t)"
             by blast
           thus ?thesis using t ide_mkarr_Ide [of "Cod t"] by simp
         qed
         show "ide (mkarr (Inv t) \<cdot> mkarr t)"
         proof -
           have "mkarr (Dom t) = mkarr (Inv t \<^bold>\<cdot> t)"
             using t Inv_in_Hom Ide_in_Hom Diagonalize_Inv Diag_Diagonalize Diagonalize_preserves_Can
             by (intro mkarr_eqI, auto)
           also have "... = mkarr (Inv t) \<cdot> mkarr t"
             using t comp_mkarr Inv_in_Hom by simp
           finally have "mkarr (Dom t) = mkarr (Inv t) \<cdot> mkarr t"
             by blast
           thus ?thesis using t ide_mkarr_Ide [of "Dom t"] by simp
         qed
       qed
       thus ?thesis using inverse_unique by auto
     qed
 
     lemma iso_can:
     assumes "can f"
     shows "iso f"
       using assms inverse_arrows_can by auto
 
     text \<open>
       The following function produces the unique canonical arrow between two given objects,
       if such an arrow exists.
 \<close>
 
     definition mkcan
     where "mkcan a b = mkarr (Inv (COD b\<^bold>\<down>) \<^bold>\<cdot> (DOM a\<^bold>\<down>))"
 
     lemma can_mkcan:
     assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
     shows "can (mkcan a b)" and "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
     proof -
       show "can (mkcan a b)"
         using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red
               Inv_preserves_Can can_mkarr_Can
         by simp
       show "\<guillemotleft>mkcan a b : a \<rightarrow> b\<guillemotright>"
         using assms mkcan_def Arr_rep Arr_implies_Ide_Dom Arr_implies_Ide_Cod Can_red Inv_in_Hom
               dom_char [of a] cod_char [of b] mkarr_rep mkarr_in_hom can_implies_arr
         by auto
     qed
 
     lemma dom_mkcan:
     assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
     shows "dom (mkcan a b) = a"
       using assms can_mkcan by blast
 
     lemma cod_mkcan:
     assumes "ide a" and "ide b" and "\<^bold>\<lfloor>DOM a\<^bold>\<rfloor> = \<^bold>\<lfloor>COD b\<^bold>\<rfloor>"
     shows "cod (mkcan a b) = b"
       using assms can_mkcan by blast
 
     lemma can_coherence':
     assumes "can f"
     shows "mkcan (dom f) (cod f) = f"
     proof -
       have "Ide \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms Ide_Diagonalize_Can Can_rep_can by simp
       hence "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using Ide_in_Hom by simp
       hence "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<rfloor>"
         using assms can_implies_arr Arr_rep Diagonalize_in_Hom by simp
       moreover have "DOM f = DOM (dom f)"
         using assms can_implies_arr dom_char rep_mkarr Arr_implies_Ide_Dom Ide_implies_Arr
               Par_Arr_norm [of "DOM f"] Ide_in_Hom
         by auto
       moreover have "COD f = COD (cod f)"
         using assms can_implies_arr cod_char rep_mkarr Arr_implies_Ide_Cod Ide_implies_Arr
               Par_Arr_norm [of "COD f"] Ide_in_Hom
         by auto
       ultimately have "can (mkcan (dom f) (cod f)) \<and> par f (mkcan (dom f) (cod f))"
         using assms can_implies_arr can_mkcan dom_mkcan cod_mkcan by simp
       thus ?thesis using assms can_coherence by blast
     qed
 
     lemma Ide_Diagonalize_rep_ide:
     assumes "ide a"
     shows "Ide \<^bold>\<lfloor>rep a\<^bold>\<rfloor>"
       using assms ide_implies_can can_def_alt rep_in_arr by simp
 
     lemma Diagonalize_DOM:
     assumes "arr f"
     shows "\<^bold>\<lfloor>DOM f\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
       using assms Diag_Diagonalize by simp
 
     lemma Diagonalize_COD:
     assumes "arr f"
     shows "\<^bold>\<lfloor>COD f\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
       using assms Diag_Diagonalize by simp
 
     lemma Diagonalize_rep_preserves_seq:
     assumes "seq g f"
     shows "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
       using assms Diagonalize_DOM Diagonalize_COD Diag_implies_Arr Diag_Diagonalize(1)
             rep_preserves_seq
       by force
 
     lemma Dom_Diagonalize_rep:
     assumes "arr f"
     shows "Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (dom f)\<^bold>\<rfloor>"
       using assms Diagonalize_rep_preserves_seq [of f "dom f"] Ide_Diagonalize_rep_ide Ide_in_Hom
       by simp
 
     lemma Cod_Diagonalize_rep:
     assumes "arr f"
     shows "Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = \<^bold>\<lfloor>rep (cod f)\<^bold>\<rfloor>"
       using assms Diagonalize_rep_preserves_seq [of "cod f" f] Ide_Diagonalize_rep_ide Ide_in_Hom
       by simp
 
     lemma mkarr_Diagonalize_rep:
     assumes "arr f" and "Diag (DOM f)" and "Diag (COD f)"
     shows "mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> = f"
     proof -
       have "mkarr (rep f) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms rep_in_Hom Diagonalize_in_Hom Diag_Diagonalize Diagonalize_Diag
         by (intro mkarr_eqI, simp_all)
       thus ?thesis using assms mkarr_rep by auto
     qed
 
     text \<open>
       We define tensor product of arrows via the constructor @{term Tensor} on terms.
 \<close>
 
     definition tensor\<^sub>F\<^sub>M\<^sub>C      (infixr "\<otimes>" 53)
       where "f \<otimes> g \<equiv> (if arr f \<and> arr g then mkarr (rep f \<^bold>\<otimes> rep g) else null)"
 
     lemma arr_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "arr (f \<otimes> g)"
       using assms tensor\<^sub>F\<^sub>M\<^sub>C_def arr_mkarr by simp
 
     lemma rep_tensor:
     assumes "arr f" and "arr g"
     shows "rep (f \<otimes> g) = \<^bold>\<parallel>rep f \<^bold>\<otimes> rep g\<^bold>\<parallel>"
       using assms tensor\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp
 
     lemma Par_memb_rep:
     assumes "arr f" and "t \<in> f"
     shows "Par t (rep f)"
       using assms mkarr_memb apply simp
       using rep_in_Hom Dom_memb Cod_memb by metis
 
     lemma Tensor_in_tensor [intro]:
     assumes "arr f" and "arr g" and "t \<in> f" and "u \<in> g"
     shows "t \<^bold>\<otimes> u \<in> f \<otimes> g"
     proof -
       have "equiv (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
       proof -
         have 1: "Par (t \<^bold>\<otimes> u) (rep f \<^bold>\<otimes> rep g)"
         proof -
           have "Par t (rep f) \<and> Par u (rep g)" using assms Par_memb_rep by blast
           thus ?thesis by simp
         qed
         moreover have "\<^bold>\<lfloor>t \<^bold>\<otimes> u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<otimes> rep g\<^bold>\<rfloor>"
           using assms 1 equiv_iff_eq_norm rep_mkarr norm_norm mkarr_memb(2)
           by (metis Arr.simps(3) Diagonalize.simps(3))
         ultimately show ?thesis by simp
       qed
       thus ?thesis
         using assms tensor\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
     qed
 
     lemma DOM_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "DOM (f \<otimes> g) = DOM f \<^bold>\<otimes> DOM g"
       by (metis (no_types, lifting) DOM_mkarr Dom.simps(3) mkarr_extensionality arr_char
           arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)
 
     lemma COD_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "COD (f \<otimes> g) = COD f \<^bold>\<otimes> COD g"
       by (metis (no_types, lifting) COD_mkarr Cod.simps(3) mkarr_extensionality arr_char
           arr_tensor assms(1) assms(2) tensor\<^sub>F\<^sub>M\<^sub>C_def)
 
     lemma tensor_in_hom [simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
     shows "\<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
     proof -
       have f: "arr f \<and> dom f = a \<and> cod f = b" using assms(1) by auto
       have g: "arr g \<and> dom g = c \<and> cod g = d" using assms(2) by auto
       have "dom (f \<otimes> g) = dom f \<otimes> dom g"
         using f g arr_tensor dom_char Tensor_in_tensor [of "dom f" "dom g" "DOM f" "DOM g"]
               DOM_in_dom mkarr_memb(2) DOM_tensor arr_dom_iff_arr
         by metis
       moreover have "cod (f \<otimes> g) = cod f \<otimes> cod g"
         using f g arr_tensor cod_char Tensor_in_tensor [of "cod f" "cod g" "COD f" "COD g"]
               COD_in_cod mkarr_memb(2) COD_tensor arr_cod_iff_arr
         by metis
       ultimately show ?thesis using assms arr_tensor by blast
     qed
 
     lemma dom_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "dom (f \<otimes> g) = dom f \<otimes> dom g"
       using assms tensor_in_hom [of f] by blast
 
     lemma cod_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "cod (f \<otimes> g) = cod f \<otimes> cod g"
       using assms tensor_in_hom [of f] by blast
 
     lemma tensor_mkarr [simp]:
     assumes "Arr t" and "Arr u"
     shows "mkarr t \<otimes> mkarr u = mkarr (t \<^bold>\<otimes> u)"
       using assms by (meson Tensor_in_tensor arr_char Arr_in_mkarr arr_mkarr arr_tensor)
 
     lemma tensor_preserves_ide:
     assumes "ide a" and "ide b"
     shows "ide (a \<otimes> b)"
     proof -
       have "can (a \<otimes> b)"
         using assms tensor\<^sub>F\<^sub>M\<^sub>C_def Can_rep_can ide_implies_can can_mkarr_Can by simp
       moreover have "dom (a \<otimes> b) = cod (a \<otimes> b)"
         using assms tensor_in_hom by simp
       ultimately show ?thesis using ide_char by metis
     qed
 
     lemma tensor_preserves_can:
     assumes "can f" and "can g"
     shows "can (f \<otimes> g)"
       using assms can_implies_arr Can_rep_can tensor\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can by simp
 
     lemma comp_preserves_can:
     assumes "can f" and "can g" and "dom f = cod g"
     shows "can (f \<cdot> g)"
     proof -
       have 1: "ARR f \<and> ARR g \<and> DOM f = COD g"
         using assms can_implies_arr arr_iff_ARR Arr_implies_Ide_Cod Arr_implies_Ide_Dom
               mkarr_inj_on_Ide cod_char dom_char
         by simp
       hence "Can (rep f \<^bold>\<cdot> rep g)"
         using assms can_implies_arr Can_rep_can by force
       thus ?thesis
         using assms 1 can_implies_arr comp_char can_mkarr_Can seq_char' by simp
     qed
 
     text \<open>
       The remaining structure required of a monoidal category is also defined syntactically.
 \<close>
 
     definition unity\<^sub>F\<^sub>M\<^sub>C :: "'c arr"                                  ("\<I>")
       where "\<I> = mkarr \<^bold>\<I>" 
 
     definition lunit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr"                         ("\<l>[_]")
     where "\<l>[a] = mkarr \<^bold>\<l>\<^bold>[rep a\<^bold>]"
 
     definition runit\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr"                         ("\<r>[_]")
     where "\<r>[a] = mkarr \<^bold>\<r>\<^bold>[rep a\<^bold>]"
 
     definition assoc\<^sub>F\<^sub>M\<^sub>C :: "'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr \<Rightarrow> 'c arr"     ("\<a>[_, _, _]")
     where "\<a>[a, b, c] = mkarr \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]"
 
     lemma can_lunit:
     assumes "ide a"
     shows "can \<l>[a]"
       using assms lunit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
       by (simp add: Can_rep_can ide_implies_can)
 
     lemma lunit_in_hom:
     assumes "ide a"
     shows "\<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>"
     proof -
       have "dom \<l>[a] = \<I> \<otimes> a"
         using assms lunit\<^sub>F\<^sub>M\<^sub>C_def unity\<^sub>F\<^sub>M\<^sub>C_def Ide_implies_Arr dom_mkarr dom_char tensor_mkarr
               Arr_rep
         by (metis Arr.simps(2) Arr.simps(5) Arr_implies_Ide_Dom Dom.simps(5)
                   ideD(1) ideD(2))
       moreover have "cod \<l>[a] = a"
         using assms lunit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
       ultimately show ?thesis
         using assms arr_cod_iff_arr by (intro in_homI, fastforce)
     qed
 
     lemma arr_lunit [simp]:
     assumes "ide a"
     shows "arr \<l>[a]"
       using assms can_lunit can_implies_arr by simp
 
     lemma dom_lunit [simp]:
     assumes "ide a"
     shows "dom \<l>[a] = \<I> \<otimes> a"
       using assms lunit_in_hom by auto
 
     lemma cod_lunit [simp]:
     assumes "ide a"
     shows "cod \<l>[a] = a"
       using assms lunit_in_hom by auto
 
     lemma can_runit:
     assumes "ide a"
     shows "can \<r>[a]"
       using assms runit\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
       by (simp add: Can_rep_can ide_implies_can)
 
     lemma runit_in_hom [simp]:
     assumes "ide a"
     shows "\<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>"
     proof -
       have "dom \<r>[a] = a \<otimes> \<I>"
         using assms Arr_rep Arr.simps(2) Arr.simps(7) Arr_implies_Ide_Dom Dom.simps(7)
               Ide_implies_Arr dom_mkarr dom_char ideD(1) ideD(2) runit\<^sub>F\<^sub>M\<^sub>C_def tensor_mkarr
               unity\<^sub>F\<^sub>M\<^sub>C_def
         by metis
       moreover have "cod \<r>[a] = a"
         using assms runit\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) cod_mkarr cod_char ideD(3) by auto
       ultimately show ?thesis 
         using assms arr_cod_iff_arr by (intro in_homI, fastforce)
     qed
 
     lemma arr_runit [simp]:
     assumes "ide a"
     shows "arr \<r>[a]"
       using assms can_runit can_implies_arr by simp
 
     lemma dom_runit [simp]:
     assumes "ide a"
     shows "dom \<r>[a] = a \<otimes> \<I>"
       using assms runit_in_hom by blast
 
     lemma cod_runit [simp]:
     assumes "ide a"
     shows "cod \<r>[a] = a"
       using assms runit_in_hom by blast
 
     lemma can_assoc:
     assumes "ide a" and "ide b" and "ide c"
     shows "can \<a>[a, b, c]"
       using assms assoc\<^sub>F\<^sub>M\<^sub>C_def can_mkarr_Can
       by (simp add: Can_rep_can ide_implies_can)
 
     lemma assoc_in_hom:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>"
     proof -
       have "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
       proof -
         have "dom \<a>[a, b, c] = mkarr (Dom \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
           using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
         also have "... = mkarr ((DOM a \<^bold>\<otimes> DOM b) \<^bold>\<otimes> DOM c)"
           by simp
         also have "... = (a \<otimes> b) \<otimes> c"
           by (metis mkarr_extensionality arr_tensor assms dom_char
               ideD(1) ideD(2) not_arr_null null_char tensor_mkarr)
         finally show ?thesis by blast
       qed
       moreover have "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
       proof -
         have "cod \<a>[a, b, c] = mkarr (Cod \<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>])"
           using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) by simp
         also have "... = mkarr (COD a \<^bold>\<otimes> COD b \<^bold>\<otimes> COD c)"
           by simp
         also have "... = a \<otimes> b \<otimes> c"
           by (metis mkarr_extensionality arr_tensor assms(1) assms(2) assms(3) cod_char
               ideD(1) ideD(3) not_arr_null null_char tensor_mkarr)
         finally show ?thesis by blast
       qed
       moreover have "arr \<a>[a, b, c]"
         using assms assoc\<^sub>F\<^sub>M\<^sub>C_def rep_in_arr(1) arr_mkarr by simp
       ultimately show ?thesis by auto
     qed
 
     lemma arr_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "arr \<a>[a, b, c]"
       using assms can_assoc can_implies_arr by simp
 
     lemma dom_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "dom \<a>[a, b, c] = (a \<otimes> b) \<otimes> c"
       using assms assoc_in_hom by blast
 
     lemma cod_assoc [simp]:
     assumes "ide a" and "ide b" and "ide c"
     shows "cod \<a>[a, b, c] = a \<otimes> b \<otimes> c"
       using assms assoc_in_hom by blast
 
     lemma ide_unity [simp]:
     shows "ide \<I>"
       using unity\<^sub>F\<^sub>M\<^sub>C_def Arr.simps(2) Dom.simps(2) arr_mkarr dom_mkarr ide_dom
       by metis
 
     lemma Unity_in_unity [simp]:
     shows "\<^bold>\<I> \<in> \<I>"
       using unity\<^sub>F\<^sub>M\<^sub>C_def Arr_in_mkarr by simp
 
     lemma rep_unity [simp]:
     shows "rep \<I> = \<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>"
       using unity\<^sub>F\<^sub>M\<^sub>C_def rep_mkarr by simp
 
     lemma Lunit_in_lunit [intro]:
     assumes "arr f" and "t \<in> f"
     shows "\<^bold>\<l>\<^bold>[t\<^bold>] \<in> \<l>[f]"
     proof -
       have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms
         by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
                   norm_rep)
       thus ?thesis
         by (simp add: mkarr_def lunit\<^sub>F\<^sub>M\<^sub>C_def)
     qed 
 
     lemma Runit_in_runit [intro]:
     assumes "arr f" and "t \<in> f"
     shows "\<^bold>\<r>\<^bold>[t\<^bold>] \<in> \<r>[f]"
     proof -
       have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms
         by (metis mkarr_memb(1) mkarr_memb(2) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm
                   norm_rep)
       thus ?thesis
         by (simp add: mkarr_def runit\<^sub>F\<^sub>M\<^sub>C_def)
     qed 
 
     lemma Assoc_in_assoc [intro]:
     assumes "arr f" and "arr g" and "arr h"
     and "t \<in> f" and "u \<in> g" and "v \<in> h"
     shows "\<^bold>\<a>\<^bold>[t, u, v\<^bold>] \<in> \<a>[f, g, h]"
     proof -
       have "Arr t \<and> Arr (rep f) \<and> Dom t = DOM f \<and> Cod t = COD f \<and> \<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
         using assms
         by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                   norm_rep)
       moreover have "Arr u \<and> Arr (rep g) \<and> Dom u = DOM g \<and> Cod u = COD g \<and>
                      \<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g\<^bold>\<rfloor>"
         using assms
         by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                   norm_rep)
       moreover have "Arr v \<and> Arr (rep h) \<and> Dom v = DOM h \<and> Cod v = COD h \<and>
                      \<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>rep h\<^bold>\<rfloor>"
         using assms
         by (metis mkarr_memb(1) rep_mkarr rep_in_arr(1) equiv_iff_eq_norm mkarr_memb(2)
                   norm_rep)
       ultimately show ?thesis
         using assoc\<^sub>F\<^sub>M\<^sub>C_def mkarr_def by simp
     qed
 
     text \<open>
       At last, we can show that we've constructed a monoidal category.
 \<close>
 
     interpretation EMC: elementary_monoidal_category
                           comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
     proof
       show "ide \<I>" using ide_unity by auto
       show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<l>[a] : \<I> \<otimes> a \<rightarrow> a\<guillemotright>" by auto
       show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<r>[a] : a \<otimes> \<I> \<rightarrow> a\<guillemotright>" by auto
       show "\<And>a. ide a \<Longrightarrow> iso \<l>[a]" using can_lunit iso_can by auto
       show "\<And>a. ide a  \<Longrightarrow> iso \<r>[a]" using can_runit iso_can by auto
       show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>[a, b, c] : (a \<otimes> b) \<otimes> c \<rightarrow> a \<otimes> b \<otimes> c\<guillemotright>" by auto
       show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow> iso \<a>[a, b, c]" using can_assoc iso_can by auto
       show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes> b)" using tensor_preserves_ide by auto
       fix f a b g c d
       show "\<lbrakk> \<guillemotleft>f : a \<rightarrow> b\<guillemotright>; \<guillemotleft>g : c \<rightarrow> d\<guillemotright> \<rbrakk> \<Longrightarrow> \<guillemotleft>f \<otimes> g : a \<otimes> c \<rightarrow> b \<otimes> d\<guillemotright>"
         using tensor_in_hom by auto
       next
       text \<open>Naturality of left unitor.\<close>
       fix f
       assume f: "arr f"
       show "\<l>[cod f] \<cdot> (\<I> \<otimes> f) = f \<cdot> \<l>[dom f]"
       proof (intro arr_eqI)
         show "par (\<l>[cod f] \<cdot> (\<I> \<otimes> f)) (f \<cdot> \<l>[dom f])"
           using f by simp
         show "\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f) \<in> \<l>[cod f] \<cdot> (\<I> \<otimes> f)"
           using f by fastforce
         show "rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<l>[dom f]"
           using f by fastforce
         show "\<^bold>\<lfloor>\<^bold>\<l>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (\<^bold>\<I> \<^bold>\<otimes> rep f)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<l>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
           using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
       qed
       text \<open>Naturality of right unitor.\<close>
       show "\<r>[cod f] \<cdot> (f \<otimes> \<I>) = f \<cdot> \<r>[dom f]"
       proof (intro arr_eqI)
         show "par (\<r>[cod f] \<cdot> (f \<otimes> \<I>)) (f \<cdot> \<r>[dom f])"
           using f by simp
         show "\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>) \<in> \<r>[cod f] \<cdot> (f \<otimes> \<I>)"
           using f by fastforce
         show "rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>] \<in> f \<cdot> \<r>[dom f]"
           using f by fastforce
         show "\<^bold>\<lfloor>\<^bold>\<r>\<^bold>[COD f\<^bold>] \<^bold>\<cdot> (rep f \<^bold>\<otimes> \<^bold>\<I>)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f \<^bold>\<cdot> \<^bold>\<r>\<^bold>[DOM f\<^bold>]\<^bold>\<rfloor>"
           using f by (simp add: Diag_Diagonalize(1) Diagonalize_DOM Diagonalize_COD)
       qed
       next
       text \<open>Naturality of associator.\<close>
       fix f0 :: "'c arr" and f1 f2
       assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
       show "\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)
                = (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
       proof (intro arr_eqI)
         show 1: "par (\<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2))
                      ((f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2])"
           using f0 f1 f2 by force
         show "\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)
                 \<in> \<a>[cod f0, cod f1, cod f2] \<cdot> ((f0 \<otimes> f1) \<otimes> f2)"
           using f0 f1 f2 by fastforce
         show "(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]
                 \<in> (f0 \<otimes> f1 \<otimes> f2) \<cdot> \<a>[dom f0, dom f1, dom f2]"
           using f0 f1 f2 by fastforce
         show "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                 = \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
         proof -
           have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                   = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
           proof -
             have b0: "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
               using f0 Cod_Diagonalize_rep by simp
             have b1: "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
               using f1 Cod_Diagonalize_rep by simp
             have b2: "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> = Cod \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
               using f2 Cod_Diagonalize_rep by simp
             have "\<^bold>\<lfloor>\<^bold>\<a>\<^bold>[rep (cod f0), rep (cod f1), rep (cod f2)\<^bold>] \<^bold>\<cdot> ((rep f0 \<^bold>\<otimes> rep f1) \<^bold>\<otimes> rep f2)\<^bold>\<rfloor>
                       = (\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
                         (\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>)"
               using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
             also have "... = \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                              \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
             proof -
               have "Seq \<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<and>
                     Seq \<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                 using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
                 by auto
               thus ?thesis
                 using f0 f1 f2 b0 b1 b2 TensorDiag_in_Hom TensorDiag_preserves_Diag
                       Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                       CompDiag_TensorDiag
                   by simp
             qed
             also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
             proof -
               have "\<^bold>\<lfloor>rep (cod f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
                 using f0 b0 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"] Diag_Diagonalize
                 by simp
               moreover have "\<^bold>\<lfloor>rep (cod f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
                 using f1 b1 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"] Diag_Diagonalize
                 by simp
               moreover have "\<^bold>\<lfloor>rep (cod f2)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                 using f2 b2 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"] Diag_Diagonalize
                 by simp
               ultimately show ?thesis by argo
             qed
             finally show ?thesis by blast
           qed
           also have "... = \<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot>
                            \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>"
           proof -
             have a0: "\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
               using f0 Dom_Diagonalize_rep by simp
             have a1: "\<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
               using f1 Dom_Diagonalize_rep by simp
             have a2: "\<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
               using f2 Dom_Diagonalize_rep by simp
             have "\<^bold>\<lfloor>(rep f0 \<^bold>\<otimes> rep f1 \<^bold>\<otimes> rep f2) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[rep (dom f0), rep (dom f1), rep (dom f2)\<^bold>]\<^bold>\<rfloor>
                     = (\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor>
                       (\<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>)"
                using f0 f1 f2 using Diag_Diagonalize(1) TensorDiag_assoc by auto
             also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                              \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
             proof -
               have "Seq \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> \<and> Seq \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> \<and>
                     Seq \<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor>"
                 using f0 f1 f2 rep_in_Hom Diagonalize_in_Hom Dom_Diagonalize_rep Cod_Diagonalize_rep
                 by auto
               thus ?thesis
                 using f0 f1 f2 a0 a1 a2 TensorDiag_in_Hom TensorDiag_preserves_Diag
                       Diag_Diagonalize Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                       CompDiag_TensorDiag
                 by force
             qed
             also have "... = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
             proof -
               have "\<^bold>\<lfloor>rep f0\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f0)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f0\<^bold>\<rfloor>"
                 using f0 a0 CompDiag_Diag_Dom [of "Diagonalize (rep f0)"] Diag_Diagonalize
                 by simp
               moreover have "\<^bold>\<lfloor>rep f1\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f1)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f1\<^bold>\<rfloor>"
                 using f1 a1 CompDiag_Diag_Dom [of "Diagonalize (rep f1)"] Diag_Diagonalize
                 by simp
               moreover have "\<^bold>\<lfloor>rep f2\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep (dom f2)\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f2\<^bold>\<rfloor>"
                 using f2 a2 CompDiag_Diag_Dom [of "Diagonalize (rep f2)"] Diag_Diagonalize
                 by simp
               ultimately show ?thesis by argo
             qed
             finally show ?thesis by argo
           qed
           finally show ?thesis by blast
         qed
       qed
       next
       text \<open>Tensor preserves composition (interchange).\<close>
       fix f g f' g'
       show "\<lbrakk> seq g f; seq g' f' \<rbrakk> \<Longrightarrow> (g \<otimes> g') \<cdot> (f \<otimes> f') = g \<cdot> f \<otimes> g' \<cdot> f'"
       proof -
         assume gf: "seq g f"
         assume gf': "seq g' f'"
         show ?thesis
         proof (intro arr_eqI)
           show "par ((g \<otimes> g') \<cdot> (f \<otimes> f')) (g \<cdot> f \<otimes> g' \<cdot> f')"
             using gf gf' by fastforce
           show "(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f') \<in> (g \<otimes> g') \<cdot> (f \<otimes> f')"
             using gf gf' by force
           show "rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f' \<in> g \<cdot> f \<otimes> g' \<cdot> f'"
            using gf gf'
            by (meson Comp_in_comp_ARR Tensor_in_tensor rep_in_arr seqE seq_char')
           show "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor> = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
           proof -
             have "\<^bold>\<lfloor>(rep g \<^bold>\<otimes> rep g') \<^bold>\<cdot> (rep f \<^bold>\<otimes> rep f')\<^bold>\<rfloor>
                     = (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>) \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>)"
               by auto
             also have "... =  \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>rep g'\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"
               using gf gf' Arr_rep Diagonalize_rep_preserves_seq
                     CompDiag_TensorDiag [of "\<^bold>\<lfloor>rep g\<^bold>\<rfloor>" " \<^bold>\<lfloor>rep g'\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>" "\<^bold>\<lfloor>rep f'\<^bold>\<rfloor>"]
                     Diag_Diagonalize Diagonalize_DOM Diagonalize_COD
               by force
             also have "... = \<^bold>\<lfloor>rep g \<^bold>\<cdot> rep f \<^bold>\<otimes> rep g' \<^bold>\<cdot> rep f'\<^bold>\<rfloor>"
               by auto
             finally show ?thesis by blast
           qed
         qed
       qed
       next
       text \<open>The triangle.\<close>
       fix a b
       assume a: "ide a"
       assume b: "ide b"
       show "(a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b] = \<r>[a] \<otimes> b"
       proof -
         have "par ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b]) (\<r>[a] \<otimes> b)"
           using a b by simp
         moreover have "can ((a \<otimes> \<l>[b]) \<cdot> \<a>[a, \<I>, b])"
           using a b ide_implies_can comp_preserves_can tensor_preserves_can can_assoc can_lunit
           by simp
         moreover have "can (\<r>[a] \<otimes> b)"
           using a b ide_implies_can can_runit tensor_preserves_can by simp
         ultimately show ?thesis using can_coherence by blast
       qed
       next
       text \<open>The pentagon.\<close>
       fix a b c d
       assume a: "ide a"
       assume b: "ide b"
       assume c: "ide c"
       assume d: "ide d"
       show "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)
               = \<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
       proof -
         let ?LHS = "(a \<otimes> \<a>[b, c, d]) \<cdot> \<a>[a, b \<otimes> c, d] \<cdot> (\<a>[a, b, c] \<otimes> d)"
         let ?RHS = "\<a>[a, b, c \<otimes> d] \<cdot> \<a>[a \<otimes> b, c, d]"
         have "par ?LHS ?RHS"
           using a b c d can_assoc tensor_preserves_ide by auto
         moreover have "can ?LHS"
           using a b c d ide_implies_can comp_preserves_can tensor_preserves_can can_assoc
                 tensor_preserves_ide
           by simp
         moreover have "can ?RHS"
           using a b c d comp_preserves_can tensor_preserves_can can_assoc tensor_in_hom
                 tensor_preserves_ide
           by simp
         ultimately show ?thesis using can_coherence by blast
       qed
     qed
 
     lemma is_elementary_monoidal_category:
     shows "elementary_monoidal_category
              comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C"
       ..
 
     abbreviation T\<^sub>F\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.T"
     abbreviation \<alpha>\<^sub>F\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
     abbreviation \<iota>\<^sub>F\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"
 
     interpretation MC: monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
       using EMC.induces_monoidal_category by auto
 
     lemma induces_monoidal_category:
     shows "monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C"
       ..
 
   end
 
   sublocale free_monoidal_category \<subseteq>
               elementary_monoidal_category
                  comp tensor\<^sub>F\<^sub>M\<^sub>C unity\<^sub>F\<^sub>M\<^sub>C lunit\<^sub>F\<^sub>M\<^sub>C runit\<^sub>F\<^sub>M\<^sub>C assoc\<^sub>F\<^sub>M\<^sub>C
     using is_elementary_monoidal_category by auto
 
   sublocale free_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>M\<^sub>C
     using induces_monoidal_category by auto
 
   section "Proof of Freeness"
 
   text \<open>
     Now we proceed on to establish the freeness of \<open>\<F>C\<close>: each functor
     from @{term C} to a monoidal category @{term D} extends uniquely
     to a strict monoidal functor from \<open>\<F>C\<close> to D.
 \<close>
 
   context free_monoidal_category
   begin
 
     lemma rep_lunit:
     assumes "ide a"
     shows "rep \<l>[a] = \<^bold>\<parallel>\<^bold>\<l>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
       using assms Lunit_in_lunit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<l>[a]"]
       by simp
 
     lemma rep_runit:
     assumes "ide a"
     shows "rep \<r>[a] = \<^bold>\<parallel>\<^bold>\<r>\<^bold>[rep a\<^bold>]\<^bold>\<parallel>"
       using assms Runit_in_runit [of a "rep a"] rep_in_arr norm_memb_eq_rep [of "\<r>[a]"]
       by simp
 
     lemma rep_assoc:
     assumes "ide a" and "ide b" and "ide c"
     shows "rep \<a>[a, b, c] = \<^bold>\<parallel>\<^bold>\<a>\<^bold>[rep a, rep b, rep c\<^bold>]\<^bold>\<parallel>"
       using assms Assoc_in_assoc [of a b c "rep a" "rep b" "rep c"] rep_in_arr
             norm_memb_eq_rep [of "\<a>[a, b, c]"]
       by simp
 
     lemma mkarr_Unity:
     shows "mkarr \<^bold>\<I> = \<I>"
       using unity\<^sub>F\<^sub>M\<^sub>C_def by simp
 
     text \<open>
       The unitors and associator were given syntactic definitions in terms of
       corresponding terms, but these were only for the special case of identity
       arguments (\emph{i.e.}~the components of the natural transformations).
       We need to show that @{term mkarr} gives the correct result for \emph{all}
       terms.
 \<close>
 
     lemma mkarr_Lunit:
     assumes "Arr t"
     shows "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = \<ll> (mkarr t)"
     proof -
       have "mkarr \<^bold>\<l>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
         using assms Arr_implies_Ide_Dom Ide_in_Hom Diagonalize_preserves_Ide
               Diag_Diagonalize Par_Arr_norm
         by (intro mkarr_eqI) simp_all
       also have "... = mkarr t \<cdot> mkarr \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
         using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
       also have "... = mkarr t \<cdot> \<l>[dom (mkarr t)]"
       proof -
         have "arr \<l>[mkarr (Dom t)]"
           using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
         moreover have "\<^bold>\<l>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<l>[mkarr (Dom t)]"
           using assms Arr_implies_Ide_Dom Lunit_in_lunit rep_mkarr
                 rep_in_arr [of "mkarr (Dom t)"]
           by simp
         ultimately show ?thesis
           using assms mkarr_memb(2) by simp
       qed
       also have "... = \<ll> (mkarr t)"
         using assms Arr_implies_Ide_Dom ide_mkarr_Ide lunit_agreement by simp
       finally show ?thesis by blast
     qed
 
     lemma mkarr_Lunit':
     assumes "Arr t"
     shows "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<ll>' (mkarr t)"
     proof -
       have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
         using assms Arr_implies_Ide_Cod Ide_in_Hom Diagonalize_preserves_Ide
               Diag_Diagonalize Par_Arr_norm
         by (intro mkarr_eqI) simp_all
       also have "... = mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
         using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
       also have "... = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
       proof -
         have "mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] = mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>])"
           using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
                 Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
           by (intro mkarr_eqI, simp_all)
         thus ?thesis by argo
       qed
       also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
       proof -
         have "mkarr (Inv \<^bold>\<l>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = lunit' (cod (mkarr t)) \<cdot> mkarr t"
           using assms Arr_implies_Ide_Cod rep_mkarr Par_Arr_norm inv_mkarr
                 norm_preserves_Can Ide_implies_Can lunit_agreement \<ll>'_ide_simp
                 Can_implies_Arr arr_mkarr cod_mkarr ide_cod lunit\<^sub>F\<^sub>M\<^sub>C_def
           by (metis (no_types, lifting) Can.simps(5))
         also have "... = \<ll>' (cod (mkarr t)) \<cdot> mkarr t"
           using assms \<ll>'_ide_simp arr_mkarr ide_cod by presburger
         finally show ?thesis by blast
       qed
       also have "... = \<ll>' (mkarr t)"
         using assms \<ll>'.is_natural_2 [of "mkarr t"] by simp
       finally show ?thesis by blast
     qed
 
     lemma mkarr_Runit:
     assumes "Arr t"
     shows "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = \<rho> (mkarr t)"
     proof -
       have "mkarr \<^bold>\<r>\<^bold>[t\<^bold>] = mkarr (t \<^bold>\<cdot> \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>])"
       proof -
         have "\<not> Diag (Dom t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Dom t") simp_all
         thus ?thesis 
           using assms Par_Arr_norm Arr_implies_Ide_Dom Ide_in_Hom Diag_Diagonalize
                 Diagonalize_preserves_Ide
           by (intro mkarr_eqI) simp_all
       qed
       also have "... = mkarr t \<cdot> mkarr \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>]"
         using assms Arr_implies_Ide_Dom Par_Arr_norm Ide_in_Hom by simp
       also have "... = mkarr t \<cdot> \<r>[dom (mkarr t)]"
       proof -
         have "arr \<r>[mkarr (Dom t)]"
           using assms Arr_implies_Ide_Dom ide_mkarr_Ide by simp
         moreover have "\<^bold>\<r>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>\<^bold>] \<in> \<r>[mkarr (Dom t)]"
           using assms Arr_implies_Ide_Dom Runit_in_runit rep_mkarr
                 rep_in_arr [of "mkarr (Dom t)"]
           by simp
         moreover have "mkarr (Dom t) = mkarr \<^bold>\<parallel>Dom t\<^bold>\<parallel>"
           using assms mkarr_rep rep_mkarr arr_mkarr Ide_implies_Arr Arr_implies_Ide_Dom
           by metis
         ultimately show ?thesis
           using assms mkarr_memb(2) by simp
       qed
       also have "... = \<rho> (mkarr t)"
         using assms Arr_implies_Ide_Dom ide_mkarr_Ide runit_agreement by simp
       finally show ?thesis by blast
     qed
 
     lemma mkarr_Runit':
     assumes "Arr t"
     shows "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = \<rho>' (mkarr t)"
     proof -
       have "mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] = mkarr (\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> t)"
       proof -
         have "\<not> Diag (Cod t \<^bold>\<otimes> \<^bold>\<I>)" by (cases "Cod t") simp_all
         thus ?thesis
           using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom
                 Diagonalize_preserves_Ide Diag_Diagonalize
           by (intro mkarr_eqI) simp_all
       qed
       also have "... = mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>] \<cdot> mkarr t"
         using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
       also have "... = mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t"
       proof -
         have "mkarr (Runit' (norm (Cod t))) = mkarr (Inv (Runit (norm (Cod t))))"
           using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom
                 Ide_implies_Can norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
           by (intro mkarr_eqI) simp_all
         thus ?thesis by argo
       qed
       also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
       proof -
         have "mkarr (Inv \<^bold>\<r>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr t = runit' (cod (mkarr t)) \<cdot> mkarr t"
           using assms Arr_implies_Ide_Cod rep_mkarr inv_mkarr norm_preserves_Can
                 Ide_implies_Can runit_agreement Can_implies_Arr arr_mkarr cod_mkarr
                 ide_cod runit\<^sub>F\<^sub>M\<^sub>C_def
           by (metis (no_types, lifting) Can.simps(7))
         also have "... = \<rho>' (cod (mkarr t)) \<cdot> mkarr t"
         proof -
           have "runit' (cod (mkarr t)) = \<rho>' (cod (mkarr t))"
             using assms \<rho>'_ide_simp arr_mkarr ide_cod by blast
           thus ?thesis by argo
         qed
         finally show ?thesis by blast
       qed
       also have "... = \<rho>' (mkarr t)"
         using assms \<rho>'.is_natural_2 [of "mkarr t"] by simp
       finally show ?thesis by blast
     qed
 
     lemma mkarr_Assoc:
     assumes "Arr t" and "Arr u" and "Arr v"
     shows "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = \<alpha> (mkarr t, mkarr u, mkarr v)"
     proof -
       have "mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>] = mkarr ((t \<^bold>\<otimes> u \<^bold>\<otimes> v) \<^bold>\<cdot> \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Dom t\<^bold>\<parallel>, \<^bold>\<parallel>Dom u\<^bold>\<parallel>, \<^bold>\<parallel>Dom v\<^bold>\<parallel>\<^bold>])"
         using assms Arr_implies_Ide_Dom Arr_implies_Ide_Cod Ide_in_Hom
               Diag_Diagonalize Diagonalize_preserves_Ide TensorDiag_preserves_Ide
               TensorDiag_preserves_Diag TensorDiag_assoc Par_Arr_norm
         by (intro mkarr_eqI, simp_all)
       also have "... = \<alpha> (mkarr t, mkarr u, mkarr v)"
         using assms Arr_implies_Ide_Dom rep_mkarr Ide_in_Hom assoc\<^sub>F\<^sub>M\<^sub>C_def
               Par_Arr_norm [of "Dom t"] Par_Arr_norm [of "Dom u"] Par_Arr_norm [of "Dom v"]
               \<alpha>_simp
         by simp
       finally show ?thesis by blast
     qed
 
     lemma mkarr_Assoc':
     assumes "Arr t" and "Arr u" and "Arr v"
     shows "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = \<alpha>' (mkarr t, mkarr u, mkarr v)"
     proof -
       have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>] = mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (t \<^bold>\<otimes> u \<^bold>\<otimes> v))"
         using assms Par_Arr_norm Arr_implies_Ide_Cod Ide_in_Hom Diag_Diagonalize
               TensorDiag_preserves_Diag CompDiag_Cod_Diag [of "\<^bold>\<lfloor>t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>v\<^bold>\<rfloor>"]
         by (intro mkarr_eqI, simp_all)
       also have "... = mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
         using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm by simp
       also have "... = mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
       proof -
         have "mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] =
               mkarr (Inv \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>])"
           using assms Arr_implies_Ide_Cod Ide_in_Hom Par_Arr_norm Inv_in_Hom Ide_implies_Can
                 norm_preserves_Can Diagonalize_Inv Diagonalize_preserves_Ide
           by (intro mkarr_eqI, simp_all)
         thus ?thesis by argo
       qed
       also have "... = inv (mkarr \<^bold>\<a>\<^bold>[\<^bold>\<parallel>Cod t\<^bold>\<parallel>, \<^bold>\<parallel>Cod u\<^bold>\<parallel>, \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]) \<cdot> mkarr (t \<^bold>\<otimes> u \<^bold>\<otimes> v)"
         using assms Arr_implies_Ide_Cod Ide_implies_Can norm_preserves_Can by simp
       also have "... = \<alpha>' (mkarr t, mkarr u, mkarr v)"
       proof -
         have "mkarr (\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>] \<^bold>\<cdot> (Cod t \<^bold>\<otimes> Cod u \<^bold>\<otimes> Cod v))
                = mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[Inv \<^bold>\<parallel>Cod t\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod u\<^bold>\<parallel>, Inv \<^bold>\<parallel>Cod v\<^bold>\<parallel>\<^bold>]"
           using assms Arr_implies_Ide_Cod Inv_in_Hom norm_preserves_Can Diagonalize_Inv
                 Ide_implies_Can Diag_Diagonalize Ide_in_Hom Diagonalize_preserves_Ide
                 Par_Arr_norm TensorDiag_preserves_Diag
                 CompDiag_Cod_Diag [of "\<^bold>\<lfloor>Cod t\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod u\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>Cod v\<^bold>\<rfloor>"]
           by (intro mkarr_eqI) simp_all
         thus ?thesis
           using assms Arr_implies_Ide_Cod rep_mkarr assoc\<^sub>F\<^sub>M\<^sub>C_def \<alpha>'.map_simp by simp
       qed
       finally show ?thesis by blast
     qed
 
     text \<open>
       Next, we define the ``inclusion of generators'' functor from @{term C} to \<open>\<F>C\<close>.
 \<close>
 
     definition inclusion_of_generators
     where "inclusion_of_generators \<equiv> \<lambda>f. if C.arr f then mkarr \<^bold>\<langle>f\<^bold>\<rangle> else null"
 
     lemma inclusion_is_functor:
     shows "functor C comp inclusion_of_generators"
       unfolding inclusion_of_generators_def
       apply unfold_locales
           apply auto[4]
       by (elim C.seqE, simp, intro mkarr_eqI, auto)
 
   end
 
   text \<open>
     We now show that, given a functor @{term V} from @{term C} to a
     a monoidal category @{term D}, the evaluation map that takes formal arrows
     of the monoidal language of @{term C} to arrows of @{term D}
     induces a strict monoidal functor from \<open>\<F>C\<close> to @{term D}.
 \<close>
 
   locale evaluation_functor =
     C: category C +
     D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
     evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
     \<F>C: free_monoidal_category C
   for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
   and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota>\<^sub>D :: "'d"
   and V :: "'c \<Rightarrow> 'd"
   begin
 
     notation eval         ("\<lbrace>_\<rbrace>")
 
     definition map
     where "map f \<equiv> if \<F>C.arr f then \<lbrace>\<F>C.rep f\<rbrace> else D.null"
 
     text \<open>
       It follows from the coherence theorem that a formal arrow and its normal
       form always have the same evaluation.
 \<close>
 
     lemma eval_norm:
     assumes "Arr t"
     shows "\<lbrace>\<^bold>\<parallel>t\<^bold>\<parallel>\<rbrace> = \<lbrace>t\<rbrace>"
       using assms \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm coherence canonical_factorization
       by simp
 
     interpretation "functor" \<F>C.comp D map
     proof
       fix f
       show "\<not>\<F>C.arr f \<Longrightarrow> map f = D.null" using map_def by simp
       assume f: "\<F>C.arr f"
       show "D.arr (map f)" using f map_def \<F>C.arr_char by simp
       show "D.dom (map f) = map (\<F>C.dom f)"
         using f map_def eval_norm \<F>C.rep_dom Arr_implies_Ide_Dom by auto
       show "D.cod (map f) = map (\<F>C.cod f)"
         using f map_def eval_norm \<F>C.rep_cod Arr_implies_Ide_Cod by auto
       next
       fix f g
       assume fg: "\<F>C.seq g f"
       show "map (\<F>C.comp g f) = D (map g) (map f)"
         using fg map_def \<F>C.rep_comp \<F>C.rep_preserves_seq eval_norm by auto
     qed
 
     lemma is_functor:
     shows "functor \<F>C.comp D map" ..
 
     interpretation FF: product_functor \<F>C.comp \<F>C.comp D D map map ..
     interpretation FoT: composite_functor \<F>C.CC.comp \<F>C.comp D \<F>C.T\<^sub>F\<^sub>M\<^sub>C map ..
     interpretation ToFF: composite_functor \<F>C.CC.comp D.CC.comp D FF.map T\<^sub>D ..
 
     interpretation strict_monoidal_functor
                      \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
     proof
       show "map \<F>C.\<iota> = \<iota>\<^sub>D"
         using \<F>C.\<iota>_def \<F>C.lunit_agreement map_def \<F>C.rep_lunit \<F>C.Arr_rep [of \<I>]
               eval_norm \<F>C.lunit_agreement D.unitor_coincidence D.comp_cod_arr D.\<iota>_in_hom
         by auto
       show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
                   map (\<F>C.tensor f g) = D.tensor (map f) (map g)"
         using map_def \<F>C.rep_tensor \<F>C.Arr_rep eval_norm by simp
       show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
                       map (\<F>C.assoc a b c) = D.assoc (map a) (map b) (map c)"
         using map_def \<F>C.assoc\<^sub>F\<^sub>M\<^sub>C_def \<F>C.rep_mkarr eval_norm by auto
     qed
 
     lemma is_strict_monoidal_functor:
     shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
       ..
 
   end
 
   sublocale evaluation_functor \<subseteq> strict_monoidal_functor
                                    \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
     using is_strict_monoidal_functor by auto
 
   text \<open>
     The final step in proving freeness is to show that the evaluation functor
     is the \emph{unique} strict monoidal extension of the functor @{term V}
     to \<open>\<F>C\<close>. This is done by induction, exploiting the syntactic construction
     of \<open>\<F>C\<close>.
 \<close>
 
   text \<open>
     To ease the statement and proof of the result, we define a locale that
     expresses that @{term F} is a strict monoidal extension to monoidal
     category @{term C}, of a functor @{term "V"} from @{term "C\<^sub>0"} to a
     monoidal category @{term D}, along a functor @{term I} from
     @{term "C\<^sub>0"} to @{term C}.
 \<close>
 
   locale strict_monoidal_extension =
     C\<^sub>0: category C\<^sub>0 +
     C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
     D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
     I: "functor" C\<^sub>0 C I +
     V: "functor" C\<^sub>0 D V +
     strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F
   for C\<^sub>0 :: "'c\<^sub>0 comp"
   and C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
   and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
   and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
   and \<iota>\<^sub>C :: "'c"
   and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
   and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota>\<^sub>D :: "'d"
   and I :: "'c\<^sub>0 \<Rightarrow> 'c"
   and V :: "'c\<^sub>0 \<Rightarrow> 'd"
   and F :: "'c \<Rightarrow> 'd" +
   assumes is_extension: "\<forall>f. C\<^sub>0.arr f \<longrightarrow> F (I f) = V f"
 
   sublocale evaluation_functor \<subseteq>
               strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                         \<F>C.inclusion_of_generators V map
   proof -
     interpret inclusion: "functor" C \<F>C.comp \<F>C.inclusion_of_generators
       using \<F>C.inclusion_is_functor by auto
     show "strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                     \<F>C.inclusion_of_generators V map"
       apply unfold_locales
       using map_def \<F>C.rep_mkarr eval_norm \<F>C.inclusion_of_generators_def by simp
   qed
 
   text \<open>
     A special case of interest is a strict monoidal extension to \<open>\<F>C\<close>,
     of a functor @{term V} from a category @{term C} to a monoidal category @{term D},
     along the inclusion of generators from @{term C} to \<open>\<F>C\<close>.
     The evaluation functor induced by @{term V} is such an extension.
 \<close>
 
   locale strict_monoidal_extension_to_free_monoidal_category =
     C: category C +
     monoidal_language C +
     \<F>C: free_monoidal_category C +
     strict_monoidal_extension C \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                               \<F>C.inclusion_of_generators V F
   for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
   and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota>\<^sub>D :: "'d"
   and V :: "'c \<Rightarrow> 'd"
   and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"
   begin
 
     lemma strictly_preserves_everything:
     shows "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
     and "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
     and "\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow> F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
     and "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
            F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
     and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
     and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
     and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
     and "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
     and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
            F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>]) = \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
     and "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
            F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
              = D.\<alpha>' (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
     proof -
       show "C.arr f \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<langle>f\<^bold>\<rangle>) = V f"
         using is_extension \<F>C.inclusion_of_generators_def by simp
       show "F (\<F>C.mkarr \<^bold>\<I>) = \<I>\<^sub>D"
         using \<F>C.mkarr_Unity \<F>C.\<iota>_def strictly_preserves_unity \<F>C.\<I>_agreement by auto
       show tensor_case:
            "\<And>t u.\<lbrakk> Arr t; Arr u \<rbrakk> \<Longrightarrow>
                    F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
       proof -
           fix t u
           assume t: "Arr t" and u: "Arr u"
           have "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.tensor (\<F>C.mkarr t) (\<F>C.mkarr u))"
             using t u \<F>C.tensor_mkarr \<F>C.arr_mkarr by simp
           also have "... = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
             using t u \<F>C.arr_mkarr strictly_preserves_tensor by blast
           finally show "F (\<F>C.mkarr (t \<^bold>\<otimes> u)) = F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u)"
             by fast
       qed
       show "\<lbrakk> Arr t; Arr u; Dom t = Cod u \<rbrakk> \<Longrightarrow>
               F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
       proof -
         fix t u
         assume t: "Arr t" and u: "Arr u" and tu: "Dom t = Cod u"
         show "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
         proof -
           have "F (\<F>C.mkarr (t \<^bold>\<cdot> u)) = F (\<F>C.mkarr t \<cdot> \<F>C.mkarr u)"
             using t u tu \<F>C.comp_mkarr by simp
           also have "... = F (\<F>C.mkarr t) \<cdot>\<^sub>D F (\<F>C.mkarr u)"
             using t u tu \<F>C.arr_mkarr by fastforce
           finally show ?thesis by blast
         qed
       qed
       show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^bold>[t\<^bold>]) = D.\<ll> (F (\<F>C.mkarr t))"
         using \<F>C.mkarr_Lunit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_lunit
         by simp
       show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^bold>[t\<^bold>]) = D.\<rho> (F (\<F>C.mkarr t))"
         using \<F>C.mkarr_Runit Arr_implies_Ide_Dom \<F>C.ide_mkarr_Ide strictly_preserves_runit
         by simp
       show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
               F (\<F>C.mkarr \<^bold>\<a>\<^bold>[t, u, v\<^bold>])
                 = \<alpha>\<^sub>D (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
         using \<F>C.mkarr_Assoc strictly_preserves_assoc \<F>C.ide_mkarr_Ide tensor_case
         by simp
       show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<ll>'.map (F (\<F>C.mkarr t))"
       proof -
         assume t: "Arr t"
         have "F (\<F>C.mkarr \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.lunit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
           using t \<F>C.mkarr_Lunit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<ll>'.map_simp
                 \<F>C.comp_cod_arr
           by simp
         also have "... = D.lunit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
           using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_lunit
                 preserves_inv
           by simp
         also have "... = D.\<ll>'.map (F (\<F>C.mkarr t))"
           using t D.\<ll>'.map_simp D.comp_cod_arr by simp
         finally show ?thesis by blast
       qed
       show "Arr t \<Longrightarrow> F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = D.\<rho>'.map (F (\<F>C.mkarr t))"
       proof -
         assume t: "Arr t"
         have "F (\<F>C.mkarr \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]) = F (\<F>C.runit' (\<F>C.mkarr (Cod t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
           using t \<F>C.mkarr_Runit' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<rho>'.map_simp
                 \<F>C.comp_cod_arr
           by simp
         also have "... = D.runit' (D.cod (F (\<F>C.mkarr t))) \<cdot>\<^sub>D F (\<F>C.mkarr t)"
           using t Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide strictly_preserves_runit
                 preserves_inv
           by simp
         also have "... = D.\<rho>'.map (F (\<F>C.mkarr t))"
           using t D.\<rho>'.map_simp D.comp_cod_arr by simp
         finally show ?thesis by blast
       qed
       show "\<lbrakk> Arr t; Arr u; Arr v \<rbrakk> \<Longrightarrow>
               F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>])
                 = D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
       proof -
         assume t: "Arr t" and u: "Arr u" and v: "Arr v"
         have "F (\<F>C.mkarr \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t, u, v\<^bold>]) =
                 F (\<F>C.assoc' (\<F>C.mkarr (Cod t)) (\<F>C.mkarr (Cod u)) (\<F>C.mkarr (Cod v))) \<cdot>\<^sub>D
                   (F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
           using t u v \<F>C.mkarr_Assoc' Arr_implies_Ide_Cod \<F>C.ide_mkarr_Ide \<F>C.\<alpha>'.map_simp
                 tensor_case \<F>C.iso_assoc
           by simp
         also have "... = D.assoc' (D.cod (F (\<F>C.mkarr t))) (D.cod (F (\<F>C.mkarr u)))
                                   (D.cod (F (\<F>C.mkarr v))) \<cdot>\<^sub>D
                                   (F (\<F>C.mkarr t) \<otimes>\<^sub>D F (\<F>C.mkarr u) \<otimes>\<^sub>D F (\<F>C.mkarr v))"
             using t u v \<F>C.ide_mkarr_Ide Arr_implies_Ide_Cod preserves_inv \<F>C.iso_assoc
                   strictly_preserves_assoc
                     [of "\<F>C.mkarr (Cod t)" "\<F>C.mkarr (Cod u)" "\<F>C.mkarr (Cod v)"]
             by simp
         also have "... = D.\<alpha>'.map (F (\<F>C.mkarr t), F (\<F>C.mkarr u), F (\<F>C.mkarr v))"
           using t u v D.\<alpha>'.map_simp by simp
         finally show ?thesis by blast
       qed
     qed
 
   end
 
   sublocale evaluation_functor \<subseteq> strict_monoidal_extension_to_free_monoidal_category
                                    C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V map
     ..
 
   context free_monoidal_category
   begin
 
     text \<open>
       The evaluation functor induced by @{term V} is the unique strict monoidal
       extension of @{term V} to \<open>\<F>C\<close>.
 \<close>
 
     theorem is_free:
     assumes "strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
     shows "F = evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
     proof -
       interpret F: strict_monoidal_extension_to_free_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
         using assms by auto
       interpret E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..
       have Ide_case: "\<And>a. Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
       proof -
         fix a
         show "Ide a \<Longrightarrow> F (mkarr a) = E.map (mkarr a)"
           using E.strictly_preserves_everything F.strictly_preserves_everything Ide_implies_Arr
           by (induct a) auto
       qed
       show ?thesis
       proof
         fix f
         have "\<not>arr f \<Longrightarrow> F f = E.map f"
           using E.is_extensional F.is_extensional by simp
         moreover have "arr f \<Longrightarrow> F f = E.map f"
         proof -
           assume f: "arr f"
           have "Arr (rep f) \<and> f = mkarr (rep f)" using f mkarr_rep by simp
           moreover have "\<And>t. Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
           proof -
             fix t
             show "Arr t \<Longrightarrow> F (mkarr t) = E.map (mkarr t)"
               using Ide_case E.strictly_preserves_everything F.strictly_preserves_everything
                     Arr_implies_Ide_Dom Arr_implies_Ide_Cod
               by (induct t) auto
           qed
           ultimately show "F f = E.map f" by metis
         qed
         ultimately show "F f = E.map f" by blast
       qed
     qed
 
   end
 
   section "Strict Subcategory"
 
   context free_monoidal_category
   begin
 
     text \<open>
       In this section we show that \<open>\<F>C\<close> is monoidally equivalent to its full subcategory
       \<open>\<F>\<^sub>SC\<close> whose objects are the equivalence classes of diagonal identity terms,
       and that this subcategory is the free strict monoidal category generated by @{term C}.
 \<close>
 
     interpretation \<F>\<^sub>SC: full_subcategory comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close>
       by (unfold_locales) auto
 
     text \<open>
       The mapping defined on equivalence classes by diagonalizing their representatives
       is a functor from the free monoidal category to the subcategory @{term "\<F>\<^sub>SC"}.
 \<close>
 
     definition D
     where "D \<equiv> \<lambda>f. if arr f then mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> else \<F>\<^sub>SC.null"
 
     text \<open>
       The arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes whose canonical representative
       term has diagonal formal domain and codomain.
 \<close>
 
     lemma strict_arr_char:
     shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
     proof
       show "arr f \<and> Diag (DOM f) \<and> Diag (COD f) \<Longrightarrow> \<F>\<^sub>SC.arr f"
         using \<F>\<^sub>SC.arr_char DOM_dom DOM_cod by simp
       show "\<F>\<^sub>SC.arr f \<Longrightarrow> arr f \<and> Diag (DOM f) \<and> Diag (COD f)"
         using \<F>\<^sub>SC.arr_char Arr_rep Arr_implies_Ide_Cod Ide_implies_Arr DOM_dom DOM_cod
         by force
     qed
 
     text \<open>
       Alternatively, the arrows of \<open>\<F>\<^sub>SC\<close> are those equivalence classes
       that are preserved by diagonalization of representatives.
 \<close>
 
     lemma strict_arr_char':
     shows "\<F>\<^sub>SC.arr f \<longleftrightarrow> arr f \<and> D f = f"
     proof
       fix f
       assume f: "\<F>\<^sub>SC.arr f"
       show "arr f \<and> D f = f"
       proof
         show "arr f" using f \<F>\<^sub>SC.arr_char by blast
         show "D f = f"
           using f strict_arr_char mkarr_Diagonalize_rep D_def by simp
       qed
       next
       assume f: "arr f \<and> D f = f"
       show "\<F>\<^sub>SC.arr f"
       proof -
         have "arr f" using f by simp
         moreover have "Diag (DOM f)"
         proof -
           have "DOM f = DOM (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
           also have "... = Dom \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
             using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
           also have "... = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
             using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
           finally have "DOM f = Dom \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
           thus ?thesis using f Arr_rep Diag_Diagonalize Dom_preserves_Diag by metis
         qed
         moreover have "Diag (COD f)"
         proof -
           have "COD f = COD (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)" using f D_def by auto
           also have "... = Cod \<^bold>\<parallel>\<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<parallel>"
             using f Arr_rep Diagonalize_in_Hom rep_mkarr by simp
           also have "... = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
             using f Arr_rep Diagonalize_in_Hom Par_Arr_norm [of "\<^bold>\<lfloor>rep f\<^bold>\<rfloor>"] by force
           finally have "COD f = Cod \<^bold>\<lfloor>rep f\<^bold>\<rfloor>" by blast
           thus ?thesis using f Arr_rep Diag_Diagonalize Cod_preserves_Diag by metis
         qed
         ultimately show ?thesis using strict_arr_char by auto
       qed
     qed
 
     interpretation D: "functor" comp \<F>\<^sub>SC.comp D
     proof -
       have 1: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)"
         unfolding strict_arr_char D_def
         using arr_mkarr Diagonalize_in_Hom Arr_rep rep_mkarr Par_Arr_norm
               Arr_implies_Ide_Dom Arr_implies_Ide_Cod Diag_Diagonalize
         by force
       show "functor comp \<F>\<^sub>SC.comp D"
       proof
         show "\<And>f. \<not> arr f \<Longrightarrow> D f = \<F>\<^sub>SC.null" using D_def by simp
         show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.arr (D f)" by fact
         show "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.dom (D f) = D (dom f)"
           using D_def Diagonalize_in_Hom \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.arr_char
                 rep_mkarr rep_dom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                 Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
           by simp
         show 2: "\<And>f. arr f \<Longrightarrow> \<F>\<^sub>SC.cod (D f) = D (cod f)"
           using D_def Diagonalize_in_Hom \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.arr_char
                 rep_mkarr rep_cod Arr_implies_Ide_Dom Arr_implies_Ide_Cod
                 Diagonalize_preserves_Ide ide_mkarr_Ide Diag_Diagonalize Dom_norm
           by simp
         fix f g
         assume fg: "seq g f"
         hence fg': "arr f \<and> arr g \<and> dom g = cod f" by blast
         show "D (g \<cdot> f) = \<F>\<^sub>SC.comp (D g) (D f)"
         proof -
           have seq: "\<F>\<^sub>SC.seq (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
           proof -
             have 3: "\<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) \<and> \<F>\<^sub>SC.arr (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
               using fg' 1 arr_char D_def by force
             moreover have "\<F>\<^sub>SC.dom (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) = \<F>\<^sub>SC.cod (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
               using fg' 2 3 \<F>\<^sub>SC.dom_char rep_in_Hom mkarr_in_hom D_def
                     Dom_Diagonalize_rep Diag_implies_Arr Diag_Diagonalize(1) \<F>\<^sub>SC.arr_char
               by force
             ultimately show ?thesis using \<F>\<^sub>SC.seqI by auto
           qed
           have "mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor> = \<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
           proof -
             have Seq: "Seq \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
               using fg rep_preserves_seq Diagonalize_in_Hom by force
             hence 4: "\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<in> Hom \<^bold>\<lfloor>DOM f\<^bold>\<rfloor> \<^bold>\<lfloor>COD g\<^bold>\<rfloor>"
               using fg' Seq Diagonalize_in_Hom by auto
             have "\<F>\<^sub>SC.comp (mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor>) (mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) = mkarr \<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<cdot> mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
               using seq \<F>\<^sub>SC.comp_char \<F>\<^sub>SC.seq_char by meson
             also have "... = mkarr (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>)"
               using Seq comp_mkarr by fastforce
             also have "... = mkarr \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
             proof (intro mkarr_eqI)
               show "Par (\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>) \<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>"
                 using fg 4 rep_in_Hom rep_preserves_seq rep_in_Hom Diagonalize_in_Hom
                       Par_Arr_norm
                 apply (elim seqE, auto)
                 by (simp_all add: rep_comp)
               show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep g\<^bold>\<rfloor> \<^bold>\<cdot> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<lfloor>rep (g \<cdot> f)\<^bold>\<rfloor>\<^bold>\<rfloor>"
                 using fg rep_preserves_seq norm_in_Hom Diag_Diagonalize Diagonalize_Diag
                 apply auto
                 by (simp add: rep_comp)
             qed
             finally show ?thesis by blast
           qed
           thus ?thesis using fg D_def by auto
         qed
       qed
     qed
 
     lemma diagonalize_is_functor:
     shows "functor comp \<F>\<^sub>SC.comp D" ..
 
     lemma diagonalize_strict_arr:
     assumes "\<F>\<^sub>SC.arr f"
     shows "D f = f"
       using assms arr_char D_def strict_arr_char Arr_rep Arr_implies_Ide_Dom Ide_implies_Arr
             mkarr_Diagonalize_rep [of f]
       by auto
 
     lemma diagonalize_is_idempotent:
     shows "D o D = D"
       unfolding D_def
       using D.is_extensional \<F>\<^sub>SC.null_char Arr_rep Diagonalize_in_Hom mkarr_Diagonalize_rep
             strict_arr_char rep_mkarr
       by fastforce
 
     lemma diagonalize_tensor:
     assumes "arr f" and "arr g"
     shows "D (f \<otimes> g) = D (D f \<otimes> D g)"
       unfolding D_def
       using assms strict_arr_char rep_in_Hom Diagonalize_in_Hom tensor_mkarr rep_tensor
             Diagonalize_in_Hom rep_mkarr Diagonalize_norm Diagonalize_Tensor
       by force
 
     lemma ide_diagonalize_can:
     assumes "can f"
     shows "ide (D f)"
       using assms D_def Can_rep_can Ide_Diagonalize_Can ide_mkarr_Ide can_implies_arr
       by simp
 
     text \<open>
       We next show that the diagonalization functor and the inclusion of the full subcategory
       \<open>\<F>\<^sub>SC\<close> underlie an equivalence of categories.  The arrows @{term "mkarr (DOM a\<^bold>\<down>)"},
       determined by reductions of canonical representatives, are the components of a
       natural isomorphism.
 \<close>
 
     interpretation S: full_inclusion_functor comp \<open>\<lambda>f. ide f \<and> Diag (DOM f)\<close> ..
     interpretation DoS: composite_functor \<F>\<^sub>SC.comp comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map D
       ..
     interpretation SoD: composite_functor comp \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map ..
 
     interpretation \<nu>: transformation_by_components
                         comp comp map SoD.map \<open>\<lambda>a. mkarr (DOM a\<^bold>\<down>)\<close>
     proof
       fix a
       assume a: "ide a"
       show "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : map a \<rightarrow> SoD.map a\<guillemotright>"
       proof -
         have "\<guillemotleft>mkarr (DOM a\<^bold>\<down>) : a \<rightarrow> mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>\<guillemotright>"
           using a Arr_implies_Ide_Dom red_in_Hom dom_char [of a] by auto
         moreover have "map a = a"
           using a map_simp by simp
         moreover have "SoD.map a = mkarr \<^bold>\<lfloor>DOM a\<^bold>\<rfloor>"
           using a D.preserves_ide \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp D_def Ide_Diagonalize_rep_ide
                 Ide_in_Hom Diagonalize_in_Hom
           by force
         ultimately show ?thesis by simp
       qed
       next
       fix f
       assume f: "arr f"
       show "mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f = SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>)"
       proof -
         have "SoD.map f \<cdot> mkarr (DOM (dom f)\<^bold>\<down>) = mkarr \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<cdot> mkarr (DOM f\<^bold>\<down>)"
           using f DOM_dom D.preserves_arr \<F>\<^sub>SC.map_simp D_def by simp
         also have "... = mkarr (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>)"
           using f Diagonalize_in_Hom red_in_Hom comp_mkarr Arr_implies_Ide_Dom
           by simp
         also have "... = mkarr (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
         proof (intro mkarr_eqI)
           show "Par (\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>) (COD f\<^bold>\<down> \<^bold>\<cdot> rep f)"
             using f Diagonalize_in_Hom red_in_Hom Arr_implies_Ide_Dom Arr_implies_Ide_Cod
             by simp
           show "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
           proof -
             have "\<^bold>\<lfloor>\<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<cdot> DOM f\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>DOM f\<^bold>\<down>\<^bold>\<rfloor>"
               using f by simp
             also have "... = \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
               using f Arr_implies_Ide_Dom Can_red Ide_Diagonalize_Can [of "DOM f\<^bold>\<down>"]
                     Diag_Diagonalize CompDiag_Diag_Ide
               by force
             also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>rep f\<^bold>\<rfloor>"
               using f Arr_implies_Ide_Cod Can_red Ide_Diagonalize_Can [of "COD f\<^bold>\<down>"]
                     Diag_Diagonalize CompDiag_Diag_Ide
               by force
             also have "... = \<^bold>\<lfloor>COD f\<^bold>\<down> \<^bold>\<cdot> rep f\<^bold>\<rfloor>"
               by simp
             finally show ?thesis by blast
           qed
         qed
         also have "... = mkarr (COD f\<^bold>\<down>) \<cdot> mkarr (rep f)"
           using f comp_mkarr rep_in_Hom red_in_Hom Arr_implies_Ide_Cod by blast
         also have "... = mkarr (DOM (cod f)\<^bold>\<down>) \<cdot> map f"
           using f DOM_cod by simp
         finally show ?thesis by blast
       qed
     qed
 
     interpretation \<nu>: natural_isomorphism comp comp map SoD.map \<nu>.map
       apply unfold_locales
       using \<nu>.map_simp_ide rep_in_Hom Arr_implies_Ide_Dom Can_red can_mkarr_Can iso_can
       by simp
 
     text \<open>
       The restriction of the diagonalization functor to the subcategory \<open>\<F>\<^sub>SC\<close>
       is the identity.
 \<close>
 
     lemma DoS_eq_\<F>\<^sub>SC:
     shows "DoS.map = \<F>\<^sub>SC.map"
     proof
       fix f
       have "\<not> \<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
         using DoS.is_extensional \<F>\<^sub>SC.map_def by simp
       moreover have "\<F>\<^sub>SC.arr f \<Longrightarrow> DoS.map f = \<F>\<^sub>SC.map f"
         using \<F>\<^sub>SC.map_simp strict_arr_char Diagonalize_Diag D_def mkarr_Diagonalize_rep
         by simp
       ultimately show "DoS.map f = \<F>\<^sub>SC.map f" by blast
     qed
 
     interpretation \<mu>: transformation_by_components
                         \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<open>\<lambda>a. a\<close>
       using \<F>\<^sub>SC.ideD \<F>\<^sub>SC.map_simp DoS_eq_\<F>\<^sub>SC \<F>\<^sub>SC.map_simp \<F>\<^sub>SC.comp_cod_arr \<F>\<^sub>SC.comp_arr_dom
       apply unfold_locales
       by (intro \<F>\<^sub>SC.in_homI) auto
          
     interpretation \<mu>: natural_isomorphism \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map
       apply unfold_locales using \<mu>.map_simp_ide \<F>\<^sub>SC.ide_is_iso by simp
 
     interpretation equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map ..
 
     text \<open>
       We defined the natural isomorphisms @{term \<mu>} and @{term \<nu>} by giving their
       components (\emph{i.e.}~their values at objects).  However, it is helpful
       in exporting these facts to have simple characterizations of their values
       for all arrows.
 \<close>
 
     definition \<mu>
     where "\<mu> \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then f else \<F>\<^sub>SC.null"
 
     definition \<nu>
     where "\<nu> \<equiv> \<lambda>f. if arr f then mkarr (COD f\<^bold>\<down>) \<cdot> f else null"
 
     lemma \<mu>_char:
     shows "\<mu>.map = \<mu>"
     proof (intro NaturalTransformation.eqI)
       show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>.map" ..
       have "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp \<F>\<^sub>SC.map \<F>\<^sub>SC.map \<F>\<^sub>SC.map"
         using DoS.as_nat_trans.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
       moreover have "\<F>\<^sub>SC.map = \<mu>" unfolding \<mu>_def using \<F>\<^sub>SC.map_def by blast
       ultimately show "natural_transformation \<F>\<^sub>SC.comp \<F>\<^sub>SC.comp DoS.map \<F>\<^sub>SC.map \<mu>"
         using \<F>\<^sub>SC.as_nat_trans.natural_transformation_axioms DoS_eq_\<F>\<^sub>SC by simp
       show "\<And>a. \<F>\<^sub>SC.ide a \<Longrightarrow> \<mu>.map a = \<mu> a"
         using \<mu>.map_simp_ide \<F>\<^sub>SC.ideD \<mu>_def by simp
     qed
 
     lemma \<nu>_char:
     shows "\<nu>.map = \<nu>"
       unfolding \<nu>.map_def \<nu>_def using map_simp DOM_cod by fastforce
 
     lemma is_equivalent_to_strict_subcategory:
     shows "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
     proof -
       have "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu>.map \<mu>.map" ..
       thus "equivalence_of_categories \<F>\<^sub>SC.comp comp D \<F>\<^sub>SC.map \<nu> \<mu>"
         using \<nu>_char \<mu>_char by simp
     qed
 
     text \<open>
       The inclusion of generators functor from @{term C} to \<open>\<F>C\<close>
       corestricts to a functor from @{term C} to \<open>\<F>\<^sub>SC\<close>.
 \<close>
 
     interpretation I: "functor" C comp inclusion_of_generators
       using inclusion_is_functor by auto
     interpretation DoI: composite_functor C comp \<F>\<^sub>SC.comp inclusion_of_generators D ..
 
     lemma DoI_eq_I:
     shows "DoI.map = inclusion_of_generators"
     proof
       fix f
       have "\<not> C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
         using DoI.is_extensional I.is_extensional \<F>\<^sub>SC.null_char by blast
       moreover have "C.arr f \<Longrightarrow> DoI.map f = inclusion_of_generators f"
       proof -
         assume f: "C.arr f"
         have "DoI.map f = D (inclusion_of_generators f)" using f by simp
         also have "... = inclusion_of_generators f"
         proof -
           have "\<F>\<^sub>SC.arr (inclusion_of_generators f)"
             using f arr_mkarr rep_mkarr Par_Arr_norm [of "\<^bold>\<langle>f\<^bold>\<rangle>"] strict_arr_char
                   inclusion_of_generators_def
             by simp
           thus ?thesis using f strict_arr_char' by blast
         qed
         finally show "DoI.map f = inclusion_of_generators f" by blast
       qed
       ultimately show "DoI.map f = inclusion_of_generators f" by blast
     qed
 
   end
 
   text \<open>
     Next, we show that the subcategory \<open>\<F>\<^sub>SC\<close> inherits monoidal structure from
     the ambient category \<open>\<F>C\<close>, and that this monoidal structure is strict.
 \<close>
 
   locale free_strict_monoidal_category =
     monoidal_language C +
     \<F>C: free_monoidal_category C +
     full_subcategory \<F>C.comp "\<lambda>f. \<F>C.ide f \<and> Diag (\<F>C.DOM f)"
     for C :: "'c comp"
   begin
 
     interpretation D: "functor" \<F>C.comp comp \<F>C.D
       using \<F>C.diagonalize_is_functor by auto
 
     notation comp           (infixr "\<cdot>\<^sub>S" 55)
 
     definition tensor\<^sub>S      (infixr "\<otimes>\<^sub>S" 53)
     where "f \<otimes>\<^sub>S g \<equiv> \<F>C.D (\<F>C.tensor f g)"
 
     definition assoc\<^sub>S       ("\<a>\<^sub>S[_, _, _]")
     where "assoc\<^sub>S a b c \<equiv> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c"
 
     lemma tensor_char:
     assumes "arr f" and "arr g"
     shows "f \<otimes>\<^sub>S g = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>)"
       unfolding \<F>C.D_def tensor\<^sub>S_def
       using assms arr_char \<F>C.rep_tensor by simp
 
     lemma tensor_in_hom [simp]:
     assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : c \<rightarrow> d\<guillemotright>"
     shows "\<guillemotleft>f \<otimes>\<^sub>S g : a \<otimes>\<^sub>S c \<rightarrow> b \<otimes>\<^sub>S d\<guillemotright>"
       unfolding tensor\<^sub>S_def
-      using assms D.preserves_hom D.preserves_arr arr_char in_hom_char by simp
+      using assms D.preserves_hom arr_char in_hom_char
+      by (metis (no_types, lifting) \<F>C.T_simp \<F>C.tensor_in_hom in_homE)
 
     lemma arr_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "arr (f \<otimes>\<^sub>S g)"
       using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
 
     lemma dom_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "dom (f \<otimes>\<^sub>S g) = dom f \<otimes>\<^sub>S dom g"
       using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
 
     lemma cod_tensor [simp]:
     assumes "arr f" and "arr g"
     shows "cod (f \<otimes>\<^sub>S g) = cod f \<otimes>\<^sub>S cod g"
       using assms arr_iff_in_hom [of f] arr_iff_in_hom [of g] tensor_in_hom by blast
 
     lemma tensor_preserves_ide:
     assumes "ide a" and "ide b"
     shows "ide (a \<otimes>\<^sub>S b)"
       using assms tensor\<^sub>S_def D.preserves_ide \<F>C.tensor_preserves_ide ide_char
       by fastforce
 
     lemma tensor_tensor:
     assumes "arr f" and "arr g" and "arr h"
     shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
     and "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
     proof -
       show "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
       proof -
         have "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (f \<otimes>\<^sub>S g)\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
           using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
                 \<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
           by simp
         also have
           "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>))\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                            \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
           using assms arr_char tensor_char by simp
         also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
           using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize
                 TensorDiag_preserves_Diag arr_char
           by force
         also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
           using assms Diag_Diagonalize TensorDiag_preserves_Diag TensorDiag_assoc arr_char
           by force
         finally show ?thesis by blast
       qed
       show "f \<otimes>\<^sub>S g \<otimes>\<^sub>S h = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>)"
       proof -
         have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>\<^bold>\<rfloor>)"
           using assms Diag_Diagonalize TensorDiag_preserves_Diag arr_char by force
         also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor>
                                    (\<^bold>\<lfloor>\<F>C.rep (\<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep g\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep h\<^bold>\<rfloor>))\<^bold>\<rfloor>))"
           using assms \<F>C.rep_mkarr TensorDiag_in_Hom Diag_Diagonalize arr_char by force
         also have "... = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep (g \<otimes>\<^sub>S h)\<^bold>\<rfloor>)"
            using assms tensor_char by simp
         also have "... = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
           using assms Diag_Diagonalize TensorDiag_preserves_Diag Diag_implies_Arr
                 \<F>C.COD_mkarr \<F>C.DOM_mkarr \<F>C.strict_arr_char tensor_char
           by simp
         finally show ?thesis by blast
       qed
     qed
 
     lemma tensor_assoc:
     assumes "arr f" and "arr g" and "arr h"
     shows "(f \<otimes>\<^sub>S g) \<otimes>\<^sub>S h = f \<otimes>\<^sub>S g \<otimes>\<^sub>S h"
       using assms tensor_tensor by presburger
 
     lemma arr_unity:
     shows "arr \<I>"
       using \<F>C.rep_unity \<F>C.Par_Arr_norm \<F>C.\<I>_agreement \<F>C.strict_arr_char by force
 
     lemma tensor_unity_arr:
     assumes "arr f"
     shows "\<I> \<otimes>\<^sub>S f = f"
       using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
       by simp
 
     lemma tensor_arr_unity:
     assumes "arr f"
     shows "f \<otimes>\<^sub>S \<I> = f"
       using assms arr_unity tensor_char \<F>C.strict_arr_char \<F>C.mkarr_Diagonalize_rep
       by simp
 
     lemma assoc_char:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<a>\<^sub>S[a, b, c] = \<F>C.mkarr (\<^bold>\<lfloor>\<F>C.rep a\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep b\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<otimes>\<^bold>\<rfloor> \<^bold>\<lfloor>\<F>C.rep c\<^bold>\<rfloor>)"
       using assms tensor_tensor(2) assoc\<^sub>S_def ideD(1) by simp
 
     lemma assoc_in_hom:
     assumes "ide a" and "ide b" and "ide c"
     shows "\<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
       using assms tensor_preserves_ide ideD tensor_assoc assoc\<^sub>S_def
       by (metis (no_types, lifting) ide_in_hom)
 
     text \<open>The category \<open>\<F>\<^sub>SC\<close> is a monoidal category.\<close>
 
     interpretation EMC: elementary_monoidal_category comp tensor\<^sub>S \<I> \<open>\<lambda>a. a\<close> \<open>\<lambda>a. a\<close> assoc\<^sub>S
     proof
       show "ide \<I>"
         using ide_char arr_char \<F>C.rep_mkarr \<F>C.Dom_norm \<F>C.Cod_norm \<F>C.\<I>_agreement
         by auto
       show "\<And>a. ide a \<Longrightarrow> iso a"
         using ide_char arr_char iso_char by auto
       show "\<And>f a b g c d. \<lbrakk> in_hom a b f; in_hom c d g \<rbrakk> \<Longrightarrow> in_hom (a \<otimes>\<^sub>S c) (b \<otimes>\<^sub>S d) (f \<otimes>\<^sub>S g)"
         using tensor_in_hom by blast
       show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> ide (a \<otimes>\<^sub>S b)"
         using tensor_preserves_ide by blast
       show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> iso \<a>\<^sub>S[a, b, c]"
         using tensor_preserves_ide ide_is_iso assoc\<^sub>S_def by presburger
       show "\<And>a b c. \<lbrakk> ide a; ide b; ide c\<rbrakk> \<Longrightarrow> \<guillemotleft>\<a>\<^sub>S[a, b, c] : (a \<otimes>\<^sub>S b) \<otimes>\<^sub>S c \<rightarrow> a \<otimes>\<^sub>S b \<otimes>\<^sub>S c\<guillemotright>"
         using assoc_in_hom by blast
       show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (a \<otimes>\<^sub>S b) \<cdot>\<^sub>S \<a>\<^sub>S[a, \<I>, b] = a \<otimes>\<^sub>S b"
         using ide_def tensor_unity_arr assoc\<^sub>S_def ideD(1) tensor_preserves_ide comp_ide_self
         by simp
       show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (\<I> \<otimes>\<^sub>S f) = f \<cdot>\<^sub>S dom f"
         using tensor_unity_arr comp_arr_dom comp_cod_arr by presburger
       show "\<And>f. arr f \<Longrightarrow> cod f \<cdot>\<^sub>S (f \<otimes>\<^sub>S \<I>) = f \<cdot>\<^sub>S dom f"
         using tensor_arr_unity comp_arr_dom comp_cod_arr by presburger
       next
       fix a
       assume a: "ide a"
       show "\<guillemotleft>a : \<I> \<otimes>\<^sub>S a \<rightarrow> a\<guillemotright>"
         using a tensor_unity_arr ide_in_hom [of a] by fast
       show "\<guillemotleft>a : a \<otimes>\<^sub>S \<I> \<rightarrow> a\<guillemotright>"
         using a tensor_arr_unity ide_in_hom [of a] by fast
       next
       fix f g f' g'
       assume fg: "seq g f"
       assume fg': "seq g' f'"
       show "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
       proof -
         have A: "\<F>C.seq g f" and B: "\<F>C.seq g' f'"
           using fg fg' seq_char by auto
         have "(g \<otimes>\<^sub>S g') \<cdot>\<^sub>S (f \<otimes>\<^sub>S f') = \<F>C.D ((g \<otimes> g') \<cdot> (f \<otimes> f'))"
           using A B tensor\<^sub>S_def by fastforce
         also have "... = \<F>C.D (g \<cdot> f \<otimes> g' \<cdot> f')"
           using A B \<F>C.interchange \<F>C.T_simp \<F>C.seqE by metis
         also have "... = \<F>C.D (g \<cdot> f) \<otimes>\<^sub>S \<F>C.D (g' \<cdot> f')"
           using A B tensor\<^sub>S_def \<F>C.T_simp \<F>C.seqE \<F>C.diagonalize_tensor arr_char
           by (metis (no_types, lifting) D.preserves_reflects_arr)
         also have "... = \<F>C.D g \<cdot>\<^sub>S \<F>C.D f \<otimes>\<^sub>S \<F>C.D g' \<cdot>\<^sub>S \<F>C.D f'"
           using A B by simp
         also have "... = g \<cdot>\<^sub>S f \<otimes>\<^sub>S g' \<cdot>\<^sub>S f'"
            using fg fg' \<F>C.diagonalize_strict_arr by (elim seqE, simp)
         finally show ?thesis by blast
       qed
       next
       fix f0 f1 f2
       assume f0: "arr f0" and f1: "arr f1" and f2: "arr f2"
       show "\<a>\<^sub>S[cod f0, cod f1, cod f2] \<cdot>\<^sub>S ((f0 \<otimes>\<^sub>S f1) \<otimes>\<^sub>S f2)
               = (f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2) \<cdot>\<^sub>S \<a>\<^sub>S[dom f0, dom f1, dom f2]"
         using f0 f1 f2 assoc\<^sub>S_def tensor_assoc dom_tensor cod_tensor arr_tensor
               comp_cod_arr [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "cod f0 \<otimes>\<^sub>S cod f1 \<otimes>\<^sub>S cod f2"]
               comp_arr_dom [of "f0 \<otimes>\<^sub>S f1 \<otimes>\<^sub>S f2" "dom f0 \<otimes>\<^sub>S dom f1 \<otimes>\<^sub>S dom f2"]
         by presburger
       next
       fix a b c d
       assume a: "ide a" and b: "ide b" and c: "ide c" and d: "ide d"
       show "(a \<otimes>\<^sub>S \<a>\<^sub>S[b, c, d]) \<cdot>\<^sub>S \<a>\<^sub>S[a, b \<otimes>\<^sub>S c, d] \<cdot>\<^sub>S (\<a>\<^sub>S[a, b, c] \<otimes>\<^sub>S d)
                = \<a>\<^sub>S[a, b, c \<otimes>\<^sub>S d] \<cdot>\<^sub>S \<a>\<^sub>S[a \<otimes>\<^sub>S b, c, d]"
         unfolding assoc\<^sub>S_def
         using a b c d tensor_assoc tensor_preserves_ide ideD tensor_in_hom
               comp_arr_dom [of "a \<otimes>\<^sub>S b \<otimes>\<^sub>S c \<otimes>\<^sub>S d"]
         by simp
     qed
 
     lemma is_elementary_monoidal_category:
     shows "elementary_monoidal_category comp tensor\<^sub>S \<I> (\<lambda>a. a) (\<lambda>a. a) assoc\<^sub>S" ..
 
     abbreviation T\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.T"
     abbreviation \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<alpha>"
     abbreviation \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C where "\<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<equiv> EMC.\<iota>"
 
     lemma is_monoidal_category:
     shows "monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C"
       using EMC.induces_monoidal_category by auto
 
   end
 
   sublocale free_strict_monoidal_category \<subseteq>
               elementary_monoidal_category comp tensor\<^sub>S \<I> "\<lambda>a. a" "\<lambda>a. a" assoc\<^sub>S
     using is_elementary_monoidal_category by auto
 
   sublocale free_strict_monoidal_category \<subseteq> monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
     using is_monoidal_category by auto
 
   sublocale free_strict_monoidal_category \<subseteq>
               strict_monoidal_category comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
     using tensor_preserves_ide lunit_agreement runit_agreement \<alpha>_ide_simp assoc\<^sub>S_def
     by unfold_locales auto
 
   context free_strict_monoidal_category
   begin
 
     text \<open>
       The inclusion of generators functor from @{term C} to \<open>\<F>\<^sub>SC\<close> is the composition
       of the inclusion of generators from @{term C} to \<open>\<F>C\<close> and the diagonalization
       functor, which projects \<open>\<F>C\<close> to \<open>\<F>\<^sub>SC\<close>.  As the diagonalization functor
       is the identity map on the image of @{term C}, the composite functor amounts to the
       corestriction to \<open>\<F>\<^sub>SC\<close> of the inclusion of generators of \<open>\<F>C\<close>.
 \<close>
 
     interpretation D: "functor" \<F>C.comp comp \<F>C.D
       using \<F>C.diagonalize_is_functor by auto
 
     interpretation I: composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D
     proof -
       interpret "functor" C \<F>C.comp \<F>C.inclusion_of_generators
         using \<F>C.inclusion_is_functor by blast
       show "composite_functor C \<F>C.comp comp \<F>C.inclusion_of_generators \<F>C.D" ..
     qed
 
     definition inclusion_of_generators
     where "inclusion_of_generators \<equiv> \<F>C.inclusion_of_generators"
 
     lemma inclusion_is_functor:
     shows "functor C comp inclusion_of_generators"
       using \<F>C.DoI_eq_I I.functor_axioms inclusion_of_generators_def
       by auto
 
     text \<open>
       The diagonalization functor is strict monoidal.
 \<close>
 
     interpretation D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                               comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                               \<F>C.D
     proof
       show "\<F>C.D \<F>C.\<iota> = \<iota>"
       proof -
         have "\<F>C.D \<F>C.\<iota> = \<F>C.mkarr \<^bold>\<lfloor>\<F>C.rep \<F>C.\<iota>\<^bold>\<rfloor>"
           unfolding \<F>C.D_def using \<F>C.\<iota>_in_hom by auto
         also have "... = \<F>C.mkarr \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[\<^bold>\<parallel>\<^bold>\<I>\<^bold>\<parallel>\<^bold>]\<^bold>\<rfloor>"
           using \<F>C.\<iota>_def \<F>C.rep_unity \<F>C.rep_lunit \<F>C.Par_Arr_norm \<F>C.Diagonalize_norm
           by auto
         also have "... = \<iota>"
           using \<F>C.unity\<^sub>F\<^sub>M\<^sub>C_def \<F>C.\<I>_agreement \<iota>_def by simp
         finally show ?thesis by blast
       qed
       show "\<And>f g. \<lbrakk> \<F>C.arr f; \<F>C.arr g \<rbrakk> \<Longrightarrow>
                     \<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
       proof -
         fix f g
         assume f: "\<F>C.arr f" and g: "\<F>C.arr g"
         have fg: "arr (\<F>C.D f) \<and> arr (\<F>C.D g)"
           using f g D.preserves_arr by blast
         have "\<F>C.D (\<F>C.tensor f g) = f \<otimes>\<^sub>S g"
           using tensor\<^sub>S_def by simp
         also have "f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
           using f g tensor\<^sub>S_def by simp
         also have "... = \<F>C.D f \<otimes>\<^sub>S \<F>C.D g"
           using f g fg tensor\<^sub>S_def \<F>C.T_simp \<F>C.diagonalize_tensor arr_char
           by (metis (no_types, lifting))
         also have "... = tensor (\<F>C.D f) (\<F>C.D g)"
           using fg T_simp by simp
         finally show "\<F>C.D (\<F>C.tensor f g) = tensor (\<F>C.D f) (\<F>C.D g)"
           by blast
       qed
       show "\<And>a b c. \<lbrakk> \<F>C.ide a; \<F>C.ide b; \<F>C.ide c \<rbrakk> \<Longrightarrow>
                       \<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
       proof -
         fix a b c
         assume a: "\<F>C.ide a" and b: "\<F>C.ide b" and c: "\<F>C.ide c"
         have abc: "ide (\<F>C.D a) \<and> ide (\<F>C.D b) \<and> ide (\<F>C.D c)"
           using a b c D.preserves_ide by blast
         have abc': "\<F>C.ide (\<F>C.D a) \<and> \<F>C.ide (\<F>C.D b) \<and> \<F>C.ide (\<F>C.D c)"
             using a b c D.preserves_ide ide_char by simp
         have 1: "\<And>f g. \<F>C.arr f \<Longrightarrow> \<F>C.arr g \<Longrightarrow> f \<otimes>\<^sub>S g = \<F>C.D (f \<otimes> g)"
           using tensor\<^sub>S_def by simp
         have 2: "\<And>f. ide f \<Longrightarrow> \<F>C.ide f" using ide_char by blast
         have "assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c) = \<F>C.D a \<otimes>\<^sub>S \<F>C.D b \<otimes>\<^sub>S \<F>C.D c"
           using abc \<alpha>_ide_simp assoc\<^sub>S_def by simp
         also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (\<F>C.D b \<otimes> \<F>C.D c)"
           using abc' 1 by auto
         also have "... = \<F>C.D a \<otimes>\<^sub>S \<F>C.D (b \<otimes> c)"
           using b c \<F>C.diagonalize_tensor by force
         also have "... = \<F>C.D (\<F>C.D a \<otimes> \<F>C.D (b \<otimes> c))"
           using 1 b c abc D.preserves_ide \<F>C.tensor_preserves_ide ide_char
           by simp
         also have "... = \<F>C.D (a \<otimes> b \<otimes> c)"
           using a b c \<F>C.diagonalize_tensor by force
         also have "... = \<F>C.D \<a>[a, b, c]"
         proof -
           have "\<F>C.can \<a>[a, b, c]" using a b c \<F>C.can_assoc by simp
           hence "\<F>C.ide (\<F>C.D \<a>[a, b, c])"
             using a b c \<F>C.ide_diagonalize_can by simp
           moreover have "\<F>C.cod (\<F>C.D \<a>[a, b, c]) = \<F>C.D (a \<otimes> b \<otimes> c)"
             using a b c \<F>C.assoc_in_hom D.preserves_hom
             by (metis (no_types, lifting) cod_char in_homE)
           ultimately show ?thesis by simp
         qed
         also have "... = \<F>C.D (\<F>C.assoc a b c)"
           using a b c by simp
         finally show "\<F>C.D (\<F>C.assoc a b c) = assoc (\<F>C.D a) (\<F>C.D b) (\<F>C.D c)"
           by blast
       qed
     qed
 
     lemma diagonalize_is_strict_monoidal_functor:
     shows "strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                    comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                    \<F>C.D"
       ..
 
     interpretation \<phi>: natural_isomorphism
                         \<F>C.CC.comp comp D.T\<^sub>DoFF.map D.FoT\<^sub>C.map D.\<phi>
       using D.structure_is_natural_isomorphism by simp
 
     text \<open>
       The diagonalization functor is part of a monoidal equivalence between the
       free monoidal category and the subcategory @{term "\<F>\<^sub>SC"}.
 \<close>
 
     interpretation E: equivalence_of_categories comp \<F>C.comp \<F>C.D map \<F>C.\<nu> \<F>C.\<mu>
       using \<F>C.is_equivalent_to_strict_subcategory by auto
 
     interpretation D: monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                        comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                        \<F>C.D D.\<phi>
       using D.monoidal_functor_axioms by metis
 
     interpretation equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                                            \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                                            \<F>C.D D.\<phi> \<I>
                                                            map \<F>C.\<nu> \<F>C.\<mu>
        ..
  
     text \<open>
       The category @{term "\<F>C"} is monoidally equivalent to its subcategory @{term "\<F>\<^sub>SC"}.
 \<close>
 
     theorem monoidally_equivalent_to_free_monoidal_category:
     shows "equivalence_of_monoidal_categories comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha>\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<iota>\<^sub>F\<^sub>S\<^sub>M\<^sub>C
                                               \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha>\<^sub>F\<^sub>M\<^sub>C \<F>C.\<iota>\<^sub>F\<^sub>M\<^sub>C
                                               \<F>C.D D.\<phi>
                                               map \<F>C.\<nu> \<F>C.\<mu>"
       ..
 
   end
 
   text \<open>
     We next show that the evaluation functor induced on the free monoidal category
     generated by @{term C} by a functor @{term V} from @{term C} to a strict monoidal
     category @{term D} restricts to a strict monoidal functor on the subcategory @{term "\<F>\<^sub>SC"}.
 \<close>
 
   locale strict_evaluation_functor =
     D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
     evaluation_map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
     \<F>C: free_monoidal_category C +
     E: evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V +
     \<F>\<^sub>SC: free_strict_monoidal_category C
   for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
   and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota>\<^sub>D :: "'d"
   and V :: "'c \<Rightarrow> 'd"
   begin
 
     notation \<F>C.in_hom   ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
     notation \<F>\<^sub>SC.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>S _\<guillemotright>")
 
     (* TODO: This is just the restriction of the evaluation functor to a subcategory.
        It would be useful to define a restriction_of_functor locale that does this in general
        and gives the lemma that it yields a functor. *)
 
     definition map
     where "map \<equiv> \<lambda>f. if \<F>\<^sub>SC.arr f then E.map f else D.null"
 
     interpretation "functor" \<F>\<^sub>SC.comp D map
       unfolding map_def
       apply unfold_locales
           apply simp
       using \<F>\<^sub>SC.arr_char E.preserves_arr
          apply simp
       using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char E.preserves_dom
         apply simp
       using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.cod_char E.preserves_cod
        apply simp
       using \<F>\<^sub>SC.arr_char \<F>\<^sub>SC.dom_char \<F>\<^sub>SC.cod_char \<F>\<^sub>SC.comp_char E.preserves_comp
       by (elim \<F>\<^sub>SC.seqE, auto)
 
     lemma is_functor:
     shows "functor \<F>\<^sub>SC.comp D map" ..
 
     text \<open>
        Every canonical arrow is an equivalence class of canonical terms.
        The evaluations in \<open>D\<close> of all such terms are identities,
        due to the strictness of \<open>D\<close>.
 \<close>
 
     lemma ide_eval_Can:
     shows "Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>"
     proof (induct t)
       show "\<And>x. Can \<^bold>\<langle>x\<^bold>\<rangle> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<langle>x\<^bold>\<rangle>\<rbrace>" by simp
       show "Can \<^bold>\<I> \<Longrightarrow> D.ide \<lbrace>\<^bold>\<I>\<rbrace>" by simp
       show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<otimes> t2) \<rbrakk> \<Longrightarrow>
                      D.ide \<lbrace>t1 \<^bold>\<otimes> t2\<rbrace>"
         by simp
       show "\<And>t1 t2. \<lbrakk> Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>; Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>; Can (t1 \<^bold>\<cdot> t2) \<rbrakk> \<Longrightarrow>
                      D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
       proof -
         fix t1 t2
         assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
         and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
         and t12: "Can (t1 \<^bold>\<cdot> t2)"
         show "D.ide \<lbrace>t1 \<^bold>\<cdot> t2\<rbrace>"
           using t1 t2 t12 Can_implies_Arr eval_in_hom [of t1] eval_in_hom [of t2] D.comp_ide_arr
           by fastforce
       qed
       show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^bold>[t\<^bold>]\<rbrace>"
         using D.strict_lunit by simp
       show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<l>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
         using D.strict_lunit by simp
       show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^bold>[t\<^bold>]\<rbrace>"
         using D.strict_runit by simp
       show "\<And>t. (Can t \<Longrightarrow> D.ide \<lbrace>t\<rbrace>) \<Longrightarrow> Can \<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<r>\<^sup>-\<^sup>1\<^bold>[t\<^bold>]\<rbrace>"
         using D.strict_runit by simp
       fix t1 t2 t3
       assume t1: "Can t1 \<Longrightarrow> D.ide \<lbrace>t1\<rbrace>"
       and t2: "Can t2 \<Longrightarrow> D.ide \<lbrace>t2\<rbrace>"
       and t3: "Can t3 \<Longrightarrow> D.ide \<lbrace>t3\<rbrace>"
       show "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
       proof -
         assume "Can \<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]"
         hence t123: "D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
           using t1 t2 t3 by simp
         have "\<lbrace>\<^bold>\<a>\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
           using t123 D.strict_assoc D.assoc_in_hom [of "\<lbrace>t1\<rbrace>" "\<lbrace>t2\<rbrace>" "\<lbrace>t3\<rbrace>"] apply simp
           by (elim D.in_homE, simp)
         thus ?thesis using t123 by simp
       qed
       show "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>] \<Longrightarrow> D.ide \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>"
       proof -
         assume "Can \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]"
         hence t123: "Can t1 \<and> Can t2 \<and> Can t3 \<and> D.ide \<lbrace>t1\<rbrace> \<and> D.ide \<lbrace>t2\<rbrace> \<and> D.ide \<lbrace>t3\<rbrace>"
           using t1 t2 t3 by simp
         have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace>
                  = D.inv \<a>\<^sub>D[D.cod \<lbrace>t1\<rbrace>, D.cod \<lbrace>t2\<rbrace>, D.cod \<lbrace>t3\<rbrace>] \<cdot>\<^sub>D (\<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>)"
           using t123 eval_Assoc' [of t1 t2 t3] Can_implies_Arr by simp
         also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
         proof -
           have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
           proof -
             have "D.dom \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>] = D.cod \<a>\<^sub>D[\<lbrace>t1\<rbrace>, \<lbrace>t2\<rbrace>, \<lbrace>t3\<rbrace>]"
               using t123 D.strict_assoc by simp
             also have "... = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>"
               using t123 by simp
             finally show ?thesis by blast
           qed
           thus ?thesis
             using t123 D.strict_assoc D.comp_arr_dom by auto
         qed
         finally have "\<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[t1, t2, t3\<^bold>]\<rbrace> = \<lbrace>t1\<rbrace> \<otimes>\<^sub>D \<lbrace>t2\<rbrace> \<otimes>\<^sub>D \<lbrace>t3\<rbrace>" by blast
         thus ?thesis using t123 by auto
       qed
     qed
 
     lemma ide_eval_can:
     assumes "\<F>C.can f"
     shows "D.ide (E.map f)"
     proof -
       have "f = \<F>C.mkarr (\<F>C.rep f)"
         using assms \<F>C.can_implies_arr \<F>C.mkarr_rep by blast
       moreover have 1: "Can (\<F>C.rep f)"
         using assms \<F>C.Can_rep_can by simp
       moreover have "D.ide \<lbrace>\<F>C.rep f\<rbrace>"
         using assms ide_eval_Can by (simp add: 1)
       ultimately show ?thesis using assms \<F>C.can_implies_arr E.map_def by force
     qed
 
     text \<open>
        Diagonalization transports formal arrows naturally along reductions,
        which are canonical terms and therefore evaluate to identities of \<open>D\<close>.
        It follows that the evaluation in \<open>D\<close> of a formal arrow is equal to the
        evaluation of its diagonalization.
 \<close>
 
     lemma map_diagonalize:
     assumes f: "\<F>C.arr f"
     shows "E.map (\<F>C.D f) = E.map f"
     proof -
       interpret EQ: equivalence_of_categories
                       \<F>\<^sub>SC.comp \<F>C.comp \<F>C.D \<F>\<^sub>SC.map \<F>C.\<nu> \<F>C.\<mu>
         using \<F>C.is_equivalent_to_strict_subcategory by auto
       have 1: "\<F>C.seq (\<F>\<^sub>SC.map (\<F>C.D f)) (\<F>C.\<nu> (\<F>C.dom f))"
       proof
         show "\<guillemotleft>\<F>C.\<nu> (\<F>C.dom f) : \<F>C.dom f \<rightarrow> \<F>C.D (\<F>C.dom f)\<guillemotright>"
           using f \<F>\<^sub>SC.map_simp EQ.F.preserves_arr
           by (intro \<F>C.in_homI, simp_all)
         show "\<guillemotleft>\<F>\<^sub>SC.map (\<F>C.D f) : \<F>C.D (\<F>C.dom f) \<rightarrow> \<F>C.cod (\<F>C.D f)\<guillemotright>"
-          using f \<F>\<^sub>SC.map_simp \<F>C.arr_iff_in_hom EQ.F.preserves_hom \<F>\<^sub>SC.arr_char
-                \<F>\<^sub>SC.in_hom_char [of "\<F>C.D f" "\<F>C.D (\<F>C.dom f)" "\<F>C.D (\<F>C.cod f)"]
-          by (intro \<F>C.in_homI, auto)
+          by (metis (no_types, lifting) EQ.F.preserves_dom EQ.F.preserves_reflects_arr
+              \<F>\<^sub>SC.arr_iff_in_hom \<F>\<^sub>SC.cod_simp \<F>\<^sub>SC.in_hom_char \<F>\<^sub>SC.map_simp f)
       qed
       have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f =
             E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
       proof -
         have "E.map (\<F>C.\<nu> (\<F>C.cod f)) \<cdot>\<^sub>D E.map f = E.map (\<F>C.\<nu> (\<F>C.cod f) \<cdot> f)"
           using f by simp
         also have "... = E.map (\<F>C.D f \<cdot> \<F>C.\<nu> (\<F>C.dom f))"
           using f EQ.\<eta>.naturality \<F>\<^sub>SC.map_simp EQ.F.preserves_arr by simp
         also have "... = E.map (\<F>\<^sub>SC.map (\<F>C.D f)) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
           using f 1 E.as_nat_trans.preserves_comp_2 EQ.F.preserves_arr \<F>\<^sub>SC.map_simp
           by (metis (no_types, lifting))
         also have "... = E.map (\<F>C.D f) \<cdot>\<^sub>D E.map (\<F>C.\<nu> (\<F>C.dom f))"
           using f EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by simp
         finally show ?thesis by blast
       qed
       moreover have "\<And>a. \<F>C.ide a \<Longrightarrow> D.ide (E.map (\<F>C.\<nu> a))"
         using \<F>C.\<nu>_def \<F>C.Arr_rep Arr_implies_Ide_Cod Can_red \<F>C.can_mkarr_Can
               ide_eval_can
         by (metis (no_types, lifting) EQ.\<eta>.preserves_reflects_arr \<F>C.seqE
             \<F>C.comp_preserves_can \<F>C.ideD(1) \<F>C.ide_implies_can)
       moreover have "D.cod (E.map f) = D.dom (E.map (\<F>C.\<nu> (\<F>C.cod f)))"
         using f E.preserves_hom EQ.\<eta>.preserves_hom by simp
       moreover have "D.dom (E.map (\<F>C.D f)) = D.cod (E.map (\<F>C.\<nu> (\<F>C.dom f)))"
           using f 1 E.preserves_seq EQ.F.preserves_arr \<F>\<^sub>SC.map_simp by auto
       ultimately show ?thesis
         using f D.comp_arr_dom D.ideD D.arr_dom_iff_arr E.as_nat_trans.is_natural_2
         by (metis E.preserves_cod \<F>C.ide_cod \<F>C.ide_dom)
     qed
 
     lemma strictly_preserves_tensor:
     assumes "\<F>\<^sub>SC.arr f" and "\<F>\<^sub>SC.arr g"
     shows "map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
     proof -
       have 1: "\<F>C.arr (f \<otimes> g)"
         using assms \<F>\<^sub>SC.arr_char \<F>C.tensor_in_hom by auto
       have 2: "\<F>\<^sub>SC.arr (\<F>\<^sub>SC.tensor f g)"
         using assms \<F>\<^sub>SC.tensor_in_hom [of f g] \<F>\<^sub>SC.T_simp by fastforce
       have "map (\<F>\<^sub>SC.tensor f g) = E.map (f \<otimes> g)"
       proof -
         have "map (\<F>\<^sub>SC.tensor f g) = map (f \<otimes>\<^sub>S g)"
           using assms \<F>\<^sub>SC.T_simp by simp
         also have "... = map (\<F>C.D (f \<otimes> g))"
           using assms \<F>C.tensor\<^sub>F\<^sub>M\<^sub>C_def \<F>\<^sub>SC.tensor\<^sub>S_def \<F>\<^sub>SC.arr_char by force
         also have "... = E.map (f \<otimes> g)"
         proof -
           interpret Diag: "functor" \<F>C.comp \<F>\<^sub>SC.comp \<F>C.D
             using \<F>C.diagonalize_is_functor by auto
           show ?thesis
             using assms 1 map_diagonalize [of "f \<otimes> g"] Diag.preserves_arr map_def by simp
         qed
         finally show ?thesis by blast
       qed
       thus ?thesis
         using assms \<F>\<^sub>SC.arr_char E.strictly_preserves_tensor map_def by simp
     qed
 
     lemma is_strict_monoidal_functor:
     shows "strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map"
     proof
       show "\<And>f g. \<F>\<^sub>SC.arr f \<Longrightarrow> \<F>\<^sub>SC.arr g \<Longrightarrow> map (\<F>\<^sub>SC.tensor f g) = map f \<otimes>\<^sub>D map g"
         using strictly_preserves_tensor by fast
       show "map \<F>\<^sub>SC.\<iota> = \<iota>\<^sub>D"
         using \<F>\<^sub>SC.arr_unity \<F>\<^sub>SC.\<iota>_def map_def E.map_def \<F>C.rep_mkarr E.eval_norm D.strict_unit
         by auto
       fix a b c
       assume a: "\<F>\<^sub>SC.ide a" and b: "\<F>\<^sub>SC.ide b" and c: "\<F>\<^sub>SC.ide c"
       show "map (\<F>\<^sub>SC.assoc a b c) = \<a>\<^sub>D[map a, map b, map c]"
       proof -
         have "map (\<F>\<^sub>SC.assoc a b c) = map a \<otimes>\<^sub>D map b \<otimes>\<^sub>D map c"
           using a b c \<F>\<^sub>SC.\<alpha>_def \<F>\<^sub>SC.assoc\<^sub>S_def \<F>\<^sub>SC.arr_tensor \<F>\<^sub>SC.T_simp \<F>\<^sub>SC.ideD(1)
                 strictly_preserves_tensor \<F>\<^sub>SC.\<alpha>_ide_simp
           by presburger
         also have "... = \<a>\<^sub>D[map a, map b, map c]"
           using a b c D.strict_assoc D.assoc_in_hom [of "map a" "map b" "map c"] by auto
         finally show ?thesis by blast
       qed
     qed
 
   end
 
   sublocale strict_evaluation_functor \<subseteq>
               strict_monoidal_functor \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D map
     using is_strict_monoidal_functor by auto
 
   locale strict_monoidal_extension_to_free_strict_monoidal_category =
     C: category C +
     monoidal_language C +
     \<F>\<^sub>SC: free_strict_monoidal_category C +
     strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                 \<F>\<^sub>SC.inclusion_of_generators V F
   for C :: "'c comp"      (infixr "\<cdot>\<^sub>C" 55)
   and D :: "'d comp"      (infixr "\<cdot>\<^sub>D" 55)
   and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
   and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
   and \<iota>\<^sub>D :: "'d"
   and V :: "'c \<Rightarrow> 'd"
   and F :: "'c free_monoidal_category.arr \<Rightarrow> 'd"
 
   sublocale strict_evaluation_functor \<subseteq>
               strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                           \<F>\<^sub>SC.inclusion_of_generators V map
   proof -
     interpret V: "functor" C \<F>\<^sub>SC.comp \<F>\<^sub>SC.inclusion_of_generators
       using \<F>\<^sub>SC.inclusion_is_functor by auto
     show "strict_monoidal_extension C \<F>\<^sub>SC.comp \<F>\<^sub>SC.T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<F>\<^sub>SC.\<alpha> \<F>\<^sub>SC.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
                                     \<F>\<^sub>SC.inclusion_of_generators V map"
     proof
       show "\<forall>f. C.arr f \<longrightarrow> map (\<F>\<^sub>SC.inclusion_of_generators f) = V f"
         using V.preserves_arr E.is_extension map_def \<F>\<^sub>SC.inclusion_of_generators_def by simp
     qed
   qed
 
   context free_strict_monoidal_category
   begin
 
     text \<open>
       We now have the main result of this section: the evaluation functor on \<open>\<F>\<^sub>SC\<close>
       induced by a functor @{term V} from @{term C} to a strict monoidal category @{term D}
       is the unique strict monoidal extension of @{term V} to \<open>\<F>\<^sub>SC\<close>.
 \<close>
 
     theorem is_free:
     assumes "strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D"
     and "strict_monoidal_extension_to_free_strict_monoidal_category C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F"
     shows "F = strict_evaluation_functor.map C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V"
     proof -
       interpret D: strict_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D
         using assms(1) by auto
 
       text \<open>
         Let @{term F} be a given extension of V to a strict monoidal functor defined on
         \<open>\<F>\<^sub>SC\<close>.
 \<close>
       interpret F: strict_monoidal_extension_to_free_strict_monoidal_category
                      C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V F
         using assms(2) by auto
 
       text \<open>
         Let @{term E\<^sub>S} be the evaluation functor from \<open>\<F>\<^sub>SC\<close> to @{term D}
         induced by @{term V}.  Then @{term E\<^sub>S} is also a strict monoidal extension of @{term V}.
 \<close>
       interpret E\<^sub>S: strict_evaluation_functor C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V ..
 
       text \<open>
         Let @{term D} be the strict monoidal functor @{term "\<F>C.D"} that projects
         \<open>\<F>C\<close> to the subcategory \<open>\<F>\<^sub>SC\<close>.
 \<close>
       interpret D: "functor" \<F>C.comp comp \<F>C.D
         using \<F>C.diagonalize_is_functor by auto
       interpret D: strict_monoidal_functor \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota>
                                            comp T\<^sub>F\<^sub>S\<^sub>M\<^sub>C \<alpha> \<iota>
                                            \<F>C.D
         using diagonalize_is_strict_monoidal_functor by blast
 
       text \<open>
          The composite functor \<open>F o D\<close> is also an extension of @{term V}
          to a strict monoidal functor on \<open>\<F>C\<close>.
 \<close>
       interpret FoD: composite_functor \<F>C.comp comp D \<F>C.D F ..
       interpret FoD: strict_monoidal_functor
                        \<F>C.comp \<F>C.T\<^sub>F\<^sub>M\<^sub>C \<F>C.\<alpha> \<F>C.\<iota> D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<open>F o \<F>C.D\<close>
         using D.strict_monoidal_functor_axioms F.strict_monoidal_functor_axioms
               strict_monoidal_functors_compose
         by fast
       interpret FoD: strict_monoidal_extension_to_free_monoidal_category
                        C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D V FoD.map
       proof
         show "\<forall>f. C.arr f \<longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
         proof -
           have "\<And>f. C.arr f \<Longrightarrow> FoD.map (\<F>C.inclusion_of_generators f) = V f"
           proof -
             fix f
             assume f: "C.arr f"
             have "FoD.map (\<F>C.inclusion_of_generators f)
                     = F (\<F>C.D (\<F>C.inclusion_of_generators f))"
               using f by simp
             also have "... = F (inclusion_of_generators f)"
               using f \<F>C.strict_arr_char' F.I.preserves_arr inclusion_of_generators_def by simp
             also have "... = V f"
               using f F.is_extension by simp
             finally show "FoD.map (\<F>C.inclusion_of_generators f) = V f"
               by blast
           qed
           thus ?thesis by blast
         qed
       qed
 
       text \<open>
          By the freeness of \<open>\<F>C\<close>, we have that \<open>F o D\<close>
          is equal to the evaluation functor @{term "E\<^sub>S.E.map"} induced by @{term V}
          on \<open>\<F>C\<close>.  Moreover, @{term E\<^sub>S.map} coincides with @{term "E\<^sub>S.E.map"} on
          \<open>\<F>\<^sub>SC\<close> and \<open>F o D\<close> coincides with @{term F} on
          \<open>\<F>\<^sub>SC\<close>.  Therefore, @{term F} coincides with @{term E} on their common
          domain \<open>\<F>\<^sub>SC\<close>, showing @{term "F = E\<^sub>S.map"}.
 \<close>
       have "\<And>f. arr f \<Longrightarrow> F f = E\<^sub>S.map f"
         using \<F>C.strict_arr_char' \<F>C.is_free [of D] E\<^sub>S.E.evaluation_functor_axioms
               FoD.strict_monoidal_extension_to_free_monoidal_category_axioms E\<^sub>S.map_def
         by simp
       moreover have "\<And>f. \<not>arr f \<Longrightarrow> F f = E\<^sub>S.map f"
         using F.is_extensional E\<^sub>S.is_extensional arr_char by auto
       ultimately show "F = E\<^sub>S.map" by blast
     qed
 
   end
 
 end