Theory CZH_UCAT_Pointed

(* Copyright 2021 (C) Mihails Milehins *)

section‹Pointed arrows and natural transformations›
theory CZH_UCAT_Pointed
  imports 
    CZH_Elementary_Categories.CZH_ECAT_NTCF
    CZH_Elementary_Categories.CZH_ECAT_Hom
begin



subsection‹Pointed arrow›


text‹
The terminology that is used in this section deviates from convention: a 
pointed arrow is merely an arrow in Set› from a singleton set to another set.
›


subsubsection‹Definition and elementary properties›


text‹See Chapter III-2 in cite"mac_lane_categories_2010".›

definition ntcf_paa :: "V  V  V  V"
  where "ntcf_paa 𝔞 B b = [(λaset {𝔞}. b), set {𝔞}, B]"


text‹Components.›

lemma ntcf_paa_components:
  shows "ntcf_paa 𝔞 B bArrVal = (λaset {𝔞}. b)"
    and [cat_cs_simps]: "ntcf_paa 𝔞 B bArrDom = set {𝔞}"
    and [cat_cs_simps]: "ntcf_paa 𝔞 B bArrCod = B"
  unfolding ntcf_paa_def arr_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Arrow value›

mk_VLambda ntcf_paa_components(1)
  |vsv ntcf_paa_ArrVal_vsv[cat_cs_intros]|
  |vdomain ntcf_paa_ArrVal_vdomain[cat_cs_simps]|
  |app ntcf_paa_ArrVal_app[unfolded vsingleton_iff, cat_cs_simps]|


subsubsection‹Pointed arrow is an arrow in Set›

lemma (in 𝒵) ntcf_paa_is_arr:
  assumes "𝔞  cat_Set αObj" and "A  cat_Set αObj" and "a  A"
  shows "ntcf_paa 𝔞 A a : set {𝔞} cat_Set αA"
proof(intro cat_Set_is_arrI arr_SetI cat_cs_intros, unfold cat_cs_simps)
  show "vfsequence (ntcf_paa 𝔞 A a)" unfolding ntcf_paa_def by simp
  show "vcard (ntcf_paa 𝔞 A a) = 3"
    unfolding ntcf_paa_def by (simp add: nat_omega_simps)
  show " (ntcf_paa 𝔞 A aArrVal)  A"
    unfolding ntcf_paa_components by (intro vrange_VLambda_vsubset assms)
qed (use assms in auto simp: cat_Set_components(1) Limit_vsingleton_in_VsetI)

lemma (in 𝒵) ntcf_paa_is_arr'[cat_cs_intros]:
  assumes "𝔞  cat_Set αObj" 
    and "A  cat_Set αObj" 
    and "a  A"
    and "A' = set {𝔞}"
    and "B' = A"
    and "ℭ' = cat_Set α"
  shows "ntcf_paa 𝔞 A a : A' ℭ'B'"
  using assms(1-3) unfolding assms(4-6) by (rule ntcf_paa_is_arr) 

lemmas [cat_cs_intros] = 𝒵.ntcf_paa_is_arr'


subsubsection‹Further properties›

lemma ntcf_paa_injective[cat_cs_simps]: 
  "ntcf_paa 𝔞 A b = ntcf_paa 𝔞 A c  b = c"
proof
  assume "ntcf_paa 𝔞 A b = ntcf_paa 𝔞 A c"
  then have "ntcf_paa 𝔞 A bArrVal𝔞 = ntcf_paa 𝔞 A cArrVal𝔞" by simp
  then show "b = c" by (cs_prems cs_simp: cat_cs_simps)
qed simp

lemma (in 𝒵) ntcf_paa_ArrVal:
  assumes "F : set {𝔞} cat_Set αX"
  shows "ntcf_paa 𝔞 X (FArrVal𝔞) = F"
