(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Universal arrow\<close>
theory CZH_UCAT_Universal
  imports
    CZH_UCAT_Introduction
    CZH_Elementary_Categories.CZH_ECAT_FUNCT
    CZH_Elementary_Categories.CZH_ECAT_Hom
begin

subsection\<open>Background\<close>

text\<open>
The following section is based, primarily, on the elements of the content
of Chapter III-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

named_theorems ua_field_simps

definition UObj :: V where [ua_field_simps]: "UObj = 0"
definition UArr :: V where [ua_field_simps]: "UArr = 1\<^sub>\<nat>"

lemma [cat_cs_simps]:
  shows UObj_simp: "[a, b]\<^sub>\<circ>\<lparr>UObj\<rparr> = a"
    and UArr_simp: "[a, b]\<^sub>\<circ>\<lparr>UArr\<rparr> = b"
  unfolding ua_field_simps by (simp_all add: nat_omega_simps)

subsection\<open>Universal map\<close>

text\<open>
The universal map is a convenience utility that allows treating
a part of the definition of the universal arrow as an arrow in the
category \<open>Set\<close>.
\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition umap_of :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "umap_of \<FF> c r u d =
    [
      (\<lambda>f'\<in>\<^sub>\<circ>Hom (\<FF>\<lparr>HomDom\<rparr>) r d. \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<FF>\<lparr>HomCod\<rparr>\<^esub> u),
      Hom (\<FF>\<lparr>HomDom\<rparr>) r d,
      Hom (\<FF>\<lparr>HomCod\<rparr>) c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)
    ]\<^sub>\<circ>"

definition umap_fo :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "umap_fo \<FF> c r u d = umap_of (op_cf \<FF>) c r u d"

text\<open>Components.\<close>

lemma (in is_functor) umap_of_components:
  assumes "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>" (*do not remove*)
  shows "umap_of \<FF> c r u d\<lparr>ArrVal\<rparr> = (\<lambda>f'\<in>\<^sub>\<circ>Hom \<AA> r d. \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u)"
    and "umap_of \<FF> c r u d\<lparr>ArrDom\<rparr> = Hom \<AA> r d"
    and "umap_of \<FF> c r u d\<lparr>ArrCod\<rparr> = Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)"
  unfolding umap_of_def arr_field_simps
  by (simp_all add: cat_cs_simps nat_omega_simps)

lemma (in is_functor) umap_fo_components:
  assumes "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "umap_fo \<FF> c r u d\<lparr>ArrVal\<rparr> = (\<lambda>f'\<in>\<^sub>\<circ>Hom \<AA> d r. u \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>)"
    and "umap_fo \<FF> c r u d\<lparr>ArrDom\<rparr> = Hom \<AA> d r"
    and "umap_fo \<FF> c r u d\<lparr>ArrCod\<rparr> = Hom \<BB> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>) c"
  unfolding
    umap_fo_def
    is_functor.umap_of_components[
      OF is_functor_op, unfolded cat_op_simps, OF assms
      ]
proof(rule vsv_eqI)
  fix f' assume "f' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<lambda>f'\<in>\<^sub>\<circ>Hom \<AA> d r. \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>op_cat \<BB>\<^esub> u)"
  then have f': "f' : d \<mapsto>\<^bsub>\<AA>\<^esub> r" by simp
  then have \<FF>f': "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    by (auto intro: cat_cs_intros)
  from f' show
    "(\<lambda>f'\<in>\<^sub>\<circ>Hom \<AA> d r. \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>op_cat \<BB>\<^esub> u)\<lparr>f'\<rparr> =
      (\<lambda>f'\<in>\<^sub>\<circ>Hom \<AA> d r. u \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>)\<lparr>f'\<rparr>"
    by (simp add: HomCod.op_cat_Comp[OF assms \<FF>f'])
qed simp_all

text\<open>Universal maps for the opposite functor.\<close>

lemma (in is_functor) op_umap_of[cat_op_simps]: "umap_of (op_cf \<FF>) = umap_fo \<FF>"
  unfolding umap_fo_def by simp

lemma (in is_functor) op_umap_fo[cat_op_simps]: "umap_fo (op_cf \<FF>) = umap_of \<FF>"
  unfolding umap_fo_def by (simp add: cat_op_simps)

lemmas [cat_op_simps] =
  is_functor.op_umap_of
  is_functor.op_umap_fo

subsubsection\<open>Arrow value\<close>

lemma umap_of_ArrVal_vsv[cat_cs_intros]: "vsv (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>)"
  unfolding umap_of_def arr_field_simps by (simp add: nat_omega_simps)

lemma umap_fo_ArrVal_vsv[cat_cs_intros]: "vsv (umap_fo \<FF> c r u d\<lparr>ArrVal\<rparr>)"
  unfolding umap_fo_def by (rule umap_of_ArrVal_vsv)

lemma (in is_functor) umap_of_ArrVal_vdomain:
  assumes "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "\<D>\<^sub>\<circ> (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>) = Hom \<AA> r d"
  unfolding umap_of_components[OF assms] by simp

lemmas [cat_cs_simps] = is_functor.umap_of_ArrVal_vdomain

lemma (in is_functor) umap_fo_ArrVal_vdomain:
  assumes "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "\<D>\<^sub>\<circ> (umap_fo \<FF> c r u d\<lparr>ArrVal\<rparr>) = Hom \<AA> d r"
  unfolding umap_fo_components[OF assms] by simp

lemmas [cat_cs_simps] = is_functor.umap_fo_ArrVal_vdomain

lemma (in is_functor) umap_of_ArrVal_app:
  assumes "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> d" and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u"
  using assms(1) unfolding umap_of_components[OF assms(2)] by simp

lemmas [cat_cs_simps] = is_functor.umap_of_ArrVal_app

lemma (in is_functor) umap_fo_ArrVal_app:
  assumes "f' : d \<mapsto>\<^bsub>\<AA>\<^esub> r" and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "umap_fo \<FF> c r u d\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr> = u \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>"
proof-
  from assms have "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    by (auto intro: cat_cs_intros)
  from this assms(2) have \<FF>f'[simp]:
    "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>op_cat \<BB>\<^esub> u = u \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>"
    by (simp add: cat_op_simps)
  from
    is_functor_axioms
    is_functor.umap_of_ArrVal_app[
      OF is_functor_op, unfolded cat_op_simps,
      OF assms
      ]
  show ?thesis
    by (simp add: cat_op_simps cat_cs_simps)
qed

lemmas [cat_cs_simps] = is_functor.umap_fo_ArrVal_app

lemma (in is_functor) umap_of_ArrVal_vrange:
  assumes "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "\<R>\<^sub>\<circ> (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)"
proof(intro vsubset_antisym vsubsetI)
  interpret vsv \<open>umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>\<close>
    unfolding umap_of_components[OF assms] by simp
  fix g assume "g \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>)"
  then obtain f'
    where g_def: "g = umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
      and f': "f' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>)"
    unfolding umap_of_components[OF assms] by auto
  then have f': "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> d"
    unfolding umap_of_ArrVal_vdomain[OF assms] by simp
  then have \<FF>f': "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>"
    by (auto intro!: cat_cs_intros)
  have g_def: "g = \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u"
    unfolding g_def umap_of_ArrVal_app[OF f' assms]..
  from \<FF>f' assms show "g \<in>\<^sub>\<circ> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)"
    unfolding g_def by (auto intro: cat_cs_intros)
qed

lemma (in is_functor) umap_fo_ArrVal_vrange:
  assumes "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "\<R>\<^sub>\<circ> (umap_fo \<FF> c r u d\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> Hom \<BB> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>) c"
  by
    (
      rule is_functor.umap_of_ArrVal_vrange[
        OF is_functor_op, unfolded cat_op_simps, OF assms, folded umap_fo_def
        ]
    )

subsubsection\<open>Universal map is an arrow in the category \<open>Set\<close>\<close>

lemma (in is_functor) cf_arr_Set_umap_of:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and r: "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and d: "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and u: "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "arr_Set \<alpha> (umap_of \<FF> c r u d)"
proof(intro arr_SetI)
  interpret HomDom: category \<alpha> \<AA> by (rule assms(1))
  interpret HomCod: category \<alpha> \<BB> by (rule assms(2))
  note umap_of_components = umap_of_components[OF u]
  from u d have c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and \<FF>d: "(\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>) \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
    by (auto intro: cat_cs_intros)
  show "vfsequence (umap_of \<FF> c r u d)" unfolding umap_of_def by simp
  show "vcard (umap_of \<FF> c r u d) = 3\<^sub>\<nat>"
    unfolding umap_of_def by (simp add: nat_omega_simps)
  from umap_of_ArrVal_vrange[OF u] show
    "\<R>\<^sub>\<circ> (umap_of \<FF> c r u d\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> umap_of \<FF> c r u d\<lparr>ArrCod\<rparr>"
    unfolding umap_of_components by simp
  from r d show "umap_of \<FF> c r u d\<lparr>ArrDom\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding umap_of_components by (intro HomDom.cat_Hom_in_Vset)
  from c \<FF>d show "umap_of \<FF> c r u d\<lparr>ArrCod\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding umap_of_components by (intro HomCod.cat_Hom_in_Vset)
qed (auto simp: umap_of_components[OF u])

lemma (in is_functor) cf_arr_Set_umap_fo:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and r: "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and d: "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and u: "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "arr_Set \<alpha> (umap_fo \<FF> c r u d)"
proof-
  from assms(1) have \<AA>: "category \<alpha> (op_cat \<AA>)"
    by (auto intro: cat_cs_intros)
  from assms(2) have \<BB>: "category \<alpha> (op_cat \<BB>)"
    by (auto intro: cat_cs_intros)
  show ?thesis
    by
      (
        rule
          is_functor.cf_arr_Set_umap_of[
            OF is_functor_op, unfolded cat_op_simps, OF \<AA> \<BB> r d u
            ]
      )
qed

lemma (in is_functor) cf_umap_of_is_arr:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "umap_of \<FF> c r u d : Hom \<AA> r d \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)"
proof(intro cat_Set_is_arrI)
  show "arr_Set \<alpha> (umap_of \<FF> c r u d)"
    by (rule cf_arr_Set_umap_of[OF assms])
qed (simp_all add: umap_of_components[OF assms(5)])

lemma (in is_functor) cf_umap_of_is_arr':
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    and "A = Hom \<AA> r d"
    and "B = Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>)"
    and "\<CC> = cat_Set \<alpha>"
  shows "umap_of \<FF> c r u d : A \<mapsto>\<^bsub>\<CC>\<^esub> B"
  using assms(1-5) unfolding assms(6-8) by (rule cf_umap_of_is_arr)

lemmas [cat_cs_intros] = is_functor.cf_umap_of_is_arr'

lemma (in is_functor) cf_umap_fo_is_arr:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "umap_fo \<FF> c r u d : Hom \<AA> d r \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>) c"
proof(intro cat_Set_is_arrI)
  show "arr_Set \<alpha> (umap_fo \<FF> c r u d)"
    by (rule cf_arr_Set_umap_fo[OF assms])
qed (simp_all add: umap_fo_components[OF assms(5)])

lemma (in is_functor) cf_umap_fo_is_arr':
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
    and "A = Hom \<AA> d r"
    and "B = Hom \<BB> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>d\<rparr>) c"
    and "\<CC> = cat_Set \<alpha>"
  shows "umap_fo \<FF> c r u d : A \<mapsto>\<^bsub>\<CC>\<^esub> B"
  using assms(1-5) unfolding assms(6-8) by (rule cf_umap_fo_is_arr)

lemmas [cat_cs_intros] = is_functor.cf_umap_fo_is_arr'

subsection\<open>Universal arrow: definition and elementary properties\<close>

text\<open>See Chapter III-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition universal_arrow_of :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "universal_arrow_of \<FF> c r u \<longleftrightarrow>
    (
      r \<in>\<^sub>\<circ> \<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr> \<and>
      u : c \<mapsto>\<^bsub>\<FF>\<lparr>HomCod\<rparr>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<and>
      (
        \<forall>r' u'.
          r' \<in>\<^sub>\<circ> \<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr> \<longrightarrow>
          u' : c \<mapsto>\<^bsub>\<FF>\<lparr>HomCod\<rparr>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<longrightarrow>
          (\<exists>!f'. f' : r \<mapsto>\<^bsub>\<FF>\<lparr>HomDom\<rparr>\<^esub> r' \<and> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>)
      )
    )"

definition universal_arrow_fo :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "universal_arrow_fo \<FF> c r u \<equiv> universal_arrow_of (op_cf \<FF>) c r u"

text\<open>Rules.\<close>

mk_ide (in is_functor) rf
  universal_arrow_of_def[where \<FF>=\<FF>, unfolded cf_HomDom cf_HomCod]
  |intro universal_arrow_ofI|
  |dest universal_arrow_ofD[dest]|
  |elim universal_arrow_ofE[elim]|

lemma (in is_functor) universal_arrow_foI:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
    and "\<And>r' u'. \<lbrakk> r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>; u' : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c \<rbrakk> \<Longrightarrow>
      \<exists>!f'. f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r \<and> u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
  shows "universal_arrow_fo \<FF> c r u"
  by
    (
      simp add:
        is_functor.universal_arrow_ofI
          [
            OF is_functor_op,
            folded universal_arrow_fo_def,
            unfolded cat_op_simps,
            OF assms
          ]
    )

lemma (in is_functor) universal_arrow_foD[dest]:
  assumes "universal_arrow_fo \<FF> c r u"
  shows "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
    and "\<And>r' u'. \<lbrakk> r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>; u' : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c \<rbrakk> \<Longrightarrow>
      \<exists>!f'. f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r \<and> u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
  by
    (
      auto simp:
        is_functor.universal_arrow_ofD
          [
            OF is_functor_op,
            folded universal_arrow_fo_def,
            unfolded cat_op_simps,
            OF assms
          ]
    )

lemma (in is_functor) universal_arrow_foE[elim]:
  assumes "universal_arrow_fo \<FF> c r u"
  obtains "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
    and "\<And>r' u'. \<lbrakk> r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>; u' : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c \<rbrakk> \<Longrightarrow>
      \<exists>!f'. f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r \<and> u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
  using assms by (auto simp: universal_arrow_foD)

text\<open>Elementary properties.\<close>

lemma (in is_functor) op_cf_universal_arrow_of[cat_op_simps]:
  "universal_arrow_of (op_cf \<FF>) c r u \<longleftrightarrow> universal_arrow_fo \<FF> c r u"
  unfolding universal_arrow_fo_def ..

lemma (in is_functor) op_cf_universal_arrow_fo[cat_op_simps]:
  "universal_arrow_fo (op_cf \<FF>) c r u \<longleftrightarrow> universal_arrow_of \<FF> c r u"
  unfolding universal_arrow_fo_def cat_op_simps ..

lemmas (in is_functor) [cat_op_simps] =
  is_functor.op_cf_universal_arrow_of
  is_functor.op_cf_universal_arrow_fo

subsection\<open>Uniqueness\<close>

text\<open>
The following properties are related to the uniqueness of the
universal arrow. These properties can be inferred from the content of
Chapter III-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

lemma (in is_functor) cf_universal_arrow_of_ex_is_iso_arr:
  \<comment>\<open>The proof is based on the ideas expressed in the proof of Theorem 5.2
  in Chapter Introduction in \cite{hungerford_algebra_2003}.\<close>
  assumes "universal_arrow_of \<FF> c r u" and "universal_arrow_of \<FF> c r' u'"
  obtains f where "f : r \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r'" and "u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
proof-

  note ua1 = universal_arrow_ofD[OF assms(1)]
  note ua2 = universal_arrow_ofD[OF assms(2)]

  from ua1(1) have \<AA>r: "\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr> : r \<mapsto>\<^bsub>\<AA>\<^esub> r" by (auto intro: cat_cs_intros)
  from ua1(1) have "\<FF>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr> = \<BB>\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>\<rparr>"
    by (auto intro: cat_cs_intros)
  with ua1(1,2) have u_def: "u = umap_of \<FF> c r u r\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>"
    unfolding umap_of_ArrVal_app[OF \<AA>r ua1(2)] by (auto simp: cat_cs_simps)

  from ua2(1) have \<AA>r': "\<AA>\<lparr>CId\<rparr>\<lparr>r'\<rparr> : r' \<mapsto>\<^bsub>\<AA>\<^esub> r'" by (auto intro: cat_cs_intros)
  from ua2(1) have "\<FF>\<lparr>ArrMap\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r'\<rparr>\<rparr> = \<BB>\<lparr>CId\<rparr>\<lparr>\<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>\<rparr>"
    by (auto intro: cat_cs_intros)
  with ua2(1,2) have u'_def: "u' = umap_of \<FF> c r' u' r'\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r'\<rparr>\<rparr>"
    unfolding umap_of_ArrVal_app[OF \<AA>r' ua2(2)] by (auto simp: cat_cs_simps)

  from \<AA>r u_def universal_arrow_ofD(3)[OF assms(1) ua1(1,2)] have eq_CId_rI:
    "\<lbrakk> f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r; u = umap_of \<FF> c r u r\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr> \<rbrakk> \<Longrightarrow> f' = \<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>"
    for f'
    by blast
  from \<AA>r' u'_def universal_arrow_ofD(3)[OF assms(2) ua2(1,2)] have eq_CId_r'I:
    "\<lbrakk> f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r'; u' = umap_of \<FF> c r' u' r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr> \<rbrakk> \<Longrightarrow>
      f' = \<AA>\<lparr>CId\<rparr>\<lparr>r'\<rparr>"
    for f'
    by blast

  from ua1(3)[OF ua2(1,2)] obtain f
    where f: "f : r \<mapsto>\<^bsub>\<AA>\<^esub> r'"
      and u'_def: "u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
      and "g : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<Longrightarrow> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>g\<rparr> \<Longrightarrow> f = g"
    for g
    by metis
  from ua2(3)[OF ua1(1,2)] obtain f'
    where f': "f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r"
      and u_def: "u = umap_of \<FF> c r' u' r\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
      and "g : r' \<mapsto>\<^bsub>\<AA>\<^esub> r \<Longrightarrow> u = umap_of \<FF> c r' u' r\<lparr>ArrVal\<rparr>\<lparr>g\<rparr> \<Longrightarrow> f' = g"
    for g
    by metis

  have "f : r \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r'"
  proof(intro is_iso_arrI is_inverseI)
    show f: "f : r \<mapsto>\<^bsub>\<AA>\<^esub> r'" by (rule f)
    show f': "f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r" by (rule f')
    show "f : r \<mapsto>\<^bsub>\<AA>\<^esub> r'" by (rule f)
    from f' have \<FF>f': "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
      by (auto intro: cat_cs_intros)
    from f have \<FF>f: "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
      by (auto intro: cat_cs_intros)
    note u'_def' = u'_def[symmetric, unfolded umap_of_ArrVal_app[OF f ua1(2)]]
      and u_def' = u_def[symmetric, unfolded umap_of_ArrVal_app[OF f' ua2(2)]]
    show "f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f = \<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>"
    proof(rule eq_CId_rI)
      from f f' show f'f: "f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f : r \<mapsto>\<^bsub>\<AA>\<^esub> r"
        by (auto intro: cat_cs_intros)
      from ua1(2) \<FF>f' \<FF>f show "u = umap_of \<FF> c r u r\<lparr>ArrVal\<rparr>\<lparr>f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<rparr>"
        unfolding umap_of_ArrVal_app[OF f'f ua1(2)] cf_ArrMap_Comp[OF f' f]
        by (simp add: HomCod.cat_Comp_assoc u'_def' u_def')
    qed
    show "f \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f' = \<AA>\<lparr>CId\<rparr>\<lparr>r'\<rparr>"
    proof(rule eq_CId_r'I)
      from f f' show ff': "f \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r'"
        by (auto intro: cat_cs_intros)
      from ua2(2) \<FF>f' \<FF>f show "u' = umap_of \<FF> c r' u' r'\<lparr>ArrVal\<rparr>\<lparr>f \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f'\<rparr>"
        unfolding umap_of_ArrVal_app[OF ff' ua2(2)] cf_ArrMap_Comp[OF f f']
        by (simp add: HomCod.cat_Comp_assoc u'_def' u_def')
    qed
  qed

  with u'_def that show ?thesis by auto

qed

lemma (in is_functor) cf_universal_arrow_fo_ex_is_iso_arr:
  assumes "universal_arrow_fo \<FF> c r u"
    and "universal_arrow_fo \<FF> c r' u'"
  obtains f where "f : r' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r" and "u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
  by
    (
      elim
        is_functor.cf_universal_arrow_of_ex_is_iso_arr[
          OF is_functor_op, unfolded cat_op_simps, OF assms
          ]
    )

lemma (in is_functor) cf_universal_arrow_of_unique:
  assumes "universal_arrow_of \<FF> c r u"
    and "universal_arrow_of \<FF> c r' u'"
  shows "\<exists>!f'. f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<and> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
proof-
  note ua1 = universal_arrow_ofD[OF assms(1)]
  note ua2 = universal_arrow_ofD[OF assms(2)]
  from ua1(3)[OF ua2(1,2)] show ?thesis .
qed

lemma (in is_functor) cf_universal_arrow_fo_unique:
  assumes "universal_arrow_fo \<FF> c r u"
    and "universal_arrow_fo \<FF> c r' u'"
  shows "\<exists>!f'. f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r \<and> u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
proof-
  note ua1 = universal_arrow_foD[OF assms(1)]
  note ua2 = universal_arrow_foD[OF assms(2)]
  from ua1(3)[OF ua2(1,2)] show ?thesis .
qed

lemma (in is_functor) cf_universal_arrow_of_is_iso_arr:
  assumes "universal_arrow_of \<FF> c r u"
    and "universal_arrow_of \<FF> c r' u'"
    and "f : r \<mapsto>\<^bsub>\<AA>\<^esub> r'"
    and "u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
  shows "f : r \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r'"
proof-
  from assms(3,4) cf_universal_arrow_of_unique[OF assms(1,2)] have eq:
    "g : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<Longrightarrow> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>g\<rparr> \<Longrightarrow> f = g" for g
    by blast
  from assms(1,2) obtain f'
    where iso_f': "f' : r \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r'"
      and u'_def: "u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
    by (auto elim: cf_universal_arrow_of_ex_is_iso_arr)
  then have f': "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r'" by auto
  from iso_f' show ?thesis unfolding eq[OF f' u'_def, symmetric].
qed

lemma (in is_functor) cf_universal_arrow_fo_is_iso_arr:
  assumes "universal_arrow_fo \<FF> c r u"
    and "universal_arrow_fo \<FF> c r' u'"
    and "f : r' \<mapsto>\<^bsub>\<AA>\<^esub> r"
    and "u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
  shows "f : r' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r"
  by
    (
      rule
        is_functor.cf_universal_arrow_of_is_iso_arr[
          OF is_functor_op, unfolded cat_op_simps, OF assms
          ]
    )

lemma (in is_functor) universal_arrow_of_if_universal_arrow_of:
  assumes "universal_arrow_of \<FF> c r u"
    and "f : r \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r'"
    and "u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
  shows "universal_arrow_of \<FF> c r' u'"
proof(intro universal_arrow_ofI assms(2))

  note ua = universal_arrow_ofD[OF assms(1)]
  note f = is_iso_arrD(1)[OF assms(2)]
  from assms(3) ua(1,2) f have u'_def: "u' = \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from  ua(2) f show u': "u' : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
    unfolding u'_def by (cs_concl cs_intro: cat_cs_intros)

  from f(1) show  "r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" by auto

  fix r'' u'' assume prems: "r'' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" "u'' : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r''\<rparr>"

  from ua(3)[OF prems] obtain f'
    where f': "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r''"
      and u''_def: "u'' = umap_of \<FF> c r u r''\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
      and f'_unique: "\<And>f''.
        \<lbrakk> f'' : r \<mapsto>\<^bsub>\<AA>\<^esub> r''; u'' = umap_of \<FF> c r u r''\<lparr>ArrVal\<rparr>\<lparr>f''\<rparr> \<rbrakk> \<Longrightarrow>
          f'' = f'"
    by metis

  from u''_def f' ua(2) have [cat_cs_simps]: "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u = u''"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) simp

  show "\<exists>!f'. f' : r' \<mapsto>\<^bsub>\<AA>\<^esub> r'' \<and> u'' = umap_of \<FF> c r' u' r''\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
  proof(intro ex1I conjI; (elim conjE)?)
    from f' assms(2) f show "f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub> : r' \<mapsto>\<^bsub>\<AA>\<^esub> r''"
      by (cs_concl cs_intro: cat_cs_intros cat_arrow_cs_intros)
    have
      "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> (\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u') =
        \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> (\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> (\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u))"
      unfolding u'_def ..
    also from f' assms(2) u' f ua(2) have
      "\<dots> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> (\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub> \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<rparr>) \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_arrow_cs_intros cat_cs_intros
        )
    also from f' assms(2) f ua(2) have "\<dots> = u''"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    finally have [cat_cs_simps]:
      "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> (\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u') = u''".
    from f' assms(2) u' f show
      "u'' = umap_of \<FF> c r' u' r''\<lparr>ArrVal\<rparr>\<lparr>f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>\<rparr>"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_arrow_cs_intros
        )
    fix g assume prems':
      "g : r' \<mapsto>\<^bsub>\<AA>\<^esub> r''" "u'' = umap_of \<FF> c r' u' r''\<lparr>ArrVal\<rparr>\<lparr>g\<rparr>"
    from prems'(1) f have gf: "g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f : r \<mapsto>\<^bsub>\<AA>\<^esub> r''"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from prems'(2,1) assms(2) u' have "u'' = \<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u'"
      by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    also from prems'(1) f ua(2) have
      "\<dots> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u"
      by (cs_concl cs_simp: cat_cs_simps u'_def u''_def cs_intro: cat_cs_intros)
    also from prems'(1) f ua(2) have
      "\<dots> = umap_of \<FF> c r u r''\<lparr>ArrVal\<rparr>\<lparr>g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<rparr>"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    finally have "u'' = umap_of \<FF> c r u r''\<lparr>ArrVal\<rparr>\<lparr>g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<rparr>".
    from f'_unique[OF gf this] have "g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f = f'".
    then have "(g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f) \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub> = f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>" by simp
    from this assms(2) prems'(1) u' f ua(2) show "g = f' \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f\<inverse>\<^sub>C\<^bsub>\<AA>\<^esub>"
      by
        (
          cs_prems
            cs_simp: cat_cs_simps cs_intro: cat_arrow_cs_intros cat_cs_intros
        )
  qed

qed

lemma (in is_functor) universal_arrow_fo_if_universal_arrow_fo:
  assumes "universal_arrow_fo \<FF> c r u"
    and "f : r' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<AA>\<^esub> r"
    and "u' = umap_fo \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
  shows "universal_arrow_fo \<FF> c r' u'"
  by
    (
      rule is_functor.universal_arrow_of_if_universal_arrow_of[
        OF is_functor_op, unfolded cat_op_simps, OF assms
        ]
    )

subsection\<open>Universal natural transformation\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
The concept of the universal natural transformation is introduced for the
statement of the elements of a variant of Proposition 1 in Chapter III-2
in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

definition ntcf_ua_of :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "ntcf_ua_of \<alpha> \<FF> c r u =
    [
      (\<lambda>d\<in>\<^sub>\<circ>\<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr>. umap_of \<FF> c r u d),
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<FF>\<lparr>HomDom\<rparr>(r,-),
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<FF>\<lparr>HomCod\<rparr>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>,
      \<FF>\<lparr>HomDom\<rparr>,
      cat_Set \<alpha>
    ]\<^sub>\<circ>"

definition ntcf_ua_fo :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "ntcf_ua_fo \<alpha> \<FF> c r u = ntcf_ua_of \<alpha> (op_cf \<FF>) c r u"

text\<open>Components.\<close>

lemma ntcf_ua_of_components:
  shows "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr> = (\<lambda>d\<in>\<^sub>\<circ>\<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr>. umap_of \<FF> c r u d)"
    and "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTDom\<rparr> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<FF>\<lparr>HomDom\<rparr>(r,-)"
    and "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTCod\<rparr> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<FF>\<lparr>HomCod\<rparr>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>"
    and "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTDGDom\<rparr> = \<FF>\<lparr>HomDom\<rparr>"
    and "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTDGCod\<rparr> = cat_Set \<alpha>"
  unfolding ntcf_ua_of_def nt_field_simps by (simp_all add: nat_omega_simps)

lemma ntcf_ua_fo_components:
  shows "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTMap\<rparr> = (\<lambda>d\<in>\<^sub>\<circ>\<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr>. umap_fo \<FF> c r u d)"
    and "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDom\<rparr> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>op_cat (\<FF>\<lparr>HomDom\<rparr>)(r,-)"
    and "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTCod\<rparr> =
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>op_cat (\<FF>\<lparr>HomCod\<rparr>)(c,-) \<circ>\<^sub>C\<^sub>F op_cf \<FF>"
    and "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDGDom\<rparr> = op_cat (\<FF>\<lparr>HomDom\<rparr>)"
    and "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDGCod\<rparr> = cat_Set \<alpha>"
  unfolding ntcf_ua_fo_def ntcf_ua_of_components umap_fo_def cat_op_simps
  by simp_all

context is_functor
begin

lemmas ntcf_ua_of_components' =
  ntcf_ua_of_components[where \<alpha>=\<alpha> and \<FF>=\<FF>, unfolded cat_cs_simps]

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

lemma ntcf_ua_fo_components':
  assumes "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  shows "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTMap\<rparr> = (\<lambda>d\<in>\<^sub>\<circ>\<AA>\<lparr>Obj\<rparr>. umap_fo \<FF> c r u d)"
    and [cat_cs_simps]:
      "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDom\<rparr> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(-,r)"
    and [cat_cs_simps]:
      "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTCod\<rparr> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(-,c) \<circ>\<^sub>C\<^sub>F op_cf \<FF>"
    and [cat_cs_simps]: "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDGDom\<rparr> = op_cat \<AA>"
    and [cat_cs_simps]: "ntcf_ua_fo \<alpha> \<FF> c r u\<lparr>NTDGCod\<rparr> = cat_Set \<alpha>"
  unfolding
    ntcf_ua_fo_components cat_cs_simps
    HomDom.cat_op_cat_cf_Hom_snd[OF assms(2)]
    HomCod.cat_op_cat_cf_Hom_snd[OF assms(1)]
  by simp_all

end

lemmas [cat_cs_simps] =
  is_functor.ntcf_ua_of_components'(2-5)
  is_functor.ntcf_ua_fo_components'(2-5)

subsubsection\<open>Natural transformation map\<close>

mk_VLambda (in is_functor)
  ntcf_ua_of_components(1)[where \<alpha>=\<alpha> and \<FF>=\<FF>, unfolded cf_HomDom]
  |vsv ntcf_ua_of_NTMap_vsv|
  |vdomain ntcf_ua_of_NTMap_vdomain|
  |app ntcf_ua_of_NTMap_app|

context is_functor
begin

context
  fixes c r
  assumes r: "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
begin

mk_VLambda ntcf_ua_fo_components'(1)[OF c r]
  |vsv ntcf_ua_fo_NTMap_vsv|
  |vdomain ntcf_ua_fo_NTMap_vdomain|
  |app ntcf_ua_fo_NTMap_app|

end

end

lemmas [cat_cs_intros] =
  is_functor.ntcf_ua_fo_NTMap_vsv
  is_functor.ntcf_ua_of_NTMap_vsv

lemmas [cat_cs_simps] =
  is_functor.ntcf_ua_fo_NTMap_vdomain
  is_functor.ntcf_ua_fo_NTMap_app
  is_functor.ntcf_ua_of_NTMap_vdomain
  is_functor.ntcf_ua_of_NTMap_app

lemma (in is_functor) ntcf_ua_of_NTMap_vrange:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "\<R>\<^sub>\<circ> (ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Arr\<rparr>"
proof(rule vsv.vsv_vrange_vsubset, unfold ntcf_ua_of_NTMap_vdomain)
  show "vsv (ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr>)" by (rule ntcf_ua_of_NTMap_vsv)
  fix d assume prems: "d \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  with category_cat_Set is_functor_axioms assms show
    "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr>\<lparr>d\<rparr> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Arr\<rparr>"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

subsubsection\<open>Commutativity of the universal maps and \<open>hom\<close>-functions\<close>

lemma (in is_functor) cf_umap_of_cf_hom_commute:
  assumes "category \<alpha> \<AA>"
    and "category \<alpha> \<BB>"
    and "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
    and "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    and "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b"
  shows
    "umap_of \<FF> c r u b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> cf_hom \<AA> [\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>, f]\<^sub>\<circ> =
      cf_hom \<BB> [\<BB>\<lparr>CId\<rparr>\<lparr>c\<rparr>, \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> umap_of \<FF> c r u a"
  (is \<open>?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf = ?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a\<close>)
proof-

  from is_functor_axioms category_cat_Set assms(1,2,4-6) have b_rf:
    "?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf : Hom \<AA> r a \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>)"
    by
      (
        cs_concl cs_shallow
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
  from is_functor_axioms category_cat_Set assms(1,2,4-6) have cf_a:
    "?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a : Hom \<AA> r a \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>)"
    by (cs_concl cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros)

  show ?thesis
  proof(rule arr_Set_eqI[of \<alpha>])
    from b_rf show arr_Set_b_rf: "arr_Set \<alpha> (?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf)"
      by (auto dest: cat_Set_is_arrD(1))
    from b_rf have dom_lhs:
      "\<D>\<^sub>\<circ> ((?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf)\<lparr>ArrVal\<rparr>) = Hom \<AA> r a"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)+
    from cf_a show arr_Set_cf_a: "arr_Set \<alpha> (?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a)"
      by (auto dest: cat_Set_is_arrD(1))
    from cf_a have dom_rhs:
      "\<D>\<^sub>\<circ> ((?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a)\<lparr>ArrVal\<rparr>) = Hom \<AA> r a"
      by (cs_concl cs_shallow cs_simp: cat_cs_simps)
    show "(?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf)\<lparr>ArrVal\<rparr> = (?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a)\<lparr>ArrVal\<rparr>"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix q assume "q : r \<mapsto>\<^bsub>\<AA>\<^esub> a"
      with is_functor_axioms category_cat_Set assms show
        "(?uof_b \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?rf)\<lparr>ArrVal\<rparr>\<lparr>q\<rparr> =
          (?cf \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_a)\<lparr>ArrVal\<rparr>\<lparr>q\<rparr>"
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
         )
    qed (use arr_Set_b_rf arr_Set_cf_a in auto)

  qed (use b_rf cf_a in \<open>cs_concl cs_shallow cs_simp: cat_cs_simps\<close>)+

qed

lemma cf_umap_of_cf_hom_unit_commute:
  assumes "category \<alpha> \<CC>"
    and "category \<alpha> \<DD>"
    and "\<FF> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
    and "\<GG> : \<DD> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<eta> : cf_id \<CC> \<mapsto>\<^sub>C\<^sub>F \<GG> \<circ>\<^sub>C\<^sub>F \<FF> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "g : c' \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and "f : d \<mapsto>\<^bsub>\<DD>\<^esub> d'"
  shows
    "umap_of \<GG> c' (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c'\<rparr>) (\<eta>\<lparr>NTMap\<rparr>\<lparr>c'\<rparr>) d' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub>
      cf_hom \<DD> [\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>, f]\<^sub>\<circ> =
        cf_hom \<CC> [g, \<GG>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub>
          umap_of \<GG> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) (\<eta>\<lparr>NTMap\<rparr>\<lparr>c\<rparr>) d"
  (is \<open>?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf = ?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd\<close>)
proof-

  interpret \<eta>: is_ntcf \<alpha> \<CC> \<CC> \<open>cf_id \<CC>\<close> \<open>\<GG> \<circ>\<^sub>C\<^sub>F \<FF>\<close> \<eta> by (rule assms(5))

  from assms have c'd'_\<FF>gf: "?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf :
    Hom \<DD> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) d \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<CC> c' (\<GG>\<lparr>ObjMap\<rparr>\<lparr>d'\<rparr>)"
    by
      (
        cs_concl
          cs_simp: cat_cs_simps
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
  then have dom_lhs:
    "\<D>\<^sub>\<circ> ((?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf)\<lparr>ArrVal\<rparr>) = Hom \<DD> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) d"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from assms have g\<GG>f_cd: "?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd :
    Hom \<DD> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) d \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<CC> c' (\<GG>\<lparr>ObjMap\<rparr>\<lparr>d'\<rparr>)"
    by
      (
        cs_concl
          cs_simp: cat_cs_simps
          cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
      )
  then have dom_rhs:
    "\<D>\<^sub>\<circ> ((?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd)\<lparr>ArrVal\<rparr>) = Hom \<DD> (\<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) d"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)

  show ?thesis
  proof(rule arr_Set_eqI[of \<alpha>])
    from c'd'_\<FF>gf show arr_Set_c'd'_\<FF>gf:
      "arr_Set \<alpha> (?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf)"
      by (auto dest: cat_Set_is_arrD(1))
    from g\<GG>f_cd show arr_Set_g\<GG>f_cd:
      "arr_Set \<alpha> (?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd)"
      by (auto dest: cat_Set_is_arrD(1))
    show
      "(?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf)\<lparr>ArrVal\<rparr> =
        (?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd)\<lparr>ArrVal\<rparr>"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs in_Hom_iff)
      fix h assume prems: "h : \<FF>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> \<mapsto>\<^bsub>\<DD>\<^esub> d"
      from \<eta>.ntcf_Comp_commute[OF assms(6)] assms have [cat_cs_simps]:
        "\<eta>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g = \<GG>\<lparr>ArrMap\<rparr>\<lparr>\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<eta>\<lparr>NTMap\<rparr>\<lparr>c'\<rparr>"
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
          )
      from assms prems show
        "(?uof_c'd' \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?\<FF>gf)\<lparr>ArrVal\<rparr>\<lparr>h\<rparr> =
          (?g\<GG>f \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?uof_cd)\<lparr>ArrVal\<rparr>\<lparr>h\<rparr>"
        by
          (
            cs_concl
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
              cs_simp: cat_cs_simps
          )
    qed (use arr_Set_c'd'_\<FF>gf arr_Set_g\<GG>f_cd in auto)

  qed (use c'd'_\<FF>gf g\<GG>f_cd in \<open>cs_concl cs_shallow cs_simp: cat_cs_simps\<close>)+

qed

subsubsection\<open>Universal natural transformation is a natural transformation\<close>

lemma (in is_functor) cf_ntcf_ua_of_is_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
  shows "ntcf_ua_of \<alpha> \<FF> c r u :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) \<mapsto>\<^sub>C\<^sub>F Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
proof(intro is_ntcfI')
  let ?ua = \<open>ntcf_ua_of \<alpha> \<FF> c r u\<close>
  show "vfsequence (ntcf_ua_of \<alpha> \<FF> c r u)" unfolding ntcf_ua_of_def by simp
  show "vcard ?ua = 5\<^sub>\<nat>" unfolding ntcf_ua_of_def by (simp add: nat_omega_simps)
  from assms(1) show "Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros)
  from is_functor_axioms assms(2) show
    "Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    by (cs_concl cs_intro: cat_cs_intros)
  from is_functor_axioms assms show "\<D>\<^sub>\<circ> (?ua\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  show "?ua\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> (Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
    if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
    using is_functor_axioms assms that
    by (cs_concl cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros)
  show "?ua\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
    (Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>)\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> ?ua\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
    if "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b" for a b f
    using is_functor_axioms assms that
    by
      (
        cs_concl
          cs_simp: cf_umap_of_cf_hom_commute cat_cs_simps cat_op_simps
          cs_intro: cat_cs_intros cat_op_intros
      )
qed (auto simp: ntcf_ua_of_components cat_cs_simps)

lemma (in is_functor) cf_ntcf_ua_fo_is_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
  shows "ntcf_ua_fo \<alpha> \<FF> c r u :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(-,r) \<mapsto>\<^sub>C\<^sub>F Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(-,c) \<circ>\<^sub>C\<^sub>F op_cf \<FF> :
    op_cat \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
proof-
  from assms(2) have c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by auto
  show ?thesis
    by
      (
        rule is_functor.cf_ntcf_ua_of_is_ntcf
          [
            OF is_functor_op,
            unfolded cat_op_simps,
            OF assms(1,2),
            unfolded
              HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)]
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric]
          ]
      )
