Theory CZH_ECAT_PCategory

(* Copyright 2021 (C) Mihails Milehins *)

section‹Product category›
theory CZH_ECAT_PCategory
  imports 
    CZH_ECAT_NTCF
    CZH_ECAT_Small_Category
    CZH_Foundations.CZH_SMC_PSemicategory
begin



subsection‹Background›


text‹See Chapter II-3 in cite‹"mac_lane_categories_2010"›.›

named_theorems cat_prod_cs_simps
named_theorems cat_prod_cs_intros



subsection‹Product category: definition and elementary properties› 

definition cat_prod :: "V ⇒ (V ⇒ V) ⇒ V" 
  where "cat_prod I 𝔄 =
    [
      (∏∘i∈∘I. 𝔄 i⦇Obj⦈),
      (∏∘i∈∘I. 𝔄 i⦇Arr⦈),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)),
      (
        λgf∈∘composable_arrs (dg_prod I 𝔄).
          (λi∈∘I. vpfst gf⦇i⦈ ∘A⇘𝔄 i⇙ vpsnd gf⦇i⦈)
      ),
      (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). (λi∈∘I. 𝔄 i⦇CId⦈⦇a⦇i⦈⦈))
    ]∘"

syntax "_PCATEGORY" :: "pttrn ⇒ V ⇒ (V ⇒ V) ⇒ V" 
  ("(3∏C_∈∘_./ _)" [0, 0, 10] 10)
translations "∏Ci∈∘I. 𝔄" ⇌ "CONST cat_prod I (λi. 𝔄)"


text‹Components.›

lemma cat_prod_components:
  shows "(∏Ci∈∘I. 𝔄 i)⦇Obj⦈ = (∏∘i∈∘I. 𝔄 i⦇Obj⦈)"
    and "(∏Ci∈∘I. 𝔄 i)⦇Arr⦈ = (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
    and "(∏Ci∈∘I. 𝔄 i)⦇Dom⦈ =
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈))"
    and "(∏Ci∈∘I. 𝔄 i)⦇Cod⦈ =
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))"
    and "(∏Ci∈∘I. 𝔄 i)⦇Comp⦈ =
      (
        λgf∈∘composable_arrs (dg_prod I 𝔄).
          (λi∈∘I. vpfst gf⦇i⦈ ∘A⇘𝔄 i⇙ vpsnd gf⦇i⦈)
      )"
    and "(∏Ci∈∘I. 𝔄 i)⦇CId⦈ =
      (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). (λi∈∘I. 𝔄 i⦇CId⦈⦇a⦇i⦈⦈))"
  unfolding cat_prod_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma cat_smc_cat_prod[slicing_commute]: 
  "smc_prod I (λi. cat_smc (𝔄 i)) = cat_smc (∏Ci∈∘I. 𝔄 i)"
  unfolding dg_prod_def cat_smc_def cat_prod_def smc_prod_def dg_field_simps
  by (simp_all add: nat_omega_simps)

context
  fixes 𝔄 φ :: "V ⇒ V"
    and ℭ :: V
begin

lemmas_with [
  where 𝔄=‹λi. cat_smc (𝔄 i)›, unfolded slicing_simps slicing_commute
  ]:
  cat_prod_ObjI = smc_prod_ObjI
  and cat_prod_ObjD = smc_prod_ObjD
  and cat_prod_ObjE = smc_prod_ObjE
  and cat_prod_Obj_cong = smc_prod_Obj_cong
  and cat_prod_ArrI = smc_prod_ArrI
  and cat_prod_ArrD = smc_prod_ArrD
  and cat_prod_ArrE = smc_prod_ArrE
  and cat_prod_Arr_cong = smc_prod_Arr_cong
  and cat_prod_Dom_vsv[cat_cs_intros] = smc_prod_Dom_vsv
  and cat_prod_Dom_vdomain[cat_cs_simps] = smc_prod_Dom_vdomain
  and cat_prod_Dom_app = smc_prod_Dom_app
  and cat_prod_Dom_app_component_app[cat_cs_simps] = 
    smc_prod_Dom_app_component_app
  and cat_prod_Cod_vsv[cat_cs_intros] = smc_prod_Cod_vsv
  and cat_prod_Cod_app = smc_prod_Cod_app
  and cat_prod_Cod_vdomain[cat_cs_simps] = smc_prod_Cod_vdomain
  and cat_prod_Cod_app_component_app[cat_cs_simps] = 
    smc_prod_Cod_app_component_app
  and cat_prod_Comp = smc_prod_Comp
  and cat_prod_Comp_vdomain[cat_cs_simps] = smc_prod_Comp_vdomain
  and cat_prod_Comp_app = smc_prod_Comp_app
  and cat_prod_Comp_app_component[cat_cs_simps] = 
    smc_prod_Comp_app_component
  and cat_prod_Comp_app_vdomain = smc_prod_Comp_app_vdomain
  and cat_prod_vunion_Obj_in_Obj = smc_prod_vunion_Obj_in_Obj
  and cat_prod_vdiff_vunion_Obj_in_Obj = smc_prod_vdiff_vunion_Obj_in_Obj
  and cat_prod_vunion_Arr_in_Arr = smc_prod_vunion_Arr_in_Arr
  and cat_prod_vdiff_vunion_Arr_in_Arr = smc_prod_vdiff_vunion_Arr_in_Arr

end



subsection‹Local assumptions for a product category›

locale pcategory_base = 𝒵 α for α I 𝔄 +
  assumes pcat_categories: "i ∈∘ I ⟹ category α (𝔄 i)"
    and pcat_index_in_Vset[cat_cs_intros]: "I ∈∘ Vset α"

lemma (in pcategory_base) pcat_categories'[cat_prod_cs_intros]:
  assumes "i ∈∘ I" and "α' = α"
  shows "category α' (𝔄 i)" 
  using assms(1) unfolding assms(2) by (rule pcat_categories)


text‹Rules.›

lemma (in pcategory_base) pcategory_base_axioms'[cat_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "pcategory_base α' I' 𝔄"
  unfolding assms by (rule pcategory_base_axioms)

mk_ide rf pcategory_base_def[unfolded pcategory_base_axioms_def]
  |intro pcategory_baseI|
  |dest pcategory_baseD[dest]|
  |elim pcategory_baseE[elim]|

lemma pcategory_base_psemicategory_baseI:
  assumes "psemicategory_base α I (λi. cat_smc (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ category α (𝔄 i)"
  shows "pcategory_base α I 𝔄"
proof-
  interpret psemicategory_base α I ‹λi. cat_smc (𝔄 i)› by (rule assms(1))
  show ?thesis
    by (intro pcategory_baseI)
      (auto simp: assms(2) psmc_index_in_Vset psmc_Obj_in_Vset psmc_Arr_in_Vset) 
qed


text‹Product category is a product semicategory.›

context pcategory_base
begin

lemma pcat_psemicategory_base: "psemicategory_base α I (λi. cat_smc (𝔄 i))"
proof(intro psemicategory_baseI)
  from pcat_index_in_Vset show "I ∈∘ Vset α" by auto
qed (auto simp: category.cat_semicategory cat_prod_cs_intros)

interpretation psmc: psemicategory_base α I ‹λi. cat_smc (𝔄 i)› 
  by (rule pcat_psemicategory_base)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  pcat_Obj_in_Vset = psmc.psmc_Obj_in_Vset
  and pcat_Arr_in_Vset = psmc.psmc_Arr_in_Vset
  and pcat_smc_prod_Obj_in_Vset = psmc.psmc_smc_prod_Obj_in_Vset
  and pcat_smc_prod_Arr_in_Vset = psmc.psmc_smc_prod_Arr_in_Vset
  and cat_prod_Dom_app_in_Obj[cat_cs_intros] = psmc.smc_prod_Dom_app_in_Obj
  and cat_prod_Cod_app_in_Obj[cat_cs_intros] = psmc.smc_prod_Cod_app_in_Obj
  and cat_prod_is_arrI = psmc.smc_prod_is_arrI
  and cat_prod_is_arrD[dest] = psmc.smc_prod_is_arrD
  and cat_prod_is_arrE[elim] = psmc.smc_prod_is_arrE

end

lemma cat_prod_dg_prod_is_arr: 
  "g : b ↦⇘dg_prod I 𝔄⇙ c ⟷ g : b ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ c"
  unfolding is_arr_def cat_prod_def smc_prod_def dg_prod_def dg_field_simps
  by (simp add: nat_omega_simps)

lemma smc_prod_composable_arrs_dg_prod:
  "composable_arrs (dg_prod I 𝔄) = composable_arrs (∏Ci∈∘I. 𝔄 i)"
  unfolding composable_arrs_def cat_prod_dg_prod_is_arr by simp


text‹Elementary properties.›

lemma (in pcategory_base) pcat_vsubset_index_pcategory_base:
  assumes "J ⊆∘ I"
  shows "pcategory_base α J 𝔄"
proof(intro pcategory_baseI)
  show "category α (𝔄 i)" if "i ∈∘ J" for i 
    using that assms by (auto intro: cat_prod_cs_intros)
  from assms show "J ∈∘ Vset α" by (simp add: vsubset_in_VsetI cat_cs_intros)
qed auto


subsubsection‹Identity›

lemma cat_prod_CId_vsv[cat_cs_intros]: "vsv ((∏Ci∈∘I. 𝔄 i)⦇CId⦈)"
  unfolding cat_prod_components by auto

lemma cat_prod_CId_vdomain[cat_cs_simps]: 
  "𝒟∘ ((∏Ci∈∘I. 𝔄 i)⦇CId⦈) = (∏Ci∈∘I. 𝔄 i)⦇Obj⦈" 
  unfolding cat_prod_components by simp

lemma cat_prod_CId_app: 
  assumes "a ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈"
  shows "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇a⦈ = (λi∈∘I. 𝔄 i⦇CId⦈⦇a⦇i⦈⦈)" 
  using assms unfolding cat_prod_components by simp

lemma cat_prod_CId_app_component[cat_cs_simps]: 
  assumes "a ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈" and "i ∈∘ I"
  shows "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇a⦈⦇i⦈ = 𝔄 i⦇CId⦈⦇a⦇i⦈⦈" 
  using assms unfolding cat_prod_components by simp

lemma (in pcategory_base) cat_prod_CId_vrange: 
  "ℛ∘ ((∏Ci∈∘I. 𝔄 i)⦇CId⦈) ⊆∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)" 
proof(intro vsubsetI)
  interpret CId: vsv ‹((∏Ci∈∘I. 𝔄 i)⦇CId⦈)› by (rule cat_prod_CId_vsv)
  fix f assume "f ∈∘ ℛ∘ ((∏Ci∈∘I. 𝔄 i)⦇CId⦈)"
  then obtain a where f_def: "f = ((∏Ci∈∘I. 𝔄 i)⦇CId⦈)⦇a⦈" 
    and "a ∈∘ 𝒟∘ ((∏Ci∈∘I. 𝔄 i)⦇CId⦈)"
    by (blast dest: CId.vrange_atD)
  then have a: "a ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈" 
    unfolding cat_prod_components by simp
  show "f ∈∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
    unfolding f_def cat_prod_CId_app[OF a]
  proof(rule VLambda_in_vproduct)
    fix i assume prems: "i ∈∘ I"
    interpret 𝔄: category α ‹𝔄 i› 
      by (simp add: ‹i ∈∘ I› cat_cs_intros cat_prod_cs_intros)
    from prems a have "a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈" unfolding cat_prod_components by auto
    with is_arrD(1) show "𝔄 i⦇CId⦈⦇a⦇i⦈⦈ ∈∘ 𝔄 i⦇Arr⦈" 
      by (auto intro: cat_cs_intros)
  qed
qed


subsubsection‹A product ‹α›-category is a tiny ‹β›-category›

lemma (in pcategory_base) pcat_tiny_category_cat_prod:
  assumes "𝒵 β" and "α ∈∘ β" 
  shows "tiny_category β (∏Ci∈∘I. 𝔄 i)"
proof-

  interpret β: 𝒵 β by (rule assms(1))

  show ?thesis
  proof(intro tiny_categoryI, (unfold slicing_simps)?)
  
    show Π: "tiny_semicategory β (cat_smc (∏Ci∈∘I. 𝔄 i))"
      unfolding slicing_commute[symmetric]
      by 
        (
          intro psemicategory_base.psmc_tiny_semicategory_smc_prod; 
          (rule assms pcat_psemicategory_base)?
        )
    interpret Π: tiny_semicategory β ‹cat_smc (∏Ci∈∘I. 𝔄 i)› by (rule Π)
  
    show "vfsequence (∏Ci∈∘I. 𝔄 i)" unfolding cat_prod_def by auto
    show "vcard (∏Ci∈∘I. 𝔄 i) = 6ℕ"
      unfolding cat_prod_def by (simp add: nat_omega_simps)
  
    show CId: "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇a⦈ : a ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ a"
      if a: "a ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈" for a
    proof(rule cat_prod_is_arrI)
      have [cat_cs_intros]: "a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈" if i: "i ∈∘ I" for i
        by (rule cat_prod_ObjD(3)[OF a i])
      from that show "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇a⦈⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ a⦇i⦈"
        if "i ∈∘ I" for i
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps 
              cs_intro: cat_cs_intros cat_prod_cs_intros that
          )
    qed (use that in ‹auto simp: cat_prod_components cat_prod_CId_app that›)
  
    show "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ f = f"
      if "f : a ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ b" for f a b
    proof(rule cat_prod_Arr_cong)
      note f = Π.smc_is_arrD[unfolded slicing_simps, OF that]
      note a = f(2) and b = f(3) and f = f(1)
      from CId[OF b] have CId_b: 
        "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ : b ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ b"
        by simp
      from Π.smc_Comp_is_arr[unfolded slicing_simps, OF this that] show 
        "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ f ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈"
        by (simp add: cat_cs_intros)
      from that show "f ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈" by auto
      fix i assume prems: "i ∈∘ I"
      interpret 𝔄i: category α ‹𝔄 i› by (simp add: prems cat_prod_cs_intros)
      from prems cat_prod_is_arrD(7)[OF that] have fi: 
        "f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈" 
        by auto
      from prems show "((∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ f)⦇i⦈ = f⦇i⦈"
        unfolding cat_prod_Comp_app_component[OF CId_b that prems]
        unfolding cat_prod_CId_app[OF b]
        by (auto intro: 𝔄i.cat_CId_left_left[OF fi])
    qed

    show "f ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ = f"
      if "f : b ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ c" for f b c
    proof(rule cat_prod_Arr_cong)
      note f = Π.smc_is_arrD[unfolded slicing_simps, OF that]
      note b = f(2) and c = f(3) and f = f(1)
      from CId[OF b] have CId_b: 
        "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ : b ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ b"
        by simp
      from Π.smc_Comp_is_arr[unfolded slicing_simps, OF that this] show 
        "f ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈ ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈"
        by (simp add: cat_cs_intros)
      from that show "f ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈" by auto
      fix i assume prems: "i ∈∘ I"
      interpret 𝔄i: category α ‹𝔄 i› by (simp add: prems cat_prod_cs_intros)
      from prems cat_prod_is_arrD[OF that] have fi: "f⦇i⦈ : b⦇i⦈ ↦⇘𝔄 i⇙ c⦇i⦈"
        by simp
      from prems show "(f ∘A⇘(∏Ci∈∘I. 𝔄 i)⇙ (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇b⦈)⦇i⦈ = f⦇i⦈"
        unfolding cat_prod_Comp_app_component[OF that CId_b prems]
        unfolding cat_prod_CId_app[OF b]
        by (auto intro: 𝔄i.cat_CId_right_left[OF fi])
    qed
  
  qed (auto simp: cat_cs_intros cat_cs_simps intro: cat_cs_intros)

qed



subsection‹Further local assumptions for product categories›


subsubsection‹Definition and elementary properties›

locale pcategory = pcategory_base α I 𝔄 for α I 𝔄 +
  assumes pcat_Obj_vsubset_Vset: "J ⊆∘ I ⟹ (∏Ci∈∘J. 𝔄 i)⦇Obj⦈ ⊆∘ Vset α"
    and pcat_Hom_vifunion_in_Vset: 
      "⟦
        J ⊆∘ I;
        A ⊆∘ (∏Ci∈∘J. 𝔄 i)⦇Obj⦈;
        B ⊆∘ (∏Ci∈∘J. 𝔄 i)⦇Obj⦈;
        A ∈∘ Vset α;
        B ∈∘ Vset α
      ⟧ ⟹ (⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏Ci∈∘J. 𝔄 i) a b) ∈∘ Vset α"


text‹Rules.›

lemma (in pcategory) pcategory_axioms'[cat_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "pcategory α' I' 𝔄"
  unfolding assms by (rule pcategory_axioms)

mk_ide rf pcategory_def[unfolded pcategory_axioms_def]
  |intro pcategoryI|
  |dest pcategoryD[dest]|
  |elim pcategoryE[elim]|

lemmas [cat_prod_cs_intros] = pcategoryD(1)

lemma pcategory_psemicategoryI:
  assumes "psemicategory α I (λi. cat_smc (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ category α (𝔄 i)"
  shows "pcategory α I 𝔄"
proof-
  interpret psemicategory α I ‹λi. cat_smc (𝔄 i)› by (rule assms(1))
  note [unfolded slicing_simps slicing_commute, cat_cs_intros] = 
    psmc_Obj_vsubset_Vset
    psmc_Hom_vifunion_in_Vset
  show ?thesis
    by (intro pcategoryI pcategory_base_psemicategory_baseI)
      (auto simp: assms(2) smc_prod_cs_intros intro!: cat_cs_intros)
qed


text‹Product category is a product semicategory.›

context pcategory
begin

lemma pcat_psemicategory: "psemicategory α I (λi. cat_smc (𝔄 i))"
proof(intro psemicategoryI, unfold slicing_simps slicing_commute)
  show "psemicategory_base α I (λi. cat_smc (𝔄 i))" 
    by (rule pcat_psemicategory_base)
qed (auto intro!: pcat_Obj_vsubset_Vset pcat_Hom_vifunion_in_Vset)

interpretation psmc: psemicategory α I ‹λi. cat_smc (𝔄 i)› 
  by (rule pcat_psemicategory)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  pcat_Obj_vsubset_Vset' = psmc.psmc_Obj_vsubset_Vset'
  and pcat_Hom_vifunion_in_Vset' = psmc.psmc_Hom_vifunion_in_Vset'
  and pcat_cat_prod_vunion_is_arr = psmc.psmc_smc_prod_vunion_is_arr
  and pcat_cat_prod_vdiff_vunion_is_arr = psmc.psmc_smc_prod_vdiff_vunion_is_arr

lemmas_with [unfolded slicing_simps slicing_commute]: 
  pcat_cat_prod_vunion_Comp = psmc.psmc_smc_prod_vunion_Comp
  and pcat_cat_prod_vdiff_vunion_Comp = psmc.psmc_smc_prod_vdiff_vunion_Comp

end


text‹Elementary properties.›

lemma (in pcategory) pcat_vsubset_index_pcategory:
  assumes "J ⊆∘ I"
  shows "pcategory α J 𝔄"
proof(intro pcategoryI pcategory_psemicategoryI)
  show "cat_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" if ‹J' ⊆∘ J› for J'
  proof-
    from that assms have "J' ⊆∘ I" by simp
    then show "cat_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" by (rule pcat_Obj_vsubset_Vset)
  qed
  fix A B J' assume prems:
    "J' ⊆∘ J"
    "A ⊆∘ (∏Ci∈∘J'. 𝔄 i)⦇Obj⦈"
    "B ⊆∘ (∏Ci∈∘J'. 𝔄 i)⦇Obj⦈"
    "A ∈∘ Vset α" 
    "B ∈∘ Vset α"
  show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏Ci∈∘J'. 𝔄 i) a b) ∈∘ Vset α"
  proof-
    from prems(1) assms have "J' ⊆∘ I" by simp
    from pcat_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
  qed
  
qed (rule pcat_vsubset_index_pcategory_base[OF assms])


subsubsection‹A product ‹α›-category is an ‹α›-category›

lemma (in pcategory) pcat_category_cat_prod: "category α (∏Ci∈∘I. 𝔄 i)"
proof-
  interpret tiny_category ‹α + ω› ‹∏Ci∈∘I. 𝔄 i›
    by (intro pcat_tiny_category_cat_prod) 
      (auto simp: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
  show ?thesis
    by (rule category_if_category)  
      (
        auto 
          intro!: pcat_Hom_vifunion_in_Vset pcat_Obj_vsubset_Vset
          intro: cat_cs_intros
      )
qed



subsection‹Local assumptions for a finite product category›


subsubsection‹Definition and elementary properties›

locale finite_pcategory = pcategory_base α I 𝔄 for α I 𝔄 +
  assumes fin_pcat_index_vfinite: "vfinite I"


text‹Rules.›

lemma (in finite_pcategory) finite_pcategory_axioms[cat_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "finite_pcategory α' I' 𝔄"
  unfolding assms by (rule finite_pcategory_axioms)

mk_ide rf finite_pcategory_def[unfolded finite_pcategory_axioms_def]
  |intro finite_pcategoryI|
  |dest finite_pcategoryD[dest]|
  |elim finite_pcategoryE[elim]|

lemmas [cat_prod_cs_intros] = finite_pcategoryD(1)

lemma finite_pcategory_finite_psemicategoryI:
  assumes "finite_psemicategory α I (λi. cat_smc (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ category α (𝔄 i)"
  shows "finite_pcategory α I 𝔄"
proof-
  interpret finite_psemicategory α I ‹λi. cat_smc (𝔄 i)› by (rule assms(1))
  show ?thesis
    by 
      (
        intro 
          assms
          finite_pcategoryI 
          pcategory_base_psemicategory_baseI 
          finite_psemicategoryD(1)[OF assms(1)]
          fin_psmc_index_vfinite
      )
qed


subsubsection‹
Local assumptions for a finite product semicategory and local
assumptions for an arbitrary product semicategory
›

sublocale finite_pcategory ⊆ pcategory α I 𝔄
proof-
  interpret finite_psemicategory α I ‹λi. cat_smc (𝔄 i)›
  proof(intro finite_psemicategoryI psemicategory_baseI)
    fix i assume "i ∈∘ I"
    then interpret 𝔄i: category α ‹𝔄 i› by (simp add: pcat_categories)
    show "semicategory α (cat_smc (𝔄 i))" by (simp add: 𝔄i.cat_semicategory)
  qed (auto intro!: cat_cs_intros fin_pcat_index_vfinite)
  show "pcategory α I 𝔄"
    by (intro pcategory_psemicategoryI) 
      (simp_all add: pcat_categories psemicategory_axioms)
qed



subsection‹Binary union and complement›

lemma (in pcategory) pcat_cat_prod_vunion_CId:
  assumes "vdisjnt J K"
    and "J ⊆∘ I"
    and "K ⊆∘ I"
    and "a ∈∘ (∏Cj∈∘J. 𝔄 j)⦇Obj⦈"
    and "b ∈∘ (∏Cj∈∘K. 𝔄 j)⦇Obj⦈"
  shows 
    "(∏Cj∈∘J. 𝔄 j)⦇CId⦈⦇a⦈ ∪∘ (∏Cj∈∘K. 𝔄 j)⦇CId⦈⦇b⦈ = 
      (∏Ci∈∘J ∪∘ K. 𝔄 i)⦇CId⦈⦇a ∪∘ b⦈"
proof-

  interpret J𝔄: pcategory α J 𝔄 
    using assms(2) by (simp add: pcat_vsubset_index_pcategory)
  interpret K𝔄: pcategory α K 𝔄 
    using assms(3) by (simp add: pcat_vsubset_index_pcategory)
  interpret JK𝔄: pcategory α ‹J ∪∘ K› 𝔄 
    using assms(2,3) by (simp add: pcat_vsubset_index_pcategory)

  interpret J𝔄': category α ‹cat_prod J 𝔄› 
    by (rule J𝔄.pcat_category_cat_prod)
  interpret K𝔄': category α ‹cat_prod K 𝔄› 
    by (rule K𝔄.pcat_category_cat_prod)
  interpret JK𝔄': category α ‹cat_prod (J ∪∘ K) 𝔄› 
    by (rule JK𝔄.pcat_category_cat_prod)

  from assms(4) have CId_a: "cat_prod J 𝔄⦇CId⦈⦇a⦈ : a ↦⇘(∏Cj∈∘J. 𝔄 j)⇙ a" 
    by (auto intro: cat_cs_intros)
  from assms(5) have CId_b: "cat_prod K 𝔄⦇CId⦈⦇b⦈ : b ↦⇘(∏Ck∈∘K. 𝔄 k)⇙ b" 
    by (auto intro: cat_cs_intros)
  have CId_a_CId_b: "cat_prod J 𝔄⦇CId⦈⦇a⦈ ∪∘ cat_prod K 𝔄⦇CId⦈⦇b⦈ :
    a ∪∘ b ↦⇘cat_prod (J ∪∘ K) 𝔄⇙ a ∪∘ b"
    by (rule pcat_cat_prod_vunion_is_arr[OF assms(1-3) CId_a CId_b])
  from CId_a have a: "a ∈∘ cat_prod J 𝔄⦇Obj⦈" by (auto intro: cat_cs_intros)
  from CId_b have b: "b ∈∘ cat_prod K 𝔄⦇Obj⦈" by (auto intro: cat_cs_intros)
  from CId_a_CId_b have ab: "a ∪∘ b ∈∘ cat_prod (J ∪∘ K) 𝔄⦇Obj⦈" 
    by (auto intro: cat_cs_intros)

  note CId_aD = J𝔄.cat_prod_is_arrD[OF CId_a]
    and CId_bD = K𝔄.cat_prod_is_arrD[OF CId_b]

  show ?thesis
  proof(rule cat_prod_Arr_cong[of _ ‹J ∪∘ K› 𝔄])
    from CId_a_CId_b show 
      "cat_prod J 𝔄⦇CId⦈⦇a⦈ ∪∘ cat_prod K 𝔄⦇CId⦈⦇b⦈ ∈∘ cat_prod (J ∪∘ K) 𝔄⦇Arr⦈"
      by auto
    from ab show "cat_prod (J ∪∘ K) 𝔄⦇CId⦈⦇a ∪∘ b⦈ ∈∘ cat_prod (J ∪∘ K) 𝔄⦇Arr⦈"
      by (auto intro: JK𝔄'.cat_is_arrD(1) cat_cs_intros)
    fix i assume "i ∈∘ J ∪∘ K"
    then consider (iJ) ‹i ∈∘ J› | (iK) ‹i ∈∘ K› by auto
    then show "(cat_prod J 𝔄⦇CId⦈⦇a⦈ ∪∘ cat_prod K 𝔄⦇CId⦈⦇b⦈)⦇i⦈ = 
      cat_prod (J ∪∘ K) 𝔄⦇CId⦈⦇a ∪∘ b⦈⦇i⦈"
      by cases
        (
          auto simp: 
            assms(1) 
            CId_aD(1-4) 
            CId_bD(1-4)
            cat_prod_CId_app[OF ab]
            cat_prod_CId_app[OF a]
            cat_prod_CId_app[OF b]
         )
  qed

qed

lemma (in pcategory) pcat_cat_prod_vdiff_vunion_CId:
  assumes "J ⊆∘ I"
    and "a ∈∘ (∏Cj∈∘I -∘ J. 𝔄 j)⦇Obj⦈"
    and "b ∈∘ (∏Cj∈∘J. 𝔄 j)⦇Obj⦈"
  shows 
    "(∏Cj∈∘I -∘ J. 𝔄 j)⦇CId⦈⦇a⦈ ∪∘ (∏Cj∈∘J. 𝔄 j)⦇CId⦈⦇b⦈ = 
      (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇a ∪∘ b⦈"
  by 
    (
      vdiff_of_vunion' 
        rule: pcat_cat_prod_vunion_CId assms: assms(2-3) subset: assms(1)
    )



subsection‹Projection›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in cite‹"mac_lane_categories_2010"›.›

definition cf_proj :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V" (‹πC›)
  where "πC I 𝔄 i =
    [
      (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). a⦇i⦈),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). f⦇i⦈),
      (∏Ci∈∘I. 𝔄 i),
      𝔄 i
    ]∘"


text‹Components.›

lemma cf_proj_components:
  shows "πC I 𝔄 i⦇ObjMap⦈ = (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). a⦇i⦈)"
    and "πC I 𝔄 i⦇ArrMap⦈ = (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). f⦇i⦈)"
    and "πC I 𝔄 i⦇HomDom⦈ = (∏Ci∈∘I. 𝔄 i)"
    and "πC I 𝔄 i⦇HomCod⦈ = 𝔄 i"
  unfolding cf_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing›

lemma cf_smcf_cf_proj[slicing_commute]: 
  "πSMC I (λi. cat_smc (𝔄 i)) i = cf_smcf (πC I 𝔄 i)"
  unfolding 
    cat_smc_def 
    cf_smcf_def 
    smcf_proj_def 
    cf_proj_def 
    cat_prod_def 
    smc_prod_def
    dg_prod_def
    dg_field_simps 
    dghm_field_simps 
  by (simp add: nat_omega_simps)

context pcategory
begin

interpretation psmc: psemicategory α I ‹λi. cat_smc (𝔄 i)› 
  by (rule pcat_psemicategory)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  pcat_cf_proj_is_semifunctor = psmc.psmc_smcf_proj_is_semifunctor

end


subsubsection‹Projection functor is a functor›

lemma (in pcategory) pcat_cf_proj_is_functor: 
  assumes "i ∈∘ I"
  shows "πC I 𝔄 i : (∏Ci∈∘I. 𝔄 i) ↦↦C⇘α⇙ 𝔄 i"
proof(intro is_functorI)
  interpret 𝔄: category α ‹(∏Ci∈∘I. 𝔄 i)› 
    by (simp add: pcat_category_cat_prod)
  show "vfsequence (πC I 𝔄 i)" unfolding cf_proj_def by simp
  show "category α (∏Ci∈∘I. 𝔄 i)" by (simp add: 𝔄.category_axioms)
  show "vcard (πC I 𝔄 i) = 4ℕ"
    unfolding cf_proj_def by (simp add: nat_omega_simps)
  show "πC I 𝔄 i⦇ArrMap⦈⦇(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈⦈ = 𝔄 i⦇CId⦈⦇πC I 𝔄 i⦇ObjMap⦈⦇c⦈⦈"
    if "c ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈" for c
  proof-
    interpret 𝔄i: category α ‹𝔄 i› 
      by (auto intro: assms cat_prod_cs_intros)
    from that have "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈ : c ↦⇘(∏Ci∈∘I. 𝔄 i)⇙ c"
      by (simp add: 𝔄.cat_CId_is_arr)
    then have "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈ ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈" 
      by (auto intro: cat_cs_intros)
    with assms have 
      "πC I 𝔄 i⦇ArrMap⦈⦇(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈⦈ = (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈⦇i⦈"
      unfolding cf_proj_components cat_prod_components by simp
    also from assms have "… = 𝔄 i⦇CId⦈⦇c⦇i⦈⦈"
      unfolding cat_prod_CId_app[OF that] by simp
    also from that have "… = 𝔄 i⦇CId⦈⦇πC I 𝔄 i⦇ObjMap⦈⦇c⦈⦈"
      unfolding cf_proj_components cat_prod_components by simp
    finally show 
      "πC I 𝔄 i⦇ArrMap⦈⦇(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇c⦈⦈ = 𝔄 i⦇CId⦈⦇πC I 𝔄 i⦇ObjMap⦈⦇c⦈⦈"
      by simp
  qed
qed 
  (
    auto simp: 
      assms cf_proj_components pcat_cf_proj_is_semifunctor cat_prod_cs_intros
  ) 

lemma (in pcategory) pcat_cf_proj_is_functor':
  assumes "i ∈∘ I" and "ℭ = (∏Ci∈∘I. 𝔄 i)" and "𝔇 = 𝔄 i"
  shows "πC I 𝔄 i : ℭ ↦↦C⇘α⇙ 𝔇"
  using assms(1) unfolding assms(2,3) by (rule pcat_cf_proj_is_functor)

lemmas [cat_cs_intros] = pcategory.pcat_cf_proj_is_functor'



subsection‹Category product universal property functor›


subsubsection‹Definition and elementary properties›

text‹
The functor that is presented in this section is used in the proof of 
the universal property of the product category later in this work.
›

definition cf_up :: "V ⇒ (V ⇒ V) ⇒ V ⇒ (V ⇒ V) ⇒ V"
  where "cf_up I 𝔄 ℭ φ =
    [
      (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈)),
      (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈)),
      ℭ,
      (∏Ci∈∘I. 𝔄 i)
    ]∘"