proof-
  interpret F: arr_Set α F
    rewrites [cat_cs_simps]: "FArrDom = set {𝔞}" 
      and [cat_cs_simps]: "FArrCod = X"
    by (auto simp: cat_Set_is_arrD[OF assms])
  from F.arr_Par_ArrDom_in_Vset have 𝔞: "𝔞  Vset α" by auto
  from assms 𝔞 F.arr_Par_ArrCod_in_Vset have lhs_is_arr:
    "ntcf_paa 𝔞 X (FArrVal𝔞) : set {𝔞} cat_Set αX"
    by
      (
        cs_concl cs_shallow 
          cs_simp: cat_Set_components(1)
          cs_intro: V_cs_intros cat_Set_cs_intros cat_cs_intros
      )
  then have dom_lhs: "𝒟 (ntcf_paa 𝔞 X (FArrVal𝔞)ArrVal) = set {𝔞}"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from assms have dom_rhs: "𝒟 (FArrVal) = set {𝔞}" 
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  show ?thesis
  proof(rule arr_Set_eqI)
    from lhs_is_arr assms 
    show arr_Set_lhs: "arr_Set α (ntcf_paa 𝔞 X (FArrVal𝔞))" 
      and arr_Set_rhs: "arr_Set α F"
      by (auto dest: cat_Set_is_arrD)
    show "ntcf_paa 𝔞 X (FArrVal𝔞)ArrVal = FArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs vsingleton_iff; (simp only:)?)
      show "ntcf_paa 𝔞 X (FArrVal𝔞)ArrVal𝔞 = FArrVal𝔞"
        by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed (use arr_Set_lhs arr_Set_rhs in auto)
  qed (use assms in cs_concl cs_shallow cs_simp: cat_cs_simps)+
qed

lemma (in 𝒵) ntcf_paa_ArrVal'(*not cat_cs_simps*):
  assumes "F : set {𝔞} cat_Set αX" and "a = 𝔞"
  shows "ntcf_paa 𝔞 X (FArrVala) = F"
  using assms(1) unfolding assms(2) by (rule ntcf_paa_ArrVal)

lemma (in 𝒵) ntcf_paa_Comp_right[cat_cs_simps]:
  assumes "F : A cat_Set αB" 
    and "𝔞  cat_Set αObj" 
    and "a  A"
  shows "F Acat_Set αntcf_paa 𝔞 A a = ntcf_paa 𝔞 B (FArrVala)"
proof-
  from assms have F_paa:
    "F Acat_Set αntcf_paa 𝔞 A a : set {𝔞} cat_Set αB"
    by (cs_concl cs_intro: cat_cs_intros)
  then have dom_lhs: "𝒟 ((F Acat_Set αntcf_paa 𝔞 A a)ArrVal) = set {𝔞}"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from assms have paa: "ntcf_paa 𝔞 B (FArrVala) : set {𝔞} cat_Set αB"
    by (cs_concl cs_shallow cs_intro: cat_Set_cs_intros cat_cs_intros)
  then have dom_rhs: "𝒟 ((ntcf_paa 𝔞 B (FArrVala))ArrVal) = set {𝔞}"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  show ?thesis
  proof(rule arr_Set_eqI)
    from F_paa paa assms 
    show arr_Set_lhs: "arr_Set α (F Acat_Set αntcf_paa 𝔞 A a)" 
      and arr_Set_rhs: "arr_Set α (ntcf_paa 𝔞 B (FArrVala))"
      by (auto dest: cat_Set_is_arrD)
    show 
      "(F Acat_Set αntcf_paa 𝔞 A a)ArrVal =
        ntcf_paa 𝔞 B (FArrVala)ArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs vsingleton_iff; (simp only:)?)
      from assms show 
        "(F Acat_Set αntcf_paa 𝔞 A a)ArrVal𝔞 =
          ntcf_paa 𝔞 B (FArrVala)ArrVal𝔞"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_cs_intros)
    qed (use arr_Set_lhs arr_Set_rhs in auto)
  qed (use F_paa paa in cs_concl cs_shallow cs_simp: cat_cs_simps)+
qed

lemmas [cat_cs_simps] = 𝒵.ntcf_paa_Comp_right



subsection‹Pointed natural transformation›


subsubsection‹Definition and elementary properties›


text‹See Chapter III-2 in cite"mac_lane_categories_2010".›

definition ntcf_pointed :: "V  V  V"
  where "ntcf_pointed α 𝔞 =
    [
      (
        λxcat_Set αObj.
          [
            (λfHom (cat_Set α) (set {𝔞}) x. fArrVal𝔞),
            Hom (cat_Set α) (set {𝔞}) x,
            x
          ]
      ),
      HomO.Cαcat_Set α(set {𝔞},-),
      cf_id (cat_Set α),
      cat_Set α,
      cat_Set α
    ]"


text‹Components.›

lemma ntcf_pointed_components:
  shows "ntcf_pointed α 𝔞NTMap =
      (
        λxcat_Set αObj.
          [
            (λfHom (cat_Set α) (set {𝔞}) x. fArrVal𝔞),
            Hom (cat_Set α) (set {𝔞}) x, 
            x
          ]
      )"
    and [cat_cs_simps]: "ntcf_pointed α 𝔞NTDom = HomO.Cαcat_Set α(set {𝔞},-)"
    and [cat_cs_simps]: "ntcf_pointed α 𝔞NTCod = cf_id (cat_Set α)"
    and [cat_cs_simps]: "ntcf_pointed α 𝔞NTDGDom = cat_Set α"
    and [cat_cs_simps]: "ntcf_pointed α 𝔞NTDGCod = cat_Set α"
  unfolding ntcf_pointed_def nt_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