qed

subsubsection\<open>Universal natural transformation and universal arrow\<close>

text\<open>
The lemmas in this subsection correspond to
variants of elements of Proposition 1 in Chapter III-2 in
\<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

lemma (in is_functor) cf_ntcf_ua_of_is_iso_ntcf:
  assumes "universal_arrow_of \<FF> c r u"
  shows "ntcf_ua_of \<alpha> \<FF> c r u :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
proof-

  have r: "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and u: "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    and bij: "\<And>r' u'.
      \<lbrakk>
        r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>;
        u' : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>
      \<rbrakk> \<Longrightarrow> \<exists>!f'. f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<and> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
    by (auto intro!: universal_arrow_ofD[OF assms(1)])

  show ?thesis
  proof(intro is_iso_ntcfI)
    show "ntcf_ua_of \<alpha> \<FF> c r u :
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) \<mapsto>\<^sub>C\<^sub>F Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
      by (rule cf_ntcf_ua_of_is_ntcf[OF r u])
    fix a assume prems: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    from is_functor_axioms prems r u have [simp]:
      "umap_of \<FF> c r u a : Hom \<AA> r a \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>)"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros)
    then have dom: "\<D>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>) = Hom \<AA> r a"
      by (cs_concl cs_simp: cat_cs_simps)
    have "umap_of \<FF> c r u a : Hom \<AA> r a \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>)"
    proof(intro cat_Set_is_iso_arrI, unfold dom)

      show umof_a: "v11 (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>)"
      proof(intro vsv.vsv_valeq_v11I, unfold dom in_Hom_iff)
        fix g f assume prems':
          "g : r \<mapsto>\<^bsub>\<AA>\<^esub> a"
          "f : r \<mapsto>\<^bsub>\<AA>\<^esub> a"
          "umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<lparr>g\<rparr> = umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
        from is_functor_axioms r u prems'(1) have \<FF>g:
          "\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
          by (cs_concl cs_shallow cs_intro: cat_cs_intros)
        from bij[OF prems \<FF>g] have unique:
          "\<lbrakk>
            f' : r \<mapsto>\<^bsub>\<AA>\<^esub> a;
            \<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u = umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>
           \<rbrakk> \<Longrightarrow> g = f'"
          for f' by (metis prems'(1) u umap_of_ArrVal_app)
        from is_functor_axioms prems'(1,2) u have \<FF>g_u:
          "\<FF>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> u = umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
          by (cs_concl cs_simp: prems'(3)[symmetric] cat_cs_simps)
        show "g = f" by (rule unique[OF prems'(2) \<FF>g_u])
      qed (auto simp: cat_cs_simps cat_cs_intros)

      interpret umof_a: v11 \<open>umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<close> by (rule umof_a)

      show "\<R>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>) = Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>)"
      proof(intro vsubset_antisym)
        from u show "\<R>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>)"
          by (rule umap_of_ArrVal_vrange)
        show "Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>)"
        proof(rule vsubsetI, unfold in_Hom_iff )
          fix f assume prems': "f : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
          from bij[OF prems prems'] obtain f'
            where f': "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> a"
              and f_def: "f = umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
            by auto
          from is_functor_axioms prems prems' u f' have
            "f' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>)"
            by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
          from this show "f \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (umap_of \<FF> c r u a\<lparr>ArrVal\<rparr>)"
            unfolding f_def by (rule umof_a.vsv_vimageI2)
        qed

      qed

    qed simp_all

    from is_functor_axioms prems r u this show
      "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
        Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Set \<alpha>\<^esub>
        (Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cat_op_simps
            cs_intro: cat_cs_intros cat_op_intros
        )
  qed

qed

lemmas [cat_cs_intros] = is_functor.cf_ntcf_ua_of_is_iso_ntcf

lemma (in is_functor) cf_ntcf_ua_fo_is_iso_ntcf:
  assumes "universal_arrow_fo \<FF> c r u"
  shows "ntcf_ua_fo \<alpha> \<FF> c r u :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(-,r) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(-,c) \<circ>\<^sub>C\<^sub>F op_cf \<FF> :
    op_cat \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
proof-
  from universal_arrow_foD[OF assms] have r: "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" and c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
    by auto
  show ?thesis
    by
      (
        rule is_functor.cf_ntcf_ua_of_is_iso_ntcf
          [
            OF is_functor_op,
            unfolded cat_op_simps,
            OF assms,
            unfolded
              HomDom.cat_op_cat_cf_Hom_snd[OF r]
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric]
          ]
      )
qed

lemmas [cat_cs_intros] = is_functor.cf_ntcf_ua_fo_is_iso_ntcf

lemma (in is_functor) cf_ua_of_if_ntcf_ua_of_is_iso_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    and "ntcf_ua_of \<alpha> \<FF> c r u :
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "universal_arrow_of \<FF> c r u"
proof(rule universal_arrow_ofI)
  interpret ua_of_u: is_iso_ntcf
    \<alpha>
    \<AA>
    \<open>cat_Set \<alpha>\<close>
    \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<close>
    \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>\<close>
    \<open>ntcf_ua_of \<alpha> \<FF> c r u\<close>
    by (rule assms(3))
  fix r' u' assume prems: "r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" "u' : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
  have "ntcf_ua_of \<alpha> \<FF> c r u\<lparr>NTMap\<rparr>\<lparr>r'\<rparr> :
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Set \<alpha>\<^esub>
    (Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>)\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
    by (rule is_iso_ntcf.iso_ntcf_is_iso_arr[OF assms(3) prems(1)])
  from this is_functor_axioms assms(1-2) prems have uof_r':
    "umap_of \<FF> c r u r' : Hom \<AA> r r' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Set \<alpha>\<^esub> Hom \<BB> c (\<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>)"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_op_intros)
  note uof_r' = cat_Set_is_iso_arrD[OF uof_r']
  interpret uof_r': v11 \<open>umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<close> by (rule uof_r'(2))
  from
    uof_r'.v11_vrange_ex1_eq[
      THEN iffD1, unfolded uof_r'(3,4) in_Hom_iff, OF prems(2)
      ]
  show "\<exists>!f'. f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<and> u' = umap_of \<FF> c r u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
    by metis