text‹Components.›

lemma cf_up_components: 
  shows "cf_up I 𝔄 ℭ φ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈))"
    and "cf_up I 𝔄 ℭ φ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈))"
    and "cf_up I 𝔄 ℭ φ⦇HomDom⦈ = ℭ"
    and "cf_up I 𝔄 ℭ φ⦇HomCod⦈ = (∏Ci∈∘I. 𝔄 i)"
  unfolding cf_up_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_cf_up[slicing_commute]: 
  "smcf_up I (λi. cat_smc (𝔄 i)) (cat_smc ℭ) (λi. cf_smcf (φ i)) = 
    cf_smcf (cf_up I 𝔄 ℭ φ)"
  unfolding 
    cat_smc_def 
    cf_smcf_def 
    cf_up_def 
    smcf_up_def 
    cat_prod_def 
    smc_prod_def
    dg_prod_def
    dg_field_simps 
    dghm_field_simps 
  by (simp add: nat_omega_simps)

context
  fixes 𝔄 φ :: "V ⇒ V"
    and ℭ :: V
begin

lemmas_with 
  [
    where 𝔄=‹λi. cat_smc (𝔄 i)› and φ=‹λi. cf_smcf (φ i)› and ℭ = ‹cat_smc ℭ›, 
    unfolded slicing_simps slicing_commute
  ]:
  cf_up_ObjMap_vdomain[simp] = smcf_up_ObjMap_vdomain
  and cf_up_ObjMap_app = smcf_up_ObjMap_app
  and cf_up_ObjMap_app_vdomain[simp] = smcf_up_ObjMap_app_vdomain
  and cf_up_ObjMap_app_component = smcf_up_ObjMap_app_component
  and cf_up_ArrMap_vdomain[simp] = smcf_up_ArrMap_vdomain
  and cf_up_ArrMap_app = smcf_up_ArrMap_app
  and cf_up_ArrMap_app_vdomain[simp] = smcf_up_ArrMap_app_vdomain
  and cf_up_ArrMap_app_component = smcf_up_ArrMap_app_component

lemma cf_up_ObjMap_vrange:
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i"
  shows "ℛ∘ (cf_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈"
proof
  (
    rule smcf_up_ObjMap_vrange[
      where 𝔄=‹λi. cat_smc (𝔄 i)› 
        and φ=‹λi. cf_smcf (φ i)› 
        and ℭ=‹cat_smc ℭ›, 
      unfolded slicing_simps slicing_commute
      ]
  )
  fix i assume "i ∈∘ I"
  then interpret is_functor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
  show "cf_smcf (φ i) : cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (𝔄 i)"
    by (rule cf_is_semifunctor)
qed

lemma cf_up_ObjMap_app_vrange:
  assumes "a ∈∘ ℭ⦇Obj⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i"
  shows " ℛ∘ (cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Obj⦈)"
proof
  (
    rule smcf_up_ObjMap_app_vrange[
      where 𝔄=‹λi. cat_smc (𝔄 i)› 
        and φ=‹λi. cf_smcf (φ i)› 
        and ℭ=‹cat_smc ℭ›, 
      unfolded slicing_simps slicing_commute
      ]
  )
  show "a ∈∘ ℭ⦇Obj⦈" by (rule assms)
  fix i assume "i ∈∘ I"
  then interpret is_functor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
  show "cf_smcf (φ i) : cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (𝔄 i)"
    by (rule cf_is_semifunctor)
qed

lemma cf_up_ArrMap_vrange:
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i"
  shows "ℛ∘ (cf_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈"
proof
  (
    rule smcf_up_ArrMap_vrange[
      where 𝔄=‹λi. cat_smc (𝔄 i)› 
        and φ=‹λi. cf_smcf (φ i)› 
        and ℭ=‹cat_smc ℭ›, 
      unfolded slicing_simps slicing_commute
      ]
  )
  fix i assume "i ∈∘ I"
  then interpret is_functor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
  show "cf_smcf (φ i) : cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (𝔄 i)"
    by (rule cf_is_semifunctor)
qed

lemma cf_up_ArrMap_app_vrange:
  assumes "a ∈∘ ℭ⦇Arr⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i"
  shows " ℛ∘ (cf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Arr⦈)"
proof
  (
    rule smcf_up_ArrMap_app_vrange
      [
        where 𝔄=‹λi. cat_smc (𝔄 i)› 
          and φ=‹λi. cf_smcf (φ i)› 
          and ℭ=‹cat_smc ℭ›, 
        unfolded slicing_simps slicing_commute
      ]
  )
  fix i assume "i ∈∘ I"
  then interpret is_functor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
  show "cf_smcf (φ i) : cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (𝔄 i)"
    by (rule cf_is_semifunctor)
qed (rule assms)

end

context pcategory
begin

interpretation psmc: psemicategory α I ‹λi. cat_smc (𝔄 i)› 
  by (rule pcat_psemicategory)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  pcat_smcf_comp_smcf_proj_smcf_up = psmc.psmc_Comp_smcf_proj_smcf_up
  and pcat_smcf_up_eq_smcf_proj = psmc.psmc_smcf_up_eq_smcf_proj

end


subsubsection‹Category product universal property functor is a functor›

lemma (in pcategory) pcat_cf_up_is_functor:
  assumes "category α ℭ" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i"
  shows "cf_up I 𝔄 ℭ φ : ℭ ↦↦C⇘α⇙ (∏Ci∈∘I. 𝔄 i)"
proof-
  interpret ℭ: category α ℭ by (simp add: assms(1))
  interpret 𝔄: category α ‹(∏Ci∈∘I. 𝔄 i)› by (rule pcat_category_cat_prod)
  show ?thesis
  proof(intro is_functorI)
    show "vfsequence (cf_up I 𝔄 ℭ φ)" unfolding cf_up_def by simp
    show "vcard (cf_up I 𝔄 ℭ φ) = 4ℕ"
      unfolding cf_up_def by (simp add: nat_omega_simps)
    show "cf_smcf (cf_up I 𝔄 ℭ φ) : cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (∏Ci∈∘I. 𝔄 i)"
      unfolding slicing_commute[symmetric]
      by (rule psemicategory.psmc_smcf_up_is_semifunctor)
        (
          auto simp: 
            assms(2)
            pcat_psemicategory 
            is_functor.cf_is_semifunctor 
            slicing_intros
        )
    show "cf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇ℭ⦇CId⦈⦇c⦈⦈ = 
      (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇c⦈⦈"
      if "c ∈∘ ℭ⦇Obj⦈" for c
    proof(rule cat_prod_Arr_cong)
      from that is_arrD(1) have CId_c: "ℭ⦇CId⦈⦇c⦈ ∈∘ ℭ⦇Arr⦈" 
        by (auto intro: cat_cs_intros)
      from CId_c cf_up_ArrMap_vrange[OF assms(2), simplified]
      show "cf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇ℭ⦇CId⦈⦇c⦈⦈ ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈"
        unfolding cf_up_components by force
      have cf_up_φ_c: "cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇c⦈ ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Obj⦈"
        unfolding cat_prod_components
      proof(intro vproductI ballI)
        fix i assume prems: "i ∈∘ I"
        interpret φ: is_functor α ℭ ‹𝔄 i› ‹φ i› by (simp add: prems assms(2))
        from that show  "cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇c⦈⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
          unfolding cf_up_ObjMap_app_component[OF that prems] 
          by (auto intro: cat_cs_intros)
      qed (simp_all add: cf_up_ObjMap_app that cf_up_ObjMap_app[OF that])
      from 𝔄.cat_CId_is_arr[OF this] show 
        "(∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇c⦈⦈ ∈∘ (∏Ci∈∘I. 𝔄 i)⦇Arr⦈"
        by auto
      fix i assume prems: "i ∈∘ I"
      interpret φ: is_functor α ℭ ‹𝔄 i› ‹φ i› by (simp add: prems assms(2))
      from cf_up_φ_c prems show 
        "cf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇ℭ⦇CId⦈⦇c⦈⦈⦇i⦈ =
          (∏Ci∈∘I. 𝔄 i)⦇CId⦈⦇cf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇c⦈⦈⦇i⦈"
        unfolding cf_up_ArrMap_app_component[OF CId_c prems] cat_prod_components
        by 
          (
            simp add: 
              that cf_up_ObjMap_app_component[OF that prems] φ.cf_ObjMap_CId 
          )
    qed 
  qed (auto simp: cf_up_components cat_cs_intros)
qed


subsubsection‹Further properties›

lemma (in pcategory) pcat_Comp_cf_proj_cf_up: 
  assumes "category α ℭ" 
    and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦C⇘α⇙ 𝔄 i" 
    and "i ∈∘ I" 
  shows "φ i = πC I 𝔄 i ∘CF (cf_up I 𝔄 ℭ φ)"
proof-
  interpret φ: is_functor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF assms(3)])
  interpret π: is_functor α ‹(∏Ci∈∘I. 𝔄 i)› ‹𝔄 i› ‹πC I 𝔄 i›
    by (simp add: assms(3) pcat_cf_proj_is_functor)
  interpret up: is_functor α ℭ ‹(∏Ci∈∘I. 𝔄 i)› ‹cf_up I 𝔄 ℭ φ›
    by (simp add: assms(2) φ.HomDom.category_axioms pcat_cf_up_is_functor)
  show ?thesis
  proof(rule cf_smcf_eqI)
    show "πC I 𝔄 i ∘CF cf_up I 𝔄 ℭ φ : ℭ ↦↦C⇘α⇙ 𝔄 i" 
      by (auto intro: cat_cs_intros)
    from assms show "cf_smcf (φ i) = cf_smcf (πC I 𝔄 i ∘CF cf_up I 𝔄 ℭ φ)"
      unfolding slicing_simps slicing_commute[symmetric]
      by 
        (
          intro pcat_smcf_comp_smcf_proj_smcf_up[
            where φ=‹λi. cf_smcf (φ i)›, unfolded slicing_commute[symmetric]
            ]
        )
        (auto simp: is_functor.cf_is_semifunctor)
  qed (auto intro: cat_cs_intros)
qed

lemma (in pcategory) pcat_cf_up_eq_cf_proj:
  assumes "𝔉 : ℭ ↦↦C⇘α⇙ (∏Ci∈∘I. 𝔄 i)"
    and "⋀i. i ∈∘ I ⟹ φ i = πC I 𝔄 i ∘CF 𝔉"
  shows "cf_up I 𝔄 ℭ φ = 𝔉"
proof(rule cf_smcf_eqI)
  interpret 𝔉: is_functor α ℭ ‹(∏Ci∈∘I. 𝔄 i)› 𝔉 by (rule assms(1))
  show "cf_up I 𝔄 ℭ φ : ℭ ↦↦C⇘α⇙ (∏Ci∈∘I. 𝔄 i)"
  proof(rule pcat_cf_up_is_functor)
    fix i assume prems: "i ∈∘ I"
    then interpret π: is_functor α ‹(∏Ci∈∘I. 𝔄 i)› ‹𝔄 i› ‹πC I 𝔄 i›
      by (rule pcat_cf_proj_is_functor)
    show "φ i : ℭ ↦↦C⇘α⇙ 𝔄 i" 
      unfolding assms(2)[OF prems] by (auto intro: cat_cs_intros)
  qed (auto intro: cat_cs_intros)
  show "𝔉 : ℭ ↦↦C⇘α⇙ (∏Ci∈∘I. 𝔄 i)" by (rule assms(1))
  from assms show "cf_smcf (cf_up I 𝔄 ℭ φ) = cf_smcf 𝔉"
    unfolding slicing_commute[symmetric]
    by (intro pcat_smcf_up_eq_smcf_proj) (auto simp: slicing_commute)
qed simp_all



subsection‹Prodfunctor with respect to a fixed argument›

text‹
A prodfunctor is a functor whose domain is a product category. 
It is a generalization of the concept of the bifunctor,
as presented in Chapter II-3 in cite‹"mac_lane_categories_2010"›.  
›

definition prodfunctor_proj :: "V ⇒ V ⇒ (V ⇒ V) ⇒ V ⇒ V ⇒ V ⇒ V"
  where "prodfunctor_proj 𝔖 I 𝔄 𝔇 J c =
    [
      (λb∈∘(∏Ci∈∘I -∘ J. 𝔄 i)⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈),
      (λf∈∘(∏Ci∈∘I -∘ J. 𝔄 i)⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ (∏Cj∈∘J. 𝔄 j)⦇CId⦈⦇c⦈⦈),
      (∏Ci∈∘I -∘ J. 𝔄 i),
      𝔇
    ]∘"

syntax "_PPRODFUNCTOR_PROJ" :: "V ⇒ pttrn ⇒ V ⇒ V ⇒ (V ⇒ V) ⇒ V ⇒ V ⇒ V" 
  (‹(_⇘(3∏C_∈∘_-∘_./_),_⇙/'(/-,_/'))› [51, 51, 51, 51, 51, 51, 51] 51)
translations "𝔖⇘∏Ci∈∘I-∘J. 𝔄,𝔇⇙(-,c)" ⇌ 
  "CONST prodfunctor_proj 𝔖 I (λi. 𝔄) 𝔇 J c"


text‹Components.›

lemma prodfunctor_proj_components:
  shows "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c))⦇ObjMap⦈ = 
      (λb∈∘(∏Ci∈∘I -∘ J. 𝔄 i)⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈)"
    and "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c))⦇ArrMap⦈ = 
      (λf∈∘(∏Ci∈∘I -∘ J. 𝔄 i)⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ (∏Cj∈∘J. 𝔄 j)⦇CId⦈⦇c⦈⦈)"
    and "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c))⦇HomDom⦈ = (∏Ci∈∘I -∘ J. 𝔄 i)"
    and "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c))⦇HomCod⦈ = 𝔇"
  unfolding prodfunctor_proj_def dghm_field_simps
  by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda prodfunctor_proj_components(1)
  |vsv prodfunctor_proj_ObjMap_vsv[cat_cs_intros]|
  |vdomain prodfunctor_proj_ObjMap_vdomain[cat_cs_simps]|
  |app prodfunctor_proj_ObjMap_app[cat_cs_simps]|


subsubsection‹Arrow map›

mk_VLambda prodfunctor_proj_components(2)
  |vsv prodfunctor_proj_ArrMap_vsv[cat_cs_intros]|
  |vdomain prodfunctor_proj_ArrMap_vdomain[cat_cs_simps]|
  |app  prodfunctor_proj_ArrMap_app[cat_cs_simps]|


subsubsection‹Prodfunctor with respect to a fixed argument is a functor›

lemma (in pcategory) pcat_prodfunctor_proj_is_functor: 
  assumes "𝔖 : (∏Ci∈∘I. 𝔄 i) ↦↦C⇘α⇙ 𝔇" 
    and "c ∈∘ (∏Cj∈∘J. 𝔄 j)⦇Obj⦈"
    and "J ⊆∘ I"
  shows "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c)) : (∏Ci∈∘I -∘ J. 𝔄 i) ↦↦C⇘α⇙ 𝔇"
proof-

  interpret is_functor α ‹(∏Ci∈∘I. 𝔄 i)› 𝔇 𝔖 by (rule assms(1))
  interpret 𝔄: pcategory α J 𝔄
    using assms(3) by (intro pcat_vsubset_index_pcategory) auto
  interpret J_𝔄: category α ‹∏Ci∈∘J. 𝔄 i› by (rule 𝔄.pcat_category_cat_prod)
  interpret IJ: pcategory α ‹I -∘ J› 𝔄
    using assms(3) by (intro pcat_vsubset_index_pcategory) auto
  interpret IJ_𝔄: category α ‹∏Ci∈∘I -∘ J. 𝔄 i›
    by (rule IJ.pcat_category_cat_prod)

  let ?IJ𝔄 = ‹(∏Ci∈∘I -∘ J. 𝔄 i)›

  from assms(2) have "c ∈∘ (∏∘j∈∘J. 𝔄 j⦇Obj⦈)"
    unfolding cat_prod_components by simp
  then have "(∏∘j∈∘J. 𝔄 j⦇Obj⦈) ≠ 0" by (auto intro!: cat_cs_intros)

  show ?thesis
  proof(intro is_functorI', unfold prodfunctor_proj_components)

    show "vfsequence (prodfunctor_proj 𝔖 I 𝔄 𝔇 J c)"
      unfolding prodfunctor_proj_def by simp
    show "vcard (prodfunctor_proj 𝔖 I 𝔄 𝔇 J c) = 4ℕ"
      unfolding prodfunctor_proj_def by (simp add: nat_omega_simps)

    show "ℛ∘ (λb∈∘?IJ𝔄⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈) ⊆∘ 𝔇⦇Obj⦈"
    proof(intro vsubsetI)
      fix x assume "x ∈∘ ℛ∘ (λb∈∘?IJ𝔄⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈)"
      then obtain b where x_def: "x = 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈" and b: "b ∈∘ ?IJ𝔄⦇Obj⦈"  
        by auto
      have "b ∪∘ c ∈∘ cat_prod I 𝔄⦇Obj⦈"
      proof(rule cat_prod_vdiff_vunion_Obj_in_Obj)
        show "b ∈∘ ?IJ𝔄⦇Obj⦈" by (rule b)
      qed (intro assms(2,3))+
      then show "x ∈∘ 𝔇⦇Obj⦈" unfolding x_def by (auto intro: cat_cs_intros)
    qed

    show is_arr:
      "(λf∈∘?IJ𝔄⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈)⦇f⦈ : 
        (λb∈∘?IJ𝔄⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈)⦇a⦈ ↦⇘𝔇⇙ 
        (λb∈∘?IJ𝔄⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈)⦇b⦈"
      (is ‹?V_f: ?V_a ↦⇘𝔇⇙ ?V_b›)
      if "f : a ↦⇘?IJ𝔄⇙ b" for f a b
    proof-
      let ?fc = ‹f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈›
      have "?fc : a ∪∘ c ↦⇘cat_prod I 𝔄⇙ b ∪∘ c"
      proof(rule pcat_cat_prod_vdiff_vunion_is_arr)
        show "f : a ↦⇘?IJ𝔄⇙ b" by (rule that)
      qed (auto simp: assms cat_cs_intros)
      then have "𝔖⦇ArrMap⦈⦇?fc⦈ : 𝔖⦇ObjMap⦈⦇a ∪∘ c⦈ ↦⇘𝔇⇙ 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈"
        by (auto intro: cat_cs_intros)
      moreover from that have "f ∈∘ ?IJ𝔄⦇Arr⦈" "a ∈∘ ?IJ𝔄⦇Obj⦈" "b ∈∘ ?IJ𝔄⦇Obj⦈"
        by (auto intro: cat_cs_intros) 
      ultimately show ?thesis by simp
    qed

    show 
      "(λf∈∘?IJ𝔄⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈)⦇g ∘A⇘?IJ𝔄⇙ f⦈ =
      (λf∈∘?IJ𝔄⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈)⦇g⦈ ∘A⇘𝔇⇙ 
      (λf∈∘?IJ𝔄⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈)⦇f⦈"
      if "g : b' ↦⇘?IJ𝔄⇙ c'" and "f : a' ↦⇘?IJ𝔄⇙ b'" for g b' c' f a'
    proof-
      from that have gf: "g ∘A⇘?IJ𝔄⇙ f : a' ↦⇘?IJ𝔄⇙ c'" 
        by (auto intro: cat_cs_intros)
      from assms(2) have CId_c: "cat_prod J 𝔄⦇CId⦈⦇c⦈ : c ↦⇘cat_prod J 𝔄⇙ c" 
        by (auto intro: cat_cs_intros)
      then have [simp]:  
        "cat_prod J 𝔄⦇CId⦈⦇c⦈ ∘A⇘cat_prod J 𝔄⇙ cat_prod J 𝔄⦇CId⦈⦇c⦈ = 
          cat_prod J 𝔄⦇CId⦈⦇c⦈"
        by (auto simp: cat_cs_simps)
      from assms(3) that(1) CId_c have g_CId_c:
        "g ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈ : b' ∪∘ c ↦⇘cat_prod I 𝔄⇙ c' ∪∘ c"
        by (rule pcat_cat_prod_vdiff_vunion_is_arr)
      from assms(3) that(2) CId_c have f_CId_c:
        "f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈ : a' ∪∘ c ↦⇘cat_prod I 𝔄⇙ b' ∪∘ c"
        by (rule pcat_cat_prod_vdiff_vunion_is_arr)
      have 
        "𝔖⦇ArrMap⦈⦇(g ∘A⇘?IJ𝔄⇙ f) ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈ = 
          𝔖⦇ArrMap⦈⦇g ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈ ∘A⇘𝔇⇙
          𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈"
        unfolding 
          pcat_cat_prod_vdiff_vunion_Comp[
            OF assms(3) that(1) CId_c that(2) CId_c, simplified
            ]
        by (intro cf_ArrMap_Comp[OF g_CId_c f_CId_c])
      moreover from gf have "g ∘A⇘?IJ𝔄⇙ f ∈∘ ?IJ𝔄⦇Arr⦈" by auto
      moreover from that have "g ∈∘ ?IJ𝔄⦇Arr⦈" "f ∈∘ ?IJ𝔄⦇Arr⦈" by auto
      ultimately show ?thesis by simp
    qed

    show 
      "(λf∈∘?IJ𝔄⦇Arr⦈. 𝔖⦇ArrMap⦈⦇f ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈)⦇?IJ𝔄⦇CId⦈⦇c'⦈⦈ = 
        𝔇⦇CId⦈⦇(λb∈∘?IJ𝔄⦇Obj⦈. 𝔖⦇ObjMap⦈⦇b ∪∘ c⦈)⦇c'⦈⦈"
      if "c' ∈∘ ?IJ𝔄⦇Obj⦈" for c'
    proof-
      have "?IJ𝔄⦇CId⦈⦇c'⦈ ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈ = cat_prod I 𝔄⦇CId⦈⦇c' ∪∘ c⦈"
        unfolding pcat_cat_prod_vdiff_vunion_CId[OF assms(3) that assms(2)] ..
      moreover from assms(3) that assms(2) have "c' ∪∘ c ∈∘ cat_prod I 𝔄⦇Obj⦈"
        by (rule cat_prod_vdiff_vunion_Obj_in_Obj)
      ultimately have "𝔖⦇ArrMap⦈⦇?IJ𝔄⦇CId⦈⦇c'⦈ ∪∘ cat_prod J 𝔄⦇CId⦈⦇c⦈⦈ =
        𝔇⦇CId⦈⦇𝔖⦇ObjMap⦈⦇c' ∪∘ c⦈⦈"
        by (auto intro: cat_cs_intros) 
      moreover from that have CId_c': "?IJ𝔄⦇CId⦈⦇c'⦈ ∈∘ ?IJ𝔄⦇Arr⦈"
        by (auto dest!: IJ_𝔄.cat_CId_is_arr)
      ultimately show ?thesis by (simp add: that)
    qed

  qed (auto intro: cat_cs_intros) 

qed

lemma (in pcategory) pcat_prodfunctor_proj_is_functor': 
  assumes "𝔖 : (∏Ci∈∘I. 𝔄 i) ↦↦C⇘α⇙ 𝔇" 
    and "c ∈∘ (∏Cj∈∘J. 𝔄 j)⦇Obj⦈"
    and "J ⊆∘ I"
    and "𝔄' = (∏Ci∈∘I -∘ J. 𝔄 i)"
    and "𝔅' = 𝔇"
  shows "(𝔖⇘∏Ci∈∘I -∘ J. 𝔄 i,𝔇⇙(-,c)) : 𝔄' ↦↦C⇘α⇙ 𝔅'"
  using assms(1-3)
  unfolding assms(4,5)
  by (rule pcat_prodfunctor_proj_is_functor)

lemmas [cat_cs_intros] = pcategory.pcat_prodfunctor_proj_is_functor'



subsection‹Singleton category›


subsubsection‹Slicing›

context
  fixes ℭ :: V
begin

lemmas_with [where ℭ=‹cat_smc ℭ›, unfolded slicing_simps slicing_commute]:
  cat_singleton_ObjI = smc_singleton_ObjI
  and cat_singleton_ObjE = smc_singleton_ObjE
  and cat_singleton_ArrI = smc_singleton_ArrI
  and cat_singleton_ArrE = smc_singleton_ArrE

end

context category
begin

interpretation smc: semicategory α ‹cat_smc ℭ› by (rule cat_semicategory)

lemmas_with [unfolded slicing_simps slicing_commute]:
  cat_finite_psemicategory_cat_singleton = 
    smc.smc_finite_psemicategory_smc_singleton
  and cat_singleton_is_arrI = smc.smc_singleton_is_arrI
  and cat_singleton_is_arrD = smc.smc_singleton_is_arrD
  and cat_singleton_is_arrE = smc.smc_singleton_is_arrE

end


subsubsection‹Identity›

lemma cat_singleton_CId_app: 
  assumes "set {⟨j, a⟩} ∈∘ (∏Ci∈∘set {j}. ℭ)⦇Obj⦈"
  shows "(∏Ci∈∘set {j}. ℭ)⦇CId⦈⦇set {⟨j, a⟩}⦈ = set {⟨j, ℭ⦇CId⦈⦇a⦈⟩}"
  using assms unfolding cat_prod_components VLambda_vsingleton by simp


subsubsection‹Singleton category is a category›

lemma (in category) cat_finite_pcategory_cat_singleton: 
  assumes "j ∈∘ Vset α"
  shows "finite_pcategory α (set {j}) (λi. ℭ)"
  by 
    (
      auto intro: 
        assms
        category_axioms 
        finite_pcategory_finite_psemicategoryI 
        cat_finite_psemicategory_cat_singleton 
    )

lemma (in category) cat_category_cat_singleton:
  assumes "j ∈∘ Vset α"
  shows "category α (∏Ci∈∘set {j}. ℭ)"
proof-
  interpret finite_pcategory α ‹set {j}› ‹λi. ℭ›
    using assms by (rule cat_finite_pcategory_cat_singleton)
  show ?thesis by (rule pcat_category_cat_prod)
qed



subsection‹Singleton functor›


subsubsection‹Definition and elementary properties›

definition cf_singleton :: "V ⇒ V ⇒ V"
  where "cf_singleton j ℭ =
    [
      (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩}),
      (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩}),
      ℭ,
      (∏Ci∈∘set {j}. ℭ)
    ]∘"


text‹Components.›

lemma cf_singleton_components:
  shows "cf_singleton j ℭ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩})"
    and "cf_singleton j ℭ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩})"
    and "cf_singleton j ℭ⦇HomDom⦈ = ℭ"
    and "cf_singleton j ℭ⦇HomCod⦈ = (∏Ci∈∘set {j}. ℭ)"
  unfolding cf_singleton_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma cf_smcf_cf_singleton[slicing_commute]: 
  "smcf_singleton j (cat_smc ℭ)= cf_smcf (cf_singleton j ℭ)"
  unfolding smcf_singleton_def cf_singleton_def slicing_simps slicing_commute
  by 
    (
      simp add: 
        nat_omega_simps dghm_field_simps dg_field_simps cat_smc_def cf_smcf_def
     )

context
  fixes ℭ :: V
begin

lemmas_with [where ℭ=‹cat_smc ℭ›, unfolded slicing_simps slicing_commute]:
  cf_singleton_ObjMap_vsv[cat_cs_intros] = smcf_singleton_ObjMap_vsv
  and cf_singleton_ObjMap_vdomain[cat_cs_simps] = smcf_singleton_ObjMap_vdomain
  and cf_singleton_ObjMap_vrange = smcf_singleton_ObjMap_vrange
  and cf_singleton_ObjMap_app[cat_prod_cs_simps] = smcf_singleton_ObjMap_app
  and cf_singleton_ArrMap_vsv[cat_cs_intros] = smcf_singleton_ArrMap_vsv
  and cf_singleton_ArrMap_vdomain[cat_cs_simps] = smcf_singleton_ArrMap_vdomain
  and cf_singleton_ArrMap_vrange = smcf_singleton_ArrMap_vrange
  and cf_singleton_ArrMap_app[cat_prod_cs_simps] = smcf_singleton_ArrMap_app

end


subsubsection‹Singleton functor is an isomorphism of categories›

lemma (in category) cat_cf_singleton_is_functor:
  assumes "j ∈∘ Vset α"
  shows "cf_singleton j ℭ : ℭ ↦↦C.iso⇘α⇙ (∏Ci∈∘set {j}. ℭ)"
proof(intro is_iso_functorI is_functorI)
  from assms show smcf_singleton: "cf_smcf (cf_singleton j ℭ) : 
    cat_smc ℭ ↦↦SMC.iso⇘α⇙ cat_smc (∏Ci∈∘set {j}. ℭ)"
    unfolding slicing_commute[symmetric]
    by (intro semicategory.smc_smcf_singleton_is_iso_semifunctor) 
      (auto intro: smc_cs_intros slicing_intros)
  show "vfsequence (cf_singleton j ℭ)" unfolding cf_singleton_def by simp
  show "vcard (cf_singleton j ℭ) = 4ℕ"
    unfolding cf_singleton_def by (simp add: nat_omega_simps)
  show "cf_smcf (cf_singleton j ℭ) : 
    cat_smc ℭ ↦↦SMC⇘α⇙ cat_smc (∏Ci∈∘set {j}. ℭ)"
    by (intro is_iso_semifunctor.axioms(1) smcf_singleton)
  show "cf_singleton j ℭ⦇ArrMap⦈⦇ℭ⦇CId⦈⦇c⦈⦈ = 
    (∏Ci∈∘set {j}. ℭ)⦇CId⦈⦇cf_singleton j ℭ⦇ObjMap⦈⦇c⦈⦈"
    if "c ∈∘ ℭ⦇Obj⦈" for c 
  proof-
    from that have CId_c: "ℭ⦇CId⦈⦇c⦈ : c ↦⇘ℭ⇙ c" by (auto simp: cat_cs_intros)
    have "set {⟨j, c⟩} ∈∘ (∏Ci∈∘set {j}. ℭ)⦇Obj⦈"
      by (simp add: cat_singleton_ObjI that)
    with that have "(∏Ci∈∘set {j}. ℭ)⦇CId⦈⦇cf_singleton j ℭ⦇ObjMap⦈⦇c⦈⦈ = 
      set {⟨j, ℭ⦇CId⦈⦇c⦈⟩}"
      by (simp add: cf_singleton_ObjMap_app cat_singleton_CId_app)
    moreover from CId_c have 
      "cf_singleton j ℭ⦇ArrMap⦈⦇ℭ⦇CId⦈⦇c⦈⦈ = set {⟨j, ℭ⦇CId⦈⦇c⦈⟩}"
      by (auto simp: cf_singleton_ArrMap_app cat_cs_intros)
    ultimately show ?thesis by simp
  qed
qed 
  (
    auto simp: 
      cat_cs_intros assms cat_category_cat_singleton cf_singleton_components 
  )



subsection‹Product of two categories›


subsubsection‹Definition and elementary properties.›


text‹See Chapter II-3 in cite‹"mac_lane_categories_2010"›.›

definition cat_prod_2 :: "V ⇒ V ⇒ V" (infixr ‹×C› 80)
  where "𝔄 ×C 𝔅 ≡ cat_prod (2ℕ) (λi. if i = 0 then 𝔄 else 𝔅)"


text‹Slicing.›
  
lemma cat_smc_cat_prod_2[slicing_commute]: 
  "cat_smc 𝔄 ×SMC cat_smc 𝔅 = cat_smc (𝔄 ×C 𝔅)"
  unfolding cat_prod_2_def smc_prod_2_def slicing_commute[symmetric] if_distrib
  by simp

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