mk_VLambda ntcf_pointed_components(1)
  |vsv ntcf_pointed_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_pointed_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_pointed_NTMap_app'|

lemma (in 𝒵) ntcf_pointed_NTMap_app_ArrVal_app[cat_cs_simps]: 
  assumes "X  cat_Set αObj" and "F : set {𝔞} cat_Set αX"
  shows "ntcf_pointed α 𝔞NTMapXArrValF = FArrVal𝔞"
  by (simp add: assms(2) ntcf_pointed_NTMap_app'[OF assms(1)] arr_Rel_components)

lemma (in 𝒵) ntcf_pointed_NTMap_app_is_iso_arr: 
  assumes "𝔞  cat_Set αObj" and "X  cat_Set αObj"
  shows "ntcf_pointed α 𝔞NTMapX :
    Hom (cat_Set α) (set {𝔞}) X isocat_Set αX"
proof-
  interpret Set: category α cat_Set α by (rule category_cat_Set)
  note app_X = ntcf_pointed_NTMap_app'[OF assms(2)]
  show ?thesis 
  proof(intro cat_Set_is_iso_arrI cat_Set_is_arrI arr_SetI)
    show ArrVal_vsv: "vsv (ntcf_pointed α 𝔞NTMapXArrVal)"
      unfolding app_X arr_Rel_components by simp
    show "vcard (ntcf_pointed α 𝔞NTMapX) = 3"
      unfolding app_X arr_Rel_components by (simp add: nat_omega_simps)
    show ArrVal_vdomain: 
      "𝒟 (ntcf_pointed α 𝔞NTMapXArrVal) = Hom (cat_Set α) (set {𝔞}) X"
      unfolding app_X arr_Rel_components by simp
    show vrange_left: 
      " (ntcf_pointed α 𝔞NTMapXArrVal) 
        ntcf_pointed α 𝔞NTMapXArrCod"
      unfolding app_X arr_Rel_components 
      by
        (
          auto
            simp: in_Hom_iff
            intro: cat_Set_cs_intros
            intro!: vrange_VLambda_vsubset
        )
    show " (ntcf_pointed α 𝔞NTMapXArrVal) = X"
    proof(intro vsubset_antisym)
      show "X   (ntcf_pointed α 𝔞NTMapXArrVal)"
      proof(intro vsubsetI)
        fix x assume prems: "x  X"
        from assms prems have F_in_vdomain: 
          "ntcf_paa 𝔞 X x  𝒟 ((ntcf_pointed α 𝔞NTMapXArrVal))"
          unfolding app_X arr_Rel_components vdomain_VLambda in_Hom_iff
          by (cs_concl cs_shallow cs_intro: cat_cs_intros)
        from assms prems have x_def: 
          "x = ntcf_pointed α 𝔞NTMapXArrValntcf_paa 𝔞 X x"
          by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        show "x   (ntcf_pointed α 𝔞NTMapXArrVal)"
           by (subst x_def) (intro vsv.vsv_vimageI2 F_in_vdomain ArrVal_vsv)
      qed
    qed (use vrange_left in simp add: app_X arr_Rel_components)
    from assms show "ntcf_pointed α 𝔞NTMapXArrDom  Vset α"
      unfolding app_X arr_Rel_components cat_Set_components(1) 
      by (intro Set.cat_Hom_in_Vset[OF _ assms(2)])
        (auto simp: cat_Set_components(1))
    show "v11 (ntcf_pointed α 𝔞NTMapXArrVal)"
    proof(intro vsv.vsv_valeq_v11I ArrVal_vsv, unfold ArrVal_vdomain in_Hom_iff)
      fix F G assume prems:
        "F : set {𝔞} cat_Set αX"
        "G : set {𝔞} cat_Set αX"
        "ntcf_pointed α 𝔞NTMapXArrValF =
          ntcf_pointed α 𝔞NTMapXArrValG"
      note F = cat_Set_is_arrD[OF prems(1)] and G = cat_Set_is_arrD[OF prems(2)]
      from prems(3,1,2) assms have F_ArrVal_G_ArrVal: "FArrVal𝔞 = GArrVal𝔞"
        by (cs_prems cs_simp: cat_cs_simps)
      interpret F: arr_Set α F + G: arr_Set α G by (simp_all add: F G)
      show "F = G"
      proof(rule arr_Set_eqI)
        show "arr_Set α F" "arr_Set α G" 
          by (intro F.arr_Set_axioms G.arr_Set_axioms)+
        show "FArrVal = GArrVal"
          by 
            (
              rule vsv_eqI, 
              unfold F.arr_Set_ArrVal_vdomain G.arr_Set_ArrVal_vdomain F(2) G(2)
            )
            (auto simp: F_ArrVal_G_ArrVal)
      qed (simp_all add: F G)
    qed
  qed (use assms in auto simp: app_X arr_Rel_components cat_Set_components(1))
qed

lemma (in 𝒵) ntcf_pointed_NTMap_app_is_iso_arr'[cat_cs_intros]: 
  assumes "𝔞  cat_Set αObj" 
    and "X  cat_Set αObj"
    and "A' = Hom (cat_Set α) (set {𝔞}) X"
    and "B' = X"
    and "ℭ' = cat_Set α"
  shows "ntcf_pointed α 𝔞NTMapX : A' isoℭ'B'"
  using assms(1,2)
  unfolding assms(3-5)
  by (rule ntcf_pointed_NTMap_app_is_iso_arr)

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_NTMap_app_is_iso_arr'

lemmas (in 𝒵) ntcf_pointed_NTMap_app_is_arr'[cat_cs_intros] = 
  is_iso_arrD(1)[OF 𝒵.ntcf_pointed_NTMap_app_is_iso_arr']

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_NTMap_app_is_arr'


subsubsection‹Pointed natural transformation is a natural isomorphism›

lemma (in 𝒵) ntcf_pointed_is_iso_ntcf:
  assumes "𝔞  cat_Set αObj"
  shows "ntcf_pointed α 𝔞 :
    HomO.Cαcat_Set α(set {𝔞},-) CF.iso cf_id (cat_Set α) :
    cat_Set α ↦↦Cαcat_Set α"
proof(intro is_iso_ntcfI is_ntcfI')

  note 𝔞 = assms[unfolded cat_Set_components(1)]
  from assms have set_𝔞: "set {𝔞}  cat_Set αObj" 
    unfolding cat_Set_components by auto

  show "vfsequence (ntcf_pointed α 𝔞)" unfolding ntcf_pointed_def by auto
  show "vcard (ntcf_pointed α 𝔞) = 5"
    unfolding ntcf_pointed_def by (auto simp: nat_omega_simps)
  from assms set_𝔞 show 
    "HomO.Cαcat_Set α(set {𝔞},-) : cat_Set α ↦↦Cαcat_Set α"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  show "ntcf_pointed α 𝔞NTMapa :
    HomO.Cαcat_Set α(set {𝔞},-)ObjMapa cat_Set αcf_id (cat_Set α)ObjMapa"
    if "a  cat_Set αObj" for a
    using assms that set_𝔞
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
      )
  show 
    "ntcf_pointed α 𝔞NTMapb Acat_Set αHomO.Cαcat_Set α (set {𝔞},-)ArrMapf =
        cf_id (cat_Set α)ArrMapf Acat_Set αntcf_pointed α 𝔞NTMapa"
    if "f : a cat_Set αb" for a b f
  proof-
    let ?pb = ntcf_pointed α 𝔞NTMapb
      and ?pa = ntcf_pointed α 𝔞NTMapa
      and ?hom = cf_hom (cat_Set α) [cat_Set αCIdset {𝔞}, f]
    from assms set_𝔞 that have pb_hom: 
      "?pb Acat_Set α?hom : Hom (cat_Set α) (set {𝔞}) a cat_Set αb"
      by 
        (
          cs_concl cs_shallow 
            cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
        )
    then have dom_lhs: 
      "𝒟 ((?pb Acat_Set α?hom)ArrVal) = Hom (cat_Set α) (set {𝔞}) a"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    from assms set_𝔞 that have f_pa:
      "f Acat_Set α?pa : Hom (cat_Set α) (set {𝔞}) a cat_Set αb"
      by (cs_concl cs_intro: cat_cs_intros)
    then have dom_rhs: 
      "𝒟 ((f Acat_Set α?pa)ArrVal) = Hom (cat_Set α) (set {𝔞}) a"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    have [cat_cs_simps]: "?pb Acat_Set α?hom = f Acat_Set α?pa"
    proof(rule arr_Set_eqI)
      from pb_hom show arr_Set_pb_hom: "arr_Set α (?pb Acat_Set α?hom)"
        by (auto dest: cat_Set_is_arrD(1))
      from f_pa show arr_Set_f_pa: "arr_Set α (f Acat_Set α?pa)"
        by (auto dest: cat_Set_is_arrD(1))
      show "(?pb Acat_Set α?hom)ArrVal = (f Acat_Set α?pa)ArrVal"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
        fix g assume "g : set {𝔞} cat_Set αa"
        with assms 𝔞 set_𝔞 that show 
          "(?pb Acat_Set α?hom)ArrValg = (f Acat_Set α?pa)ArrValg"
          by
            (
              cs_concl cs_shallow
                cs_simp: V_cs_simps cat_cs_simps 
                cs_intro:
                  V_cs_intros cat_cs_intros cat_op_intros cat_prod_cs_intros
            )
      qed (use arr_Set_pb_hom arr_Set_f_pa in auto)
    qed (use pb_hom f_pa in cs_concl cs_shallow cs_simp: cat_cs_simps)+
    from assms that set_𝔞 show ?thesis
      by 
        (
          cs_concl cs_shallow 
            cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
        )
  qed
  show "ntcf_pointed α 𝔞NTMapa :
    HomO.Cαcat_Set α(set {𝔞},-)ObjMapa isocat_Set αcf_id (cat_Set α)ObjMapa"
    if "a  cat_Set αObj" for a
    using assms 𝔞 set_𝔞 that
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
      )

qed (auto simp: ntcf_pointed_components intro: cat_cs_intros)

lemma (in 𝒵) ntcf_pointed_is_iso_ntcf'[cat_cs_intros]:
  assumes "𝔞  cat_Set αObj"
    and "𝔉' = HomO.Cαcat_Set α(set {𝔞},-)"
    and "𝔊' = cf_id (cat_Set α)"
    and "𝔄' = cat_Set α"
    and "𝔅' = cat_Set α"
    and "α' = α"
  shows "ntcf_pointed α 𝔞 : 𝔉' CF.iso 𝔊' : 𝔄' ↦↦Cα'𝔅'"
  using assms(1) unfolding assms(2-6) by (rule ntcf_pointed_is_iso_ntcf)

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_is_iso_ntcf'



subsection‹Inverse pointed natural transformation›


subsubsection‹Definition and elementary properties›


text‹See Chapter III-2 in cite"mac_lane_categories_2010".›

definition ntcf_pointed_inv :: "V  V  V"
  where "ntcf_pointed_inv α 𝔞 =
    [
      (
        λXcat_Set αObj.
          [(λxX. ntcf_paa 𝔞 X x), X, Hom (cat_Set α) (set {𝔞}) X]
      ),
      cf_id (cat_Set α),
      HomO.Cαcat_Set α(set {𝔞},-),
      cat_Set α,
      cat_Set α
    ]"


text‹Components.›

lemma ntcf_pointed_inv_components:
  shows "ntcf_pointed_inv α 𝔞NTMap =
      (
        λXcat_Set αObj.
          [(λxX. ntcf_paa 𝔞 X x), X, Hom (cat_Set α) (set {𝔞}) X]
      )"
    and [cat_cs_simps]: "ntcf_pointed_inv α 𝔞NTDom = cf_id (cat_Set α)"
    and [cat_cs_simps]: 
      "ntcf_pointed_inv α 𝔞NTCod = HomO.Cαcat_Set α(set {𝔞},-)"
    and [cat_cs_simps]: "ntcf_pointed_inv α 𝔞NTDGDom = cat_Set α"
    and [cat_cs_simps]: "ntcf_pointed_inv α 𝔞NTDGCod = cat_Set α"
  unfolding ntcf_pointed_inv_def nt_field_simps
  by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

mk_VLambda ntcf_pointed_inv_components(1)
  |vsv ntcf_pointed_inv_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_pointed_inv_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_pointed_inv_NTMap_app'|

lemma (in 𝒵) ntcf_pointed_inv_NTMap_app_ArrVal_app[cat_cs_simps]: 
  assumes "X  cat_Set αObj" and "x  X"
  shows "ntcf_pointed_inv α 𝔞NTMapXArrValx = ntcf_paa 𝔞 X x"
  by 
    (
      simp add: 
        assms(2) ntcf_pointed_inv_NTMap_app'[OF assms(1)] arr_Rel_components
    )

lemma (in 𝒵) ntcf_pointed_inv_NTMap_app_is_arr: 
  assumes "𝔞  cat_Set αObj" and "X  cat_Set αObj"
  shows "ntcf_pointed_inv α 𝔞NTMapX :
    X cat_Set αHom (cat_Set α) (set {𝔞}) X"
proof-
  interpret Set: category α cat_Set α by (rule category_cat_Set)
  note app_X = ntcf_pointed_inv_NTMap_app'[OF assms(2)]
  show ?thesis 
  proof(intro cat_Set_is_arrI arr_SetI)
    show ArrVal_vsv: "vsv (ntcf_pointed_inv α 𝔞NTMapXArrVal)"
      unfolding app_X arr_Rel_components by simp
    show "vcard (ntcf_pointed_inv α 𝔞NTMapX) = 3"
      unfolding app_X arr_Rel_components by (simp add: nat_omega_simps)
    show ArrVal_vdomain: 
      "𝒟 (ntcf_pointed_inv α 𝔞NTMapXArrVal) =
        ntcf_pointed_inv α 𝔞NTMapXArrDom"
      unfolding app_X arr_Rel_components by simp
    from assms show vrange_left: 
      " (ntcf_pointed_inv α 𝔞NTMapXArrVal) 
        ntcf_pointed_inv α 𝔞NTMapXArrCod"
      unfolding app_X arr_Rel_components by (auto intro: cat_cs_intros)
    from assms show "ntcf_pointed_inv α 𝔞NTMapXArrCod  Vset α"
      unfolding app_X arr_Rel_components cat_Set_components(1) 
      by (intro Set.cat_Hom_in_Vset[OF _ assms(2)])
        (auto simp: cat_Set_components(1))  
  qed (use assms in auto simp: app_X arr_Rel_components cat_Set_components(1))
qed

lemma (in 𝒵) ntcf_pointed_inv_NTMap_app_is_arr'[cat_cs_intros]: 
  assumes "𝔞  cat_Set αObj" 
    and "X  cat_Set αObj"
    and "A' = X"
    and "B' = Hom (cat_Set α) (set {𝔞}) X"
    and "ℭ' = cat_Set α"
  shows "ntcf_pointed_inv α 𝔞NTMapX : A' ℭ'B'"
  using assms(1,2) 
  unfolding assms(3-5) 
  by (rule ntcf_pointed_inv_NTMap_app_is_arr)

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_inv_NTMap_app_is_arr'

lemma (in 𝒵) is_inverse_ntcf_pointed_inv_NTMap_app:
  assumes "𝔞  cat_Set αObj" and "X  cat_Set αObj"
  shows 
    "is_inverse
      (cat_Set α)
      (ntcf_pointed_inv α 𝔞NTMapX)
      (ntcf_pointed α 𝔞NTMapX)"
  (is is_inverse (cat_Set α) ?bwd ?fwd)
proof(intro is_inverseI)

  let ?Hom = Hom (cat_Set α) (set {𝔞}) X

  interpret Set: category α cat_Set α by (rule category_cat_Set)

  from assms(1) have set_𝔞: "set {𝔞}  cat_Set αObj"
    unfolding cat_Set_components(1) by blast
  have Hom_𝔞X: "?Hom  cat_Set αObj"
     by
       (
         auto 
          simp: cat_Set_components(1) 
          intro!: Set.cat_Hom_in_Vset set_𝔞 assms(2)
       )

  from assms show "?bwd : X cat_Set α?Hom"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  from assms show "?fwd : ?Hom cat_Set αX"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)

  from assms set_𝔞 Hom_𝔞X have lhs_is_arr:
    "?bwd Acat_Set α?fwd : ?Hom cat_Set α?Hom"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  then have dom_lhs: "𝒟 ((?bwd Acat_Set α?fwd)ArrVal) = ?Hom"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  from Hom_𝔞X have rhs_is_arr: "cat_Set αCId?Hom : ?Hom cat_Set α?Hom"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  then have dom_rhs: "𝒟 ((cat_Set αCId?Hom)ArrVal) = ?Hom"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  show "?bwd Acat_Set α?fwd = cat_Set αCId?Hom"
  proof(rule arr_Set_eqI)
    from lhs_is_arr show arr_Set_lhs: "arr_Set α (?bwd Acat_Set α?fwd)"
      by (auto dest: cat_Set_is_arrD)
    from rhs_is_arr show arr_Set_rhs: "arr_Set α (cat_Set αCId?Hom)"
      by (auto dest: cat_Set_is_arrD)
    show "(?bwd Acat_Set α?fwd)ArrVal = cat_Set αCId?HomArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix F assume "F : set {𝔞} cat_Set αX"
      with assms Hom_𝔞X show 
        "(?bwd Acat_Set α?fwd)ArrValF = cat_Set αCId?HomArrValF"
        by
          (
            cs_concl  
              cs_simp: cat_cs_simps ntcf_paa_ArrVal
              cs_intro: V_cs_intros cat_Set_cs_intros cat_cs_intros
          )
    qed (use arr_Set_lhs arr_Set_rhs in auto)
  qed (use lhs_is_arr rhs_is_arr in cs_concl cs_shallow cs_simp: cat_cs_simps)+

  from assms have lhs_is_arr: "?fwd Acat_Set α?bwd : X cat_Set αX"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  then have dom_lhs: "𝒟 ((?fwd Acat_Set α?bwd)ArrVal) = X"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  from assms have rhs_is_arr: "cat_Set αCIdX : X cat_Set αX"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  then have dom_rhs: "𝒟 ((cat_Set αCIdX)ArrVal) = X"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  show "?fwd Acat_Set α?bwd = cat_Set αCIdX"
  proof(rule arr_Set_eqI)
    from lhs_is_arr show arr_Set_lhs: "arr_Set α (?fwd Acat_Set α?bwd)"
      by (auto dest: cat_Set_is_arrD)
    from rhs_is_arr show arr_Set_rhs: "arr_Set α (cat_Set αCIdX)"
      by (auto dest: cat_Set_is_arrD)
    show "(?fwd Acat_Set α?bwd)ArrVal = cat_Set αCIdXArrVal"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix x assume "x  X"
      with assms show 
        "(?fwd Acat_Set α?bwd)ArrValx = cat_Set αCIdXArrValx"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed (use arr_Set_lhs arr_Set_rhs in auto)
  qed (use lhs_is_arr rhs_is_arr in cs_concl cs_shallow cs_simp: cat_cs_simps)+