qed (intro assms)+

lemma (in is_functor) cf_ua_fo_if_ntcf_ua_fo_is_iso_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "u : \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> c"
    and "ntcf_ua_fo \<alpha> \<FF> c r u :
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(-,r) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(-,c) \<circ>\<^sub>C\<^sub>F op_cf \<FF> :
      op_cat \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "universal_arrow_fo \<FF> c r u"
proof-
  from assms(2) have c: "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by auto
  show ?thesis
    by
      (
        rule is_functor.cf_ua_of_if_ntcf_ua_of_is_iso_ntcf
          [
            OF is_functor_op,
            unfolded cat_op_simps,
            OF assms(1,2),
            unfolded
              HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)]
              HomCod.cat_op_cat_cf_Hom_snd[OF c]
              ntcf_ua_fo_def[symmetric],
            OF assms(3)
          ]
      )
qed

lemma (in is_functor) cf_universal_arrow_of_if_is_iso_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
    and "\<phi> :
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "universal_arrow_of \<FF> c r (\<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>)"
    (is \<open>universal_arrow_of \<FF> c r ?u\<close>)
proof-

  interpret \<phi>: is_iso_ntcf
    \<alpha> \<AA> \<open>cat_Set \<alpha>\<close> \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<close> \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>\<close> \<phi>
    by (rule assms(3))

  show ?thesis
  proof(intro universal_arrow_ofI assms)

    from assms(1,2) show u: "?u : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
        )
    fix r' u' assume prems: "r' \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" "u' : c \<mapsto>\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
    have \<phi>r'_ArrVal_app[symmetric, cat_cs_simps]:
      "\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr>\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr> =
        \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>"
      if "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r'" for f'
    proof-
      have "\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(r,-)\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> =
        (Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(c,-) \<circ>\<^sub>C\<^sub>F \<FF>)\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> \<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>"
        using that by (intro \<phi>.ntcf_Comp_commute)
      then have
        "\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> cf_hom \<AA> [\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>, f']\<^sub>\<circ> =
          cf_hom \<BB> [\<BB>\<lparr>CId\<rparr>\<lparr>c\<rparr>, \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> \<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>"
        using assms(1,2) that prems
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
          )
      then have
        "(\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub>
        cf_hom \<AA> [\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>, f']\<^sub>\<circ>)\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr> =
          (cf_hom \<BB> [\<BB>\<lparr>CId\<rparr>\<lparr>c\<rparr>, \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr>]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub>
          \<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>)\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>"
         by simp
      from this assms(1,2) u that show ?thesis
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros cat_prod_cs_intros
          )
    qed

    show "\<exists>!f'. f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r' \<and> u' = umap_of \<FF> c r ?u r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
    proof(intro ex1I conjI; (elim conjE)?)
      from assms prems show
        "(\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr>)\<inverse>\<^sub>C\<^bsub>cat_Set \<alpha>\<^esub>\<lparr>ArrVal\<rparr>\<lparr>u'\<rparr> : r \<mapsto>\<^bsub>\<AA>\<^esub> r'"
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_arrow_cs_intros
          )
      with assms(1,2) prems show "u' =
        umap_of \<FF> c r ?u r'\<lparr>ArrVal\<rparr>\<lparr>(\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr>)\<inverse>\<^sub>C\<^bsub>cat_Set \<alpha>\<^esub>\<lparr>ArrVal\<rparr>\<lparr>u'\<rparr>\<rparr>"
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )
      fix f' assume prems':
        "f' : r \<mapsto>\<^bsub>\<AA>\<^esub> r'"
        "u' = umap_of \<FF> c r (\<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>) r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
      from prems'(2,1) assms(1,2) have u'_def:
        "u' = \<FF>\<lparr>ArrMap\<rparr>\<lparr>f'\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>"
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cat_op_simps
              cs_intro: cat_cs_intros cat_op_intros
          )
      from prems' show "f' = (\<phi>\<lparr>NTMap\<rparr>\<lparr>r'\<rparr>)\<inverse>\<^sub>C\<^bsub>cat_Set \<alpha>\<^esub>\<lparr>ArrVal\<rparr>\<lparr>u'\<rparr>"
        unfolding u'_def \<phi>r'_ArrVal_app[OF prems'(1)]
        by
          (
            cs_concl
              cs_simp: cat_cs_simps
              cs_intro: cat_arrow_cs_intros cat_cs_intros cat_op_intros
          )

    qed

  qed

qed

lemma (in is_functor) cf_universal_arrow_fo_if_is_iso_ntcf:
  assumes "r \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "c \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
    and "\<phi> :
      Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<AA>(-,r) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<BB>(-,c) \<circ>\<^sub>C\<^sub>F op_cf \<FF> :
      op_cat \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "universal_arrow_fo \<FF> c r (\<phi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<AA>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>)"
  by
    (
      rule is_functor.cf_universal_arrow_of_if_is_iso_ntcf
        [
          OF is_functor_op,
          unfolded cat_op_simps,
          OF assms(1,2),
          unfolded
            HomDom.cat_op_cat_cf_Hom_snd[OF assms(1)]
            HomCod.cat_op_cat_cf_Hom_snd[OF assms(2)]
            ntcf_ua_fo_def[symmetric],
          OF assms(3)
        ]
  )

text\<open>\newpage\<close>

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory KBPs
imports Kripke Traces
begin
(*>*)

section\<open>Knowledge-based Programs\<close>

text \<open>

\label{sec:kbps-theory-kbps-semantics}

A knowledge-based programs (KBPs) encodes the dependency of action on
knowledge by a sequence of guarded commands, and a \emph{joint
knowledge-based program} (JKBP) assigns a KBP to each agent:

\<close>

record ('a, 'p, 'aAct) GC =
  guard  :: "('a, 'p) Kform"
  action :: "'aAct"

type_synonym ('a, 'p, 'aAct) KBP = "('a, 'p, 'aAct) GC list"
type_synonym ('a, 'p, 'aAct) JKBP = "'a \<Rightarrow> ('a, 'p, 'aAct) KBP"

text\<open>

We use a list of guarded commands just so we can reuse this definition
and others in algorithmic contexts; we would otherwise use a set as
there is no problem with infinite programs or actions, and we always
ignore the sequential structure.

Intuitively a KBP for an agent cannot directly evaluate the truth of
an arbitrary formula as it may depend on propositions that the agent
has no certainty about. For example, a card-playing agent cannot
determine which cards are in the deck, despite being sure that those
in her hand are not. Conversely agent $a$ can evaluate formulas of the
form @{term "\<^bold>K\<^sub>a \<phi>"} as these depend only on the worlds the agent thinks
is possible.

Thus we restrict the guards of the JKBP to be boolean combinations of
\emph{subjective} formulas:

\<close>

fun subjective :: "'a \<Rightarrow> ('a, 'p) Kform \<Rightarrow> bool" where
  "subjective a (Kprop p)      = False"
| "subjective a (Knot f)       = subjective a f"
| "subjective a (Kand f g)     = (subjective a f \<and> subjective a g)"
| "subjective a (Kknows a' f)  = (a = a')"
| "subjective a (Kcknows as f) = (a \<in> set as)"

text\<open>

All JKBPs in the following sections are assumed to be subjective.

This syntactic restriction implies the desired semantic property, that
we can evaluate a guard at an arbitrary world that is compatible with
a given observation \citep[\S3]{DBLP:journals/dc/FaginHMV97}.

\<close>

lemma S5n_subjective_eq:
  assumes S5n: "S5n M"
  assumes subj: "subjective a \<phi>"
  assumes ww': "(w, w') \<in> relations M a"
  shows "M, w \<Turnstile> \<phi> \<longleftrightarrow> M, w' \<Turnstile> \<phi>"
(*<*)
using subj ww'
proof(induct \<phi> rule: subjective.induct[case_names Kprop Knot Kand Kknows Kcknows])
  case (Kcknows a as \<phi>)
  hence "(w, w') \<in> (\<Union>a\<in>set as. relations M a)\<^sup>+" by auto
  with Kcknows S5n show ?case by (auto dest: S5n_tc_rels_eq)
qed (auto dest: S5n_rels_eq[OF S5n])

(*>*)
text\<open>

The proof is by induction over the formula @{term "\<phi>"}, using the
properties of $S5_n$ Kripke structures in the knowledge cases.

We capture the fixed but arbitrary JKBP using a locale, and work in
this context for the rest of this section.

\<close>

locale JKBP =
  fixes jkbp :: "('a, 'p, 'aAct) JKBP"
  assumes subj: "\<forall>a gc. gc \<in> set (jkbp a) \<longrightarrow> subjective a (guard gc)"

context JKBP
begin

text\<open>

The action of the JKBP at a world is the list of all actions that are
enabled at that world:

\<close>

definition jAction :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> 'a \<Rightarrow> 'aAct list"
where "jAction \<equiv> \<lambda>M w a. [ action gc. gc \<leftarrow> jkbp a, M, w \<Turnstile> guard gc ]"

text\<open>

All of our machinery on Kripke structures lifts from the models
relation of \S\ref{sec:kbps-logic-of-knowledge} through @{term
"jAction"}, due to the subjectivity requirement. In particular, the
KBP for agent $a$ behaves the same at worlds that $a$ cannot
distinguish amongst:

\<close>

lemma S5n_jAction_eq:
  assumes S5n: "S5n M"
  assumes ww': "(w, w') \<in> relations M a"
  shows "jAction M w a = jAction M w' a"
(*<*)
proof -
  { fix gc assume "gc \<in> set (jkbp a)"
    with subj have "subjective a (guard gc)" by auto
    with S5n ww' have "M, w \<Turnstile> guard gc = M, w' \<Turnstile> guard gc"
      by - (rule S5n_subjective_eq, simp_all) }
  thus ?thesis
    unfolding jAction_def
    by - (rule arg_cong[where f=concat], simp)
qed
(*>*)

text\<open>

Also the JKBP behaves the same on relevant generated models for all
agents:

\<close>

lemma gen_model_jAction_eq:
  assumes S: "gen_model M w = gen_model M' w"
  assumes w': "w' \<in> worlds (gen_model M' w)"
  assumes M: "kripke M"
  assumes M': "kripke M'"
  shows "jAction M w' = jAction M' w'"
(*<*)
  unfolding jAction_def
  by (auto iff: gen_model_eq[OF M M' S w'])
(*>*)

text\<open>

Finally, @{term "jAction"} is invariant under simulations:

\<close>

lemma simulation_jAction_eq:
  assumes M: "kripke M"
  assumes sim: "sim M M' f"
  assumes w: "w \<in> worlds M"
  shows "jAction M w = jAction M' (f w)"
(*<*)
  unfolding jAction_def
  using assms by (auto iff: sim_semantic_equivalence)
(*>*)

end

section\<open>Environments and Views\<close>

text\<open>

\label{sec:kbps-theory-environments}

The previous section showed how a JKBP can be interpreted statically,
with respect to a fixed Kripke structure. As we also wish to capture
how agents interact, we adopt the \emph{interpreted systems} and
\emph{contexts} of \cite{FHMV:1995}, which we term \emph{environments}
following \cite{Ron:1996}.

A \emph{pre-environment} consists of the following:
\begin{itemize}

\item @{term "envInit"}, an arbitrary set of initial states;

\item The protocol of the environment @{term "envAction"}, which
  depends on the current state;

\item A transition function @{term "envTrans"}, which incorporates the
  environment's action and agents' behaviour into a state change; and

\item A propositional evaluation function @{term "envVal"}.

\end{itemize}
We extend the @{term "JKBP"} locale with these constants:

\<close>

locale PreEnvironment = JKBP jkbp for jkbp :: "('a, 'p, 'aAct) JKBP"
+ fixes envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"

text\<open>

\label{sec:kbps-views}

We represent the possible evolutions of the system as finite sequences
of states, represented by a left-recursive type @{typ "'s Trace"} with
constructors @{term "tInit s"} and @{term "t \<leadsto> s"}, equipped with
@{term "tFirst"}, @{term "tLast"}, @{term "tLength"} and @{term
"tMap"} functions.

Constructing these traces requires us to determine the agents' actions
at a given state. To do so we need to find an appropriate S$5_n$
structure for interpreting @{term "jkbp"}.

Given that we want the agents to make optimal use of the information
they have access to, we allow these structures to depend on the entire
history of the system, suitably conditioned by what the agents can
observe. We capture this notion of observation with a \emph{view}
\citep{Ron:1996}, which is an arbitrary function of a trace:

\<close>

type_synonym ('s, 'tview) View = "'s Trace \<Rightarrow> 'tview"
type_synonym ('a, 's, 'tview) JointView = "'a \<Rightarrow> 's Trace \<Rightarrow> 'tview"

text\<open>

\label{sec:kbps-synchrony}

We require views to be \emph{synchronous}, i.e. that agents be able to
tell the time using their view by distinguishing two traces of
different lengths. As we will see in the next section, this guarantees
that the JKBP has an essentially unique implementation.

We extend the @{term "PreEnvironment"} locale with a view:

\<close>

locale PreEnvironmentJView =
  PreEnvironment jkbp envInit envAction envTrans envVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
+ fixes jview :: "('a, 's, 'tview) JointView"
  assumes sync: "\<forall>a t t'. jview a t = jview a t' \<longrightarrow> tLength t = tLength t'"

text\<open>

The two principle synchronous views are the clock view and the
perfect-recall view which we discuss further in
\S\ref{sec:kbps-theory-views}. We will later derive an agent's
concrete view from an instantaneous observation of the global state in
\S\ref{sec:kbps-environments}.

We build a Kripke structure from a set of traces by relating traces
that yield the same view. To obtain an S$5_n$ structure we also need a
way to evaluate propositions: we apply @{term "envVal"} to the final
state of a trace:

\<close>

definition (in PreEnvironmentJView)
  mkM :: "'s Trace set \<Rightarrow> ('a, 'p, 's Trace) KripkeStructure"
where
  "mkM T \<equiv>
      \<lparr> worlds = T,
        relations = \<lambda>a. { (t, t') . {t, t'} \<subseteq> T \<and> jview a t = jview a t' },
        valuation = envVal \<circ> tLast \<rparr>"
(*<*)

context PreEnvironmentJView
begin

lemma mkM_kripke[intro, simp]: "kripke (mkM T)"
  unfolding mkM_def by (rule kripkeI) fastforce

lemma mkM_S5n[intro, simp]: "S5n (mkM T)"
  unfolding mkM_def
  by (intro S5nI equivI)
     (bestsimp intro: equivI refl_onI symI transI)+

lemma mkM_simps[simp]:
  "worlds (mkM T) = T"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> jview a t = jview a t'"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> t \<in> T"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> t' \<in> T"
  "valuation (mkM T) = envVal \<circ> tLast"
  unfolding mkM_def by simp_all

lemma mkM_rel_length[simp]:
  assumes tt': "(t, t') \<in> relations (mkM T) a"
  shows "tLength t' = tLength t"
proof -
  from tt' have "jview a t = jview a t'" by simp
  thus ?thesis by (bestsimp dest: sync[rule_format])
qed

(*>*)
text\<open>

This construction supplants the role of the \emph{local states} of
\citet{FHMV:1995}.

The following section shows how we can canonically interpret the JKBP
with respect to this structure.

\<close>

section\<open>Canonical Structures\<close>

text\<open>

\label{sec:kbps-canonical-kripke}

Our goal in this section is to find the canonical set of traces for a
given JKBP in a particular environment. As we will see, this always
exists with respect to synchronous views.

We inductively define an \emph{interpretation} of a JKBP with respect
to an arbitrary set of traces @{term "T"} by constructing a sequence
of sets of traces of increasing length:

\<close>

fun jkbpTn :: "nat \<Rightarrow> 's Trace set \<Rightarrow> 's Trace set"(*<*)("jkbpT\<^bsub>_\<^esub>")(*>*) where
  "jkbpT\<^bsub>0\<^esub> T     = { tInit s |s. s \<in> set envInit }"
| "jkbpT\<^bsub>Suc n\<^esub> T = { t \<leadsto> envTrans eact aact (tLast t) |t eact aact.
                             t \<in> jkbpT\<^bsub>n\<^esub> T \<and> eact \<in> set (envAction (tLast t))
                          \<and> (\<forall>a. aact a \<in> set (jAction (mkM T) t a)) }"

text\<open>

This model reflects the failure of any agent to provide an action as
failure of the entire system. In general @{term "envTrans"} may
incorporate a scheduler and communication failure models.

The union of this sequence gives us a closure property:

\<close>

definition jkbpT :: "'s Trace set \<Rightarrow> 's Trace set" where
  "jkbpT T \<equiv> \<Union>n. jkbpT\<^bsub>n\<^esub> T"
(*<*)

lemma jkbpTn_length:
  "t \<in> jkbpTn n T \<Longrightarrow> tLength t = n"
  by (induct n arbitrary: t, auto)

lemma jkbpT_tLength_inv:
  "\<lbrakk> t \<in> jkbpT T; tLength t = n \<rbrakk> \<Longrightarrow> t \<in> jkbpTn n T"
  unfolding jkbpT_def
  by (induct n arbitrary: t) (fastforce simp: jkbpTn_length)+

lemma jkbpT_traces_of_length:
   "{ t \<in> jkbpT T . tLength t = n } = jkbpTn n T"
  using jkbpT_tLength_inv
  unfolding jkbpT_def by (bestsimp simp: jkbpTn_length)

(*>*)
text\<open>

We say that a set of traces @{term "T"} \emph{represents} a JKBP if it
is closed under @{term "jkbpT"}:

\<close>

definition represents :: "'s Trace set \<Rightarrow> bool" where
  "represents T \<equiv> jkbpT T = T"
(*<*)

lemma representsI:
  "jkbpT T = T \<Longrightarrow> represents T"
  unfolding represents_def by simp

lemma representsD:
  "represents T \<Longrightarrow> jkbpT T = T"
  unfolding represents_def by simp

(*>*)
text\<open>

This is the vicious cycle that we break using our assumption that the
view is synchronous. The key property of such views is that the
satisfaction of an epistemic formula is determined by the set of
traces in the model that have the same length. Lifted to @{term
"jAction"}, we have:

\<close>

(*<*)
lemma sync_tLength_eq_trc:
  assumes "(t, t') \<in> (\<Union>a\<in>as. relations (mkM T) a)\<^sup>*"
  shows "tLength t = tLength t'"
  using assms by (induct rule: rtrancl_induct) auto

lemma sync_gen_model_tLength:
  assumes traces: "{ t \<in> T . tLength t = n } = { t \<in> T' . tLength t = n }"
      and tT: "t \<in> { t \<in> T . tLength t = n }"
  shows "gen_model (mkM T) t = gen_model (mkM T') t"
  apply(rule gen_model_subset[where T="{ t \<in> T . tLength t = n }"])
  apply simp_all

  (* t \<in> T and t \<in> T' *)
  prefer 4
  using tT
  apply simp
  prefer 4
  using tT traces
  apply simp

  apply (unfold mkM_def)[1]
  using tT traces
  apply (auto)[1]

  using tT
  apply (auto dest: sync_tLength_eq_trc[where as=UNIV] kripke_rels_trc_worlds)[1]

  using tT traces
  apply (auto dest: sync_tLength_eq_trc[where as=UNIV] kripke_rels_trc_worlds)[1]

  done

(*>*)
lemma sync_jview_jAction_eq:
  assumes traces: "{ t \<in> T . tLength t = n } = { t \<in> T' . tLength t = n }"
  assumes tT: "t \<in> { t \<in> T . tLength t = n }"
  shows "jAction (mkM T) t = jAction (mkM T') t"
(*<*)
  apply (rule gen_model_jAction_eq[where w=t])
  apply (rule sync_gen_model_tLength)
  using assms
  apply (auto intro: gen_model_world_refl)
  done

(*>*)
text\<open>

This implies that for a synchronous view we can inductively define the
\emph{canonical traces} of a JKBP. These are the traces that a JKBP
generates when it is interpreted with respect to those very same
traces. We do this by constructing the sequence \<open>jkbpC\<^sub>n\<close> of
\emph{(canonical) temporal slices} similarly to @{term "jkbpT\<^bsub>n\<^esub>"}:

\<close>

fun jkbpCn :: "nat \<Rightarrow> 's Trace set"(*<*)("jkbpC\<^bsub>_\<^esub>")(*>*) where
  "jkbpC\<^bsub>0\<^esub>      = { tInit s |s. s \<in> set envInit }"
| "jkbpC\<^bsub>Suc n\<^esub> = { t \<leadsto> envTrans eact aact (tLast t) |t eact aact.
                             t \<in> jkbpC\<^bsub>n\<^esub> \<and> eact \<in> set (envAction (tLast t))
                          \<and> (\<forall>a. aact a \<in> set (jAction (mkM jkbpC\<^bsub>n\<^esub>) t a)) }"

abbreviation MCn :: "nat \<Rightarrow> ('a, 'p, 's Trace) KripkeStructure"(*<*)("MC\<^bsub>_\<^esub>")(*>*) where
  "MC\<^bsub>n\<^esub> \<equiv> mkM jkbpC\<^bsub>n\<^esub>"
(*<*)

lemma jkbpCn_step_inv:
  "t \<leadsto> s \<in> jkbpCn (Suc n) \<Longrightarrow> t \<in> jkbpCn n"
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpCn_length[simp]:
  "t \<in> jkbpCn n \<Longrightarrow> tLength t = n"
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpCn_init_inv[intro]:
  "tInit s \<in> jkbpCn n \<Longrightarrow> s \<in> set envInit"
   by (frule jkbpCn_length) auto

lemma jkbpCn_tFirst_init_inv[intro]:
 "t \<in> jkbpCn n \<Longrightarrow> tFirst t \<in> set envInit"
  by (induct n arbitrary: t) (auto iff: Let_def)

(*>*)
text\<open>

The canonical set of traces for a JKBP with respect to a joint view is
the set of canonical traces of all lengths.

\<close>

definition jkbpC :: "'s Trace set" where
  "jkbpC \<equiv> \<Union>n. jkbpC\<^bsub>n\<^esub>"

abbreviation MC :: "('a, 'p, 's Trace) KripkeStructure" where
  "MC \<equiv> mkM jkbpC"
(*<*)

lemma jkbpCn_jkbpC_subset:
  "jkbpCn n \<subseteq> jkbpC"
  unfolding jkbpC_def by blast

lemma jkbpCn_jkbpC_inc[intro]:
  "t \<in> jkbpCn n \<Longrightarrow> t \<in> jkbpC"
  unfolding jkbpC_def by best

lemma jkbpC_tLength_inv[intro]:
  "\<lbrakk> t \<in> jkbpC; tLength t = n \<rbrakk> \<Longrightarrow> t \<in> jkbpCn n"
  unfolding jkbpC_def
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpC_traces_of_length:
   "{ t \<in> jkbpC . tLength t = n } = jkbpCn n"
  unfolding jkbpC_def by bestsimp

lemma jkbpC_prefix_closed[dest]:
  "t \<leadsto> s \<in> jkbpC \<Longrightarrow> t \<in> jkbpC"
  apply (drule jkbpC_tLength_inv)
   apply simp
  apply (auto iff: Let_def jkbpC_def)
  done

lemma jkbpC_init[iff]:
  "tInit s \<in> jkbpC \<longleftrightarrow> s \<in> set envInit"
  unfolding jkbpC_def
  apply rule
   apply fast
  apply (subgoal_tac "tInit s \<in> jkbpCn 0")
   apply simp
  apply (rule_tac x=0 in exI)
  apply simp_all
  done

lemma jkbpC_jkbpCn_rels:
  "\<lbrakk> (u, v) \<in> relations MC a; tLength u = n \<rbrakk>
    \<Longrightarrow> (u, v) \<in> relations (MC\<^bsub>n\<^esub>) a"
  unfolding mkM_def by (fastforce dest: sync[rule_format])

lemma jkbpC_tFirst_init_inv[intro]:
  "t \<in> jkbpC \<Longrightarrow> tFirst t \<in> set envInit"
  unfolding jkbpC_def by blast

(*>*)
text\<open>

We can show that @{term "jkbpC"} represents the joint knowledge-based
program @{term "jkbp"} with respect to @{term "jview"}:

\<close>

lemma jkbpC_jkbpCn_jAction_eq:
  assumes tCn: "t \<in> jkbpC\<^bsub>n\<^esub>"
  shows "jAction MC t = jAction MC\<^bsub>n\<^esub> t"
(*<*)
  using assms
  by - (rule sync_jview_jAction_eq, auto iff: jkbpC_traces_of_length)

(*>*)
text\<open>\<close>

text\<open>\<close>

theorem jkbpC_represents: "represents jkbpC"
(*<*)
  using jkbpTn_jkbpCn_represents
  by (simp add: representsI jkbpC_def jkbpT_def)

(*>*)
text\<open>

We can show uniqueness too, by a similar argument:

\<close>

theorem jkbpC_represents_uniquely:
  assumes repT: "represents T"
  shows "T = jkbpC"
(*<*)
proof -
  { fix n
    have "{ t \<in> T . tLength t = n } = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0
      from repT have F: "{t \<in> T. tLength t = 0} = jkbpTn 0 T"
        by - (subst jkbpT_traces_of_length[symmetric], simp add: representsD)
      thus ?case by (simp add: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> T. tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

        (* F and H are very similar. *)
      from repT have F: "\<And>n. jkbpTn n T = {t \<in> T. tLength t = n}"
        by - (subst jkbpT_traces_of_length[symmetric], simp add: representsD)
      from indhyp F have G: "jkbpTn n T = jkbpCn n"
        by simp
      from repT have H: "\<And>n. {t \<in> T. tLength t = n} = {t \<in> jkbpTn n T. tLength t = n}"
        by (subst representsD[OF repT, symmetric], auto iff: jkbpT_traces_of_length jkbpTn_length)
      from F indhyp have ACTS:
        "\<And>t. t \<in> jkbpTn n T
          \<Longrightarrow> jAction (mkM T) t = jAction (MCn n) t"
        by - (rule sync_jview_jAction_eq[where n="n"], auto)
      show ?case
        apply (auto iff: Let_def ACTS G H jkbpC_traces_of_length)
        apply blast+
        done
    qed }
  thus ?thesis by auto
qed
(*>*)

end (* context PreEnvironmentJView *)

text\<open>

Thus, at least with synchronous views, we are justified in talking
about \emph{the} representation of a JKBP in a given environment. More
generally these results are also valid for the more general notion of
\emph{provides witnesses} as shown by \citet[Lemma 7.2.4]{FHMV:1995}
and \citet{DBLP:journals/dc/FaginHMV97}: it requires only that if a
subjective knowledge formula is false on a trace then there is a trace
of the same length or less that bears witness to that effect. This is
a useful generalisation in asynchronous settings.

The next section shows how we can construct canonical representations
of JKBPs using automata.

\<close>

(*<*)
end
(*>*)


theory ReduceExp
  imports SRRead
begin

    (*
        --- OVERVIEW ---
          1. expression syntax
          2. free variables / reduction
          4. type system for expressions
          4. disjoint environments [disj_env]
          5. well-typed value lemmas [is_value, env_level, max_env_level]
          6. well-typed s-expression lemmas [is_sexp, env_level, max_env_level]
          7. well-typed free var lemmas [well_typed, free_vars]
          8. well-typed manipulation lemmas [well_typed, add_env, rem_env, comb_env]
    *)

    (*
      ####################################
        P3. reduction
      ####################################
    *)

    (* memory values *)

datatype mem_value =
  ArrValue "p_exp list"
  | ChanSValue
  | ChanRValue string
    (* true if unique, false otherwise *)
  (*| PairValue p_exp p_exp*) (*p_aff*)

type_synonym p_state = "mem_value gen_env"

fun app_op :: "p_op \<Rightarrow> p_const \<Rightarrow> p_exp \<Rightarrow> bool" where
  "app_op (I2Op f2) c e' = (\<exists> i. c = IConst i \<and> e' = OpExp (I1Op (f2 i)))"
| "app_op (I1Op f1) c e' = (\<exists> i. c = IConst i \<and> e' = ConstExp (IConst (f1 i)))"
| "app_op (C2Op f2) c e' = (\<exists> i. c = IConst i \<and> e' = OpExp (C1Op (f2 i)))"
| "app_op (C1Op f1) c e' = (\<exists> i. c = IConst i \<and> e' = ConstExp (BConst (f1 i)))"
| "app_op (R2Op f2) c e' = (\<exists> b. c = BConst b \<and> e' = OpExp (R1Op (f2 b)))"
| "app_op (R1Op f1) c e' = (\<exists> b. c = BConst b \<and> e' = ConstExp (BConst (f1 b)))"

fun new_array_dat :: "int \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "new_array_dat i v = (if i \<le> 0 then [] else v # (new_array_dat (i - 1) v))"

definition new_array :: "int \<Rightarrow> p_exp \<Rightarrow> mem_value" where
  "new_array i v = (ArrValue (new_array_dat i v))"

fun read_array where
  "read_array [] i = None"
| "read_array (v # t) i = (if i = 0 then Some v else read_array t (i - 1))"

fun write_array where
  "write_array [] i v' = None"
| "write_array (v # t) i v' = (if i = 0 then Some (v' # t) else (case (write_array t (i - 1) v') of
    None \<Rightarrow> None
  | Some t' \<Rightarrow> Some (v # t')
  ))"

    (* in order to ensure that ownership transfer is safe, we require aggressive removal of permissions once
      they are no longer needed. for this reason, every use is tracked as an action.  *)
datatype p_act =
    (* - nothing *)
  NoAct
    (* - new resource, ##resources consumed to create the resource *)
  | MakeAct string (*"string set"*)
  | Mk2Act string string
    (* - resource used, ##resources transferred to the resource *)
  | UseAct string (*"string set"*)

fun ext_list where
  "ext_list [] v = [v]"
| "ext_list (v' # t) v = v' # (ext_list t v)"

fun app_con :: "p_state \<Rightarrow> p_const \<Rightarrow> p_exp \<Rightarrow> p_act \<Rightarrow> p_state \<times> p_exp \<Rightarrow> bool" where
  "app_con s EmptyArrayConst v ax (s', e') = (\<exists> a. ax = MakeAct a \<and> v = ConstExp UnitConst \<and>
    e' = VarExp a SelfRef \<and> s' = add_env s a (ArrValue []) \<and> fresh_var s a
  )"
| "app_con s NewChanConst v ax (s', e') = (\<exists> c_s c_r. ax = Mk2Act c_s c_r \<and> v = ConstExp UnitConst \<and>
    e' = (PairExp (VarExp c_s SelfRef) (VarExp c_r SelfRef)) \<and> s' = add_env (add_env s c_s ChanSValue) c_r (ChanRValue c_s) \<and>
    fresh_var s c_s \<and> fresh_var s c_r \<and> c_s \<noteq> c_r)"
| "app_con s UnpackConst v ax (s', e') = (\<exists> v1 v2 f. ax = NoAct \<and> v = PairExp v1 v2 \<and> s' = s \<and>
    e' = (LamExp f (AppExp (AppExp (VarExp f NoRef) v1) v2)) \<and> f \<notin> free_vars v \<and> f \<notin> ref_vars v)"
(*
| "app_con s ReadConst e ax (s', e') = (\<exists> x a i v arr. ax = UseAct x \<and> ack_full_exp x v e' \<and>
    e = PairExp (VarExp x a) (ConstExp (IConst i)) \<and>
    s (deref_name x a) = Some (ArrValue arr) \<and> read_array arr i = Some v \<and> s' = s
  )"
| "app_con s ExtArrayConst e ax (s', e') = (\<exists> x a v arr. ax = UseAct x \<and>
    e = PairExp (VarExp x a) v \<and> is_value v \<and> s (deref_name x a) = Some (ArrValue arr) \<and>
    e' = VarExp x a \<and> s' = add_env s (deref_name x a) (ArrValue (ext_list arr v))
  )"  *)

  (*
| "app_con s PairConst v ax (s', e') = (\<exists> p. ax = MakeAct p \<and>
    e' = VarExp p True \<and> s' = add_mem s p (LValue v) \<and> fresh_var s p)"

| "app_con s WriteConst (VarExp x True) NoAct (s', e') = (\<exists> x2 a i v arr arr'. e' = ConstExp UnitConst \<and>
    s x = Some (PairValue (VarExp x2 True) v) \<and> s x2 = Some (PairValue (VarExp a True) (ConstExp (IConst i))) \<and>
    s a = Some (ArrValue arr) \<and> Some arr' = write_array arr i v \<and> s' = add_mem s a (ArrValue arr')
  )"*)
| "app_con s c v a (s', e') = False"

definition unit_exp where
  "unit_exp = ConstExp UnitConst"

fun app_cv :: "p_state \<Rightarrow> p_const \<Rightarrow> p_exp \<Rightarrow> p_exp \<Rightarrow> p_act \<Rightarrow> p_state \<times> p_exp \<Rightarrow> bool" where
  "app_cv s ReadConst e ix ax (s', e') = (\<exists> x a i v arr. e = VarExp x a \<and> ix = ConstExp (IConst i) \<and>
    ax = UseAct x \<and> s (deref_name x a) = Some (ArrValue arr) \<and>
    read_array arr i = Some v \<and> ack_full_exp x v e' \<and> s' = s)"
| "app_cv s ExtArrayConst e v ax (s', e') = (\<exists> x a arr. e = VarExp x a \<and>
    ax = UseAct x \<and> s (deref_name x a) = Some (ArrValue arr) \<and>
    e' = e \<and> s' = add_env s (deref_name x a) (ArrValue (ext_list arr v)))"