lemmas_with 
  [
    where 𝔄=‹cat_smc 𝔄› and 𝔅=‹cat_smc 𝔅›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.cat_semicategory 𝔅.cat_semicategory
  ]:
  cat_prod_2_ObjI = smc_prod_2_ObjI 
  and cat_prod_2_ObjI'[cat_prod_cs_intros] = smc_prod_2_ObjI'
  and cat_prod_2_ObjE = smc_prod_2_ObjE
  and cat_prod_2_ArrI = smc_prod_2_ArrI
  and cat_prod_2_ArrI'[cat_prod_cs_intros] = smc_prod_2_ArrI'
  and cat_prod_2_ArrE = smc_prod_2_ArrE
  and cat_prod_2_is_arrI = smc_prod_2_is_arrI
  and cat_prod_2_is_arrI'[cat_prod_cs_intros] = smc_prod_2_is_arrI'
  and cat_prod_2_is_arrE = smc_prod_2_is_arrE
  and cat_prod_2_Dom_vsv = smc_prod_2_Dom_vsv
  and cat_prod_2_Dom_vdomain[cat_cs_simps] = smc_prod_2_Dom_vdomain
  and cat_prod_2_Dom_app[cat_prod_cs_simps] = smc_prod_2_Dom_app
  and cat_prod_2_Dom_vrange = smc_prod_2_Dom_vrange
  and cat_prod_2_Cod_vsv = smc_prod_2_Cod_vsv
  and cat_prod_2_Cod_vdomain[cat_cs_simps] = smc_prod_2_Cod_vdomain
  and cat_prod_2_Cod_app[cat_prod_cs_simps] = smc_prod_2_Cod_app
  and cat_prod_2_Cod_vrange = smc_prod_2_Cod_vrange
  and cat_prod_2_op_cat_cat_Obj[cat_op_simps] = smc_prod_2_op_smc_smc_Obj
  and cat_prod_2_cat_op_cat_Obj[cat_op_simps] = smc_prod_2_smc_op_smc_Obj
  and cat_prod_2_op_cat_cat_Arr[cat_op_simps] = smc_prod_2_op_smc_smc_Arr
  and cat_prod_2_cat_op_cat_Arr[cat_op_simps] = smc_prod_2_smc_op_smc_Arr

lemmas_with 
  [
    where 𝔄=‹cat_smc 𝔄› and 𝔅=‹cat_smc 𝔅›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.cat_semicategory 𝔅.cat_semicategory
  ]:
  cat_prod_2_Comp_app[cat_prod_cs_simps] = smc_prod_2_Comp_app

end


subsubsection‹Product of two categories is a category›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝒵 α by (rule categoryD[OF 𝔄])
interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

lemma finite_pcategory_cat_prod_2: "finite_pcategory α (2ℕ) (if2 𝔄 𝔅)"
proof(intro finite_pcategoryI pcategory_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "2ℕ ∈∘ Vset α" by blast
  show "category α (i = 0 ? 𝔄 : 𝔅)" if "i ∈∘ 2ℕ" for i
    by (auto simp: cat_cs_intros)
qed auto

interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemma category_cat_prod_2[cat_cs_intros]: "category α (𝔄 ×C 𝔅)"
  unfolding cat_prod_2_def by (rule pcat_category_cat_prod)

end


subsubsection‹Identity›

lemma cat_prod_2_CId_vsv[cat_cs_intros]: "vsv ((𝔄 ×C 𝔅)⦇CId⦈)"
  unfolding cat_prod_2_def cat_prod_components by simp

lemma cat_prod_2_CId_vdomain[cat_cs_simps]: 
  "𝒟∘ ((𝔄 ×C 𝔅)⦇CId⦈) = (𝔄 ×C 𝔅)⦇Obj⦈"
  unfolding cat_prod_2_def cat_prod_components by simp

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

interpretation finite_pcategory α ‹2ℕ› ‹(λi. if i = 0 then 𝔄 else 𝔅)›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemma cat_prod_2_CId_app[cat_prod_cs_simps]:
  assumes "[a, b]∘ ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
  shows "(𝔄 ×C 𝔅)⦇CId⦈⦇a, b⦈∙ = [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈]∘"
proof-
  have "(𝔄 ×C 𝔅)⦇CId⦈⦇a, b⦈∙ = 
    (λi∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇CId⦈⦇[a, b]∘⦇i⦈⦈)"
    by 
      (
        rule 
          cat_prod_CId_app[
            OF assms[unfolded cat_prod_2_def], folded cat_prod_2_def
            ]
      )
  also have 
    "(λi∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇CId⦈⦇[a, b]∘⦇i⦈⦈) = 
      [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈]∘"
  proof(rule vsv_eqI, unfold vdomain_VLambda)
    fix i assume "i ∈∘ 2ℕ"
    then consider ‹i = 0› | ‹i = 1ℕ› unfolding two by auto
    then show 
      "(λi∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇CId⦈⦇[a, b]∘⦇i⦈⦈)⦇i⦈ = 
        [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈]∘⦇i⦈"
      by cases (simp_all add: two nat_omega_simps)
  qed (auto simp: two nat_omega_simps)
  finally show ?thesis by simp
qed

lemma cat_prod_2_CId_vrange: "ℛ∘ ((𝔄 ×C 𝔅)⦇CId⦈) ⊆∘ (𝔄 ×C 𝔅)⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold cat_cs_simps)
  show "vsv ((𝔄 ×C 𝔅)⦇CId⦈)" by (rule cat_prod_2_CId_vsv)
  fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
  then obtain a b where ab_def: "ab = [a, b]∘" 
    and a: "a ∈∘ 𝔄⦇Obj⦈" 
    and b: "b ∈∘ 𝔅⦇Obj⦈"
    by (elim cat_prod_2_ObjE[OF 𝔄 𝔅])
  from 𝔄 𝔅 a b show "(𝔄 ×C 𝔅)⦇CId⦈⦇ab⦈ ∈∘ (𝔄 ×C 𝔅)⦇Arr⦈"
    unfolding ab_def by (cs_concl cs_intro: cat_cs_intros cat_prod_cs_intros)
qed

end


subsubsection‹Opposite product category›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

lemma op_smc_smc_prod_2[smc_op_simps]: 
  "op_cat (𝔄 ×C 𝔅) = op_cat 𝔄 ×C op_cat 𝔅"
proof(rule cat_smc_eqI [of α])
  from 𝔄 𝔅 show cat_lhs: "category α (op_cat (𝔄 ×C 𝔅))"
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
      )
  interpret cat_lhs: category α ‹op_cat (𝔄 ×C 𝔅)› by (rule cat_lhs)
  from 𝔄 𝔅 show cat_rhs: "category α (op_cat 𝔄 ×C op_cat 𝔅)"
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
      )
  interpret cat_rhs: category α ‹op_cat 𝔄 ×C op_cat 𝔅› by (rule cat_rhs)
  show "op_cat (𝔄 ×C 𝔅)⦇CId⦈ = (op_cat 𝔄 ×C op_cat 𝔅)⦇CId⦈"
    unfolding cat_op_simps
  proof(rule vsv_eqI, unfold cat_cs_simps)
    show "vsv ((𝔄 ×C 𝔅)⦇CId⦈)" by (rule cat_prod_2_CId_vsv)
    show "vsv ((op_cat 𝔄 ×C op_cat 𝔅)⦇CId⦈)" by (rule cat_prod_2_CId_vsv)
    from 𝔄 𝔅 show "(𝔄 ×C 𝔅)⦇Obj⦈ = (op_cat 𝔄 ×C op_cat 𝔅)⦇Obj⦈"
      by 
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_op_intros
        )
    show "(𝔄 ×C 𝔅)⦇CId⦈⦇ab⦈ = (op_cat 𝔄 ×C op_cat 𝔅)⦇CId⦈⦇ab⦈"
      if "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈" for ab
      using that unfolding cat_cs_simps
    proof-
      from that obtain a b
        where ab_def: "ab = [a, b]∘" 
          and a: "a ∈∘ 𝔄⦇Obj⦈" 
          and b: "b ∈∘ 𝔅⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF 𝔄 𝔅])
      from 𝔄 𝔅 a b show "(𝔄 ×C 𝔅)⦇CId⦈⦇ab⦈ = (op_cat 𝔄 ×C op_cat 𝔅)⦇CId⦈⦇ab⦈"
        unfolding ab_def
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_op_simps cat_prod_cs_simps
              cs_intro: cat_op_intros cat_prod_cs_intros
          )
    qed
  qed

  from 𝔄 𝔅 show "cat_smc (op_cat (𝔄 ×C 𝔅)) = cat_smc (op_cat 𝔄 ×C op_cat 𝔅)"
    unfolding slicing_commute[symmetric]
    by (cs_concl cs_shallow cs_simp: smc_op_simps cs_intro: slicing_intros)

qed

end


subsubsection‹Flip›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

lemma cat_prod_2_Obj_fconverse[cat_cs_simps]:
  "((𝔄 ×C 𝔅)⦇Obj⦈)¯∙ = (𝔅 ×C 𝔄)⦇Obj⦈"
proof-
  interpret fbrelation ‹((𝔄 ×C 𝔅)⦇Obj⦈)› 
    by (auto elim: cat_prod_2_ObjE[OF 𝔄 𝔅])
  show ?thesis
  proof(intro vsubset_antisym vsubsetI)
    fix ba assume prems: "ba ∈∘ ((𝔄 ×C 𝔅)⦇Obj⦈)¯∙"
    then obtain a b where ba_def: "ba = [b, a]∘" by clarsimp
    from prems[unfolded ba_def] have "[a, b]∘ ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈" by auto
    then have "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈"
      by (auto elim: cat_prod_2_ObjE[OF 𝔄 𝔅])
    with 𝔄 𝔅 show "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
      unfolding ba_def by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
  next
    fix ba assume "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"  
    then obtain a b 
      where ba_def: "ba = [b, a]∘" 
        and b: "b ∈∘ 𝔅⦇Obj⦈"
        and a: "a ∈∘ 𝔄⦇Obj⦈"
      by (elim cat_prod_2_ObjE[OF 𝔅 𝔄])
    from b a show "ba ∈∘ ((𝔄 ×C 𝔅)⦇Obj⦈)¯∙"
      unfolding ba_def by (auto simp: cat_prod_2_ObjI[OF 𝔄 𝔅 a b])
  qed
qed

lemma cat_prod_2_Arr_fconverse[cat_cs_simps]:
  "((𝔄 ×C 𝔅)⦇Arr⦈)¯∙ = (𝔅 ×C 𝔄)⦇Arr⦈"
proof-
  interpret fbrelation ‹((𝔄 ×C 𝔅)⦇Arr⦈)› 
    by (auto elim: cat_prod_2_ArrE[OF 𝔄 𝔅])
  show ?thesis
  proof(intro vsubset_antisym vsubsetI)
    fix ba assume prems: "ba ∈∘ ((𝔄 ×C 𝔅)⦇Arr⦈)¯∙"
    then obtain a b where ba_def: "ba = [b, a]∘" by clarsimp
    from prems[unfolded ba_def] have "[a, b]∘ ∈∘ (𝔄 ×C 𝔅)⦇Arr⦈" by auto
    then have "a ∈∘ 𝔄⦇Arr⦈" and "b ∈∘ 𝔅⦇Arr⦈"
      by (auto elim: cat_prod_2_ArrE[OF 𝔄 𝔅])
    with 𝔄 𝔅 show "ba ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
      unfolding ba_def 
      by 
        (
          cs_concl 
            cs_simp: cat_prod_cs_simps 
            cs_intro: cat_prod_cs_intros cat_cs_intros
        )
  next
    fix ba assume "ba ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"  
    then obtain a b 
      where ba_def: "ba = [b, a]∘" 
        and b: "b ∈∘ 𝔅⦇Arr⦈"
        and a: "a ∈∘ 𝔄⦇Arr⦈"
      by (elim cat_prod_2_ArrE[OF 𝔅 𝔄])
    from b a show "ba ∈∘ ((𝔄 ×C 𝔅)⦇Arr⦈)¯∙"
      unfolding ba_def by (auto simp: cat_prod_2_ArrI[OF 𝔄 𝔅 a b])
  qed
qed

end



subsection‹Projections for the product of two categories›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in cite‹"mac_lane_categories_2010"›.›

definition cf_proj_fst :: "V ⇒ V ⇒ V" (‹πC.1›)
  where "πC.1 𝔄 𝔅 = cf_proj (2ℕ) (λi. if i = 0 then 𝔄 else 𝔅) 0"
definition cf_proj_snd :: "V ⇒ V ⇒ V" (‹πC.2›)
  where "πC.2 𝔄 𝔅 = cf_proj (2ℕ) (λi. if i = 0 then 𝔄 else 𝔅) (1ℕ)"


text‹Slicing›

lemma cf_smcf_cf_proj_fst[slicing_commute]: 
  "πSMC.1 (cat_smc 𝔄) (cat_smc 𝔅) = cf_smcf (πC.1 𝔄 𝔅)"
  unfolding 
    cf_proj_fst_def smcf_proj_fst_def slicing_commute[symmetric] if_distrib ..

lemma cf_smcf_cf_proj_snd[slicing_commute]: 
  "πSMC.2 (cat_smc 𝔄) (cat_smc 𝔅) = cf_smcf (πC.2 𝔄 𝔅)"
  unfolding 
    cf_proj_snd_def smcf_proj_snd_def slicing_commute[symmetric] if_distrib ..

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

lemmas_with 
  [
    where 𝔄=‹cat_smc 𝔄› and 𝔅=‹cat_smc 𝔅›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.cat_semicategory 𝔅.cat_semicategory
  ]:
  cf_proj_fst_ObjMap_app = smcf_proj_fst_ObjMap_app 
  and cf_proj_snd_ObjMap_app = smcf_proj_snd_ObjMap_app
  and cf_proj_fst_ArrMap_app = smcf_proj_fst_ArrMap_app
  and cf_proj_snd_ArrMap_app = smcf_proj_snd_ArrMap_app

end


subsubsection‹
Domain and codomain of a projection of a product of two categories
›

lemma cf_proj_fst_HomDom: "πC.1 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×C 𝔅"
  unfolding cf_proj_fst_def cf_proj_components cat_prod_2_def ..

lemma cf_proj_fst_HomCod: "πC.1 𝔄 𝔅⦇HomCod⦈ = 𝔄"
  unfolding cf_proj_fst_def cf_proj_components cat_prod_2_def by simp
  
lemma cf_proj_snd_HomDom: "πC.2 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×C 𝔅"
  unfolding cf_proj_snd_def cf_proj_components cat_prod_2_def ..

lemma cf_proj_snd_HomCod: "πC.2 𝔄 𝔅⦇HomCod⦈ = 𝔅"
  unfolding cf_proj_snd_def cf_proj_components cat_prod_2_def by simp


subsubsection‹Projection of a product of two categories is a functor›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝒵 α by (rule categoryD[OF 𝔄])
interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)
interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemma cf_proj_fst_is_functor: 
  assumes "i ∈∘ I" 
  shows "πC.1 𝔄 𝔅 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔄"
  by 
    (
      rule 
        pcat_cf_proj_is_functor[
          where i=0, simplified, folded cf_proj_fst_def cat_prod_2_def
          ]
    )

lemma cf_proj_fst_is_functor'[cat_cs_intros]: 
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×C 𝔅" and "𝔇 = 𝔄"
  shows "πC.1 𝔄 𝔅 : ℭ ↦↦C⇘α⇙ 𝔇"
  using assms(1) unfolding assms(2,3) by (rule cf_proj_fst_is_functor)

lemma cf_proj_snd_is_functor: 
  assumes "i ∈∘ I" 
  shows "πC.2 𝔄 𝔅 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔅"
  by 
    (
      rule 
        pcat_cf_proj_is_functor[
          where i=‹1ℕ›, simplified, folded cf_proj_snd_def cat_prod_2_def
          ]
    )

lemma cf_proj_snd_is_functor'[cat_cs_intros]: 
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×C 𝔅" and "𝔇 = 𝔅"
  shows "πC.2 𝔄 𝔅 : ℭ ↦↦C⇘α⇙ 𝔇"
  using assms(1) unfolding assms(2,3) by (rule cf_proj_snd_is_functor)

end



subsection‹Product of three categories›


subsubsection‹Definition and elementary properties.›

definition cat_prod_3 :: "V ⇒ V ⇒ V ⇒ V" ("(_ ×C3 _ ×C3 _)" [81, 81, 81] 80)
  where "𝔄 ×C3 𝔅 ×C3 ℭ = (∏Ci∈∘3ℕ. if3 𝔄 𝔅 ℭ i)"

abbreviation cat_pow_3 :: "V ⇒ V" (‹_^C3› [81] 80)
  where "ℭ^C3 ≡ ℭ ×C3 ℭ ×C3 ℭ"


text‹Slicing.›
  
lemma cat_smc_cat_prod_3[slicing_commute]: 
  "cat_smc 𝔄 ×SMC3 cat_smc 𝔅 ×SMC3 cat_smc ℭ = cat_smc (𝔄 ×C3 𝔅 ×C3 ℭ)"
  unfolding cat_prod_3_def smc_prod_3_def slicing_commute[symmetric] if_distrib
  by (simp add: if_distrib[symmetric])

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅" and ℭ: "category α ℭ"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)
interpretation ℭ: category α ℭ by (rule ℭ)

lemmas_with 
  [
    where 𝔄=‹cat_smc 𝔄› and 𝔅=‹cat_smc 𝔅› and ℭ=‹cat_smc ℭ›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.cat_semicategory 𝔅.cat_semicategory ℭ.cat_semicategory
  ]:
  cat_prod_3_ObjI = smc_prod_3_ObjI 
  and cat_prod_3_ObjI'[cat_prod_cs_intros] = smc_prod_3_ObjI'
  and cat_prod_3_ObjE = smc_prod_3_ObjE
  and cat_prod_3_ArrI = smc_prod_3_ArrI
  and cat_prod_3_ArrI'[cat_prod_cs_intros] = smc_prod_3_ArrI'
  and cat_prod_3_ArrE = smc_prod_3_ArrE
  and cat_prod_3_is_arrI = smc_prod_3_is_arrI
  and cat_prod_3_is_arrI'[cat_prod_cs_intros] = smc_prod_3_is_arrI'
  and cat_prod_3_is_arrE = smc_prod_3_is_arrE
  and cat_prod_3_Dom_vsv = smc_prod_3_Dom_vsv
  and cat_prod_3_Dom_vdomain[cat_cs_simps] = smc_prod_3_Dom_vdomain
  and cat_prod_3_Dom_app[cat_prod_cs_simps] = smc_prod_3_Dom_app
  and cat_prod_3_Dom_vrange = smc_prod_3_Dom_vrange
  and cat_prod_3_Cod_vsv = smc_prod_3_Cod_vsv
  and cat_prod_3_Cod_vdomain[cat_cs_simps] = smc_prod_3_Cod_vdomain
  and cat_prod_3_Cod_app[cat_prod_cs_simps] = smc_prod_3_Cod_app
  and cat_prod_3_Cod_vrange = smc_prod_3_Cod_vrange

lemmas_with 
  [
    where 𝔄=‹cat_smc 𝔄› and 𝔅=‹cat_smc 𝔅› and ℭ=‹cat_smc ℭ›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.cat_semicategory 𝔅.cat_semicategory ℭ.cat_semicategory
  ]:
  cat_prod_3_Comp_app[cat_prod_cs_simps] = smc_prod_3_Comp_app

end


subsubsection‹Product of three categories is a category›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅" and ℭ: "category α ℭ"
begin

interpretation 𝒵 α by (rule categoryD[OF 𝔄])
interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)
interpretation ℭ: category α ℭ by (rule ℭ)

lemma finite_pcategory_cat_prod_3: "finite_pcategory α (3ℕ) (if3 𝔄 𝔅 ℭ)"
proof(intro finite_pcategoryI pcategory_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "3ℕ ∈∘ Vset α" by blast
  show "category α (if3 𝔄 𝔅 ℭ i)" if "i ∈∘ 3ℕ" for i
    by (auto simp: cat_cs_intros)
qed auto

interpretation finite_pcategory α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_pcategory_cat_prod_3 𝔄 𝔅 ℭ)

lemma category_cat_prod_3[cat_cs_intros]: "category α (𝔄 ×C3 𝔅 ×C3 ℭ)"
  unfolding cat_prod_3_def by (rule pcat_category_cat_prod)

end


subsubsection‹Identity›

lemma cat_prod_3_CId_vsv[cat_cs_intros]: "vsv ((𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈)"
  unfolding cat_prod_3_def cat_prod_components by simp

lemma cat_prod_3_CId_vdomain[cat_cs_simps]: 
  "𝒟∘ ((𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈) = (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
  unfolding cat_prod_3_def cat_prod_components by simp

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅" and ℭ: "category α ℭ"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)
interpretation ℭ: category α ℭ by (rule ℭ)

interpretation finite_pcategory α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_pcategory_cat_prod_3 𝔄 𝔅 ℭ)

lemma cat_prod_3_CId_app[cat_prod_cs_simps]:
  assumes "[a, b, c]∘ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
  shows "(𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈⦇a, b, c⦈∙ = [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈, ℭ⦇CId⦈⦇c⦈]∘"
proof-
  have "(𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈⦇a, b, c⦈∙ = 
    (λi∈∘3ℕ. if3 𝔄 𝔅 ℭ i⦇CId⦈⦇[a, b, c]∘⦇i⦈⦈)"
    by 
      (
        rule 
          cat_prod_CId_app[
            OF assms[unfolded cat_prod_3_def], folded cat_prod_3_def
            ]
      )
  also have 
    "(λi∈∘3ℕ. if3 𝔄 𝔅 ℭ i⦇CId⦈⦇[a, b, c]∘⦇i⦈⦈) = [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈, ℭ⦇CId⦈⦇c⦈]∘"
  proof(rule vsv_eqI, unfold vdomain_VLambda)
    fix i assume "i ∈∘ 3ℕ"
    then consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› unfolding three by auto
    then show 
      "(λi∈∘3ℕ. (if3 𝔄 𝔅 ℭ i)⦇CId⦈⦇[a, b, c]∘⦇i⦈⦈)⦇i⦈ = 
        [𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈, ℭ⦇CId⦈⦇c⦈]∘⦇i⦈"
      by cases (simp_all add: three nat_omega_simps)
  qed (auto simp: three nat_omega_simps)
  finally show ?thesis by simp
qed

lemma cat_prod_3_CId_vrange: 
  "ℛ∘ ((𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈) ⊆∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold cat_cs_simps)
  show "vsv ((𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈)" by (rule cat_prod_3_CId_vsv)
  fix abc assume "abc ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
  then obtain a b c where abc_def: "abc = [a, b, c]∘" 
    and a: "a ∈∘ 𝔄⦇Obj⦈" 
    and b: "b ∈∘ 𝔅⦇Obj⦈"
    and c: "c ∈∘ ℭ⦇Obj⦈"
    by (elim cat_prod_3_ObjE[OF 𝔄 𝔅 ℭ])
  from 𝔄 𝔅 ℭ a b c show "(𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈⦇abc⦈ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈"
    unfolding abc_def 
    by (cs_concl cs_intro: cat_cs_intros cat_prod_cs_intros)
qed

end



subsection‹
Conversion of a product of three categories to products of two categories
›

definition cf_cat_prod_21_of_3 :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ =
    [
      (λA∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈. [[A⦇0⦈, A⦇1ℕ⦈]∘, A⦇2ℕ⦈]∘),
      (λF∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈. [[F⦇0⦈, F⦇1ℕ⦈]∘, F⦇2ℕ⦈]∘),
      𝔄 ×C3 𝔅 ×C3 ℭ,
      (𝔄 ×C 𝔅) ×C ℭ
    ]∘"

definition cf_cat_prod_12_of_3 :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ =
    [
      (λA∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈. [A⦇0⦈, [A⦇1ℕ⦈, A⦇2ℕ⦈]∘]∘),
      (λF∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈. [F⦇0⦈, [F⦇1ℕ⦈, F⦇2ℕ⦈]∘]∘),
      𝔄 ×C3 𝔅 ×C3 ℭ,
      𝔄 ×C (𝔅 ×C ℭ)
    ]∘"


text‹Components.›

lemma cf_cat_prod_21_of_3_components:
  shows "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈ =
    (λA∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈. [[A⦇0⦈, A⦇1ℕ⦈]∘, A⦇2ℕ⦈]∘)"
    and "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈ =
    (λF∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈. [[F⦇0⦈, F⦇1ℕ⦈]∘, F⦇2ℕ⦈]∘)"
    and [cat_cs_simps]: "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇HomDom⦈ = 𝔄 ×C3 𝔅 ×C3 ℭ"
    and [cat_cs_simps]: "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇HomCod⦈ = (𝔄 ×C 𝔅) ×C ℭ"
  unfolding cf_cat_prod_21_of_3_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)