qed


subsubsection‹Inverse pointed natural transformation is a natural isomorphism›

lemma (in 𝒵) ntcf_pointed_inv_is_ntcf:
  assumes "𝔞  cat_Set αObj"
  shows "ntcf_pointed_inv α 𝔞 :
    cf_id (cat_Set α) CF HomO.Cαcat_Set α(set {𝔞},-) :
    cat_Set α ↦↦Cαcat_Set α"
proof(intro is_ntcfI')

  interpret Set: category α cat_Set α by (rule category_cat_Set)

  note 𝔞 = assms[unfolded cat_Set_components(1)]
  from assms have set_𝔞: "set {𝔞}  cat_Set αObj" 
    unfolding cat_Set_components by auto

  show "vfsequence (ntcf_pointed_inv α 𝔞)" 
    unfolding ntcf_pointed_inv_def by simp
  show "vcard (ntcf_pointed_inv α 𝔞) = 5"
    unfolding ntcf_pointed_inv_def by (simp add: nat_omega_simps)
  from set_𝔞 show "HomO.Cαcat_Set α(set {𝔞},-) : cat_Set α ↦↦Cαcat_Set α"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)

  show "ntcf_pointed_inv α 𝔞NTMapa :
    cf_id (cat_Set α)ObjMapa cat_Set αHomO.Cαcat_Set α(set {𝔞},-)ObjMapa"
    if "a  cat_Set αObj" for a
    using that assms set_𝔞
    by 
      (
        cs_concl cs_shallow 
          cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros
      )

  show 
    "ntcf_pointed_inv α 𝔞NTMapB Acat_Set αcf_id (cat_Set α)ArrMapF =
      HomO.Cαcat_Set α(set {𝔞},-)ArrMapF Acat_Set αntcf_pointed_inv α 𝔞NTMapA"
    if "F : A cat_Set αB" for A B F
  proof-
    let ?pb = ntcf_pointed_inv α 𝔞NTMapB
      and ?pa = ntcf_pointed_inv α 𝔞NTMapA
      and ?hom = cf_hom (cat_Set α) [cat_Set αCIdset {𝔞}, F]
    from assms set_𝔞 that have pb_F: 
      "?pb Acat_Set αF : A cat_Set αHom (cat_Set α) (set {𝔞}) B"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_prod_cs_intros)
    then have dom_lhs: "𝒟 ((?pb Acat_Set αF)ArrVal) = A"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    from that assms set_𝔞 that have hom_pa:
      "?hom Acat_Set α?pa : A cat_Set αHom (cat_Set α) (set {𝔞}) B"
      by (cs_concl cs_intro: cat_cs_intros cat_prod_cs_intros cat_op_intros)
    then have dom_rhs: "𝒟 ((?hom Acat_Set α?pa)ArrVal) = A"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    have [cat_cs_simps]: "?pb Acat_Set αF = ?hom Acat_Set α?pa"
    proof(rule arr_Set_eqI)
      from pb_F show arr_Set_pb_F: "arr_Set α (?pb Acat_Set αF)"
        by (auto dest: cat_Set_is_arrD(1))
      from hom_pa show arr_Set_hom_pa: "arr_Set α (?hom Acat_Set α?pa)"
        by (auto dest: cat_Set_is_arrD(1))
      show "(?pb Acat_Set αF)ArrVal = (?hom Acat_Set α?pa)ArrVal"
      proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
        fix a assume "a  A"
        with assms 𝔞 set_𝔞 that show 
          "(?pb Acat_Set αF)ArrVala = (?hom Acat_Set α?pa)ArrVala"
          by
            (
              cs_concl 
                cs_simp: cat_cs_simps
                cs_intro: 
                  cat_Set_cs_intros
                  cat_cs_intros
                  cat_prod_cs_intros
                  cat_op_intros
            )
      qed (use arr_Set_pb_F arr_Set_hom_pa in auto)
    qed (use pb_F hom_pa in cs_concl cs_shallow cs_simp: cat_cs_simps)+
    from assms that set_𝔞 show ?thesis
      by 
        (
          cs_concl cs_shallow 
            cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
        )
  qed