| "app_cv s WriteConst e p ax (s', e') = (\<exists> x a i v arr arr'. e = VarExp x a \<and>
    p = PairExp (ConstExp (IConst i)) v \<and> ax = UseAct x \<and>
    s (deref_name x a) = Some (ArrValue arr) \<and> Some arr' = write_array arr i v \<and>
    e' = unit_exp \<and> s' = add_env s (deref_name x a) (ArrValue arr'))"(*
| "app_cv s UnpackConst f p ax (s', e') = (\<exists> v1 v2. v1 = f \<and> p = PairExp v1 v2 \<and>
    ax = NoAct \<and> s' = s \<and> e' = AppExp (AppExp f v1) v2)"*)

| "app_cv s c v1 v2 ax (s', e') = False"

datatype app_act =
  LamApp
  | FixApp
  | ConstApp
  | OpApp
  | IfApp1
  | IfApp2
  | CVApp
  (*| UnpackApp*)

fun app_red_exp :: "app_act \<Rightarrow> p_state \<times> p_exp \<Rightarrow> p_act \<Rightarrow> p_state \<times> p_exp \<Rightarrow> bool" where
  "app_red_exp LamApp (s, e) a (s', e') = (\<exists> x ex v.
    e = AppExp (LamExp x ex) v \<and> a = NoAct \<and> is_value v \<and> safe_subst_exp ex x v e' \<and> s = s')"