lemma cf_cat_prod_12_of_3_components:
  shows "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈ =
    (λA∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈. [A⦇0⦈, [A⦇1ℕ⦈, A⦇2ℕ⦈]∘]∘)"
    and "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈ =
    (λF∈∘(𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈. [F⦇0⦈, [F⦇1ℕ⦈, F⦇2ℕ⦈]∘]∘)"
    and [cat_cs_simps]: "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇HomDom⦈ = 𝔄 ×C3 𝔅 ×C3 ℭ"
    and [cat_cs_simps]: "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇HomCod⦈ = 𝔄 ×C (𝔅 ×C ℭ)"
  unfolding cf_cat_prod_12_of_3_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Object›

mk_VLambda cf_cat_prod_21_of_3_components(1)
  |vsv cf_cat_prod_21_of_3_ObjMap_vsv[cat_cs_intros]|
  |vdomain cf_cat_prod_21_of_3_ObjMap_vdomain[cat_cs_simps]|
  |app cf_cat_prod_21_of_3_ObjMap_app'|

mk_VLambda cf_cat_prod_12_of_3_components(1)
  |vsv cf_cat_prod_12_of_3_ObjMap_vsv[cat_cs_intros]|
  |vdomain cf_cat_prod_12_of_3_ObjMap_vdomain[cat_cs_simps]|
  |app cf_cat_prod_12_of_3_ObjMap_app'|

lemma cf_cat_prod_21_of_3_ObjMap_app[cat_cs_simps]:
  assumes "A = [a, b, c]∘" and "[a, b, c]∘ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
  shows "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ = [[a, b]∘, c]∘"
  using assms(2) 
  unfolding assms(1)
  by (simp add: cf_cat_prod_21_of_3_ObjMap_app' nat_omega_simps)

lemma cf_cat_prod_12_of_3_ObjMap_app[cat_cs_simps]:
  assumes "A = [a, b, c]∘" and "[a, b, c]∘ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
  shows "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ = [a, [b, c]∘]∘"
  using assms(2)
  unfolding assms(1)
  by (simp add: cf_cat_prod_12_of_3_ObjMap_app' nat_omega_simps)

lemma cf_cat_prod_21_of_3_ObjMap_vrange: 
  assumes "category α 𝔄" and "category α 𝔅" and "category α ℭ"
  shows "ℛ∘ (cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈) ⊆∘ ((𝔄 ×C 𝔅) ×C ℭ)⦇Obj⦈"
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret ℭ: category α ℭ by (rule assms(3))
  show ?thesis
  proof(rule vsv.vsv_vrange_vsubset, unfold cf_cat_prod_21_of_3_ObjMap_vdomain)
    fix A assume prems: "A ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
    then show "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ ∈∘ ((𝔄 ×C 𝔅) ×C ℭ)⦇Obj⦈"
      by (elim cat_prod_3_ObjE[OF assms], insert prems, simp only:)
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_prod_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (cs_concl cs_shallow cs_intro: cat_cs_intros)
qed

lemma cf_cat_prod_12_of_3_ObjMap_vrange: 
  assumes "category α 𝔄" and "category α 𝔅" and "category α ℭ"
  shows "ℛ∘ (cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈) ⊆∘ (𝔄 ×C (𝔅 ×C ℭ))⦇Obj⦈"
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret ℭ: category α ℭ by (rule assms(3))
  show ?thesis
  proof(rule vsv.vsv_vrange_vsubset, unfold cf_cat_prod_12_of_3_ObjMap_vdomain)
    fix A assume prems: "A ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈"
    then show "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ ∈∘ (𝔄 ×C (𝔅 ×C ℭ))⦇Obj⦈"
      by (elim cat_prod_3_ObjE[OF assms], insert prems, simp only:)
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_prod_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (cs_concl cs_shallow cs_intro: cat_cs_intros)
qed


subsubsection‹Arrow›

mk_VLambda cf_cat_prod_21_of_3_components(2)
  |vsv cf_cat_prod_21_of_3_ArrMap_vsv[cat_cs_intros]|
  |vdomain cf_cat_prod_21_of_3_ArrMap_vdomain[cat_cs_simps]|
  |app cf_cat_prod_21_of_3_ArrMap_app'|

mk_VLambda cf_cat_prod_12_of_3_components(2)
  |vsv cf_cat_prod_12_of_3_ArrMap_vsv[cat_cs_intros]|
  |vdomain cf_cat_prod_12_of_3_ArrMap_vdomain[cat_cs_simps]|
  |app cf_cat_prod_12_of_3_ArrMap_app'|

lemma cf_cat_prod_21_of_3_ArrMap_app[cat_cs_simps]:
  assumes "F = [h, g, f]∘" and "[h, g, f]∘ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈"
  shows "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈ = [[h, g]∘, f]∘"
  using assms(2) unfolding assms(1)
  by (simp add: cf_cat_prod_21_of_3_ArrMap_app' nat_omega_simps)

lemma cf_cat_prod_12_of_3_ArrMap_app[cat_cs_simps]:
  assumes "F = [h, g, f]∘" and "[h, g, f]∘ ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Arr⦈"
  shows "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈ = [h, [g, f]∘]∘"
  using assms(2) 
  unfolding assms(1)
  by (simp add: cf_cat_prod_12_of_3_ArrMap_app' nat_omega_simps)


subsubsection‹
Conversion of a product of three categories to products 
of two categories is a functor
›

lemma cf_cat_prod_21_of_3_is_functor:
  assumes "category α 𝔄" and "category α 𝔅" and "category α ℭ"
  shows "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ : 𝔄 ×C3 𝔅 ×C3 ℭ ↦↦C⇘α⇙ (𝔄 ×C 𝔅) ×C ℭ"
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret ℭ: category α ℭ by (rule assms(3))

  show ?thesis
  proof(rule is_functorI')
    show "vfsequence (cf_cat_prod_21_of_3 𝔄 𝔅 ℭ)"
      unfolding cf_cat_prod_21_of_3_def by auto
    show "vcard (cf_cat_prod_21_of_3 𝔄 𝔅 ℭ) = 4ℕ"
      unfolding cf_cat_prod_21_of_3_def by (simp add: nat_omega_simps)
    show "ℛ∘ (cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈) ⊆∘ ((𝔄 ×C 𝔅) ×C ℭ)⦇Obj⦈"
      by (rule cf_cat_prod_21_of_3_ObjMap_vrange[OF assms])
    show 
      "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈ : 
        cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ ↦⇘(𝔄 ×C 𝔅) ×C ℭ⇙ 
        cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇B⦈"
      if "F : A ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ B"
      for A B F
      using that
      by (elim cat_prod_3_is_arrE[OF assms], insert that, simp only:)
        (
          cs_concl 
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
        )
    show 
      "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇G ∘A⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ F⦈ = 
        cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇G⦈ ∘A⇘(𝔄 ×C 𝔅) ×C ℭ⇙ 
        cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈"
      if "G : B ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ C" and "F : A ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ B"
      for B C G A F
    proof- 
      from that(2) obtain f f' f'' a a' a'' b b' b''
        where F_def: "F = [f, f', f'']∘"
          and A_def: "A = [a, a', a'']∘"
          and B_def: "B = [b, b', b'']∘"
          and f: "f : a ↦⇘𝔄⇙ b"
          and f': "f' : a' ↦⇘𝔅⇙ b'"
          and f'': "f'' : a'' ↦⇘ℭ⇙ b''"
        by (elim cat_prod_3_is_arrE[OF assms])
      with that(1) obtain g g' g'' c c' c''
        where G_def: "G = [g, g', g'']∘"
          and C_def: "C = [c, c', c'']∘"
          and g: "g : b ↦⇘𝔄⇙ c"
          and g': "g' : b' ↦⇘𝔅⇙ c'"
          and g'': "g'' : b'' ↦⇘ℭ⇙ c''"
        by (auto elim: cat_prod_3_is_arrE[OF assms])
      from that f f' f'' g g' g'' show ?thesis
        unfolding F_def A_def B_def G_def C_def
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cat_prod_cs_simps 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show 
      "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇(𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈⦇C⦈⦈ =
        ((𝔄 ×C 𝔅) ×C ℭ)⦇CId⦈⦇cf_cat_prod_21_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇C⦈⦈"
      if "C ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈" for C
      using that 
      by (elim cat_prod_3_ObjE[OF assms], insert that, simp only: )
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_prod_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

qed

lemma cf_cat_prod_21_of_3_is_functor'[cat_cs_intros]:
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "category α ℭ"
    and "𝔄' = 𝔄 ×C3 𝔅 ×C3 ℭ"
    and "𝔅' = (𝔄 ×C 𝔅) ×C ℭ"
  shows "cf_cat_prod_21_of_3 𝔄 𝔅 ℭ : 𝔄' ↦↦C⇘α⇙ 𝔅'"
  using assms(1-3) unfolding assms(4,5) by (rule cf_cat_prod_21_of_3_is_functor)

lemma cf_cat_prod_12_of_3_is_functor:
  assumes "category α 𝔄" and "category α 𝔅" and "category α ℭ"
  shows "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ : 𝔄 ×C3 𝔅 ×C3 ℭ ↦↦C⇘α⇙ 𝔄 ×C (𝔅 ×C ℭ)"
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret ℭ: category α ℭ by (rule assms(3))

  show ?thesis
  proof(rule is_functorI')
    show "vfsequence (cf_cat_prod_12_of_3 𝔄 𝔅 ℭ)"
      unfolding cf_cat_prod_12_of_3_def by auto
    show "vcard (cf_cat_prod_12_of_3 𝔄 𝔅 ℭ) = 4ℕ"
      unfolding cf_cat_prod_12_of_3_def by (simp add: nat_omega_simps)
    show "ℛ∘ (cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈) ⊆∘ (𝔄 ×C (𝔅 ×C ℭ))⦇Obj⦈"
      by (rule cf_cat_prod_12_of_3_ObjMap_vrange[OF assms])
    show 
      "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈ :
        cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇A⦈ ↦⇘𝔄 ×C (𝔅 ×C ℭ)⇙ 
        cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇B⦈"
      if "F : A ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ B"
      for A B F
      using that
      by (elim cat_prod_3_is_arrE[OF assms], insert that, simp only:)
        (
          cs_concl 
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
        )
    show 
      "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇G ∘A⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ F⦈ = 
        cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇G⦈ ∘A⇘𝔄 ×C (𝔅 ×C ℭ)⇙ 
        cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇F⦈"
      if "G : B ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ C" and "F : A ↦⇘𝔄 ×C3 𝔅 ×C3 ℭ⇙ B"
      for B C G A F
    proof- 
      from that(2) obtain f f' f'' a a' a'' b b' b''
        where F_def: "F = [f, f', f'']∘"
          and A_def: "A = [a, a', a'']∘"
          and B_def: "B = [b, b', b'']∘"
          and f: "f : a ↦⇘𝔄⇙ b"
          and f': "f' : a' ↦⇘𝔅⇙ b'"
          and f'': "f'' : a'' ↦⇘ℭ⇙ b''"
        by (elim cat_prod_3_is_arrE[OF assms])
      with that(1) obtain g g' g'' c c' c''
        where G_def: "G = [g, g', g'']∘"
          and C_def: "C = [c, c', c'']∘"
          and g: "g : b ↦⇘𝔄⇙ c"
          and g': "g' : b' ↦⇘𝔅⇙ c'"
          and g'': "g'' : b'' ↦⇘ℭ⇙ c''"
        by (auto elim: cat_prod_3_is_arrE[OF assms])
      from that f f' f'' g g' g'' show ?thesis
        unfolding F_def A_def B_def G_def C_def
        by
          (
            cs_concl cs_shallow 
              cs_simp: cat_cs_simps cat_prod_cs_simps 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show 
      "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ArrMap⦈⦇(𝔄 ×C3 𝔅 ×C3 ℭ)⦇CId⦈⦇C⦈⦈ =
        (𝔄 ×C (𝔅 ×C ℭ))⦇CId⦈⦇cf_cat_prod_12_of_3 𝔄 𝔅 ℭ⦇ObjMap⦈⦇C⦈⦈"
      if "C ∈∘ (𝔄 ×C3 𝔅 ×C3 ℭ)⦇Obj⦈" for C
      using that 
      by (elim cat_prod_3_ObjE[OF assms], insert that, simp only: )
        (
          cs_concl cs_shallow 
            cs_simp: cat_cs_simps cat_prod_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

qed

lemma cf_cat_prod_12_of_3_is_functor'[cat_cs_intros]:
  assumes "category α 𝔄" 
    and "category α 𝔅" 
    and "category α ℭ"
    and "𝔄' = 𝔄 ×C3 𝔅 ×C3 ℭ"
    and "𝔅' = 𝔄 ×C (𝔅 ×C ℭ)"
  shows "cf_cat_prod_12_of_3 𝔄 𝔅 ℭ : 𝔄' ↦↦C⇘α⇙ 𝔅'"
  using assms(1-3) unfolding assms(4,5) by (rule cf_cat_prod_12_of_3_is_functor)



subsection‹Bifunctors›

text‹
A bifunctor is defined as a functor from a product of two categories
to a category (see Chapter II-3 in cite‹"mac_lane_categories_2010"›).
This subsection exposes the elementary properties of the projections of the 
bifunctors established by fixing an argument in a functor (see Chapter II-3 
in cite‹"mac_lane_categories_2010"› for further information).
›


subsubsection‹Definitions and elementary properties›

definition bifunctor_proj_fst :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  (‹(_⇘_,_⇙/'(/-,_/')/CF)› [51, 51, 51, 51] 51)
  where "𝔖⇘𝔄,𝔅⇙(-,b)CF =
    (𝔖⇘∏Ci∈∘2ℕ -∘ set {1ℕ}. (i = 0 ? 𝔄 : 𝔅),𝔖⦇HomCod⦈⇙(-,set {⟨1ℕ, b⟩})) ∘CF
      cf_singleton 0 𝔄"

definition bifunctor_proj_snd :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  (‹(_⇘_,_⇙/'(/_,-/')/CF)› [51, 51, 51, 51] 51)
  where "𝔖⇘𝔄,𝔅⇙(a,-)CF =
    (𝔖⇘∏Ci∈∘2ℕ -∘ set {0}. (i = 0 ? 𝔄 : 𝔅),𝔖⦇HomCod⦈⇙(-,set {⟨0, a⟩})) ∘CF
      cf_singleton (1ℕ) 𝔅"

abbreviation bcf_ObjMap_app :: "V ⇒ V ⇒ V ⇒ V" (infixl "⊗HM.Oı" 55)
  where "a ⊗HM.O⇘𝔖⇙ b ≡ 𝔖⦇ObjMap⦈⦇a, b⦈∙"
abbreviation bcf_ArrMap_app :: "V ⇒ V ⇒ V ⇒ V" (infixl "⊗HM.Aı" 55)
  where "g ⊗HM.A⇘𝔖⇙ f ≡ 𝔖⦇ArrMap⦈⦇g, f⦈∙"


text‹Elementary properties.›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)
interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemma cat_singleton_qm_fst_def[simp]: 
  "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅)) = (∏Ci∈∘set {0}. 𝔄)"
proof(rule cat_eqI[of α])
  show "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Obj⦈ = (∏Ci∈∘set {0}. 𝔄)⦇Obj⦈"
    unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
  show [simp]: "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Arr⦈ = (∏Ci∈∘set {0}. 𝔄)⦇Arr⦈"
    unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
  show [simp]: "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Dom⦈ = (∏Ci∈∘set {0}. 𝔄)⦇Dom⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
  show [simp]: 
    "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Cod⦈ = (∏Ci∈∘set {0}. 𝔄)⦇Cod⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
  have [simp]: 
    "f : a ↦⇘∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅)⇙ b ⟷ 
      f : a ↦⇘∏Ci∈∘set {0}. 𝔄⇙ b"
    for f a b
    unfolding is_arr_def by simp
  show "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈ = (∏Ci∈∘set {0}. 𝔄)⦇Comp⦈"
  proof(rule vsv_eqI)
    show "vsv ((∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈)"
      unfolding cat_prod_components by simp
    show "vsv ((∏Ci∈∘set {0}. 𝔄)⦇Comp⦈)"
      unfolding cat_prod_components by simp
    show "𝒟∘ ((∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈) = 
      𝒟∘ ((∏Ci∈∘set {0}. 𝔄)⦇Comp⦈)"
      by (simp add: composable_arrs_def cat_cs_simps)
    show "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈⦇gf⦈ = 
      (∏Ci∈∘set {0}. 𝔄)⦇Comp⦈⦇gf⦈"
      if "gf ∈∘ 𝒟∘ ((∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈)" for gf
    proof-
      from that have "gf ∈∘ composable_arrs (∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))"
        by (simp add: cat_cs_simps)
      then obtain g f a b c where gf_def: "gf = [g, f]∘" 
        and g: "g : b ↦⇘(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⇙ c" 
        and f: "f : a ↦⇘(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⇙ b"
        by clarsimp
      then have g': "g : b ↦⇘(∏Ci∈∘set {0}. 𝔄)⇙ c" 
        and f': "f : a ↦⇘(∏Ci∈∘set {0}. 𝔄)⇙ b"
        by simp_all
      show ?thesis
        unfolding gf_def
        unfolding cat_prod_Comp_app[OF g f] cat_prod_Comp_app[OF g' f']
        by (subst (1 2) VLambda_vsingleton_def) simp
    qed
  qed
  show "(∏Ci∈∘set {0}. (i = 0 ? 𝔄 : 𝔅))⦇CId⦈ = (∏Ci∈∘set {0}. 𝔄)⦇CId⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp    
qed 
  (
    simp_all add: 
      𝔄.cat_category_cat_singleton
      pcategory.pcat_category_cat_prod 
      pcat_vsubset_index_pcategory 
      vsubset_vsingleton_leftI
  )

lemma cat_singleton_qm_snd_def[simp]: 
  "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅)) = (∏Ci∈∘set {1ℕ}. 𝔅)"
proof(rule cat_eqI[of α])
  show "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Obj⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇Obj⦈"
    unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
  show [simp]: 
    "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Arr⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇Arr⦈"
    unfolding cat_prod_components by (subst vproduct_vsingleton_def) simp
  show [simp]: 
    "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Dom⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇Dom⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
  show [simp]: 
    "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Cod⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇Cod⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp
  have [simp]: "f : a ↦⇘∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅)⇙ b ⟷ 
    f : a ↦⇘∏Ci∈∘set {1ℕ}. 𝔅⇙ b"
    for f a b
    unfolding is_arr_def by simp
  show "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇Comp⦈"
  proof(rule vsv_eqI)
    show "vsv ((∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈)"
      unfolding cat_prod_components by simp
    show "vsv ((∏Ci∈∘set {1ℕ}. 𝔅)⦇Comp⦈)"
      unfolding cat_prod_components by simp
    show "𝒟∘ ((∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈) = 
      𝒟∘ ((∏Ci∈∘set {1ℕ}. 𝔅)⦇Comp⦈)"
      by (simp add: composable_arrs_def cat_cs_simps)
    show "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈⦇gf⦈ = 
      (∏Ci∈∘set {1ℕ}. 𝔅)⦇Comp⦈⦇gf⦈"
      if "gf ∈∘ 𝒟∘ ((∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇Comp⦈)" for gf
    proof-
      from that have "gf ∈∘ composable_arrs (∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))"
        by (simp add: cat_cs_simps)
      then obtain g f a b c where gf_def: "gf = [g, f]∘" 
        and g: "g : b ↦⇘(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⇙ c" 
        and f: "f : a ↦⇘(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⇙ b"
        by clarsimp
      then have g': "g : b ↦⇘(∏Ci∈∘set {1ℕ}. 𝔅)⇙ c" 
        and f': "f : a ↦⇘(∏Ci∈∘set {1ℕ}. 𝔅)⇙ b"
        by simp_all
      show ?thesis
        unfolding gf_def
        unfolding cat_prod_Comp_app[OF g f] cat_prod_Comp_app[OF g' f']
        by (subst (1 2) VLambda_vsingleton_def) simp
    qed
  qed
  show "(∏Ci∈∘set {1ℕ}. (i = 0 ? 𝔄 : 𝔅))⦇CId⦈ = (∏Ci∈∘set {1ℕ}. 𝔅)⦇CId⦈"
    unfolding cat_prod_components 
    by (subst vproduct_vsingleton_def, subst (1 2) VLambda_vsingleton_def) simp    
qed 
  (
    simp_all add: 
      𝔅.cat_category_cat_singleton
      pcategory.pcat_category_cat_prod 
      pcat_vsubset_index_pcategory 
      vsubset_vsingleton_leftI
  )

end


subsubsection‹Object map›

context
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemmas_with [OF 𝔄.category_axioms 𝔅.category_axioms, simp]:
  cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

lemma bifunctor_proj_fst_ObjMap_app[cat_cs_simps]:
  assumes "[a, b]∘ ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
  shows "(𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈ = 𝔖⦇ObjMap⦈⦇a, b⦈∙"
proof-

  let ?𝔇 = ‹𝔖⦇HomCod⦈›
  let ?𝔖 = ‹𝔖⇘∏Ci∈∘2ℕ-∘set {1ℕ}.(i = 0 ? 𝔄 : 𝔅),?𝔇⇙(-,set {⟨1ℕ, b⟩})›
  let ?cfs = ‹cf_singleton 0 𝔄›

  from assms have a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈"
    by (all‹elim cat_prod_2_ObjE[OF 𝔄 𝔅]›) auto

  from a have za: "set {⟨0, a⟩} ∈∘ (∏Ci∈∘set {0}. 𝔄)⦇Obj⦈"
    by (intro cat_singleton_ObjI[where a=a]) simp
  have [simp]: "vinsert ⟨0, a⟩ (set {⟨1ℕ, b⟩}) = [a, b]∘"
    using ord_of_nat_succ_vempty unfolding vcons_def
    by (simp add: vinsert_vempty insert_commute vinsert_vsingleton)

  have "(𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈ = (?𝔖⦇ObjMap⦈ ∘∘ ?cfs⦇ObjMap⦈)⦇a⦈"
    unfolding bifunctor_proj_fst_def dghm_comp_components by simp
  also have "… = ?𝔖⦇ObjMap⦈⦇?cfs⦇ObjMap⦈⦇a⦈⦈"
    by (rule vsv_vcomp_at)
      (
        simp_all add:
          two a za
          cf_singleton_components 
          prodfunctor_proj_components 
          cf_singleton_ObjMap_app 
          
      ) 
  also from za have "… = 𝔖⦇ObjMap⦈⦇a, b⦈∙" 
    unfolding two cf_singleton_ObjMap_app[OF a] prodfunctor_proj_components 
    by simp
  finally show ?thesis by simp

qed

lemma bifunctor_proj_snd_ObjMap_app[cat_cs_simps]:
  assumes "[a, b]∘ ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
  shows "(𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈ = 𝔖⦇ObjMap⦈⦇a, b⦈∙"
proof-

  let ?𝔇 = ‹𝔖⦇HomCod⦈›
  let ?𝔖 = ‹𝔖⇘∏Ci∈∘2ℕ-∘set {0}.(i = 0 ? 𝔄 : 𝔅),?𝔇⇙(-,set {⟨0, a⟩})›
  let ?cfs = ‹cf_singleton (1ℕ) 𝔅›

  from assms have a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈"
    by (all‹elim cat_prod_2_ObjE[OF 𝔄 𝔅]›) auto
  from a have za: "set {⟨0, a⟩} ∈∘ (∏Ci∈∘set {0}. 𝔄)⦇Obj⦈"
    by (intro cat_singleton_ObjI[where a=a]) simp
  from b have ob: "set {⟨1ℕ, b⟩} ∈∘ (∏Ci∈∘set {1ℕ}. 𝔅)⦇Obj⦈"
    by (intro cat_singleton_ObjI[where a=b]) simp
  have[simp]: "vinsert ⟨1ℕ, b⟩ (set {⟨0, a⟩}) = [a, b]∘"
    using ord_of_nat_succ_vempty unfolding vcons_def
    by (simp add: vinsert_vempty)

  have "(𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈ = (?𝔖⦇ObjMap⦈ ∘∘ ?cfs⦇ObjMap⦈)⦇b⦈"
    unfolding bifunctor_proj_snd_def dghm_comp_components by simp
  also have "… = ?𝔖⦇ObjMap⦈⦇?cfs⦇ObjMap⦈⦇b⦈⦈"
    by (rule vsv_vcomp_at)
      (
        simp_all add: 
          two
          cf_singleton_components 
          prodfunctor_proj_components 
          cf_singleton_ObjMap_app 
          ob b
      ) 
  also from ob have "… = 𝔖⦇ObjMap⦈⦇a, b⦈∙" 
    unfolding two cf_singleton_ObjMap_app[OF b] prodfunctor_proj_components 
    by simp
  finally show ?thesis by simp

qed

end


subsubsection‹Arrow map›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemmas_with [OF 𝔄.category_axioms 𝔅.category_axioms, simp]:
  cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

lemma bifunctor_proj_fst_ArrMap_app[cat_cs_simps]:
  assumes "b ∈∘ 𝔅⦇Obj⦈" and "f ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈⦇f⦈ = 𝔖⦇ArrMap⦈⦇f, 𝔅⦇CId⦈⦇b⦈⦈∙"
proof-

  let ?𝔇 = ‹𝔖⦇HomCod⦈›
  let ?𝔖 = ‹𝔖⇘∏Ci∈∘2ℕ-∘set {1ℕ}.(i = 0 ? 𝔄 : 𝔅),?𝔇⇙(-,set {⟨1ℕ, b⟩})›
  let ?cfs = ‹cf_singleton 0 𝔄›

  from assms(1) have "𝔅⦇CId⦈⦇b⦈ : b ↦⇘𝔅⇙ b" by (auto intro: cat_cs_intros)
  then have CId_b: "𝔅⦇CId⦈⦇b⦈ ∈∘ 𝔅⦇Arr⦈" by auto

  from assms(2) have zf: "set {⟨0, f⟩} ∈∘ (∏Ci∈∘set {0}. 𝔄)⦇Arr⦈"
    by (intro cat_singleton_ArrI[where a=f]) simp
  from assms(1) have ob: "set {⟨1ℕ, b⟩} ∈∘ (∏Ci∈∘set {1ℕ}. 𝔅)⦇Obj⦈"
    by (intro cat_singleton_ObjI[where a=b]) simp
  have [simp]: "vinsert ⟨0, f⟩ (set {⟨1ℕ, 𝔅⦇CId⦈⦇b⦈⟩}) = [f, 𝔅⦇CId⦈⦇b⦈]∘"
    using ord_of_nat_succ_vempty unfolding vcons_def
    by (simp add: insert_commute ord_of_nat_vone vinsert_vempty vinsert_vsingleton)

  have "(𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈⦇f⦈ = (?𝔖⦇ArrMap⦈ ∘∘ ?cfs⦇ArrMap⦈)⦇f⦈"
    unfolding bifunctor_proj_fst_def dghm_comp_components by simp
  also have "… = ?𝔖⦇ArrMap⦈⦇?cfs⦇ArrMap⦈⦇f⦈⦈"
    by (rule vsv_vcomp_at)
      (
        simp_all add:
          two
          assms(2)
          cf_singleton_components
          prodfunctor_proj_components
          cf_singleton_ArrMap_app 
          zf
      )   
  also from assms(1) zf have "… = 𝔖⦇ArrMap⦈⦇f, 𝔅⦇CId⦈⦇b⦈⦈∙" 
    unfolding cf_singleton_ArrMap_app[OF assms(2)] prodfunctor_proj_components 
    by (simp add: two cat_singleton_CId_app[OF ob])
  finally show ?thesis by simp

qed

lemma bifunctor_proj_snd_ArrMap_app[cat_cs_simps]:
  assumes "a ∈∘ 𝔄⦇Obj⦈" and "g ∈∘ 𝔅⦇Arr⦈" 
  shows "(𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈⦇g⦈ = 𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a⦈, g⦈∙"
proof-

  let ?𝔇 = ‹𝔖⦇HomCod⦈›
  let ?𝔖 = ‹𝔖⇘∏Ci∈∘2ℕ-∘set {0}.(i = 0 ? 𝔄 : 𝔅),?𝔇⇙(-,set {⟨0, a⟩})›
  let ?cfs = ‹cf_singleton (1ℕ) 𝔅›

  from assms(1) have "𝔄⦇CId⦈⦇a⦈ : a ↦⇘𝔄⇙ a" by (auto intro: cat_cs_intros)
  then have CId_a: "𝔄⦇CId⦈⦇a⦈ ∈∘ 𝔄⦇Arr⦈" by auto

  from assms(2) have og: "set {⟨1ℕ, g⟩} ∈∘ (∏Ci∈∘set {1ℕ}. 𝔅)⦇Arr⦈"
    by (intro cat_singleton_ArrI[where a=g]) simp
  from assms(1) have ob: "set {⟨0, a⟩} ∈∘ (∏Ci∈∘set {0}. 𝔄)⦇Obj⦈"
    by (intro cat_singleton_ObjI[where a=a]) simp
  have [simp]: "vinsert ⟨1ℕ, g⟩ (set {⟨0, 𝔄⦇CId⦈⦇a⦈⟩}) = [𝔄⦇CId⦈⦇a⦈, g]∘"
    using ord_of_nat_succ_vempty unfolding vcons_def
    by (simp add: vinsert_vempty)

  have "(𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈⦇g⦈ = (?𝔖⦇ArrMap⦈ ∘∘ ?cfs⦇ArrMap⦈)⦇g⦈"
    unfolding two bifunctor_proj_snd_def dghm_comp_components by simp
  also have "… = ?𝔖⦇ArrMap⦈⦇?cfs⦇ArrMap⦈⦇g⦈⦈"
    by (rule vsv_vcomp_at)
      (
        simp_all add:
          two
          assms(2) 
          cf_singleton_components 
          prodfunctor_proj_components 
          cf_singleton_ArrMap_app 
          og
      )   
  also from assms(1) og have "… = 𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a⦈, g⦈∙" 
    unfolding cf_singleton_ArrMap_app[OF assms(2)] prodfunctor_proj_components 
    by (simp add: two cat_singleton_CId_app[OF ob])
  finally show ?thesis by simp

qed

end


subsubsection‹Bifunctor projections are functors›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "category α 𝔄" and 𝔅: "category α 𝔅"
begin

interpretation 𝔄: category α 𝔄 by (rule 𝔄)
interpretation 𝔅: category α 𝔅 by (rule 𝔅)

interpretation finite_pcategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pcategory_cat_prod_2 𝔄 𝔅)

lemmas_with [OF 𝔄.category_axioms 𝔅.category_axioms, simp]:
  cat_singleton_qm_fst_def and cat_singleton_qm_snd_def

lemma bifunctor_proj_fst_is_functor:
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝔖⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ 𝔇"
proof-

  interpret 𝔖: is_functor α ‹𝔄 ×C 𝔅› 𝔇 𝔖 by (rule assms(1))

  show ?thesis
    unfolding bifunctor_proj_fst_def
  proof
    (
      intro cf_comp_is_functorI[where 𝔅=‹(∏Ci∈∘set {0}. 𝔄)›], 
      unfold 𝔖.cf_HomCod
    )
    from assms(2) have zb: 
      "set {⟨1ℕ, b⟩} ∈∘ (∏Cj∈∘set {1ℕ}. if j = 0 then 𝔄 else 𝔅)⦇Obj⦈"
      unfolding cat_prod_components by (intro vproduct_vsingletonI) simp_all
    have o_zo: "set {1ℕ} ⊆∘ 2ℕ" by clarsimp
    from pcat_prodfunctor_proj_is_functor[
        folded cat_prod_2_def, where J=‹set {1ℕ}›, OF assms(1) zb o_zo
        ]
    show "𝔖⇘∏Ci∈∘2ℕ-∘set {1ℕ}.(i = 0 ? 𝔄 : 𝔅),𝔇⇙(-,set {⟨1ℕ, b⟩}) :
      (∏Ci∈∘set {0}. 𝔄) ↦↦C⇘α⇙ 𝔇"
      unfolding two by simp
    from category.cat_cf_singleton_is_functor[OF 𝔄.category_axioms, of 0] show 
      "cf_singleton 0 𝔄 : 𝔄 ↦↦C⇘α⇙ (∏Ci∈∘set {0}. 𝔄)"
      by force
  qed

qed

lemma bifunctor_proj_fst_is_functor'[cat_cs_intros]:
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈" and "𝔄' = 𝔄"
  shows "𝔖⇘𝔄,𝔅⇙(-,b)CF : 𝔄' ↦↦C⇘α⇙ 𝔇"
  using assms(1,2) unfolding assms(3) by (rule bifunctor_proj_fst_is_functor)

lemma bifunctor_proj_fst_ObjMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "vsv ((𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈)"
proof-
  interpret 𝔖: is_functor α 𝔄 𝔇 ‹𝔖⇘𝔄,𝔅⇙(-,b)CF›
    by (rule bifunctor_proj_fst_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ObjMap_vsv)
qed

lemma bifunctor_proj_fst_ObjMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝒟∘ ((𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret 𝔖: is_functor α 𝔄 𝔇 ‹𝔖⇘𝔄,𝔅⇙(-,b)CF›
    by (rule bifunctor_proj_fst_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ObjMap_vdomain)
qed

lemma bifunctor_proj_fst_ArrMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "vsv ((𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈)"
proof-
  interpret 𝔖: is_functor α 𝔄 𝔇 ‹𝔖⇘𝔄,𝔅⇙(-,b)CF›
    by (rule bifunctor_proj_fst_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ArrMap_vsv)
qed

lemma bifunctor_proj_fst_ArrMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝒟∘ ((𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
  interpret 𝔖: is_functor α 𝔄 𝔇 ‹𝔖⇘𝔄,𝔅⇙(-,b)CF›
    by (rule bifunctor_proj_fst_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ArrMap_vdomain)
qed

lemma bifunctor_proj_snd_is_functor:
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔖⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ 𝔇"
proof-

  interpret 𝔖: is_functor α ‹𝔄 ×C 𝔅› 𝔇 𝔖 by (rule assms(1))

  show ?thesis
    unfolding bifunctor_proj_snd_def
  proof
    (
      intro cf_comp_is_functorI[where 𝔅=‹(∏Ci∈∘set {1ℕ}. 𝔅)›], 
      unfold 𝔖.cf_HomCod
    )
    from assms(2) have zb: 
      "set {⟨0, a⟩} ∈∘ (∏Cj∈∘set {0}. if j = 0 then 𝔄 else 𝔅)⦇Obj⦈"
      unfolding cat_prod_components by (intro vproduct_vsingletonI) simp_all
    have o_zo: "set {0} ⊆∘ 2ℕ" by clarsimp
    from 
      pcat_prodfunctor_proj_is_functor[
        folded cat_prod_2_def, where J=‹set {0}›, OF assms(1) zb o_zo
        ]
    show "𝔖⇘∏Ci∈∘2ℕ-∘set {0}.(i = 0 ? 𝔄 : 𝔅),𝔇⇙(-,set {⟨0, a⟩}) :
      (∏Ci∈∘set {1ℕ}. 𝔅) ↦↦C⇘α⇙ 𝔇"
      unfolding two by simp
    from category.cat_cf_singleton_is_functor[OF 𝔅.category_axioms, of ‹1ℕ›] 
    show "cf_singleton (1ℕ) 𝔅 : 𝔅 ↦↦C⇘α⇙ (∏Ci∈∘set {1ℕ}. 𝔅)"
      by force
  qed

qed

lemma bifunctor_proj_snd_is_functor'[cat_cs_intros]:
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈" and "𝔅' = 𝔅"
  shows "𝔖⇘𝔄,𝔅⇙(a,-)CF : 𝔅' ↦↦C⇘α⇙ 𝔇"
  using assms(1,2) unfolding assms(3) by (rule bifunctor_proj_snd_is_functor)

lemma bifunctor_proj_snd_ObjMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "vsv ((𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈)"
proof-
  interpret 𝔖: is_functor α 𝔅 𝔇 ‹𝔖⇘𝔄,𝔅⇙(a,-)CF›
    by (rule bifunctor_proj_snd_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ObjMap_vsv)
qed

lemma bifunctor_proj_snd_ObjMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝒟∘ ((𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈) = 𝔅⦇Obj⦈"
proof-
  interpret 𝔖: is_functor α 𝔅 𝔇 ‹𝔖⇘𝔄,𝔅⇙(a,-)CF›
    by (rule bifunctor_proj_snd_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ObjMap_vdomain)
qed

lemma bifunctor_proj_snd_ArrMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "vsv ((𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈)"
proof-
  interpret 𝔖: is_functor α 𝔅 𝔇 ‹𝔖⇘𝔄,𝔅⇙(a,-)CF›
    by (rule bifunctor_proj_snd_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ArrMap_vsv)
qed

lemma bifunctor_proj_snd_ArrMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ 𝔇" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝒟∘ ((𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈) = 𝔅⦇Arr⦈"
proof-
  interpret 𝔖: is_functor α 𝔅 𝔇 ‹𝔖⇘𝔄,𝔅⇙(a,-)CF›
    by (rule bifunctor_proj_snd_is_functor[OF assms])
  show ?thesis by (rule 𝔖.cf_ArrMap_vdomain)
qed

end



subsection‹Bifunctor flip›


subsubsection‹Definition and elementary properties›

definition bifunctor_flip :: "V ⇒ V ⇒ V ⇒ V"
  where "bifunctor_flip 𝔄 𝔅 𝔉 =
    [fflip (𝔉⦇ObjMap⦈), fflip (𝔉⦇ArrMap⦈), 𝔅 ×C 𝔄, 𝔉⦇HomCod⦈]∘"


text‹Components›

lemma bifunctor_flip_components:
  shows "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈ = fflip (𝔉⦇ObjMap⦈)"
    and "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈ = fflip (𝔉⦇ArrMap⦈)"
    and "bifunctor_flip 𝔄 𝔅 𝔉⦇HomDom⦈ = 𝔅 ×C 𝔄"
    and "bifunctor_flip 𝔄 𝔅 𝔉⦇HomCod⦈ = 𝔉⦇HomCod⦈"
  unfolding bifunctor_flip_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Bifunctor flip object map›

lemma bifunctor_flip_ObjMap_vsv[cat_cs_intros]: 
  "vsv (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)"
  unfolding bifunctor_flip_components by (rule fflip_vsv)

lemma bifunctor_flip_ObjMap_app:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "a ∈∘ 𝔄⦇Obj⦈"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇b, a⦈∙ = 𝔉⦇ObjMap⦈⦇a, b⦈∙"
  using assms
  unfolding bifunctor_flip_components assms(4,5)
  by 
    (
      cs_concl cs_shallow 
        cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
    )

lemma bifunctor_flip_ObjMap_app'[cat_cs_simps]:
  assumes "ba = [b, a]∘"
    and "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "a ∈∘ 𝔄⦇Obj⦈"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈ = 𝔉⦇ObjMap⦈⦇a, b⦈∙"
  using assms(2-6) unfolding assms(1) by (rule bifunctor_flip_ObjMap_app)

lemma bifunctor_flip_ObjMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) = (𝔅 ×C 𝔄)⦇Obj⦈"
  using assms
  unfolding bifunctor_flip_components 
  by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

lemma bifunctor_flip_ObjMap_vrange[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) = ℛ∘ (𝔉⦇ObjMap⦈)"
proof-
  
  interpret 𝔉: is_functor α ‹𝔄 ×C 𝔅› ℭ 𝔉 by (rule assms(3))

  show ?thesis
  proof(intro vsubset_antisym)

    show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) ⊆∘ ℛ∘ (𝔉⦇ObjMap⦈)"
    proof
      (
        intro vsv.vsv_vrange_vsubset, 
        unfold bifunctor_flip_ObjMap_vdomain[OF assms]
      )
      fix ba assume "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
      then obtain a b
        where ba_def: "ba = [b, a]∘" 
          and b: "b ∈∘ 𝔅⦇Obj⦈" 
          and a: "a ∈∘ 𝔄⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF assms(2,1)])
      from assms a b show 
        "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈ ∈∘ ℛ∘ (𝔉⦇ObjMap⦈)"
        unfolding ba_def
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_prod_cs_intros
          )
    qed (auto intro: cat_cs_intros)

    show "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)"
    proof(intro vsv.vsv_vrange_vsubset, unfold 𝔉.cf_ObjMap_vdomain)
      fix ab assume prems: "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
      then obtain a b 
        where ab_def: "ab = [a, b]∘" 
          and a: "a ∈∘ 𝔄⦇Obj⦈" 
          and b: "b ∈∘ 𝔅⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF assms(1,2)])
      from assms a b have ba: "[b, a]∘ ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
        by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
      from assms bifunctor_flip_ObjMap_vsv prems a b ba show 
        "𝔉⦇ObjMap⦈⦇ab⦈ ∈∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)"
        by 
          (
            cs_concl cs_shallow 
              cs_simp: ab_def cat_cs_simps cs_intro: V_cs_intros
          )
    qed auto

  qed

qed


subsubsection‹Bifunctor flip arrow map›

lemma bifunctor_flip_ArrMap_vsv[cat_cs_intros]: 
  "vsv (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)"
  unfolding bifunctor_flip_components by (rule fflip_vsv)

lemma bifunctor_flip_ArrMap_app:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "g ∈∘ 𝔄⦇Arr⦈"
    and "f ∈∘ 𝔅⦇Arr⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇f, g⦈∙ = 𝔉⦇ArrMap⦈⦇g, f⦈∙"
  using assms
  unfolding bifunctor_flip_components
  by 
    (
      cs_concl cs_shallow 
        cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
    )

lemma bifunctor_flip_ArrMap_app'[cat_cs_simps]:
  assumes "fg = [f, g]∘"
    and "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "g ∈∘ 𝔄⦇Arr⦈"
    and "f ∈∘ 𝔅⦇Arr⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇fg⦈ = 𝔉⦇ArrMap⦈⦇g, f⦈∙"
  using assms(2-6) unfolding assms(1) by (rule bifunctor_flip_ArrMap_app)

lemma bifunctor_flip_ArrMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) = (𝔅 ×C 𝔄)⦇Arr⦈"
  using assms
  unfolding bifunctor_flip_components 
  by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

lemma bifunctor_flip_ArrMap_vrange[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) = ℛ∘ (𝔉⦇ArrMap⦈)"
proof-
  
  interpret 𝔉: is_functor α ‹𝔄 ×C 𝔅› ℭ 𝔉 by (rule assms(3))

  show ?thesis
  proof(intro vsubset_antisym)

    show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) ⊆∘ ℛ∘ (𝔉⦇ArrMap⦈)"
    proof
      (
        intro vsv.vsv_vrange_vsubset, 
        unfold bifunctor_flip_ArrMap_vdomain[OF assms]
      )
      fix fg assume "fg ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
      then obtain f g
        where fg_def: "fg = [f, g]∘" 
          and f: "f ∈∘ 𝔅⦇Arr⦈" 
          and g: "g ∈∘ 𝔄⦇Arr⦈"
        by (elim cat_prod_2_ArrE[OF assms(2,1)])
      from f obtain a b where f: "f : a ↦⇘𝔅⇙ b" by (auto intro: is_arrI)
      from g obtain a' b' where g: "g : a' ↦⇘𝔄⇙ b'" by (auto intro: is_arrI)
      from 𝔉.cf_ArrMap_vsv assms f g show 
        "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇fg⦈ ∈∘ ℛ∘ (𝔉⦇ArrMap⦈)"
        unfolding fg_def
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps 
              cs_intro: V_cs_intros cat_cs_intros cat_prod_cs_intros
          )
    qed (auto intro: cat_cs_intros)

    show "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)"
    proof(intro vsv.vsv_vrange_vsubset, unfold 𝔉.cf_ArrMap_vdomain)
      fix gf assume prems: "gf ∈∘ (𝔄 ×C 𝔅)⦇Arr⦈"
      then obtain g f 
        where gf_def: "gf = [g, f]∘" 
          and g: "g ∈∘ 𝔄⦇Arr⦈"
          and f: "f ∈∘ 𝔅⦇Arr⦈"
        by (elim cat_prod_2_ArrE[OF assms(1,2)])
      from assms g f have fg: "[f, g]∘ ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
        by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
      from assms bifunctor_flip_ArrMap_vsv prems g f fg show 
        "𝔉⦇ArrMap⦈⦇gf⦈ ∈∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)"
        unfolding gf_def
        by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: V_cs_intros)
    qed auto

  qed

qed


subsubsection‹Bifunctor flip is a bifunctor›

lemma bifunctor_flip_is_functor:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ "
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔉: is_functor α ‹𝔄 ×C 𝔅› ℭ 𝔉 by (rule assms)

  show ?thesis
  proof(intro is_functorI')
    show "vfsequence (bifunctor_flip 𝔄 𝔅 𝔉)"
      unfolding bifunctor_flip_def by simp
    from assms(1,2) show "category α (𝔅 ×C 𝔄)"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros)
    show "vcard (bifunctor_flip 𝔄 𝔅 𝔉) = 4ℕ"
      unfolding bifunctor_flip_def by (simp add: nat_omega_simps)
    show "vsv (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)" by (auto intro: cat_cs_intros)
    show "vsv (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)" by (auto intro: cat_cs_intros)
    from assms show "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) = (𝔅 ×C 𝔄)⦇Obj⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    from assms 𝔉.cf_ObjMap_vrange show 
      "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    from assms show "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) = (𝔅 ×C 𝔄)⦇Arr⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    show "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇gf⦈ :
      bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈ ↦⇘ℭ⇙
      bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇b'a'⦈"
      if "gf : ba ↦⇘𝔅 ×C 𝔄⇙ b'a'" for ba b'a' gf
    proof-
      from that obtain g f a b a' b'
        where gf_def: "gf = [g, f]∘"
          and ba_def: "ba = [b, a]∘"
          and b'a'_def: "b'a' = [b', a']∘"
          and g: "g : b ↦⇘𝔅⇙ b'"
          and f: "f : a ↦⇘𝔄⇙ a'"
        by (elim cat_prod_2_is_arrE[OF assms(2,1)])
      from assms g f show ?thesis
        unfolding gf_def ba_def b'a'_def
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show 
      "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇gg' ∘A⇘𝔅 ×C 𝔄⇙ ff'⦈ =
        bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇gg'⦈ ∘A⇘ℭ⇙ 
        bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇ff'⦈"
      if gg': "gg' : bb' ↦⇘𝔅 ×C 𝔄⇙ cc'" and ff': "ff' : aa' ↦⇘𝔅 ×C 𝔄⇙ bb'" 
      for bb' cc' gg' aa' ff'
    proof-
      obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘"
          and bb'_def: "bb' = [b, b']∘"
          and cc'_def: "cc' = [c, c']∘"   
          and g: "g : b ↦⇘𝔅⇙ c"  
          and g': "g' : b' ↦⇘𝔄⇙ c'"
        by (elim cat_prod_2_is_arrE[OF assms(2,1) gg'])
      moreover obtain f f' a a' b'' b''' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and "bb' = [b'', b''']∘"   
          and "f : a ↦⇘𝔅⇙ b''"  
          and "f' : a' ↦⇘𝔄⇙ b'''"
        by (elim cat_prod_2_is_arrE[OF assms(2,1) ff'])
      ultimately have f: "f : a ↦⇘𝔅⇙ b" and f': "f' : a' ↦⇘𝔄⇙ b'" 
        by (auto simp: cat_op_simps)
      from assms g g' f f' have [cat_cs_simps]:
        "𝔉⦇ArrMap⦈⦇g' ∘A⇘𝔄⇙ f', g ∘A⇘𝔅⇙ f⦈∙ = 
          𝔉⦇ArrMap⦈⦇[g', g]∘ ∘A⇘𝔄 ×C 𝔅⇙ [f', f]∘⦈"
        by 
          (
            cs_concl cs_shallow 
              cs_simp: cat_prod_2_Comp_app cs_intro: cat_prod_cs_intros
          )
      from assms g g' f f' show 
        "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇gg' ∘A⇘𝔅 ×C 𝔄⇙ ff'⦈ =
          bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇gg'⦈ ∘A⇘ℭ⇙
          bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇ff'⦈"
        unfolding gg'_def ff'_def (*slow*)
        by 
          (
            cs_concl cs_shallow 
              cs_simp: cat_prod_cs_simps cat_cs_simps
              cs_intro: cat_prod_cs_intros cat_cs_intros
          )
    qed
    show 
      "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇(𝔅 ×C 𝔄)⦇CId⦈⦇ba⦈⦈ = 
        ℭ⦇CId⦈⦇bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈⦈"
      if "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈" for ba
    proof-
      from that obtain b a 
        where ba_def: "ba = [b, a]∘" 
          and b: "b ∈∘ 𝔅⦇Obj⦈"
          and a: "a ∈∘ 𝔄⦇Obj⦈"
        by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
      from assms b a have [cat_cs_simps]:
        "𝔉⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a⦈, 𝔅⦇CId⦈⦇b⦈⦈∙ =
          𝔉⦇ArrMap⦈⦇(𝔄 ×C 𝔅)⦇CId⦈⦇a, b⦈∙⦈"
        by 
          (
            cs_concl cs_shallow 
              cs_simp: cat_prod_2_CId_app cs_intro: cat_prod_cs_intros
          )
      from assms b a show ?thesis
        unfolding ba_def
        by 
          (
            cs_concl cs_shallow
              cs_intro: cat_cs_intros cat_prod_cs_intros 
              cs_simp: cat_prod_cs_simps cat_cs_simps
          )
    qed
  qed (auto simp: bifunctor_flip_components cat_cs_simps cat_cs_intros)

qed

lemma bifunctor_flip_is_functor'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "𝔇 = 𝔅 ×C 𝔄"
  shows "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔇 ↦↦C⇘α⇙ ℭ"
  using assms(1-3) unfolding assms(4) by (intro bifunctor_flip_is_functor)


subsubsection‹Double-flip of a bifunctor›

lemma bifunctor_flip_flip[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉) = 𝔉"
proof(rule cf_eqI)

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔉: is_functor α ‹𝔄 ×C 𝔅› ℭ 𝔉 by (rule assms(3))

  from assms show 
    "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉) : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)

  from assms have ObjMap_dom_lhs: 
    "𝒟∘ (bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ObjMap⦈) = 
      (𝔄 ×C 𝔅)⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  have ObjMap_dom_rhs: "𝒟∘ (𝔉⦇ObjMap⦈) = (𝔄 ×C 𝔅)⦇Obj⦈" 
    by (simp add: cat_cs_simps)
  from assms have ArrMap_dom_lhs: 
    "𝒟∘ (bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ArrMap⦈) =
      (𝔄 ×C 𝔅)⦇Arr⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  have ArrMap_dom_rhs: "𝒟∘ (𝔉⦇ArrMap⦈) = (𝔄 ×C 𝔅)⦇Arr⦈" 
    by (simp add: cat_cs_simps)

  show "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
  proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
    fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
    then obtain a b
      where ab_def: "ab = [a, b]∘" and a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈" 
      by (rule cat_prod_2_ObjE[OF assms(1,2)])
    from assms a b show 
      "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ObjMap⦈⦇ab⦈ = 𝔉⦇ObjMap⦈⦇ab⦈"
      unfolding ab_def
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed (auto simp: cat_cs_intros)

  show "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
  proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
    fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Arr⦈"
    then obtain a b
      where ab_def: "ab = [a, b]∘" and a: "a ∈∘ 𝔄⦇Arr⦈" and b: "b ∈∘ 𝔅⦇Arr⦈" 
      by (rule cat_prod_2_ArrE[OF assms(1,2)])
    from assms a b show 
      "bifunctor_flip 𝔅 𝔄 (bifunctor_flip 𝔄 𝔅 𝔉)⦇ArrMap⦈⦇ab⦈ = 𝔉⦇ArrMap⦈⦇ab⦈"
      unfolding ab_def 
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed (auto simp: cat_cs_intros)

qed (simp_all add: assms(3))


subsubsection‹A projection of a bifunctor flip›

lemma bifunctor_flip_proj_snd[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF = 𝔉⇘𝔄,𝔅⇙(-,b)CF"
proof(rule cf_eqI)

  from assms show f_𝔉b: "bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  from assms show 𝔉b: "𝔉⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)

  from assms have ObjMap_dom_lhs:
    "𝒟∘ ((bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from assms have ObjMap_dom_rhs: "𝒟∘ ((𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from assms have ArrMap_dom_lhs:
    "𝒟∘ ((bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from assms have ArrMap_dom_rhs: "𝒟∘ ((𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  show "(bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ObjMap⦈ = (𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈"
  proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
    from assms show "vsv ((bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ObjMap⦈)"
      by (intro bifunctor_proj_snd_ObjMap_vsv)
        (cs_concl cs_shallow cs_intro: cat_cs_intros)
    from assms show "vsv ((𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈)"
      by (intro bifunctor_proj_fst_ObjMap_vsv)
        (cs_concl cs_shallow cs_intro: cat_cs_intros)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    with assms show 
      "(bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ObjMap⦈⦇a⦈ = 
        (𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
  qed simp

  show 
    "(bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ArrMap⦈ = (𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈"
  proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
    from assms show "vsv ((bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ArrMap⦈)"
      by (intro bifunctor_proj_snd_ArrMap_vsv)
        (cs_concl cs_shallow cs_intro: cat_cs_intros)
    from assms show "vsv ((𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈)"
      by (intro bifunctor_proj_fst_ArrMap_vsv)
        (cs_concl cs_shallow cs_intro: cat_cs_intros)
    fix f assume "f ∈∘ 𝔄⦇Arr⦈"
    with assms show 
      "(bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(b,-)CF)⦇ArrMap⦈⦇f⦈ =
        (𝔉⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈⦇f⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed simp

qed simp_all

lemma bifunctor_flip_proj_fst[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "bifunctor_flip 𝔄 𝔅 𝔉⇘𝔅,𝔄⇙(-,a)CF = 𝔉⇘𝔄,𝔅⇙(a,-)CF"
proof-
  from assms have f_𝔉: "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  show ?thesis
    by 
      (
        rule 
          bifunctor_flip_proj_snd
            [
              OF assms(2,1) f_𝔉 assms(4), 
              unfolded bifunctor_flip_flip[OF assms(1,2,3)],
              symmetric
            ]
      )
qed


subsubsection‹A flip of a bifunctor isomorphism›

lemma bifunctor_flip_is_iso_functor:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔉 : 𝔄 ×C 𝔅 ↦↦C.iso⇘α⇙ ℭ"
  shows "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔅 ×C 𝔄 ↦↦C.iso⇘α⇙ ℭ "
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔉: is_iso_functor α ‹𝔄 ×C 𝔅› ℭ 𝔉 by (rule assms(3))

  from assms have f_𝔉: "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ "
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)

  from f_𝔉 have ObjMap_dom: 
    "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) = (𝔅 ×C 𝔄)⦇Obj⦈" 
    by (cs_concl cs_simp: cat_cs_simps)
  from f_𝔉 have ArrMap_dom: 
    "𝒟∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) = (𝔅 ×C 𝔄)⦇Arr⦈" 
    by (cs_concl cs_simp: cat_cs_simps)

  show ?thesis
  proof(intro is_iso_functorI' vsv.vsv_valeq_v11I, unfold ObjMap_dom ArrMap_dom)
    from assms show "bifunctor_flip 𝔄 𝔅 𝔉 : 𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    fix ba b'a'
    assume prems: 
      "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
      "b'a' ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
      "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈ = bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇b'a'⦈"
    from prems(1) obtain b a
      where ba_def: "ba = [b, a]∘" 
        and b: "b ∈∘ 𝔅⦇Obj⦈" 
        and a: "a ∈∘ 𝔄⦇Obj⦈" 
      by (elim cat_prod_2_ObjE[OF assms(2,1)])
    from prems(2) obtain a' b'
      where b'a'_def: "b'a' = [b', a']∘" 
        and b': "b' ∈∘ 𝔅⦇Obj⦈" 
        and a': "a' ∈∘ 𝔄⦇Obj⦈" 
      by (rule cat_prod_2_ObjE[OF assms(2,1)])
    from prems(3) assms a b b' a' have 𝔉ab_𝔉a'b': 
      "𝔉⦇ObjMap⦈⦇a, b⦈∙ = 𝔉⦇ObjMap⦈⦇a', b'⦈∙"
      unfolding ba_def b'a'_def
      by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cf_cs_intros)
    from assms a b a' b' have "[a, b]∘ = [a', b']∘"
      by 
        (
          cs_concl cs_shallow
            cs_intro: 
              𝔉.ObjMap.v11_eq_iff[THEN iffD1, OF _ _ 𝔉ab_𝔉a'b'] 
              cat_prod_cs_intros
        )
    then show "ba = b'a'" unfolding ba_def b'a'_def by simp
  next
    fix fg f'g' assume prems:
      "fg ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
      "f'g' ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈" 
      "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇fg⦈ = bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇f'g'⦈"
    from prems(1) obtain f g
      where fg_def: "fg = [f, g]∘" 
        and f: "f ∈∘ 𝔅⦇Arr⦈" 
        and g: "g ∈∘ 𝔄⦇Arr⦈" 
      by (elim cat_prod_2_ArrE[OF assms(2,1)])
    from prems(2) obtain f' g'
      where f'g'_def: "f'g' = [f', g']∘" 
        and f': "f' ∈∘ 𝔅⦇Arr⦈" 
        and g': "g' ∈∘ 𝔄⦇Arr⦈" 
      by (rule cat_prod_2_ArrE[OF assms(2,1)])
    from prems(3) assms f g f' g' have 𝔉gf_𝔉g'f': 
      "𝔉⦇ArrMap⦈⦇g, f⦈∙ = 𝔉⦇ArrMap⦈⦇g', f'⦈∙"
      unfolding fg_def f'g'_def
      by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cf_cs_intros)
    from assms g f g' f' have "[g, f]∘ = [g', f']∘"
      by 
        (
          cs_concl cs_shallow
            cs_intro:
              𝔉.ArrMap.v11_eq_iff[THEN iffD1, OF _ _ 𝔉gf_𝔉g'f'] 
              cat_prod_cs_intros
        )
    then show "fg = f'g'" unfolding fg_def f'g'_def by simp
  next
    
    show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) = ℭ⦇Obj⦈"
    proof(rule vsubset_antisym)
      show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
      proof(rule vsv.vsv_vrange_vsubset, unfold ObjMap_dom)
        fix ba assume "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
        then obtain b a
          where ba_def: "ba = [b, a]∘" 
            and b: "b ∈∘ 𝔅⦇Obj⦈" 
            and a: "a ∈∘ 𝔄⦇Obj⦈" 
          by (elim cat_prod_2_ObjE[OF assms(2,1)])
        from assms b a show "bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇ba⦈ ∈∘ ℭ⦇Obj⦈"
          unfolding ba_def 
          by (cs_concl cs_intro: cat_cs_intros cf_cs_intros cat_prod_cs_intros)
      qed (auto simp: cat_cs_intros)
      show "ℭ⦇Obj⦈ ⊆∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)"
      proof(intro vsubsetI)
        fix c assume prems: "c ∈∘ ℭ⦇Obj⦈"
        from prems obtain ab 
          where ab: "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈" and 𝔉ab: "𝔉⦇ObjMap⦈⦇ab⦈ = c"
          by blast
        from ab obtain b a
          where ab_def: "ab = [a, b]∘" 
            and a: "a ∈∘ 𝔄⦇Obj⦈" 
            and b: "b ∈∘ 𝔅⦇Obj⦈" 
          by (elim cat_prod_2_ObjE[OF assms(1,2)])
        show "c ∈∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈)"
        proof(intro vsv.vsv_vimageI2', unfold ObjMap_dom)
          from assms a b show "[b, a]∘ ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
            by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
          from assms b a prems show "c = bifunctor_flip 𝔄 𝔅 𝔉⦇ObjMap⦈⦇b, a⦈∙"
            by 
              (
                cs_concl cs_shallow
                  cs_simp: 𝔉ab[unfolded ab_def] cat_cs_simps
                  cs_intro: cf_cs_intros
              )
        qed (auto intro: cat_cs_intros)
      qed
    qed

    show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) = ℭ⦇Arr⦈"
    proof(rule vsubset_antisym)
      show "ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
      proof(rule vsv.vsv_vrange_vsubset, unfold ArrMap_dom)
        show "vsv (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)" by (auto intro: cat_cs_intros)
        fix fg assume "fg ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
        then obtain f g
          where fg_def: "fg = [f, g]∘" 
            and f: "f ∈∘ 𝔅⦇Arr⦈" 
            and g: "g ∈∘ 𝔄⦇Arr⦈" 
          by (elim cat_prod_2_ArrE[OF assms(2,1)])
        from g f obtain a b a' b' 
          where f: "f : a ↦⇘𝔅⇙ b" and g: "g : a' ↦⇘𝔄⇙ b'"
          by (auto intro!: is_arrI)
        from assms f g show "bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇fg⦈ ∈∘ ℭ⦇Arr⦈"
          by 
            (
              cs_concl cs_shallow 
                cs_simp: fg_def cs_intro: cat_cs_intros cat_prod_cs_intros
            )
      qed
      show "ℭ⦇Arr⦈ ⊆∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)"
      proof(intro vsubsetI)
        fix c assume prems: "c ∈∘ ℭ⦇Arr⦈"
        from prems obtain ab 
          where ab: "ab ∈∘ (𝔄 ×C 𝔅)⦇Arr⦈" and 𝔉ab: "𝔉⦇ArrMap⦈⦇ab⦈ = c"
          by blast
        from ab obtain b a
          where ab_def: "ab = [a, b]∘" 
            and a: "a ∈∘ 𝔄⦇Arr⦈" 
            and b: "b ∈∘ 𝔅⦇Arr⦈" 
          by (elim cat_prod_2_ArrE[OF assms(1,2)])
        show "c ∈∘ ℛ∘ (bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈)"
        proof(intro vsv.vsv_vimageI2', unfold ArrMap_dom)
          from assms a b show "[b, a]∘ ∈∘ (𝔅 ×C 𝔄)⦇Arr⦈"
            by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
          from assms b a prems show "c = bifunctor_flip 𝔄 𝔅 𝔉⦇ArrMap⦈⦇b, a⦈∙"
            by 
              (
                cs_concl cs_shallow
                  cs_simp: 𝔉ab[unfolded ab_def] cat_cs_simps 
                  cs_intro: cat_cs_intros 
              )
        qed (auto intro: cat_cs_intros)
      qed
    qed

  qed (auto intro: cat_cs_intros)

qed



subsection‹Array bifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in cite‹"mac_lane_categories_2010"›.›

definition cf_array :: "V ⇒ V ⇒ V ⇒ (V ⇒ V) ⇒ (V ⇒ V) ⇒ V"
  where "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊 =
    [
      (λa∈∘(𝔅 ×C ℭ)⦇Obj⦈. 𝔊 (vpfst a)⦇ObjMap⦈⦇vpsnd a⦈),
      (
        λf∈∘(𝔅 ×C ℭ)⦇Arr⦈.
          𝔊 (𝔅⦇Cod⦈⦇vpfst f⦈)⦇ArrMap⦈⦇vpsnd f⦈ ∘A⇘𝔇⇙
          𝔉 (ℭ⦇Dom⦈⦇vpsnd f⦈)⦇ArrMap⦈⦇vpfst f⦈
      ),
      𝔅 ×C ℭ,
      𝔇
    ]∘"


text‹Components.›

lemma cf_array_components:
  shows "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈ =
    (λa∈∘(𝔅 ×C ℭ)⦇Obj⦈. 𝔊 (vpfst a)⦇ObjMap⦈⦇vpsnd a⦈)"
    and "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈ =
      (
        λf∈∘(𝔅 ×C ℭ)⦇Arr⦈.
          𝔊 (𝔅⦇Cod⦈⦇vpfst f⦈)⦇ArrMap⦈⦇vpsnd f⦈ ∘A⇘𝔇⇙
          𝔉 (ℭ⦇Dom⦈⦇vpsnd f⦈)⦇ArrMap⦈⦇vpfst f⦈
      )"
    and "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇HomDom⦈ = 𝔅 ×C ℭ"
    and "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇HomCod⦈ = 𝔇"
  unfolding cf_array_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

lemma cf_array_ObjMap_vsv: "vsv (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈)"
  unfolding cf_array_components by simp

lemma cf_array_ObjMap_vdomain[cat_cs_simps]:
  "𝒟∘ (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈) = (𝔅 ×C ℭ)⦇Obj⦈"
  unfolding cf_array_components by simp

lemma cf_array_ObjMap_app[cat_cs_simps]:
  assumes "[b, c]∘ ∈∘ (𝔅 ×C ℭ)⦇Obj⦈"
  shows "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇b, c⦈∙ = 𝔊 b⦇ObjMap⦈⦇c⦈"
  using assms unfolding cf_array_components by (simp add: nat_omega_simps)

lemma cf_array_ObjMap_vrange:
  assumes "category α 𝔅" 
    and "category α ℭ"
    and "⋀b. b ∈∘ 𝔅⦇Obj⦈ ⟹ 𝔊 b : ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold cf_array_ObjMap_vdomain)
  show "vsv (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈)" by (rule cf_array_ObjMap_vsv)
  fix x assume prems: "x ∈∘ (𝔅 ×C ℭ)⦇Obj⦈"
  then obtain b c where x_def: "x = [b, c]∘" 
    and b: "b ∈∘ 𝔅⦇Obj⦈" 
    and c: "c ∈∘ ℭ⦇Obj⦈"
    by (elim cat_prod_2_ObjE[OF assms(1,2)])
  interpret 𝔊b: is_functor α ℭ 𝔇 ‹𝔊 b› by (rule assms(3)[OF b])
  from prems c show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇x⦈ ∈∘ 𝔇⦇Obj⦈"
    unfolding x_def cf_array_components 
    by (auto simp: nat_omega_simps cat_cs_intros)
qed


subsubsection‹Arrow map›

lemma cf_array_ArrMap_vsv: "vsv (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈)"
  unfolding cf_array_components by simp

lemma cf_array_ArrMap_vdomain[cat_cs_simps]:
  "𝒟∘ (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈) = (𝔅 ×C ℭ)⦇Arr⦈"
  unfolding cf_array_components by simp

lemma cf_array_ArrMap_app[cat_cs_simps]:
  assumes "category α 𝔅"
    and "category α ℭ"
    and "g : a ↦⇘𝔅⇙ b"
    and "f : a' ↦⇘ℭ⇙ b'"
  shows "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇g, f⦈∙ = 
    𝔊 b⦇ArrMap⦈⦇f⦈ ∘A⇘𝔇⇙ 𝔉 a'⦇ArrMap⦈⦇g⦈"
proof-
  interpret 𝔅: category α 𝔅 by (rule assms(1))
  interpret ℭ: category α ℭ by (rule assms(2))
  from cat_prod_2_is_arrI[OF assms] have "[g, f]∘ ∈∘ (𝔅 ×C ℭ)⦇Arr⦈" by auto
  with assms show ?thesis
    unfolding cf_array_components by (simp add: nat_omega_simps cat_cs_simps)
qed

lemma cf_array_ArrMap_vrange:
  assumes "category α 𝔅" 
    and "category α ℭ"
    and "⋀c. c ∈∘ ℭ⦇Obj⦈ ⟹ 𝔉 c : 𝔅 ↦↦C⇘α⇙ 𝔇"
    and "⋀b. b ∈∘ 𝔅⦇Obj⦈ ⟹ 𝔊 b : ℭ ↦↦C⇘α⇙ 𝔇"
    and [cat_cs_simps]: 
      "⋀b c. b ∈∘ 𝔅⦇Obj⦈ ⟹ c ∈∘ ℭ⦇Obj⦈ ⟹ 𝔊 b⦇ObjMap⦈⦇c⦈ = 𝔉 c⦇ObjMap⦈⦇b⦈"
  shows "ℛ∘ (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold cf_array_ArrMap_vdomain)
  interpret 𝔅: category α 𝔅 by (rule assms(1))
  interpret ℭ: category α ℭ by (rule assms(2))
  interpret 𝔅ℭ: category α ‹𝔅 ×C ℭ› 
    by (simp add: 𝔅.category_axioms ℭ.category_axioms category_cat_prod_2)
  fix gf assume prems: "gf ∈∘ (𝔅 ×C ℭ)⦇Arr⦈"
  then obtain bc b'c' where gf: "gf : bc ↦⇘𝔅 ×C ℭ⇙ b'c'" by auto
  then obtain g f b c b' c'
    where gf_def: "gf = [g, f]∘" 
      and "bc = [b, c]∘" 
      and "b'c' = [b', c']∘"
      and g: "g : b ↦⇘𝔅⇙ b'" 
      and f: "f : c ↦⇘ℭ⇙ c'"
    by (elim cat_prod_2_is_arrE[OF assms(1,2)])
  then have b: "b ∈∘ 𝔅⦇Obj⦈" 
    and b': "b' ∈∘ 𝔅⦇Obj⦈" 
    and c: "c ∈∘ ℭ⦇Obj⦈" 
    and c': "c' ∈∘ ℭ⦇Obj⦈"
    by auto
  interpret 𝔊b: is_functor α ℭ 𝔇 ‹𝔊 b› by (rule assms(4)[OF b])
  interpret 𝔉c: is_functor α 𝔅 𝔇 ‹𝔉 c› by (rule assms(3)[OF c])
  interpret 𝔊b': is_functor α ℭ 𝔇 ‹𝔊 b'› by (rule assms(4)[OF b'])
  interpret 𝔉c': is_functor α 𝔅 𝔇 ‹𝔉 c'› by (rule assms(3)[OF c'])
  from 
    𝔊b.is_functor_axioms 
    𝔉c.is_functor_axioms 
    𝔊b'.is_functor_axioms 
    𝔉c'.is_functor_axioms 
    𝔊b.HomCod.category_axioms 
    g f
  have "𝔊 b'⦇ArrMap⦈⦇f⦈ ∘A⇘𝔇⇙ 𝔉 c⦇ArrMap⦈⦇g⦈ ∈∘ 𝔇⦇Arr⦈"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  with g f prems show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇gf⦈ ∈∘ 𝔇⦇Arr⦈"
    unfolding gf_def cf_array_components 
    by (simp add: nat_omega_simps cat_cs_simps)
qed (simp add: cf_array_ArrMap_vsv)


subsubsection‹Array bifunctor is a bifunctor›

lemma cf_array_specification:
  ―‹See Proposition 1 from Chapter II-3 in \cite{mac_lane_categories_2010}.›
  assumes "category α 𝔅"
    and "category α ℭ"
    and "category α 𝔇"
    and "⋀c. c ∈∘ ℭ⦇Obj⦈ ⟹ 𝔉 c : 𝔅 ↦↦C⇘α⇙ 𝔇"
    and "⋀b. b ∈∘ 𝔅⦇Obj⦈ ⟹ 𝔊 b : ℭ ↦↦C⇘α⇙ 𝔇"
    and "⋀b c. b ∈∘ 𝔅⦇Obj⦈ ⟹ c ∈∘ ℭ⦇Obj⦈ ⟹ 𝔊 b⦇ObjMap⦈⦇c⦈ = 𝔉 c⦇ObjMap⦈⦇b⦈"
    and 
      "⋀b c b' c' f g. ⟦ f : b ↦⇘𝔅⇙ b'; g : c ↦⇘ℭ⇙ c' ⟧ ⟹
        𝔊 b'⦇ArrMap⦈⦇g⦈ ∘A⇘𝔇⇙ 𝔉 c⦇ArrMap⦈⦇f⦈ =
          𝔉 c'⦇ArrMap⦈⦇f⦈ ∘A⇘𝔇⇙ 𝔊 b⦇ArrMap⦈⦇g⦈"
  shows cf_array_is_functor: "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and cf_array_ObjMap_app_fst: "⋀b c. ⟦ b ∈∘ 𝔅⦇Obj⦈; c ∈∘ ℭ⦇Obj⦈ ⟧ ⟹
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇b, c⦈∙ = 𝔉 c⦇ObjMap⦈⦇b⦈"
    and cf_array_ObjMap_app_snd: "⋀b c. ⟦ b ∈∘ 𝔅⦇Obj⦈; c ∈∘ ℭ⦇Obj⦈ ⟧ ⟹
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇b, c⦈∙ = 𝔊 b⦇ObjMap⦈⦇c⦈"
    and cf_array_ArrMap_app_fst: "⋀a b f c. ⟦ f : a ↦⇘𝔅⇙ b; c ∈∘ ℭ⦇Obj⦈⟧ ⟹
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇f, ℭ⦇CId⦈⦇c⦈⦈∙ = 𝔉 c⦇ArrMap⦈⦇f⦈"
    and cf_array_ArrMap_app_snd: "⋀a b g c. ⟦ g : a ↦⇘ℭ⇙ b; c ∈∘ 𝔅⦇Obj⦈ ⟧ ⟹
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇𝔅⦇CId⦈⦇c⦈, g⦈∙ = 𝔊 c⦇ArrMap⦈⦇g⦈"
proof-

  interpret 𝔅: category α 𝔅 by (rule assms(1))
  interpret ℭ: category α ℭ by (rule assms(2))
  interpret 𝔇: category α 𝔇 by (rule assms(3))

  from assms(4) have [cat_cs_intros]: "𝔉 c : 𝔅' ↦↦C⇘α'⇙ 𝔇'" 
    if "c ∈∘ ℭ⦇Obj⦈" "𝔅' = 𝔅" "𝔇' = 𝔇" "α' = α" for α' c 𝔅' 𝔇'
    using that(1) unfolding that(2-4) by (intro assms(4))
  from assms(4) have [cat_cs_intros]: "𝔊 c : ℭ' ↦↦C⇘α'⇙ 𝔇'" 
    if "c ∈∘ 𝔅⦇Obj⦈" "ℭ' = ℭ" "𝔇' = 𝔇" "α' = α" for α' c ℭ' 𝔇'
    using that(1) unfolding that(2-4) by (intro assms(5))

  show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  proof(intro is_functorI')
    show "vfsequence (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊)" unfolding cf_array_def by auto
    from assms(1,2) show "category α (𝔅 ×C ℭ)"
      by (simp add: category_cat_prod_2)
    show "vcard (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊) = 4ℕ"
      unfolding cf_array_def by (simp add: nat_omega_simps)
    show "ℛ∘ (cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
      by (rule cf_array_ObjMap_vrange) (auto simp: assms intro: cat_cs_intros)
    show cf_array_is_arrI: "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈ :
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇aa'⦈ ↦⇘𝔇⇙ cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇bb'⦈"
      if ff': "ff' : aa' ↦⇘𝔅 ×C ℭ⇙ bb'" for aa' bb' ff'
    proof-
      obtain f f' a a' b b' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and bb'_def: "bb' = [b, b']∘"   
          and f: "f : a ↦⇘𝔅⇙ b"  
          and f': "f' : a' ↦⇘ℭ⇙ b'"
        by (elim cat_prod_2_is_arrE[OF 𝔅.category_axioms ℭ.category_axioms ff'])
      then have a: "a ∈∘ 𝔅⦇Obj⦈" 
        and b: "b ∈∘ 𝔅⦇Obj⦈" 
        and a': "a' ∈∘ ℭ⦇Obj⦈" 
        and b': "b' ∈∘ ℭ⦇Obj⦈"
        by auto
      from f' assms(5)[OF a] a have
        "𝔊 a⦇ArrMap⦈⦇f'⦈ : 𝔉 a'⦇ObjMap⦈⦇a⦈ ↦⇘𝔇⇙ 𝔉 b'⦇ObjMap⦈⦇a⦈"
        by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
      with assms(1-3) f f' assms(4)[OF b'] show ?thesis
        unfolding ff'_def aa'_def bb'_def
        by 
          (
            cs_concl 
              cs_simp: cat_cs_simps assms(6) 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇gg' ∘A⇘𝔅 ×C ℭ⇙ ff'⦈ = 
      cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇gg'⦈ ∘A⇘𝔇⇙ cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈"
      if gg': "gg' : bb' ↦⇘𝔅 ×C ℭ⇙ cc'" and ff': "ff' : aa' ↦⇘𝔅 ×C ℭ⇙ bb'" 
      for bb' cc' gg' aa' ff'
    proof-
      obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘"
          and bb'_def: "bb' = [b, b']∘"
          and cc'_def: "cc' = [c, c']∘"   
          and g: "g : b ↦⇘𝔅⇙ c"  
          and g': "g' : b' ↦⇘ℭ⇙ c'"
        by (elim cat_prod_2_is_arrE[OF 𝔅.category_axioms ℭ.category_axioms gg'])
      moreover obtain f f' a a' b'' b''' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and "bb' = [b'', b''']∘"   
          and f: "f : a ↦⇘𝔅⇙ b''"  
          and f': "f' : a' ↦⇘ℭ⇙ b'''"
        by (elim cat_prod_2_is_arrE[OF 𝔅.category_axioms ℭ.category_axioms ff'])
      ultimately have f: "f : a ↦⇘𝔅⇙ b" and f': "f' : a' ↦⇘ℭ⇙ b'" by auto
      with g have a: "a ∈∘ 𝔅⦇Obj⦈" 
        and b: "b ∈∘ 𝔅⦇Obj⦈" 
        and c: "c ∈∘ 𝔅⦇Obj⦈" 
        and a': "a' ∈∘ ℭ⦇Obj⦈" 
        and b': "b' ∈∘ ℭ⦇Obj⦈"
        and c': "b' ∈∘ ℭ⦇Obj⦈"
        by auto
      from f' assms(5)[OF a] a have 𝔊a_f':
        "𝔊 a⦇ArrMap⦈⦇f'⦈ : 𝔉 a'⦇ObjMap⦈⦇a⦈ ↦⇘𝔇⇙ 𝔉 b'⦇ObjMap⦈⦇a⦈"
        by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
      from f' b assms(5)[OF b] have 𝔊b_f': 
        "𝔊 b⦇ArrMap⦈⦇f'⦈ : 𝔉 a'⦇ObjMap⦈⦇b⦈ ↦⇘𝔇⇙ 𝔉 b'⦇ObjMap⦈⦇b⦈"
        by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
      from f' c assms(5)[OF c] have 𝔊c_f':
        "𝔊 c⦇ArrMap⦈⦇f'⦈ : 𝔉 a'⦇ObjMap⦈⦇c⦈ ↦⇘𝔇⇙ 𝔉 b'⦇ObjMap⦈⦇c⦈"
        by (cs_concl cs_simp: assms(6)[symmetric] cs_intro: cat_cs_intros)
      have
        "𝔉 b'⦇ArrMap⦈⦇g⦈ ∘A⇘𝔇⇙ (𝔉 b'⦇ArrMap⦈⦇f⦈ ∘A⇘𝔇⇙ 𝔊 a⦇ArrMap⦈⦇f'⦈) = 
          (𝔊 c⦇ArrMap⦈⦇f'⦈ ∘A⇘𝔇⇙ 𝔉 a'⦇ArrMap⦈⦇g⦈) ∘A⇘𝔇⇙ 𝔉 a'⦇ArrMap⦈⦇f⦈"
        using f' f g 𝔊b_f' assms(4)[OF a'] assms(4)[OF b'] 
        by 
          (
            cs_concl cs_shallow 
              cs_simp: cat_cs_simps assms(7) cs_intro: cat_cs_intros
          )
      also have "… =
        𝔊 c⦇ArrMap⦈⦇f'⦈ ∘A⇘𝔇⇙ (𝔉 a'⦇ArrMap⦈⦇g⦈ ∘A⇘𝔇⇙ 𝔉 a'⦇ArrMap⦈⦇f⦈)"
        using assms(2) f f' g g' assms(4)[OF a'] assms(5)[OF c]
        by (cs_concl cs_simp: assms(6) cat_cs_simps cs_intro: cat_cs_intros)
      finally have [cat_cs_simps]:
        "𝔉 b'⦇ArrMap⦈⦇g⦈ ∘A⇘𝔇⇙ (𝔉 b'⦇ArrMap⦈⦇f⦈ ∘A⇘𝔇⇙ 𝔊 a⦇ArrMap⦈⦇f'⦈) =
          𝔊 c⦇ArrMap⦈⦇f'⦈ ∘A⇘𝔇⇙ (𝔉 a'⦇ArrMap⦈⦇g⦈ ∘A⇘𝔇⇙ 𝔉 a'⦇ArrMap⦈⦇f⦈)"
        by simp
      show ?thesis
        using 
          𝔊a_f' 𝔊c_f'
          f f' 
          g g'
          assms(1,2)  
          assms(4)[OF a'] 
          assms(4)[OF c']
          assms(5)[OF c]
        unfolding gg'_def ff'_def aa'_def bb'_def cc'_def (*slow*)
        by 
          (
            cs_concl 
              cs_simp: assms(6,7) cat_prod_cs_simps cat_cs_simps 
              cs_intro: cat_prod_cs_intros cat_cs_intros
          )
    qed
    show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇(𝔅 ×C ℭ)⦇CId⦈⦇cc'⦈⦈ = 
      𝔇⦇CId⦈⦇cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇cc'⦈⦈"
      if "cc' ∈∘ (𝔅 ×C ℭ)⦇Obj⦈" for cc'
    proof-
      from that obtain c c' 
        where cc'_def: "cc' = [c, c']∘" 
          and c: "c ∈∘ 𝔅⦇Obj⦈" 
          and c': "c' ∈∘ ℭ⦇Obj⦈"
        by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
      from assms(1,2,3) c c' assms(4)[OF c'] assms(5)[OF c] show ?thesis
        unfolding cc'_def (*slow*)
        by 
          (
            cs_concl 
              cs_simp: cat_prod_cs_simps cat_cs_simps assms(6) 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
  qed (auto simp: cf_array_components cat_cs_intros)

  show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇b, c⦈∙ = 𝔉 c⦇ObjMap⦈⦇b⦈"
    if "b ∈∘ 𝔅⦇Obj⦈" and "c ∈∘ ℭ⦇Obj⦈" for b c
    using that assms(1,2,3)
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps assms(6) cs_intro: cat_prod_cs_intros
      )
  show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ObjMap⦈⦇b, c⦈∙ = 𝔊 b⦇ObjMap⦈⦇c⦈"
    if "b ∈∘ 𝔅⦇Obj⦈" and "c ∈∘ ℭ⦇Obj⦈" for b c 
    using that assms(1,2,3)
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
  show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇f, ℭ⦇CId⦈⦇c⦈⦈∙ = 𝔉 c⦇ArrMap⦈⦇f⦈"
    if f: "f : a ↦⇘𝔅⇙ b" and c: "c ∈∘ ℭ⦇Obj⦈" for a b f c
  proof-
    from f have "a ∈∘ 𝔅⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈" by auto
    from assms(5)[OF this(1)] assms(5)[OF this(2)] assms(4)[OF c] show ?thesis
      using assms(1,2,3) f c 
      by 
        (
          cs_concl cs_shallow 
            cs_simp: cat_cs_simps assms(6) cs_intro: cat_cs_intros
        )
  qed

  show "cf_array 𝔅 ℭ 𝔇 𝔉 𝔊⦇ArrMap⦈⦇𝔅⦇CId⦈⦇c⦈, g⦈∙ = 𝔊 c⦇ArrMap⦈⦇g⦈"
    if g: "g : a ↦⇘ℭ⇙ b" and c: "c ∈∘ 𝔅⦇Obj⦈" for a b g c
  proof-
    from g have "a ∈∘ ℭ⦇Obj⦈" and "b ∈∘ ℭ⦇Obj⦈" by auto
    from assms(4)[OF this(1)] assms(4)[OF this(2)] assms(5)[OF c] show ?thesis
      using assms(1,2,3) g c
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps assms(6)[symmetric] cs_intro: cat_cs_intros
        )
  qed

qed



subsection‹Composition of a covariant bifunctor and covariant functors›


subsubsection‹Definition and elementary properties.›

definition cf_bcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_bcomp 𝔖 𝔉 𝔊 =
    [
      (
        λa∈∘(𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈)⦇Obj⦈.
          𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇vpfst a⦈, 𝔊⦇ObjMap⦈⦇vpsnd a⦈⦈∙
      ),
      (
        λf∈∘(𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈)⦇Arr⦈.
          𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇vpfst f⦈, 𝔊⦇ArrMap⦈⦇vpsnd f⦈⦈∙
      ),
      𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈,
      𝔖⦇HomCod⦈
    ]∘"


text‹Components.›

lemma cf_bcomp_components:
  shows "cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈ = 
      (
        λa∈∘(𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈)⦇Obj⦈.
          𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇vpfst a⦈, 𝔊⦇ObjMap⦈⦇vpsnd a⦈⦈∙
      )"
    and "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈ = 
      (
        λf∈∘(𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈)⦇Arr⦈.
          𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇vpfst f⦈, 𝔊⦇ArrMap⦈⦇vpsnd f⦈⦈∙
      )"
    and "cf_bcomp 𝔖 𝔉 𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈ ×C 𝔊⦇HomDom⦈"
    and "cf_bcomp 𝔖 𝔉 𝔊⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_bcomp_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

lemma cf_bcomp_ObjMap_vsv: "vsv (cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈)"
  unfolding cf_bcomp_components by simp

lemma cf_bcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅" and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) = (𝔅' ×C ℭ')⦇Obj⦈"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms)
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms)
  show ?thesis unfolding cf_bcomp_components by (simp add: cat_cs_simps)
qed

lemma cf_bcomp_ObjMap_app[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "[a, b]∘ ∈∘ (𝔅' ×C ℭ')⦇Obj⦈"
  shows "cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇a, b⦈∙ = 𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈, 𝔊⦇ObjMap⦈⦇b⦈⦈∙"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  from assms show ?thesis 
    unfolding cf_bcomp_components 
    by (simp_all add: cat_cs_simps nat_omega_simps)
qed

lemma cf_bcomp_ObjMap_vrange:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
proof
  (
    rule vsv.vsv_vrange_vsubset, 
    unfold cf_bcomp_ObjMap_vdomain[OF assms(1,2)]
  )
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  show "vsv (cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈)" by (rule cf_bcomp_ObjMap_vsv)
  fix bc assume "bc ∈∘ (𝔅' ×C ℭ')⦇Obj⦈"
  with 𝔉.HomDom.category_axioms 𝔊.HomDom.category_axioms obtain b c 
    where bc_def: "bc = [b, c]∘" and b: "b ∈∘ 𝔅'⦇Obj⦈" and c: "c ∈∘ ℭ'⦇Obj⦈"
    by (elim cat_prod_2_ObjE[rotated -1])  
  from assms b c show "cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇bc⦈ ∈∘ 𝔇⦇Obj⦈"
    unfolding bc_def 
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed


subsubsection‹Arrow map›

lemma cf_bcomp_ArrMap_vsv: "vsv (cf_bcomp ℭ 𝔖 𝔉⦇ArrMap⦈)"
  unfolding cf_bcomp_components by simp

lemma cf_bcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅" and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈) = (𝔅' ×C ℭ')⦇Arr⦈"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  show ?thesis unfolding cf_bcomp_components by (simp add: cat_cs_simps)
qed

lemma cf_bcomp_ArrMap_app[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "[g, f]∘ ∈∘ (𝔅' ×C ℭ')⦇Arr⦈"
  shows "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇g, f⦈∙ = 𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇g⦈, 𝔊⦇ArrMap⦈⦇f⦈⦈∙"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  from assms show ?thesis 
    unfolding cf_bcomp_components by (simp_all add: nat_omega_simps cat_cs_simps)
qed

lemma cf_bcomp_ArrMap_vrange:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold cf_bcomp_ArrMap_vdomain[OF assms(1,2)])
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  fix gf assume "gf ∈∘ (𝔅' ×C ℭ')⦇Arr⦈"
  with 𝔉.HomDom.category_axioms 𝔊.HomDom.category_axioms obtain g f
    where gf_def: "gf = [g, f]∘" and g: "g ∈∘ 𝔅'⦇Arr⦈" and f: "f ∈∘ ℭ'⦇Arr⦈"
    by (elim cat_prod_2_ArrE[rotated -1])  
  from g obtain a b where g: "g : a ↦⇘𝔅'⇙ b" by auto
  from f obtain a' b' where f: "f : a' ↦⇘ℭ'⇙ b'" by auto
  from assms g f show "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gf⦈ ∈∘ 𝔇⦇Arr⦈"
    unfolding gf_def 
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed (simp add: cf_bcomp_ArrMap_vsv)


subsubsection‹
Composition of a covariant bifunctor and 
covariant functors is a functor
›

lemma cf_bcomp_is_functor:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_bcomp 𝔖 𝔉 𝔊 : 𝔅' ×C ℭ' ↦↦C⇘α⇙ 𝔇"
proof-

  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  interpret 𝔖: is_functor α ‹𝔅 ×C ℭ› 𝔇 𝔖 by (rule assms(3))

  show ?thesis
  proof(intro is_functorI')
    show "vfsequence (cf_bcomp 𝔖 𝔉 𝔊)" unfolding cf_bcomp_def by simp
    show "category α (𝔅' ×C ℭ')"
      by 
        (
          simp add: 
            𝔉.HomDom.category_axioms  
            𝔊.HomDom.category_axioms 
            category_cat_prod_2
        )
    show "vcard (cf_bcomp 𝔖 𝔉 𝔊) = 4ℕ"
      unfolding cf_bcomp_def by (simp add: nat_omega_simps)
    from assms show "ℛ∘ (cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
      by (rule cf_bcomp_ObjMap_vrange)
    show "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈ :
      cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇aa'⦈ ↦⇘𝔇⇙ cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇bb'⦈"
    if ff': "ff' : aa' ↦⇘𝔅' ×C ℭ'⇙ bb'" for aa' bb' ff'
    proof-
      obtain f f' a a' b b' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and bb'_def: "bb' = [b, b']∘"   
          and f: "f : a ↦⇘𝔅'⇙ b"  
          and f': "f' : a' ↦⇘ℭ'⇙ b'"
        by 
          (
            elim 
              cat_prod_2_is_arrE[
                OF 𝔉.HomDom.category_axioms 𝔊.HomDom.category_axioms ff'
                ]
          )
      from assms f f' show ?thesis
        unfolding ff'_def aa'_def bb'_def
        by
          (
            cs_concl 
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gg' ∘A⇘𝔅' ×C ℭ'⇙ ff'⦈ =
      cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gg'⦈ ∘A⇘𝔇⇙ cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈"
      if gg': "gg' : bb' ↦⇘𝔅' ×C ℭ'⇙ cc'" 
        and ff': "ff' : aa' ↦⇘𝔅' ×C ℭ'⇙ bb'"
      for bb' cc' gg' aa' ff'
    proof-
      obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘"
          and bb'_def: "bb' = [b, b']∘"
          and cc'_def: "cc' = [c, c']∘"   
          and g: "g : b ↦⇘𝔅'⇙ c"  
          and g': "g' : b' ↦⇘ℭ'⇙ c'"
        by 
          (
            elim cat_prod_2_is_arrE[
              OF 𝔉.HomDom.category_axioms 𝔊.HomDom.category_axioms gg'
              ]
          )
      moreover obtain f f' a a' b'' b''' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and "bb' = [b'', b''']∘"   
          and f: "f : a ↦⇘𝔅'⇙ b''"  
          and f': "f' : a' ↦⇘ℭ'⇙ b'''"
        by 
          (
            elim cat_prod_2_is_arrE[
              OF 𝔉.HomDom.category_axioms 𝔊.HomDom.category_axioms ff'
              ]
          )
      ultimately have f: "f : a ↦⇘𝔅'⇙ b" and f': "f' : a' ↦⇘ℭ'⇙ b'" by auto
      from assms f f' g g' have [cat_cs_simps]:
        "[𝔉⦇ArrMap⦈⦇g⦈ ∘A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈, 𝔊⦇ArrMap⦈⦇g'⦈ ∘A⇘ℭ⇙ 𝔊⦇ArrMap⦈⦇f'⦈]∘ = 
          [𝔉⦇ArrMap⦈⦇g⦈, 𝔊⦇ArrMap⦈⦇g'⦈]∘ ∘A⇘𝔅 ×C ℭ⇙ [𝔉⦇ArrMap⦈⦇f⦈, 𝔊⦇ArrMap⦈⦇f'⦈]∘"
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_prod_cs_simps
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
      from assms f f' g g' show ?thesis
        unfolding gg'_def ff'_def aa'_def bb'_def cc'_def
        by
          (
            cs_concl 
              cs_simp: cat_prod_cs_simps cat_cs_simps 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show 
      "cf_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇(𝔅' ×C ℭ')⦇CId⦈⦇cc'⦈⦈ = 
        𝔇⦇CId⦈⦇cf_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇cc'⦈⦈"
      if "cc' ∈∘ (𝔅' ×C ℭ')⦇Obj⦈" for cc'
    proof-
      from that obtain c c' 
        where cc'_def: "cc' = [c, c']∘" 
          and c: "c ∈∘ 𝔅'⦇Obj⦈"
          and c': "c' ∈∘ ℭ'⦇Obj⦈"
        by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
      from assms c c' have [cat_cs_simps]: 
        "[𝔅⦇CId⦈⦇𝔉⦇ObjMap⦈⦇c⦈⦈, ℭ⦇CId⦈⦇𝔊⦇ObjMap⦈⦇c'⦈⦈]∘ = 
          (𝔅 ×C ℭ)⦇CId⦈⦇𝔉⦇ObjMap⦈⦇c⦈, 𝔊⦇ObjMap⦈⦇c'⦈⦈∙"
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_prod_cs_simps
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
      from assms c c' show ?thesis
        unfolding cc'_def
        by
          (
            cs_concl  
              cs_simp: cat_prod_cs_simps cat_cs_simps
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
  qed (auto simp: cf_bcomp_components cat_cs_intros cat_cs_simps)

qed

lemma cf_bcomp_is_functor'[cat_cs_intros]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔄' =  𝔅' ×C ℭ'"
  shows "cf_bcomp 𝔖 𝔉 𝔊 : 𝔄' ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_bcomp_is_functor)



subsection‹Composition of a contracovariant bifunctor and covariant functors›

text‹
The term ‹contracovariant bifunctor› is used to refer to a bifunctor
that is contravariant in the first argument and covariant in the second
argument.
›

definition cf_cn_cov_bcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_cn_cov_bcomp 𝔖 𝔉 𝔊 =
    [
      (
        λa∈∘(op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈)⦇Obj⦈.
          𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇vpfst a⦈, 𝔊⦇ObjMap⦈⦇vpsnd a⦈⦈∙
      ),
      (
        λf∈∘(op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈)⦇Arr⦈.
          𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇vpfst f⦈, 𝔊⦇ArrMap⦈⦇vpsnd f⦈⦈∙
      ),
      op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈,
      𝔖⦇HomCod⦈
    ]∘"


text‹Components.›

lemma cf_cn_cov_bcomp_components:
  shows "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈ =
      (
        λa∈∘(op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈)⦇Obj⦈.
          𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇vpfst a⦈, 𝔊⦇ObjMap⦈⦇vpsnd a⦈⦈∙
      )"
    and "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈ =
      (
        λf∈∘(op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈)⦇Arr⦈.
          𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇vpfst f⦈, 𝔊⦇ArrMap⦈⦇vpsnd f⦈⦈∙
      )"
    and "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇HomDom⦈ = op_cat (𝔉⦇HomDom⦈) ×C 𝔊⦇HomDom⦈"
    and "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_cn_cov_bcomp_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

lemma cf_cn_cov_bcomp_ObjMap_vsv: "vsv (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈)"
  unfolding cf_cn_cov_bcomp_components by simp

lemma cf_cn_cov_bcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅" and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) = (op_cat 𝔅' ×C ℭ')⦇Obj⦈"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  show ?thesis 
    unfolding cf_cn_cov_bcomp_components 
    by (simp add: nat_omega_simps cat_cs_simps)
qed

lemma cf_cn_cov_bcomp_ObjMap_app[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "[a, b]∘ ∈∘ (op_cat 𝔅' ×C ℭ')⦇Obj⦈"
  shows 
    "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇a, b⦈∙ =
      𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈, 𝔊⦇ObjMap⦈⦇b⦈⦈∙"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  from assms show ?thesis 
    unfolding cf_cn_cov_bcomp_components 
    by (simp_all add: cat_cs_simps nat_omega_simps)
qed

lemma cf_cn_cov_bcomp_ObjMap_vrange:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
proof
  (
    rule vsv.vsv_vrange_vsubset, 
    unfold cf_cn_cov_bcomp_ObjMap_vdomain[OF assms(1,2)]
  )
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  show "vsv (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈)" 
    by (rule cf_cn_cov_bcomp_ObjMap_vsv)
  fix bc assume "bc ∈∘ (op_cat 𝔅' ×C ℭ')⦇Obj⦈"
  with 𝔉.HomDom.category_op 𝔊.HomDom.category_axioms obtain b c 
    where bc_def: "bc = [b, c]∘" 
      and b: "b ∈∘ op_cat 𝔅'⦇Obj⦈" 
      and c: "c ∈∘ ℭ'⦇Obj⦈"
    by (elim cat_prod_2_ObjE[rotated -1])  
  from assms b c show "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇bc⦈ ∈∘ 𝔇⦇Obj⦈"
    unfolding bc_def cat_op_simps
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
qed


subsubsection‹Arrow map›

lemma cf_cn_cov_bcomp_ArrMap_vsv: "vsv (cf_cn_cov_bcomp ℭ 𝔖 𝔉⦇ArrMap⦈)"
  unfolding cf_cn_cov_bcomp_components by simp

lemma cf_cn_cov_bcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅" and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈) = (op_cat 𝔅' ×C ℭ')⦇Arr⦈"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  show ?thesis unfolding cf_cn_cov_bcomp_components by (simp add: cat_cs_simps)
qed

lemma cf_cn_cov_bcomp_ArrMap_app[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "[g, f]∘ ∈∘ (op_cat 𝔅' ×C ℭ')⦇Arr⦈"
  shows "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇g, f⦈∙ =
    𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇g⦈, 𝔊⦇ArrMap⦈⦇f⦈⦈∙"
proof-
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  from assms show ?thesis 
    unfolding cf_cn_cov_bcomp_components 
    by (simp_all add: nat_omega_simps cat_cs_simps)
qed

lemma cf_cn_cov_bcomp_ArrMap_vrange:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
proof
  (
    rule vsv.vsv_vrange_vsubset, 
    unfold cf_cn_cov_bcomp_ArrMap_vdomain[OF assms(1,2)]
  )
  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  fix gf assume "gf ∈∘ (op_cat 𝔅' ×C ℭ')⦇Arr⦈"
  with 𝔉.HomDom.category_op 𝔊.HomDom.category_axioms obtain g f
    where gf_def: "gf = [g, f]∘" 
      and g: "g ∈∘ op_cat 𝔅'⦇Arr⦈" 
      and f: "f ∈∘ ℭ'⦇Arr⦈"
    by (elim cat_prod_2_ArrE[rotated -1])  
  from g obtain a b where g: "g : a ↦⇘𝔅'⇙ b" unfolding cat_op_simps by auto
  from f obtain a' b' where f: "f : a' ↦⇘ℭ'⇙ b'" by auto
  from assms g f show "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gf⦈ ∈∘ 𝔇⦇Arr⦈"
    unfolding gf_def 
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps 
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
qed (rule cf_cn_cov_bcomp_ArrMap_vsv)


subsubsection‹
Composition of a contracovariant bifunctor and functors is a functor
›

lemma cf_cn_cov_bcomp_is_functor:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_cn_cov_bcomp 𝔖 𝔉 𝔊 : op_cat 𝔅' ×C ℭ' ↦↦C⇘α⇙ 𝔇"
proof-

  interpret 𝔉: is_functor α 𝔅' 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_functor α ℭ' ℭ 𝔊 by (rule assms(2))
  interpret 𝔖: is_functor α ‹op_cat 𝔅 ×C ℭ› 𝔇 𝔖 by (rule assms(3))

  show ?thesis
  proof(intro is_functorI')
    show "vfsequence (cf_cn_cov_bcomp 𝔖 𝔉 𝔊)" 
      unfolding cf_cn_cov_bcomp_def by simp
    show "category α (op_cat 𝔅' ×C ℭ')"
      by 
        (
          simp add: 
            𝔉.HomDom.category_op 𝔊.HomDom.category_axioms category_cat_prod_2
        )
    show "vcard (cf_cn_cov_bcomp 𝔖 𝔉 𝔊) = 4ℕ"
      unfolding cf_cn_cov_bcomp_def by (simp add: nat_omega_simps)
    from assms show "ℛ∘ (cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
      by (rule cf_cn_cov_bcomp_ObjMap_vrange)
    show 
      "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈ :
        cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇aa'⦈ ↦⇘𝔇⇙
        cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇bb'⦈"
      if ff': "ff' : aa' ↦⇘op_cat 𝔅' ×C ℭ'⇙ bb'" for aa' bb' ff'
    proof-
      obtain f f' a a' b b' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and bb'_def: "bb' = [b, b']∘"   
          and f: "f : a ↦⇘op_cat 𝔅'⇙ b"  
          and f': "f' : a' ↦⇘ℭ'⇙ b'"
        by 
          (
            elim 
              cat_prod_2_is_arrE[
                OF 𝔉.HomDom.category_op 𝔊.HomDom.category_axioms ff'
                ]
          )
      from assms f f' show ?thesis
        unfolding ff'_def aa'_def bb'_def cat_op_simps
        by (*slow*)
          (
            cs_concl 
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed
    show 
      "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gg' ∘A⇘op_cat 𝔅' ×C ℭ'⇙ ff'⦈ =
        cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇gg'⦈ ∘A⇘𝔇⇙ 
        cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇ff'⦈"
      if gg': "gg' : bb' ↦⇘op_cat 𝔅' ×C ℭ'⇙ cc'" 
        and ff': "ff' : aa' ↦⇘op_cat 𝔅' ×C ℭ'⇙ bb'"
      for bb' cc' gg' aa' ff'
    proof-
      obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘"
          and bb'_def: "bb' = [b, b']∘"
          and cc'_def: "cc' = [c, c']∘"   
          and g: "g : b ↦⇘op_cat 𝔅'⇙ c"  
          and g': "g' : b' ↦⇘ℭ'⇙ c'"
        by 
          (
            elim cat_prod_2_is_arrE[
              OF 𝔉.HomDom.category_op 𝔊.HomDom.category_axioms gg'
              ]
          )
      moreover obtain f f' a a' b'' b''' 
        where ff'_def: "ff' = [f, f']∘"
          and aa'_def: "aa' = [a, a']∘"
          and "bb' = [b'', b''']∘"   
          and f: "f : a ↦⇘op_cat 𝔅'⇙ b''"  
          and "f' : a' ↦⇘ℭ'⇙ b'''"
        by 
          (
            elim cat_prod_2_is_arrE[
              OF 𝔉.HomDom.category_op 𝔊.HomDom.category_axioms ff'
              ]
          )
      ultimately have f: "f : a ↦⇘op_cat 𝔅'⇙ b" and f': "f' : a' ↦⇘ℭ'⇙ b'" 
        by auto
      from assms f f' g g' have [cat_cs_simps]:
        "[
          𝔉⦇ArrMap⦈⦇f⦈ ∘A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇g⦈, 
          𝔊⦇ArrMap⦈⦇g'⦈ ∘A⇘ℭ⇙ 𝔊⦇ArrMap⦈⦇f'⦈
         ]∘ = 
          [𝔉⦇ArrMap⦈⦇g⦈, 𝔊⦇ArrMap⦈⦇g'⦈]∘ ∘A⇘op_cat 𝔅 ×C ℭ⇙ 
          [𝔉⦇ArrMap⦈⦇f⦈, 𝔊⦇ArrMap⦈⦇f'⦈]∘"
        unfolding cat_op_simps
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
      from assms f f' g g' show ?thesis
        unfolding gg'_def ff'_def aa'_def bb'_def cc'_def cat_op_simps
        by
          (
            cs_concl
              cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed
    show 
      "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ArrMap⦈⦇(op_cat 𝔅' ×C ℭ')⦇CId⦈⦇cc'⦈⦈ = 
        𝔇⦇CId⦈⦇cf_cn_cov_bcomp 𝔖 𝔉 𝔊⦇ObjMap⦈⦇cc'⦈⦈"
      if "cc' ∈∘ (op_cat 𝔅' ×C ℭ')⦇Obj⦈" for cc'
    proof-
      from that obtain c c' 
        where cc'_def: "cc' = [c, c']∘" 
          and c: "c ∈∘ op_cat 𝔅'⦇Obj⦈"
          and c': "c' ∈∘ ℭ'⦇Obj⦈"
        by (elim cat_prod_2_ObjE[rotated 2]) 
          (auto intro: cat_cs_intros)
      from assms c c' have [cat_cs_simps]: 
        "[𝔅⦇CId⦈⦇𝔉⦇ObjMap⦈⦇c⦈⦈, ℭ⦇CId⦈⦇𝔊⦇ObjMap⦈⦇c'⦈⦈]∘ =
          (op_cat 𝔅 ×C ℭ)⦇CId⦈⦇𝔉⦇ObjMap⦈⦇c⦈, 𝔊⦇ObjMap⦈⦇c'⦈⦈∙"
        unfolding cat_op_simps
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_prod_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
      from assms c c' show ?thesis
        unfolding cc'_def cat_op_simps
        by (*slow*)
          (
            cs_concl  
              cs_simp: cat_prod_cs_simps cat_cs_simps cat_op_simps 
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed
  qed (auto simp: cf_cn_cov_bcomp_components cat_cs_simps intro: cat_cs_intros)

qed

lemma cf_cn_cov_bcomp_is_functor'[cat_cs_intros]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅"
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔄' = op_cat 𝔅' ×C ℭ'"
  shows "cf_cn_cov_bcomp 𝔖 𝔉 𝔊 : 𝔄' ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_bcomp_is_functor)


subsubsection‹Projection of a contracovariant bifunctor and functors›

lemma cf_cn_cov_bcomp_bifunctor_proj_snd[cat_cs_simps]:
  assumes "𝔉 : 𝔅' ↦↦C⇘α⇙ 𝔅" 
    and "𝔊 : ℭ' ↦↦C⇘α⇙ ℭ"
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "b ∈∘ 𝔅'⦇Obj⦈"
  shows
    "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF =
      (𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊"
proof(rule cf_eqI)
  from assms show [intro]: 
    "cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF : ℭ' ↦↦C⇘α⇙ 𝔇"
    "(𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊 : ℭ' ↦↦C⇘α⇙ 𝔇"
    by (cs_concl cs_intro: cat_cs_intros cat_op_intros)+
  from assms have ObjMap_dom_lhs:
    "𝒟∘ ((cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ObjMap⦈) = ℭ'⦇Obj⦈"
    and ObjMap_dom_rhs:
    "𝒟∘ (((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ObjMap⦈) = ℭ'⦇Obj⦈"
    and ArrMap_dom_lhs:
    "𝒟∘ ((cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ArrMap⦈) = ℭ'⦇Arr⦈"
    and ArrMap_dom_rhs:
    "𝒟∘ (((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ArrMap⦈) = ℭ'⦇Arr⦈"
    by (cs_concl cs_intro: cat_cs_intros cat_op_intros cs_simp: cat_cs_simps)+
  show 
    "(cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ObjMap⦈ =
      ((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ObjMap⦈"
  proof(rule vsv_eqI, unfold ObjMap_dom_lhs ObjMap_dom_rhs)
    fix a assume "a ∈∘ ℭ'⦇Obj⦈"
    with assms show 
      "(cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ObjMap⦈⦇a⦈ =
        ((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ObjMap⦈⦇a⦈"
      by 
        (
          cs_concl 
            cs_simp: cat_prod_cs_simps cat_cs_simps 
            cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
        )
  qed (auto intro: is_functor.cf_ObjMap_vsv) 
  show 
    "(cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ArrMap⦈ =
      ((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ArrMap⦈"
  proof(rule vsv_eqI, unfold ArrMap_dom_lhs ArrMap_dom_rhs)
    fix f assume "f ∈∘ ℭ'⦇Arr⦈"
    then obtain a' b' where "f : a' ↦⇘ℭ'⇙ b'" by (auto intro: is_arrI)
    with assms show 
      "(cf_cn_cov_bcomp 𝔖 𝔉 𝔊⇘op_cat 𝔅',ℭ'⇙(b,-)CF)⦇ArrMap⦈⦇f⦈ =
        ((𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF) ∘CF 𝔊)⦇ArrMap⦈⦇f⦈"
      by 
        (
          cs_concl 
            cs_simp: cat_cs_simps cat_op_simps 
            cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
        )
  qed (auto intro: is_functor.cf_ArrMap_vsv) 
qed simp_all



subsection‹Composition of a covariant bifunctor and a covariant functor›


subsubsection‹Definition and elementary properties›

definition cf_lcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_lcomp ℭ 𝔖 𝔉 = cf_bcomp 𝔖 𝔉 (cf_id ℭ)"

definition cf_rcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_rcomp 𝔅 𝔖 𝔊 = cf_bcomp 𝔖 (cf_id 𝔅) 𝔊"


text‹Components.›

lemma cf_lcomp_components:
  shows "cf_lcomp ℭ 𝔖 𝔉⦇HomDom⦈ = 𝔉⦇HomDom⦈ ×C ℭ"
    and "cf_lcomp ℭ 𝔖 𝔉⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_lcomp_def cf_bcomp_components dghm_id_components by simp_all

lemma cf_rcomp_components:
  shows "cf_rcomp 𝔅 𝔖 𝔊⦇HomDom⦈ = 𝔅 ×C 𝔊⦇HomDom⦈"
    and "cf_rcomp 𝔅 𝔖 𝔊⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_rcomp_def cf_bcomp_components dghm_id_components by simp_all


subsubsection‹Object map›

lemma cf_lcomp_ObjMap_vsv: "vsv (cf_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈)"
  unfolding cf_lcomp_def by (rule cf_bcomp_ObjMap_vsv)

lemma cf_rcomp_ObjMap_vsv: "vsv (cf_rcomp ℭ 𝔖 𝔉⦇ObjMap⦈)"
  unfolding cf_rcomp_def by (rule cf_bcomp_ObjMap_vsv)

lemma cf_lcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "category α ℭ" and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
  shows "𝒟∘ (cf_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈) = (𝔄 ×C ℭ)⦇Obj⦈"
  using assms 
  unfolding cf_lcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_rcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔅" and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈) = (𝔅 ×C 𝔄)⦇Obj⦈"
  using assms 
  unfolding cf_rcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_lcomp_ObjMap_app[cat_cs_simps]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "a ∈∘ 𝔄⦇Obj⦈" 
    and "c ∈∘ ℭ⦇Obj⦈"
  shows "cf_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈⦇a, c⦈∙ = 𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈, c⦈∙"
  using assms 
  unfolding cf_lcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

lemma cf_rcomp_ObjMap_app[cat_cs_simps]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "cf_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈⦇b, a⦈∙ = 𝔖⦇ObjMap⦈⦇b, 𝔊⦇ObjMap⦈⦇a⦈⦈∙"
  using assms 
  unfolding cf_rcomp_def
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

lemma cf_lcomp_ObjMap_vrange:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
  using assms
  unfolding cf_lcomp_def 
  by (intro cf_bcomp_ObjMap_vrange) (cs_concl cs_intro: cat_cs_intros)+

lemma cf_rcomp_ObjMap_vrange:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
  using assms
  unfolding cf_rcomp_def 
  by (intro cf_bcomp_ObjMap_vrange) (cs_concl cs_intro: cat_cs_intros)+


subsubsection‹Arrow map›

lemma cf_lcomp_ArrMap_vsv: "vsv (cf_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈)"
  unfolding cf_lcomp_def by (rule cf_bcomp_ArrMap_vsv)

lemma cf_rcomp_ArrMap_vsv: "vsv (cf_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈)"
  unfolding cf_rcomp_def by (rule cf_bcomp_ArrMap_vsv)

lemma cf_lcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "category α ℭ" and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
  shows "𝒟∘ (cf_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈) = (𝔄 ×C ℭ)⦇Arr⦈"
  using assms 
  unfolding cf_lcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_rcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔅" and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈) = (𝔅 ×C 𝔄)⦇Arr⦈"
  using assms 
  unfolding cf_rcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_lcomp_ArrMap_app[cat_cs_simps]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
    and "f ∈∘ 𝔄⦇Arr⦈" 
    and "g ∈∘ ℭ⦇Arr⦈"
  shows "cf_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈⦇f, g⦈∙ = 𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈, g⦈∙"
  using assms 
  unfolding cf_lcomp_def
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

lemma cf_rcomp_ArrMap_app[cat_cs_simps]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
    and "f ∈∘ 𝔅⦇Arr⦈" 
    and "g ∈∘ 𝔄⦇Arr⦈"
  shows "cf_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈⦇f, g⦈∙ = 𝔖⦇ArrMap⦈⦇f, 𝔊⦇ArrMap⦈⦇g⦈⦈∙"
  using assms 
  unfolding cf_rcomp_def
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros)

lemma cf_lcomp_ArrMap_vrange:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
  using assms
  unfolding cf_lcomp_def
  by (intro cf_bcomp_ArrMap_vrange) (cs_concl cs_intro: cat_cs_intros)+

lemma cf_rcomp_ArrMap_vrange:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
  using assms
  unfolding cf_rcomp_def
  by (intro cf_bcomp_ArrMap_vrange) (cs_concl cs_intro: cat_cs_intros)+


subsubsection‹
Composition of a covariant bifunctor and a covariant functor is a functor
›

lemma cf_lcomp_is_functor:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_lcomp ℭ 𝔖 𝔉 : 𝔄 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  using assms
  unfolding cf_lcomp_def
  by (cs_concl cs_intro: cat_cs_intros)+

lemma cf_lcomp_is_functor'[cat_cs_intros]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔄' = 𝔄 ×C ℭ"
  shows "cf_lcomp ℭ 𝔖 𝔉 : 𝔄' ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_lcomp_is_functor)

lemma cf_rcomp_is_functor:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_rcomp 𝔅 𝔖 𝔊 : 𝔅 ×C 𝔄 ↦↦C⇘α⇙ 𝔇"
  using assms 
  unfolding cf_rcomp_def 
  by (cs_concl cs_intro: cat_cs_intros)+

lemma cf_rcomp_is_functor'[cat_cs_intros]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔄' = 𝔅 ×C 𝔄"
  shows "cf_rcomp 𝔅 𝔖 𝔊 : 𝔄' ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_rcomp_is_functor)



subsection‹Composition of a contracovariant bifunctor and a covariant functor›

definition cf_cn_cov_lcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_cn_cov_lcomp ℭ 𝔖 𝔉 = cf_cn_cov_bcomp 𝔖 𝔉 (cf_id ℭ)"

definition cf_cn_cov_rcomp :: "V ⇒ V ⇒ V ⇒ V"
  where "cf_cn_cov_rcomp 𝔅 𝔖 𝔊 = cf_cn_cov_bcomp 𝔖 (cf_id 𝔅) 𝔊"


text‹Components.›

lemma cf_cn_cov_lcomp_components:
  shows "cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇HomDom⦈ = op_cat (𝔉⦇HomDom⦈) ×C ℭ"
    and "cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_cn_cov_lcomp_def cf_cn_cov_bcomp_components dghm_id_components 
  by simp_all

lemma cf_cn_cov_rcomp_components:
  shows "cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇HomDom⦈ = op_cat 𝔅 ×C 𝔊⦇HomDom⦈"
    and "cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇HomCod⦈ = 𝔖⦇HomCod⦈"
  unfolding cf_cn_cov_rcomp_def cf_cn_cov_bcomp_components dghm_id_components 
  by simp_all


subsubsection‹Object map›

lemma cf_cn_cov_lcomp_ObjMap_vsv: "vsv (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈)"
  unfolding cf_cn_cov_lcomp_def by (rule cf_cn_cov_bcomp_ObjMap_vsv)

lemma cf_cn_cov_rcomp_ObjMap_vsv: "vsv (cf_cn_cov_rcomp ℭ 𝔖 𝔉⦇ObjMap⦈)"
  unfolding cf_cn_cov_rcomp_def by (rule cf_cn_cov_bcomp_ObjMap_vsv)

lemma cf_cn_cov_lcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "category α ℭ" and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
  shows "𝒟∘ (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈) = (op_cat 𝔄 ×C ℭ)⦇Obj⦈"
  using assms 
  unfolding cf_cn_cov_lcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_cn_cov_rcomp_ObjMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔅" and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈) = (op_cat 𝔅 ×C 𝔄)⦇Obj⦈"
  using assms 
  unfolding cf_cn_cov_rcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_cn_cov_lcomp_ObjMap_app[cat_cs_simps]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "a ∈∘ op_cat 𝔄⦇Obj⦈" 
    and "c ∈∘ ℭ⦇Obj⦈"
  shows "cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈⦇a, c⦈∙ = 𝔖⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈, c⦈∙"
  using assms 
  unfolding cf_cn_cov_lcomp_def cat_op_simps
  by
    (
      cs_concl 
        cs_simp: cat_cs_simps cat_op_simps 
        cs_intro: cat_cs_intros cat_prod_cs_intros
    )

lemma cf_cn_cov_rcomp_ObjMap_app[cat_cs_simps]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ op_cat 𝔅⦇Obj⦈" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈⦇b, a⦈∙ = 𝔖⦇ObjMap⦈⦇b, 𝔊⦇ObjMap⦈⦇a⦈⦈∙"
  using assms 
  unfolding cf_cn_cov_rcomp_def cat_op_simps
  by
    (
      cs_concl 
        cs_simp: cat_cs_simps cat_op_simps 
        cs_intro: cat_cs_intros cat_prod_cs_intros
    )

lemma cf_cn_cov_lcomp_ObjMap_vrange:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
  using assms
  unfolding cf_cn_cov_lcomp_def 
  by (intro cf_cn_cov_bcomp_ObjMap_vrange) 
    (cs_concl cs_intro: cat_cs_intros)+

lemma cf_cn_cov_rcomp_ObjMap_vrange:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ObjMap⦈) ⊆∘ 𝔇⦇Obj⦈"
  using assms
  unfolding cf_cn_cov_rcomp_def 
  by (intro cf_cn_cov_bcomp_ObjMap_vrange) 
    (cs_concl cs_intro: cat_cs_intros)+


subsubsection‹Arrow map›

lemma cf_cn_cov_lcomp_ArrMap_vsv: "vsv (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈)"
  unfolding cf_cn_cov_lcomp_def by (rule cf_cn_cov_bcomp_ArrMap_vsv)

lemma cf_cn_cov_rcomp_ArrMap_vsv: "vsv (cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈)"
  unfolding cf_cn_cov_rcomp_def by (rule cf_cn_cov_bcomp_ArrMap_vsv)

lemma cf_cn_cov_lcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "category α ℭ" and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
  shows "𝒟∘ (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈) = (op_cat 𝔄 ×C ℭ)⦇Arr⦈"
  using assms 
  unfolding cf_cn_cov_lcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_cn_cov_rcomp_ArrMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔅" and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈) = (op_cat 𝔅 ×C 𝔄)⦇Arr⦈"
  using assms 
  unfolding cf_cn_cov_rcomp_def 
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_cn_cov_lcomp_ArrMap_app[cat_cs_simps]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅"
    and "f ∈∘ op_cat 𝔄⦇Arr⦈" 
    and "g ∈∘ ℭ⦇Arr⦈"
  shows "cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈⦇f, g⦈∙ = 𝔖⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈, g⦈∙"
  using assms 
  unfolding cf_cn_cov_lcomp_def cat_op_simps
  by 
    (
      cs_concl 
        cs_simp: cat_cs_simps cat_op_simps 
        cs_intro: cat_cs_intros cat_prod_cs_intros
    )

lemma cf_cn_cov_rcomp_ArrMap_app[cat_cs_simps]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ"
    and "f ∈∘ op_cat 𝔅⦇Arr⦈" 
    and "g ∈∘ 𝔄⦇Arr⦈"
  shows "cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈⦇f, g⦈∙ = 𝔖⦇ArrMap⦈⦇f, 𝔊⦇ArrMap⦈⦇g⦈⦈∙"
  using assms 
  unfolding cf_cn_cov_rcomp_def cat_op_simps
  by 
    (
      cs_concl 
        cs_simp: cat_cs_simps cat_op_simps
        cs_intro: cat_cs_intros cat_prod_cs_intros
    )

lemma cf_cn_cov_lcomp_ArrMap_vrange:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_lcomp ℭ 𝔖 𝔉⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
  using assms
  unfolding cf_cn_cov_lcomp_def
  by (intro cf_cn_cov_bcomp_ArrMap_vrange) 
    (cs_concl cs_intro: cat_cs_intros)+

lemma cf_cn_cov_rcomp_ArrMap_vrange:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "ℛ∘ (cf_cn_cov_rcomp 𝔅 𝔖 𝔊⦇ArrMap⦈) ⊆∘ 𝔇⦇Arr⦈"
  using assms
  unfolding cf_cn_cov_rcomp_def cat_op_simps
  by (intro cf_cn_cov_bcomp_ArrMap_vrange) 
    (cs_concl cs_intro: cat_cs_intros)+


subsubsection‹
Composition of a contracovariant bifunctor and a covariant functor is a functor
›

lemma cf_cn_cov_lcomp_is_functor:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_cn_cov_lcomp ℭ 𝔖 𝔉 : op_cat 𝔄 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  using assms
  unfolding cf_cn_cov_lcomp_def cat_op_simps
  by (cs_concl cs_intro: cat_cs_intros)+

lemma cf_cn_cov_lcomp_is_functor'[cat_cs_intros]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔄ℭ = op_cat 𝔄 ×C ℭ"
  shows "cf_cn_cov_lcomp ℭ 𝔖 𝔉 : 𝔄ℭ ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_lcomp_is_functor)

lemma cf_cn_cov_rcomp_is_functor:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
  shows "cf_cn_cov_rcomp 𝔅 𝔖 𝔊 : op_cat 𝔅 ×C 𝔄 ↦↦C⇘α⇙ 𝔇"
  using assms
  unfolding cf_cn_cov_rcomp_def cat_op_simps
  by (cs_concl cs_intro: cat_cs_intros)+

lemma cf_cn_cov_rcomp_is_functor'[cat_cs_intros]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "𝔅𝔄 = op_cat 𝔅 ×C 𝔄"
  shows "cf_cn_cov_rcomp 𝔅 𝔖 𝔊 : 𝔅𝔄 ↦↦C⇘α⇙ 𝔇"
  using assms(1-3) unfolding assms(4) by (rule cf_cn_cov_rcomp_is_functor)


subsubsection‹
Projection of a composition of a contracovariant bifunctor and a covariant 
functor
›

lemma cf_cn_cov_rcomp_bifunctor_proj_snd[cat_cs_simps]:
  assumes "category α 𝔅" 
    and "𝔊 : 𝔄 ↦↦C⇘α⇙ ℭ" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows
    "cf_cn_cov_rcomp 𝔅 𝔖 𝔊⇘op_cat 𝔅,𝔄⇙(b,-)CF =
      (𝔖⇘op_cat 𝔅,ℭ⇙(b,-)CF) ∘CF 𝔊"
  using assms 
  unfolding cf_cn_cov_rcomp_def
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma cf_cn_cov_lcomp_bifunctor_proj_snd[cat_cs_simps]:
  assumes "category α ℭ" 
    and "𝔉 : 𝔄 ↦↦C⇘α⇙ 𝔅" 
    and "𝔖 : op_cat 𝔅 ×C ℭ ↦↦C⇘α⇙ 𝔇"
    and "b ∈∘ 𝔄⦇Obj⦈"
  shows
    "cf_cn_cov_lcomp ℭ 𝔖 𝔉⇘op_cat 𝔄,ℭ⇙(b,-)CF =
      (𝔖⇘op_cat 𝔅,ℭ⇙(𝔉⦇ObjMap⦈⦇b⦈,-)CF)"
  using assms 
  unfolding cf_cn_cov_lcomp_def
  by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros)



subsection‹Composition of bifunctors›


subsubsection‹Definitions and elementary properties›

definition cf_blcomp :: "V ⇒ V"
  where "cf_blcomp 𝔖 = 
    cf_lcomp (𝔖⦇HomCod⦈) 𝔖 𝔖 ∘CF  
    cf_cat_prod_21_of_3 (𝔖⦇HomCod⦈) (𝔖⦇HomCod⦈) (𝔖⦇HomCod⦈)"

definition cf_brcomp :: "V ⇒ V"
  where "cf_brcomp 𝔖 = 
    cf_rcomp (𝔖⦇HomCod⦈) 𝔖 𝔖 ∘CF
    cf_cat_prod_12_of_3 (𝔖⦇HomCod⦈) (𝔖⦇HomCod⦈) (𝔖⦇HomCod⦈)"


text‹Alternative forms of the definitions.›

lemma cf_blcomp_def':
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "cf_blcomp 𝔖 = cf_lcomp ℭ 𝔖 𝔖 ∘CF cf_cat_prod_21_of_3 ℭ ℭ ℭ"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  show ?thesis
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cf_blcomp_def cs_intro: cat_cs_intros
      )
qed

lemma cf_brcomp_def':
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "cf_brcomp 𝔖 = cf_rcomp ℭ 𝔖 𝔖 ∘CF cf_cat_prod_12_of_3 ℭ ℭ ℭ"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  show ?thesis
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cf_brcomp_def cs_intro: cat_cs_intros
      )
qed


subsubsection‹Compositions of bifunctors are functors›

lemma cf_blcomp_is_functor:
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "cf_blcomp 𝔖 : ℭ ×C3 ℭ ×C3 ℭ ↦↦C⇘α⇙ ℭ"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  show ?thesis
    by (cs_concl cs_simp: cat_cs_simps cf_blcomp_def' cs_intro: cat_cs_intros)
qed

lemma cf_blcomp_is_functor'[cat_cs_intros]:
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ" and "𝔄' = ℭ ×C3 ℭ ×C3 ℭ"
  shows "cf_blcomp 𝔖 : 𝔄' ↦↦C⇘α⇙ ℭ"
  using assms(1) unfolding assms(2) by (rule cf_blcomp_is_functor)

lemma cf_brcomp_is_functor:
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "cf_brcomp 𝔖 : ℭ ×C3 ℭ ×C3 ℭ ↦↦C⇘α⇙ ℭ"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  show ?thesis
    by (cs_concl cs_simp: cat_cs_simps cf_brcomp_def' cs_intro: cat_cs_intros)
qed

lemma cf_brcomp_is_functor'[cat_cs_intros]:
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ" and "𝔄' = ℭ ×C3 ℭ ×C3 ℭ"
  shows "cf_brcomp 𝔖 : 𝔄' ↦↦C⇘α⇙ ℭ"
  using assms(1) unfolding assms(2) by (rule cf_brcomp_is_functor)


subsubsection‹Object map›

lemma cf_blcomp_ObjMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "vsv (cf_blcomp 𝔖⦇ObjMap⦈)"
proof-
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms])
  show ?thesis by auto
qed

lemma cf_brcomp_ObjMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "vsv (cf_brcomp 𝔖⦇ObjMap⦈)"
proof-
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms])
  show ?thesis by auto
qed
 
lemma cf_blcomp_ObjMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_blcomp 𝔖⦇ObjMap⦈) = (ℭ ×C3 ℭ ×C3 ℭ)⦇Obj⦈"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms])
  show ?thesis 
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma cf_brcomp_ObjMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_brcomp 𝔖⦇ObjMap⦈) = (ℭ ×C3 ℭ ×C3 ℭ)⦇Obj⦈"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms])
  show ?thesis 
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma cf_blcomp_ObjMap_app[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
    and "A = [a, b, c]∘"
    and "a ∈∘ ℭ⦇Obj⦈"
    and "b ∈∘ ℭ⦇Obj⦈"
    and "c ∈∘ ℭ⦇Obj⦈"
  shows "cf_blcomp 𝔖⦇ObjMap⦈⦇A⦈ = (a ⊗HM.O⇘𝔖⇙ b) ⊗HM.O⇘𝔖⇙ c"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms(1)])
  from assms(3-5) show ?thesis
    unfolding assms(2)
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_prod_cs_simps cf_blcomp_def' 
          cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed

lemma cf_brcomp_ObjMap_app[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
    and "A = [a, b, c]∘"
    and "a ∈∘ ℭ⦇Obj⦈"
    and "b ∈∘ ℭ⦇Obj⦈"
    and "c ∈∘ ℭ⦇Obj⦈"
  shows "cf_brcomp 𝔖⦇ObjMap⦈⦇A⦈ = a ⊗HM.O⇘𝔖⇙ (b ⊗HM.O⇘𝔖⇙ c)"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms(1)])
  from assms(3-5) show ?thesis
    unfolding assms(2)
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_prod_cs_simps cf_brcomp_def'
          cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed


subsubsection‹Arrow map›

lemma cf_blcomp_ArrMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "vsv (cf_blcomp 𝔖⦇ArrMap⦈)"
proof-
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms])
  show ?thesis by auto
qed

lemma cf_brcomp_ArrMap_vsv[cat_cs_intros]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "vsv (cf_brcomp 𝔖⦇ArrMap⦈)"
proof-
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms])
  show ?thesis by auto
qed
 
lemma cf_blcomp_ArrMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_blcomp 𝔖⦇ArrMap⦈) = (ℭ ×C3 ℭ ×C3 ℭ)⦇Arr⦈"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms])
  show ?thesis 
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma cf_brcomp_ArrMap_vdomain[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
  shows "𝒟∘ (cf_brcomp 𝔖⦇ArrMap⦈) = (ℭ ×C3 ℭ ×C3 ℭ)⦇Arr⦈"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms])
  show ?thesis 
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma cf_blcomp_ArrMap_app[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
    and "F = [h, g, f]∘"
    and "h ∈∘ ℭ⦇Arr⦈"
    and "g ∈∘ ℭ⦇Arr⦈"
    and "f ∈∘ ℭ⦇Arr⦈"
  shows "cf_blcomp 𝔖⦇ArrMap⦈⦇F⦈ = (h ⊗HM.A⇘𝔖⇙ g) ⊗HM.A⇘𝔖⇙ f"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_blcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_blcomp 𝔖›
    by (rule cf_blcomp_is_functor[OF assms(1)])
  from assms(3-5) show ?thesis
    unfolding assms(2)
    by 
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_prod_cs_simps cf_blcomp_def' 
          cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed

lemma cf_brcomp_ArrMap_app[cat_cs_simps]: 
  assumes "𝔖 : ℭ ×C ℭ ↦↦C⇘α⇙ ℭ"
    and "F = [h, g, f]∘"
    and "h ∈∘ ℭ⦇Arr⦈"
    and "g ∈∘ ℭ⦇Arr⦈"
    and "f ∈∘ ℭ⦇Arr⦈"
  shows "cf_brcomp 𝔖⦇ArrMap⦈⦇F⦈ = h ⊗HM.A⇘𝔖⇙ (g ⊗HM.A⇘𝔖⇙ f)"
proof-
  interpret 𝔖: is_functor α ‹ℭ ×C ℭ› ℭ 𝔖 by (rule assms)
  interpret cf_brcomp: is_functor α ‹ℭ ×C3 ℭ ×C3 ℭ› ℭ ‹cf_brcomp 𝔖›
    by (rule cf_brcomp_is_functor[OF assms(1)])
  from assms(3-5) show ?thesis
    unfolding assms(2)
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_prod_cs_simps cf_brcomp_def'
          cs_intro: cat_cs_intros cat_prod_cs_intros
      )
qed



subsection‹Binatural transformation›


subsubsection‹Definitions and elementary properties›

text‹
In this work, a ‹binatural transformation› is used to denote a natural 
transformation of bifunctors.
›

definition bnt_proj_fst :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  (‹(_⇘_,_⇙/'(/-,_/')/NTCF)› [51, 51, 51, 51] 51)
  where "𝔑⇘𝔄,𝔅⇙(-,b)NTCF =
    [
      (λa∈∘𝔄⦇Obj⦈. 𝔑⦇NTMap⦈⦇a, b⦈∙),
      𝔑⦇NTDom⦈⇘𝔄,𝔅⇙(-,b)CF,
      𝔑⦇NTCod⦈⇘𝔄,𝔅⇙(-,b)CF,
      𝔄,
      𝔑⦇NTDGCod⦈
    ]∘"

definition bnt_proj_snd :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  (‹(_⇘_,_⇙/'(/_,-/')/NTCF)› [51, 51, 51, 51] 51)
  where "𝔑⇘𝔄,𝔅⇙(a,-)NTCF =
    [
      (λb∈∘𝔅⦇Obj⦈. 𝔑⦇NTMap⦈⦇a, b⦈∙),
      𝔑⦇NTDom⦈⇘𝔄,𝔅⇙(a,-)CF,
      𝔑⦇NTCod⦈⇘𝔄,𝔅⇙(a,-)CF,
      𝔅,
      𝔑⦇NTDGCod⦈
    ]∘"


text‹Components›

lemma bnt_proj_fst_components:
  shows "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈ = (λa∈∘𝔄⦇Obj⦈. 𝔑⦇NTMap⦈⦇a, b⦈∙)"
    and "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTDom⦈ = 𝔑⦇NTDom⦈⇘𝔄,𝔅⇙(-,b)CF"
    and "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTCod⦈ = 𝔑⦇NTCod⦈⇘𝔄,𝔅⇙(-,b)CF"
    and "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTDGDom⦈ = 𝔄"
    and "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTDGCod⦈ = 𝔑⦇NTDGCod⦈"
  unfolding bnt_proj_fst_def nt_field_simps by (simp_all add: nat_omega_simps)

lemma bnt_proj_snd_components:
  shows "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈ = (λb∈∘𝔅⦇Obj⦈. 𝔑⦇NTMap⦈⦇a, b⦈∙)"
    and "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTDom⦈ = 𝔑⦇NTDom⦈⇘𝔄,𝔅⇙(a,-)CF"
    and "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTCod⦈ = 𝔑⦇NTCod⦈⇘𝔄,𝔅⇙(a,-)CF"
    and "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTDGDom⦈ = 𝔅"
    and "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTDGCod⦈ = 𝔑⦇NTDGCod⦈"
  unfolding bnt_proj_snd_def nt_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation maps›

mk_VLambda bnt_proj_fst_components(1)[folded VLambda_vconst_on]
  |vsv bnt_proj_fst_NTMap_vsv[cat_cs_intros]|
  |vdomain bnt_proj_fst_NTMap_vdomain[cat_cs_simps]|
  |app bnt_proj_fst_NTMap_app[cat_cs_simps]|

lemma bnt_proj_fst_vrange:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "ℛ∘ ((𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))
  show ?thesis
    unfolding bnt_proj_fst_components
  proof(rule vrange_VLambda_vsubset)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"    
    with assms show "𝔑⦇NTMap⦈⦇a, b⦈∙ ∈∘ ℭ⦇Arr⦈"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_prod_cs_intros)
  qed
qed

mk_VLambda bnt_proj_snd_components(1)[folded VLambda_vconst_on]
  |vsv bnt_proj_snd_NTMap_vsv[intro]|
  |vdomain bnt_proj_snd_NTMap_vdomain[cat_cs_simps]|
  |app bnt_proj_snd_NTMap_app[cat_cs_simps]|

lemma bnt_proj_snd_vrange:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "ℛ∘ ((𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))
  show ?thesis
    unfolding bnt_proj_snd_components
  proof(rule vrange_VLambda_vsubset)
    fix b assume "b ∈∘ 𝔅⦇Obj⦈"    
    with assms show "𝔑⦇NTMap⦈⦇a, b⦈∙ ∈∘ ℭ⦇Arr⦈"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_prod_cs_intros)
  qed
qed


subsubsection‹Binatural transformation projection is a natural transformation›

lemma bnt_proj_snd_is_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(a,-)NTCF : 𝔖⇘𝔄,𝔅⇙(a,-)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))
  show ?thesis
  proof(intro is_ntcfI')
    show "vfsequence (𝔑⇘𝔄,𝔅⇙(a,-)NTCF)" unfolding bnt_proj_snd_def by simp 
    show "vcard (𝔑⇘𝔄,𝔅⇙(a,-)NTCF) = 5ℕ"
      unfolding bnt_proj_snd_def by (simp add: nat_omega_simps)
    from assms show "𝔖⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from assms show "𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇b⦈ :
      (𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈ ↦⇘ℭ⇙ (𝔖'⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈"
      if "b ∈∘ 𝔅⦇Obj⦈" for b
      using that assms 
      by 
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
        )
    show "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇b⦈ ∘A⇘ℭ⇙ (𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈⦇f⦈ =
      (𝔖'⇘𝔄,𝔅⇙(a,-)CF)⦇ArrMap⦈⦇f⦈ ∘A⇘ℭ⇙ (𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇a'⦈"
      if "f : a' ↦⇘𝔅⇙ b" for a' b f
      using that assms 
      by 
        (
          cs_concl  
            cs_simp: is_ntcf.ntcf_Comp_commute cat_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (auto simp: bnt_proj_snd_components cat_cs_simps)
qed

lemma bnt_proj_snd_is_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
    and "𝔉 = 𝔖⇘𝔄,𝔅⇙(a,-)CF"
    and "𝔊 = 𝔖'⇘𝔄,𝔅⇙(a,-)CF"
  shows "𝔑⇘𝔄,𝔅⇙(a,-)NTCF : 𝔉 ↦CF 𝔊 : 𝔅 ↦↦C⇘α⇙ ℭ"
  using assms by (auto intro: bnt_proj_snd_is_ntcf)

lemma bnt_proj_fst_is_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(-,b)NTCF : 𝔖⇘𝔄,𝔅⇙(-,b)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))
  show ?thesis
  proof(intro is_ntcfI')
    show "vfsequence (𝔑⇘𝔄,𝔅⇙(-,b)NTCF)" unfolding bnt_proj_fst_def by simp 
    show "vcard (𝔑⇘𝔄,𝔅⇙(-,b)NTCF) = 5ℕ"
      unfolding bnt_proj_fst_def by (simp add: nat_omega_simps)
    from assms show "𝔖⇘𝔄,𝔅⇙(-,b)CF : 𝔄  ↦↦C⇘α⇙ ℭ"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros)
    from assms show "𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros)
    show "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈⦇a⦈ :
      (𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔖'⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝔄⦇Obj⦈" for a
      using that assms 
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
        )
    show "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈⦇b'⦈ ∘A⇘ℭ⇙ (𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈⦇f⦈ =
      (𝔖'⇘𝔄,𝔅⇙(-,b)CF)⦇ArrMap⦈⦇f⦈ ∘A⇘ℭ⇙ (𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈⦇a⦈"
      if "f : a ↦⇘𝔄⇙ b'" for a b' f
      using that assms 
      by
        (
          cs_concl 
            cs_simp: is_ntcf.ntcf_Comp_commute cat_cs_simps 
            cs_intro: cat_cs_intros cat_prod_cs_intros
        )
  qed (auto simp: bnt_proj_fst_components cat_cs_simps)
qed

lemma bnt_proj_fst_is_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈"
    and "𝔉 = 𝔖⇘𝔄,𝔅⇙(-,b)CF"
    and "𝔊 = 𝔖'⇘𝔄,𝔅⇙(-,b)CF"
    and "𝔄' = 𝔄"
  shows "𝔑⇘𝔄,𝔅⇙(-,b)NTCF : 𝔉 ↦CF 𝔊 : 𝔄' ↦↦C⇘α⇙ ℭ"
  using assms(1-4) unfolding assms(5-7) by (rule bnt_proj_fst_is_ntcf)


subsubsection‹Array binatural transformation is a natural transformation›

lemma ntcf_array_is_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔖 : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "vfsequence 𝔑"
    and "vcard 𝔑 = 5ℕ"
    and "𝔑⦇NTDom⦈ = 𝔖"
    and "𝔑⦇NTCod⦈ = 𝔖'"
    and "𝔑⦇NTDGDom⦈ = 𝔄 ×C 𝔅"
    and "𝔑⦇NTDGCod⦈ = ℭ"
    and "vsv (𝔑⦇NTMap⦈)"
    and "𝒟∘ (𝔑⦇NTMap⦈) = (𝔄 ×C 𝔅)⦇Obj⦈"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔅⦇Obj⦈ ⟧ ⟹
      𝔑⦇NTMap⦈⦇a, b⦈∙ : 𝔖⦇ObjMap⦈⦇a, b⦈∙ ↦⇘ℭ⇙ 𝔖'⦇ObjMap⦈⦇a, b⦈∙"
    and "⋀a. a ∈∘ 𝔄⦇Obj⦈ ⟹
      𝔑⇘𝔄,𝔅⇙(a,-)NTCF : 𝔖⇘𝔄,𝔅⇙(a,-)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
    and "⋀b. b ∈∘ 𝔅⦇Obj⦈ ⟹
      𝔑⇘𝔄,𝔅⇙(-,b)NTCF : 𝔖⇘𝔄,𝔅⇙(-,b)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"  
  shows "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔑: vsv ‹𝔑⦇NTMap⦈› by (rule assms(11))  

  have [cat_cs_intros]:
    "⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔅⦇Obj⦈; A = 𝔖⦇ObjMap⦈⦇a, b⦈∙; B = 𝔖'⦇ObjMap⦈⦇a, b⦈∙ ⟧ ⟹
      𝔑⦇NTMap⦈⦇a, b⦈∙ : A ↦⇘ℭ⇙ B"
    for a b A B
    by (auto intro: assms(13))

  show ?thesis
  proof(intro is_ntcfI')

    show "𝔑⦇NTMap⦈⦇ab⦈ : 𝔖⦇ObjMap⦈⦇ab⦈ ↦⇘ℭ⇙ 𝔖'⦇ObjMap⦈⦇ab⦈"
      if "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈" for ab
    proof-
      from that obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF assms(1,2)])
      from a b show ?thesis unfolding ab_def by (rule assms(13))
    qed
    
    show
      "𝔑⦇NTMap⦈⦇a'b'⦈ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇gf⦈ = 𝔖'⦇ArrMap⦈⦇gf⦈ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇ab⦈"
      if "gf : ab ↦⇘𝔄 ×C 𝔅⇙ a'b'" for ab a'b' gf
    proof-
      from that obtain g f a b a' b'
        where gf_def: "gf = [g, f]∘" 
          and ab_def: "ab = [a, b]∘" 
          and a'b'_def: "a'b' = [a', b']∘"
          and g: "g : a ↦⇘𝔄⇙ a'"
          and f: "f : b ↦⇘𝔅⇙ b'"
        by (elim cat_prod_2_is_arrE[OF assms(1,2)])
      then have a: "a ∈∘ 𝔄⦇Obj⦈" 
        and a': "a' ∈∘ 𝔄⦇Obj⦈" 
        and b: "b ∈∘ 𝔅⦇Obj⦈" 
        and b': "b' ∈∘ 𝔅⦇Obj⦈" 
        by auto
      show ?thesis
        unfolding gf_def ab_def a'b'_def
      proof-
        from is_ntcfD'(13)[OF assms(15)[OF b] g] g f assms(1,2,3,4) 
        have [cat_cs_simps]:
          "(𝔖'⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇a, b⦈∙) =
            (𝔑⦇NTMap⦈⦇a', b⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙)"
          by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) auto
        from is_ntcfD'(13)[OF assms(14)[OF a'] f] g f assms(1,2) 
        have 𝔖'𝔑:
          "𝔖'⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇a', b⦈∙ =
            𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈,f⦈∙"
          by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) auto
        from g f assms(1-4) have [cat_cs_simps]: 
          "𝔖'⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ (𝔑⦇NTMap⦈⦇a', b⦈∙ ∘A⇘ℭ⇙ q) =
            𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙ (𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈,f⦈∙ ∘A⇘ℭ⇙ q)"
          if "q : r ↦⇘ℭ⇙ 𝔖⦇ObjMap⦈⦇a', b⦈∙" for q r
          using that
          by
            (
              cs_concl 
                cs_simp: 𝔖'𝔑 category.cat_Comp_assoc[symmetric]  
                cs_intro: cat_cs_intros cat_prod_cs_intros
            ) 

        from assms(1-4) g f have 
          "𝔖'⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔖'⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙ =
            𝔖'⦇ArrMap⦈⦇[𝔄⦇CId⦈⦇a'⦈, f]∘ ∘A⇘𝔄 ×C 𝔅⇙ [g, 𝔅⦇CId⦈⦇b⦈]∘⦈"
          by 
            (
              cs_concl  
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
            ) 
        also from assms(1-4) g f have "… = 𝔖'⦇ArrMap⦈⦇g, f⦈∙"
          by 
            (
              cs_concl  
                cs_simp: cat_cs_simps cat_prod_cs_simps
                cs_intro: cat_cs_intros cat_prod_cs_intros
            )
        finally have 𝔖'_gf: "𝔖'⦇ArrMap⦈⦇g, f⦈∙ =
          𝔖'⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔖'⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙"
          by simp
        from assms(1-4) g f have 
          "𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙ =
            𝔖⦇ArrMap⦈⦇[𝔄⦇CId⦈⦇a'⦈, f]∘ ∘A⇘𝔄 ×C 𝔅⇙ [g, 𝔅⦇CId⦈⦇b⦈]∘⦈"
          by 
            (
              cs_concl  
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
            ) 
        also from assms(1-4) g f have "… = 𝔖⦇ArrMap⦈⦇g, f⦈∙"
          by 
            (
              cs_concl  
                cs_simp: cat_cs_simps cat_prod_cs_simps
                cs_intro: cat_cs_intros cat_prod_cs_intros
            )
        finally have 𝔖_gf: "𝔖⦇ArrMap⦈⦇g, f⦈∙ =
          𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙"
          by simp
        from assms(1-4) g f assms(13)[OF a b] assms(13)[OF a' b] have 
          "𝔖'⦇ArrMap⦈⦇g, f⦈∙ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇a, b⦈∙ =
            (𝔖'⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈, f⦈∙ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇a', b⦈∙) ∘A⇘ℭ⇙
            𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙"
          unfolding 𝔖'_gf 
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
            )
        also from assms(1-4) g f have 
          "… = (𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈,f⦈∙) ∘A⇘ℭ⇙
            𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙"
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
            )
        also from assms(1-4) g f assms(13)[OF a' b'] have 
          "… = 𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙
            (𝔖⦇ArrMap⦈⦇𝔄⦇CId⦈⦇a'⦈,f⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, 𝔅⦇CId⦈⦇b⦈⦈∙)"
          by 
            (
              cs_concl  
                cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_prod_cs_intros
            )
        also from assms(1-4) g f assms(13)[OF a' b'] have 
          "… = 𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, f⦈∙"
          unfolding 𝔖_gf[symmetric] by simp
        finally show 
          "𝔑⦇NTMap⦈⦇a', b'⦈∙ ∘A⇘ℭ⇙ 𝔖⦇ArrMap⦈⦇g, f⦈∙ =
            𝔖'⦇ArrMap⦈⦇g, f⦈∙ ∘A⇘ℭ⇙ 𝔑⦇NTMap⦈⦇a, b⦈∙"
          by simp
      qed
    qed

  qed (auto simp: assms)

qed


subsubsection‹Binatural transformation projections and isomorphisms›

lemma is_iso_ntcf_if_bnt_proj_snd_is_iso_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "⋀a. a ∈∘ 𝔄⦇Obj⦈ ⟹ 
      𝔑⇘𝔄,𝔅⇙(a,-)NTCF : 𝔖⇘𝔄,𝔅⇙(a,-)CF ↦CF.iso 𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  show ?thesis  
  proof(intro is_iso_ntcfI)
    show "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" by (rule assms(3))
    fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
    then obtain a b 
      where ab_def: "ab = [a, b]∘" and a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈"
      by (elim cat_prod_2_ObjE[OF assms(1,2)])
    interpret 𝔑a: is_iso_ntcf 
      α 𝔅 ℭ ‹𝔖⇘𝔄,𝔅⇙(a,-)CF› ‹𝔖'⇘𝔄,𝔅⇙(a,-)CF› ‹𝔑⇘𝔄,𝔅⇙(a,-)NTCF›
      by (rule assms(4)[OF a])
    from b have 𝔑ab: "𝔑⦇NTMap⦈⦇a, b⦈∙ = (𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇b⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    from 𝔑a.iso_ntcf_is_iso_arr[OF b] assms(1,2,3) a b show
      "𝔑⦇NTMap⦈⦇ab⦈ : 𝔖⦇ObjMap⦈⦇ab⦈ ↦iso⇘ℭ⇙ 𝔖'⦇ObjMap⦈⦇ab⦈" 
      by 
        (
          cs_prems cs_shallow 
            cs_simp: cat_cs_simps ab_def cs_intro: cat_prod_cs_intros
        )
  qed
qed

lemma is_iso_ntcf_if_bnt_proj_fst_is_iso_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "⋀b. b ∈∘ 𝔅⦇Obj⦈ ⟹
      𝔑⇘𝔄,𝔅⇙(-,b)NTCF : 𝔖⇘𝔄,𝔅⇙(-,b)CF ↦CF.iso 𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
  shows "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
proof-
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  show ?thesis  
  proof(intro is_iso_ntcfI)
    show "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" by (rule assms(3))
    fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
    then obtain a b 
      where ab_def: "ab = [a, b]∘" and a: "a ∈∘ 𝔄⦇Obj⦈" and b: "b ∈∘ 𝔅⦇Obj⦈"
      by (elim cat_prod_2_ObjE[OF assms(1,2)])
    interpret 𝔑a: is_iso_ntcf 
      α 𝔄 ℭ ‹𝔖⇘𝔄,𝔅⇙(-,b)CF› ‹𝔖'⇘𝔄,𝔅⇙(-,b)CF› ‹𝔑⇘𝔄,𝔅⇙(-,b)NTCF›
      by (rule assms(4)[OF b])
    from b have 𝔑ab: "𝔑⦇NTMap⦈⦇a, b⦈∙ = (𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇b⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from 𝔑a.iso_ntcf_is_iso_arr[OF a] assms(1,2,3) a b show
      "𝔑⦇NTMap⦈⦇ab⦈ : 𝔖⦇ObjMap⦈⦇ab⦈ ↦iso⇘ℭ⇙ 𝔖'⦇ObjMap⦈⦇ab⦈"
      unfolding ab_def 
      by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros)
  qed
qed

lemma bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(a,-)NTCF :
    𝔖⇘𝔄,𝔅⇙(a,-)CF ↦CF.iso 𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
proof(intro is_iso_ntcfI)
  from assms show "𝔑⇘𝔄,𝔅⇙(a,-)NTCF :
    𝔖⇘𝔄,𝔅⇙(a,-)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(a,-)CF : 𝔅 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
  show "(𝔑⇘𝔄,𝔅⇙(a,-)NTCF)⦇NTMap⦈⦇b⦈ :
    (𝔖⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈ ↦iso⇘ℭ⇙ (𝔖'⇘𝔄,𝔅⇙(a,-)CF)⦇ObjMap⦈⦇b⦈"
    if "b ∈∘ 𝔅⦇Obj⦈" for b
    using assms that 
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cs_intro: cat_prod_cs_intros cat_arrow_cs_intros
      )
qed

lemma bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "𝔉 = 𝔖⇘𝔄,𝔅⇙(a,-)CF"
    and "𝔊 = 𝔖'⇘𝔄,𝔅⇙(a,-)CF"
    and "𝔅' = 𝔅"
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(a,-)NTCF : 𝔉 ↦CF.iso 𝔊 : 𝔅' ↦↦C⇘α⇙ ℭ"
  unfolding assms(4-6) 
  by (rule bnt_proj_snd_is_iso_ntcf_if_is_iso_ntcf[OF assms(1-3,7)])

lemma bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(-,b)NTCF :
    𝔖⇘𝔄,𝔅⇙(-,b)CF ↦CF.iso 𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
proof(intro is_iso_ntcfI)
  from assms show "𝔑⇘𝔄,𝔅⇙(-,b)NTCF :
    𝔖⇘𝔄,𝔅⇙(-,b)CF ↦CF 𝔖'⇘𝔄,𝔅⇙(-,b)CF : 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
  show "(𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈⦇a⦈ :
    (𝔖⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈ ↦iso⇘ℭ⇙ (𝔖'⇘𝔄,𝔅⇙(-,b)CF)⦇ObjMap⦈⦇a⦈"
    if "a ∈∘ 𝔄⦇Obj⦈" for a
    using assms that 
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps
          cs_intro: cat_prod_cs_intros cat_arrow_cs_intros
      )
qed

lemma bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "𝔉 = 𝔖⇘𝔄,𝔅⇙(-,b)CF"
    and "𝔊 = 𝔖'⇘𝔄,𝔅⇙(-,b)CF"
    and "𝔄' = 𝔄"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "𝔑⇘𝔄,𝔅⇙(-,b)NTCF : 𝔉 ↦CF.iso 𝔊 : 𝔄' ↦↦C⇘α⇙ ℭ"
  unfolding assms(4-6) 
  by (rule bnt_proj_fst_is_iso_ntcf_if_is_iso_ntcf[OF assms(1-3,7)])



subsection‹Binatural transformation flip›


subsubsection‹Definition and elementary properties›

definition bnt_flip :: "V ⇒ V ⇒ V ⇒ V"
  where "bnt_flip 𝔄 𝔅 𝔑 =
    [
      fflip (𝔑⦇NTMap⦈), 
      bifunctor_flip 𝔄 𝔅 (𝔑⦇NTDom⦈),
      bifunctor_flip 𝔄 𝔅 (𝔑⦇NTCod⦈),
      𝔅 ×C 𝔄,
      𝔑⦇NTDGCod⦈
    ]∘"


text‹Components.›

lemma bnt_flip_components:
  shows "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈ = fflip (𝔑⦇NTMap⦈)"
    and "bnt_flip 𝔄 𝔅 𝔑⦇NTDom⦈ = bifunctor_flip 𝔄 𝔅 (𝔑⦇NTDom⦈)"
    and "bnt_flip 𝔄 𝔅 𝔑⦇NTCod⦈ = bifunctor_flip 𝔄 𝔅 (𝔑⦇NTCod⦈)"
    and "bnt_flip 𝔄 𝔅 𝔑⦇NTDGDom⦈ = 𝔅 ×C 𝔄"
    and "bnt_flip 𝔄 𝔅 𝔑⦇NTDGCod⦈ = 𝔑⦇NTDGCod⦈"
  unfolding bnt_flip_def nt_field_simps by (simp_all add: nat_omega_simps)

context 
  fixes α 𝔄 𝔅 ℭ 𝔖 𝔖' 𝔑
  assumes 𝔑: "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
begin

interpretation 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule 𝔑)

lemmas bnt_flip_components' = 
  bnt_flip_components[where 𝔄=𝔄 and 𝔅=𝔅 and 𝔑=𝔑, unfolded cat_cs_simps]

lemmas [cat_cs_simps] = bnt_flip_components'(2-5)

end


subsubsection‹Natural transformation map›

lemma bnt_flip_NTMap_vsv[cat_cs_intros]: "vsv (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈)"
  unfolding bnt_flip_components by (rule fflip_vsv)

lemma bnt_flip_NTMap_app:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇b, a⦈∙ = 𝔑⦇NTMap⦈⦇a, b⦈∙"
  using assms
  unfolding bnt_flip_components
  by 
    (
      cs_concl cs_shallow 
        cs_simp: V_cs_simps cat_cs_simps cs_intro: cat_prod_cs_intros
    )

lemma bnt_flip_NTMap_app'[cat_cs_simps]:
  assumes "ba = [b, a]∘"
    and "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇ba⦈ = 𝔑⦇NTMap⦈⦇a, b⦈∙"
  using assms(2-6) unfolding assms(1) by (rule bnt_flip_NTMap_app)

lemma bnt_flip_NTMap_vdomain[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
  shows "𝒟∘ (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈) = (𝔅 ×C 𝔄)⦇Obj⦈"
  using assms
  unfolding bnt_flip_components
  by (cs_concl cs_shallow cs_simp: V_cs_simps cat_cs_simps)

lemma bnt_flip_NTMap_vrange[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
  shows "ℛ∘ (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈) = ℛ∘ (𝔑⦇NTMap⦈)"
proof-
  
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))

  show ?thesis
  proof(intro vsubset_antisym)

    show "ℛ∘ (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈) ⊆∘ ℛ∘ (𝔑⦇NTMap⦈)"
    proof
      (
        intro vsv.vsv_vrange_vsubset, 
        unfold bnt_flip_NTMap_vdomain[OF assms]
      )
      fix ba assume "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
      then obtain a b
        where ba_def: "ba = [b, a]∘" 
          and b: "b ∈∘ 𝔅⦇Obj⦈" 
          and a: "a ∈∘ 𝔄⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF assms(2,1)])
      from 𝔑.ntcf_NTMap_vsv assms a b show 
        "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇ba⦈ ∈∘ ℛ∘ (𝔑⦇NTMap⦈)"
        unfolding ba_def
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_prod_cs_intros
          )
    qed (cs_concl cs_shallow cs_intro: cat_cs_intros)

    show "ℛ∘ (𝔑⦇NTMap⦈) ⊆∘ ℛ∘ (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈)"
    proof(intro vsv.vsv_vrange_vsubset, unfold 𝔑.ntcf_NTMap_vdomain)
      fix ab assume prems: "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
      then obtain a b 
        where ab_def: "ab = [a, b]∘" 
          and a: "a ∈∘ 𝔄⦇Obj⦈" 
          and b: "b ∈∘ 𝔅⦇Obj⦈"
        by (elim cat_prod_2_ObjE[OF assms(1,2)])
      from assms a b have ba: "[b, a]∘ ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈"
        by (cs_concl cs_shallow cs_intro: cat_prod_cs_intros)
      from assms bnt_flip_NTMap_vsv prems a b ba show 
        "𝔑⦇NTMap⦈⦇ab⦈ ∈∘ ℛ∘ (bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈)"
        unfolding ab_def 
        by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: V_cs_intros)
    qed auto

  qed

qed


subsubsection‹Binatural transformation flip natural transformation map›

lemma bnt_flip_NTMap_is_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
  shows "bnt_flip 𝔄 𝔅 𝔑 : 
    bifunctor_flip 𝔄 𝔅 𝔖 ↦CF bifunctor_flip 𝔄 𝔅 𝔖' : 
    𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
proof-

  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))

  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))

  show ?thesis
  proof(intro is_ntcfI')
    show "vfsequence (bnt_flip 𝔄 𝔅 𝔑)" unfolding bnt_flip_def by simp
    show "vcard (bnt_flip 𝔄 𝔅 𝔑) = 5ℕ"
      unfolding bnt_flip_def by (simp add: nat_omega_simps)
    show "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇ba⦈ :
      bifunctor_flip 𝔄 𝔅 𝔖⦇ObjMap⦈⦇ba⦈ ↦⇘ℭ⇙
      bifunctor_flip 𝔄 𝔅 𝔖'⦇ObjMap⦈⦇ba⦈"
      if "ba ∈∘ (𝔅 ×C 𝔄)⦇Obj⦈" for ba
    proof-
      from that obtain b a 
        where ba_def: "ba = [b, a]∘" 
          and b: "b ∈∘ 𝔅⦇Obj⦈"
          and a: "a ∈∘ 𝔄⦇Obj⦈"
        by (elim cat_prod_2_ObjE[rotated 2]) (auto intro: cat_cs_intros)
      from assms a b show ?thesis 
        by 
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps ba_def 
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed
    show 
      "bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇b'a'⦈ ∘A⇘ℭ⇙ bifunctor_flip 𝔄 𝔅 𝔖⦇ArrMap⦈⦇gf⦈ =
        bifunctor_flip 𝔄 𝔅 𝔖'⦇ArrMap⦈⦇gf⦈ ∘A⇘ℭ⇙ bnt_flip 𝔄 𝔅 𝔑⦇NTMap⦈⦇ba⦈"
      if "gf : ba ↦⇘𝔅 ×C 𝔄⇙ b'a'" for ba b'a' gf
    proof-
      from that obtain g f a b a' b'
        where gf_def: "gf = [g, f]∘"
          and ba_def: "ba = [b, a]∘"
          and b'a'_def: "b'a' = [b', a']∘"
          and g: "g : b ↦⇘𝔅⇙ b'"
          and f: "f : a ↦⇘𝔄⇙ a'"
        by (elim cat_prod_2_is_arrE[OF assms(2,1)])
      from assms g f show ?thesis
        unfolding gf_def ba_def b'a'_def
        by 
          ( 
            cs_concl 
              cs_simp: cat_cs_simps cat_cs_simps 𝔑.ntcf_Comp_commute
              cs_intro: cat_cs_intros cat_prod_cs_intros
          )
    qed

  qed 
    (
      use assms in 
        ‹cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros›
    )+

qed

lemma bnt_flip_NTMap_is_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "𝒯 = bifunctor_flip 𝔄 𝔅 𝔖"
    and "𝒯' = bifunctor_flip 𝔄 𝔅 𝔖'"
    and "𝔇 = 𝔅 ×C 𝔄"
  shows "bnt_flip 𝔄 𝔅 𝔑 : 𝒯 ↦CF 𝒯' : 𝔇 ↦↦C⇘α⇙ ℭ"
  using assms(1-3) unfolding assms(4-6) by (intro bnt_flip_NTMap_is_ntcf)


subsubsection‹Double-flip of a binatural transformation›

lemma bnt_flip_flip[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
  shows "bnt_flip 𝔅 𝔄 (bnt_flip 𝔄 𝔅 𝔑) = 𝔑"
proof(rule ntcf_eqI)
  interpret 𝔄: category α 𝔄 by (rule assms(1))
  interpret 𝔅: category α 𝔅 by (rule assms(2))
  interpret 𝔑: is_ntcf α ‹𝔄 ×C 𝔅› ℭ 𝔖 𝔖' 𝔑 by (rule assms(3))
  from assms show
    "bnt_flip 𝔅 𝔄 (bnt_flip 𝔄 𝔅 𝔑) : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  then have dom_lhs:
    "𝒟∘ (bnt_flip 𝔅 𝔄 (bnt_flip 𝔄 𝔅 𝔑)⦇NTMap⦈) = (𝔄 ×C 𝔅)⦇Obj⦈"
    by (cs_concl cs_simp: cat_cs_simps)
  show "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" by (rule assms(3))
  then have dom_rhs: "𝒟∘ (𝔑⦇NTMap⦈) = (𝔄 ×C 𝔅)⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  show "bnt_flip 𝔅 𝔄 (bnt_flip 𝔄 𝔅 𝔑)⦇NTMap⦈ = 𝔑⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix ab assume "ab ∈∘ (𝔄 ×C 𝔅)⦇Obj⦈"
    then obtain a b
      where ab_def: "ab = [a, b]∘" 
        and a: "a ∈∘ 𝔄⦇Obj⦈" 
        and b: "b ∈∘ 𝔅⦇Obj⦈" 
      by (rule cat_prod_2_ObjE[OF assms(1,2)])
    from assms a b show 
      "bnt_flip 𝔅 𝔄 (bnt_flip 𝔄 𝔅 𝔑)⦇NTMap⦈⦇ab⦈ = 𝔑⦇NTMap⦈⦇ab⦈" 
      by 
        (
          cs_concl cs_shallow 
            cs_simp: cat_cs_simps ab_def cs_intro: cat_cs_intros
        )
  qed (cs_concl cs_shallow cs_intro: V_cs_intros cat_cs_intros)+
qed simp_all


subsubsection‹A projection of a flip of a binatural transformation›

lemma bnt_flip_proj_snd[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "b ∈∘ 𝔅⦇Obj⦈"
  shows "bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(b,-)NTCF = 𝔑⇘𝔄,𝔅⇙(-,b)NTCF"
proof(rule ntcf_eqI)
  from assms show "bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(b,-)NTCF :
    bifunctor_flip 𝔄 𝔅 𝔖⇘𝔅,𝔄⇙(b,-)CF ↦CF bifunctor_flip 𝔄 𝔅 𝔖'⇘𝔅,𝔄⇙(b,-)CF :
    𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  from assms show "𝔑⇘𝔄,𝔅⇙(-,b)NTCF :
    bifunctor_flip 𝔄 𝔅 𝔖⇘𝔅,𝔄⇙(b,-)CF ↦CF bifunctor_flip 𝔄 𝔅 𝔖'⇘𝔅,𝔄⇙(b,-)CF :
    𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from assms have dom_lhs: 
    "𝒟∘ ((bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(b,-)NTCF)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from assms have dom_rhs: "𝒟∘ ((𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  show "(bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(b,-)NTCF)⦇NTMap⦈ = (𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    with assms show 
      "(bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(b,-)NTCF)⦇NTMap⦈⦇a⦈ = (𝔑⇘𝔄,𝔅⇙(-,b)NTCF)⦇NTMap⦈⦇a⦈"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  qed (auto simp: cat_cs_intros)
qed simp_all

lemma bnt_flip_proj_fst[cat_cs_simps]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ" 
    and "a ∈∘ 𝔄⦇Obj⦈"
  shows "bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(-,a)NTCF = 𝔑⇘𝔄,𝔅⇙(a,-)NTCF"
proof-
  from assms have f_𝔑: 
    "bnt_flip 𝔄 𝔅 𝔑 :
      bifunctor_flip 𝔄 𝔅 𝔖 ↦CF bifunctor_flip 𝔄 𝔅 𝔖' :
      𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  show ?thesis
    by 
      (
        rule 
          bnt_flip_proj_snd
            [
              OF assms(2,1) f_𝔑 assms(4), 
              unfolded bnt_flip_flip[OF assms(1,2,3)],
              symmetric
            ]
      )
qed


subsubsection‹A flip of a binatural isomorphism›

lemma bnt_flip_is_iso_ntcf:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
  shows "bnt_flip 𝔄 𝔅 𝔑 :
    bifunctor_flip 𝔄 𝔅 𝔖 ↦CF.iso bifunctor_flip 𝔄 𝔅 𝔖' : 
    𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
proof(rule is_iso_ntcf_if_bnt_proj_snd_is_iso_ntcf)
  from assms show f_𝔑: "bnt_flip 𝔄 𝔅 𝔑 :
    bifunctor_flip 𝔄 𝔅 𝔖 ↦CF bifunctor_flip 𝔄 𝔅 𝔖' :
    𝔅 ×C 𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_intro: cat_cs_intros ntcf_cs_intros)
  fix a assume "a ∈∘ 𝔅⦇Obj⦈"
  with assms f_𝔑 show 
    "bnt_flip 𝔄 𝔅 𝔑⇘𝔅,𝔄⇙(a,-)NTCF :
      bifunctor_flip 𝔄 𝔅 𝔖⇘𝔅,𝔄⇙(a,-)CF ↦CF.iso
      bifunctor_flip 𝔄 𝔅 𝔖'⇘𝔅,𝔄⇙(a,-)CF :
      𝔄 ↦↦C⇘α⇙ ℭ"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros ntcf_cs_intros)
qed (simp_all add: assms)

lemma bnt_flip_is_iso_ntcf'[cat_cs_intros]:
  assumes "category α 𝔄"
    and "category α 𝔅"
    and "𝔑 : 𝔖 ↦CF.iso 𝔖' : 𝔄 ×C 𝔅 ↦↦C⇘α⇙ ℭ"
    and "𝔉 = bifunctor_flip 𝔄 𝔅 𝔖"
    and "𝔊 = bifunctor_flip 𝔄 𝔅 𝔖'"
    and "𝔇 = 𝔅 ×C 𝔄"
  shows "bnt_flip 𝔄 𝔅 𝔑 : 𝔉 ↦CF.iso 𝔊 : 𝔇 ↦↦C⇘α⇙ ℭ"
  using bnt_flip_is_iso_ntcf[OF assms(1-3)] unfolding assms(4-6) by simp

text‹\newpage›

end