qed (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+

lemma (in 𝒵) ntcf_pointed_inv_is_ntcf'[cat_cs_intros]:
  assumes "𝔞  cat_Set αObj"
    and "𝔉' = cf_id (cat_Set α)"
    and "𝔊' = HomO.Cαcat_Set α(set {𝔞},-)"
    and "𝔄' = cat_Set α"
    and "𝔅' = cat_Set α"
    and "α' = α"
  shows "ntcf_pointed_inv α 𝔞 : 𝔉' CF 𝔊' : 𝔄' ↦↦Cα'𝔅'"
  using assms(1) unfolding assms(2-6) by (rule ntcf_pointed_inv_is_ntcf)

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_inv_is_ntcf'

lemma (in 𝒵) inv_ntcf_ntcf_pointed[cat_cs_simps]:
  assumes "𝔞  cat_Set αObj"
  shows "inv_ntcf (ntcf_pointed α 𝔞) = ntcf_pointed_inv α 𝔞"
  by 
    (
      rule iso_ntcf_if_is_inverse(3)[symmetric], 
      rule is_iso_ntcfD(1)[OF ntcf_pointed_is_iso_ntcf[OF assms]],
      rule ntcf_pointed_inv_is_ntcf[OF assms],
      rule is_inverse_ntcf_pointed_inv_NTMap_app[OF assms]
    )

lemma (in 𝒵) inv_ntcf_ntcf_pointed_inv[cat_cs_simps]:
  assumes "𝔞  cat_Set αObj"
  shows "inv_ntcf (ntcf_pointed_inv α 𝔞) = ntcf_pointed α 𝔞"
  by
    (
      rule iso_ntcf_if_is_inverse(4)[symmetric], 
      rule is_iso_ntcfD(1)[OF ntcf_pointed_is_iso_ntcf[OF assms]],
      rule ntcf_pointed_inv_is_ntcf[OF assms],
      rule is_inverse_ntcf_pointed_inv_NTMap_app[OF assms]
    )

lemma (in 𝒵) ntcf_pointed_inv_is_iso_ntcf:
  assumes "𝔞  cat_Set αObj"
  shows "ntcf_pointed_inv α 𝔞 :
    cf_id (cat_Set α) CF.iso HomO.Cαcat_Set α(set {𝔞},-) :
    cat_Set α ↦↦Cαcat_Set α"
  by
    (
      rule iso_ntcf_if_is_inverse(2), 
      rule is_iso_ntcfD(1)[OF ntcf_pointed_is_iso_ntcf[OF assms]],
      rule ntcf_pointed_inv_is_ntcf[OF assms],
      rule is_inverse_ntcf_pointed_inv_NTMap_app[OF assms]
    )

lemma (in 𝒵) ntcf_pointed_inv_is_iso_ntcf'[cat_cs_intros]:
  assumes "𝔞  cat_Set αObj"
    and "𝔉' = cf_id (cat_Set α)"
    and "𝔊' = HomO.Cαcat_Set α(set {𝔞},-)"
    and "𝔄' = cat_Set α"
    and "𝔅' = cat_Set α"
    and "α' = α"
  shows "ntcf_pointed_inv α 𝔞 : 𝔉' CF.iso 𝔊' : 𝔄' ↦↦Cα'𝔅'"
  using assms(1) unfolding assms(2-6) by (rule ntcf_pointed_inv_is_iso_ntcf)

lemmas [cat_cs_intros] = 𝒵.ntcf_pointed_inv_is_iso_ntcf'

text‹\newpage›

end