| "app_red_exp FixApp (s, e) a (s', e') = (\<exists> x ex. e = AppExp (ConstExp FixConst) (LamExp x ex) \<and>
  a = NoAct \<and> safe_subst_exp ex x (AppExp (ConstExp FixConst) (LamExp x ex)) e' \<and> s = s')"
| "app_red_exp OpApp (s, e) a (s', e') = (\<exists> xop c. e = AppExp (OpExp xop) (ConstExp c) \<and>
  a = NoAct \<and> app_op xop c e' \<and> s = s')"
| "app_red_exp ConstApp (s, e) a (s', e') = (\<exists> c v. e = AppExp (ConstExp c) v \<and>
  is_value v \<and> app_con s c v a (s', e'))"
| "app_red_exp CVApp (s, e) a (s', e') = (\<exists> c v1 v2. e = AppExp (AppExp (ConstExp c) v1) v2 \<and>
  bin_const c \<and> is_value v1 \<and> is_value v2 \<and> app_cv s c v1 v2 a (s', e'))"
  (*
| "app_red_exp UnpackApp (s, e) a (s', e') = (\<exists> f v1 v2. e = AppExp (AppExp (ConstExp UnpackConst) f) (PairExp v1 v2) \<and>
    a = NoAct \<and> is_value f \<and> is_value v1 \<and> is_value v2 \<and> s' = s \<and> e' = AppExp (AppExp f v1) v2)"  *)
| "app_red_exp IfApp1 (s, e) a (s', e') = (\<exists> e1 e2. e = IfExp (ConstExp (BConst True)) e1 e2 \<and>
  a = NoAct \<and> e' = e1 \<and> s = s')"
| "app_red_exp IfApp2 (s, e) a (s', e') = (\<exists> e1 e2. e = IfExp (ConstExp (BConst False)) e1 e2 \<and>
  a = NoAct \<and> e' = e2 \<and> s = s')"

  (*
fun red_exp :: "p_state \<times> p_exp \<Rightarrow> p_act \<Rightarrow> p_state \<times> p_exp \<Rightarrow> bool" where
  "red_exp (s, e) a (s', e') = (app_red_exp (s, e) a (s', e') \<or> (case e of
    AppExp e1 e2 \<Rightarrow> (\<exists> e2'. AppExp e1 e2' = e' \<and> red_exp (s, e2) a (s', e2')) \<or>
      (\<exists> e1'. AppExp e1' e2 = e' \<and> red_exp (s, e1) a (s', e1'))
    | other \<Rightarrow> False
  ))"*)

    (* ##### basic reduction lemmas ##### *)
  (*
lemma app_red_exp_contain_env: "\<lbrakk> app_red_exp are (s1, e1) ax (s2, e2) \<rbrakk> \<Longrightarrow> contain_env s2 s1"
  apply (case_tac are)
        apply (auto)
        apply (rule_tac id_contain_env)
       apply (rule_tac id_contain_env)
      apply (case_tac c)
                  apply (auto)
        apply (rule_tac add_contain_env)
        apply (simp add: fresh_var_def)
       apply (rule_tac add_contain_env)

      apply (rule_tac id_contain_env)
     apply (rule_tac id_contain_env)
    apply (rule_tac id_contain_env)
   apply (rule_tac id_contain_env)
  apply (rule_tac id_contain_env)
  done  *)

end