theory EigbyzProof
imports EigbyzDefs "../Majorities" "../Reduction"
begin

subsection {* Preliminary Lemmas *}

text {* Some technical lemmas about labels and trees. *}

lemma not_leaf_length:
  assumes l: "\<not>(is_leaf l)"
  shows "length_lbl l \<le> f"
  using l length_lbl[of l] by (simp add: is_leaf_def)

lemma nil_is_Label: "[] \<in> Label"
  by (auto simp: Label_def)

lemma card_set_lbl: "card (set_lbl l) = length_lbl l"
  unfolding set_lbl_def length_lbl_def
  using Rep_Label[of l, unfolded Label_def]
  by (auto elim: distinct_card)

lemma Rep_Label_root_node [simp]: "Rep_Label root_node = []"
  using nil_is_Label by (simp add: root_node_def Abs_Label_inverse)

lemma root_node_length [simp]: "length_lbl root_node = 0"
  by (simp add: length_lbl_def)

lemma root_node_not_leaf: "\<not>(is_leaf root_node)"
  by (simp add: is_leaf_def)

text {* Removing the last element of a non-root label gives a label. *}

lemma butlast_rep_in_label:
  assumes l:"l \<noteq> root_node"
  shows "butlast (Rep_Label l) \<in> Label"
proof -
  have "Rep_Label l \<noteq> []"
  proof
    assume "Rep_Label l = []"
    hence "Rep_Label l = Rep_Label root_node" by simp
    with l show "False" by (simp only: Rep_Label_inject)
  qed
  with Rep_Label[of l] show ?thesis
    by (auto simp: Label_def elim: distinct_butlast)
qed

text {*
  The label of a child is well-formed.
*}

lemma Rep_Label_append:
  assumes l: "\<not>(is_leaf l)"
  shows "(Rep_Label l @ [p] \<in> Label) = (p \<notin> set_lbl l)"
     (is "?lhs = ?rhs" is "(?l' \<in> _) = _")
proof
  assume lhs: "?lhs" thus ?rhs
    by (auto simp: Label_def set_lbl_def)
next
  assume p: "?rhs"
  from l[THEN not_leaf_length] have "length ?l' \<le> Suc f"
    by (simp add: length_lbl_def)
  moreover
  from Rep_Label[of l] have "distinct (Rep_Label l)"
    by (simp add: Label_def)
  with p have "distinct ?l'" by (simp add: set_lbl_def)
  ultimately
  show ?lhs by (simp add: Label_def)
qed

text {*
  The label of a child is the label of the parent, extended by a process.
*}
lemma label_children:
  assumes c: "c \<in> children l"
  shows "\<exists>p. p \<notin> set_lbl l \<and> Rep_Label c = Rep_Label l @ [p]"
proof -
  from c obtain p
    where p: "p \<notin> set_lbl l" and l: "\<not>(is_leaf l)"
      and c: "c = Abs_Label (Rep_Label l @ [p])"
    by (auto simp: children_def)
  with Rep_Label_append[OF l] show ?thesis
    by (auto simp: Abs_Label_inverse)
qed

text {*
  The label of any child node is one longer than the label of its parent.
*}

lemma children_length:
  assumes "l \<in> children h"
  shows "length_lbl l = Suc (length_lbl h)"
  using label_children[OF assms] by (auto simp: length_lbl_def)

text {* The root node is never a child. *}

lemma children_not_root:
  assumes "root_node \<in> children l"
  shows "P"
  using label_children[OF assms] Abs_Label_inverse[OF nil_is_Label]
  by (auto simp: root_node_def)

text {*
  The label of a child with the last element removed is the label of
  the parent.
*}

lemma children_butlast_lbl:
  assumes "c \<in> children l"
  shows "butlast_lbl c = l"
  using label_children[OF assms]
  by (auto simp: butlast_lbl_def Rep_Label_inverse)

text {*
  The root node is not a child, and it is the only such node.
*}

lemma root_iff_no_child: "(l = root_node) = (\<forall>l'. l \<notin> children l')"
proof
  assume "l = root_node"
  thus "\<forall>l'. l \<notin> children l'" by (auto elim: children_not_root)
next
  assume rhs: "\<forall>l'. l \<notin> children l'"
  show "l = root_node"
  proof (rule rev_exhaust[of "Rep_Label l"])
    assume "Rep_Label l = []"
    hence "Rep_Label l = Rep_Label root_node" by simp
    thus ?thesis by (simp only: Rep_Label_inject)
  next
    fix l' q
    assume l': "Rep_Label l = l' @ [q]"
    let ?l' = "Abs_Label l'"
    from Rep_Label[of l] l' have "l' \<in> Label" by (simp add: Label_def)
    hence repl': "Rep_Label ?l' = l'" by (rule Abs_Label_inverse)

    from Rep_Label[of l] l' have "l' @ [q] \<in> Label" by (simp add: Label_def)
    with l' have "Rep_Label l = Rep_Label (Abs_Label (l' @ [q]))"
      by (simp add: Abs_Label_inverse)
    hence "l = Abs_Label (l' @ [q])" by (simp add: Rep_Label_inject)
    moreover
    from Rep_Label[of l] l' have "length l' < Suc f" "q \<notin> set l'"
      by (auto simp: Label_def)
    moreover
    note repl'
    ultimately have "l \<in> children ?l'"
      by (auto simp: children_def is_leaf_def length_lbl_def set_lbl_def)
    with rhs show ?thesis by blast
  qed
qed

text {*
  If some label @{text l} is not a leaf, then the set of processes that
  appear at the end of the labels of its children is the set of all
  processes that do not appear in @{text l}.
*}

lemma children_last_set:
  assumes l: "\<not>(is_leaf l)"
  shows "last_lbl ` (children l) = UNIV - set_lbl l"
proof
  show "last_lbl ` (children l) \<subseteq> UNIV - set_lbl l"
    by (auto dest: label_children simp: last_lbl_def)
next
  show "UNIV - set_lbl l \<subseteq> last_lbl ` (children l)"
  proof (auto simp: image_def)
    fix p
    assume p: "p \<notin> set_lbl l"
    with l have c: "Abs_Label (Rep_Label l @ [p]) \<in> children l"
      by (auto simp: children_def)
    with Rep_Label_append[OF l] p
    show "\<exists>c \<in> children l. p = last_lbl c"
      by (force simp: last_lbl_def Abs_Label_inverse)
  qed
qed

text {*
  The function returning the last element of a label is injective on the
  set of children of some given label.
*}

lemma last_lbl_inj_on_children:"inj_on last_lbl (children l)"
proof (auto simp: inj_on_def)
  fix c c'
  assume c: "c \<in> children l" and c': "c' \<in> children l"
     and eq: "last_lbl c = last_lbl c'"
  from c c' obtain p p'
    where p: "Rep_Label c = Rep_Label l @ [p]"
      and p': "Rep_Label c' = Rep_Label l @ [p']"
    by (auto dest!: label_children)
  from p p' eq have "p = p'" by (simp add: last_lbl_def)
  with p p' have "Rep_Label c = Rep_Label c'" by simp
  thus "c = c'" by (simp add: Rep_Label_inject)
qed

text {*
  The number of children of any non-leaf label @{text l} is the
  number of processes that do not appear in @{text l}.
*}

lemma card_children:
  assumes "\<not>(is_leaf l)"
  shows "card (children l) = N - (length_lbl l)"
proof -
  from assms
  have "last_lbl ` (children l) = UNIV - set_lbl l"
    by (rule children_last_set)
  moreover
  have "card (UNIV - set_lbl l) = card (UNIV::Proc set) - card (set_lbl l)"
    by (auto simp: card_Diff_subset_Int)
  moreover
  from last_lbl_inj_on_children
  have "card (children l) = card (last_lbl ` children l)"
    by (rule sym[OF card_image])
  moreover
  note card_set_lbl[of l]
  ultimately
  show ?thesis by auto
qed

text {*
  Suppose a non-root label @{text l'} of length @{text "r+1"} ending in @{text q},
  and suppose that @{text q} is well heard by process @{text p} in round
  @{text r}. Then the value with which @{text p} decorates @{text l} is the one
  that @{text q} associates to the parent of @{text l}.
*}

lemma sho_correct_vals:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and l': "l' \<in> children l"
      and shop: "last_lbl l' \<in> SHOs (length_lbl l) p \<inter> HOs (length_lbl l) p"
                (is "?q \<in> SHOs (?len l) p \<inter> _")
  shows "vals (rho (?len l') p) l' = vals (rho (?len l) ?q) l"
proof -
  let ?r = "?len l"
  from run obtain \<mu>p
    where nxt: "nextState EIG_M ?r p (rho ?r p) \<mu>p (rho (Suc ?r) p)"
      and mu: "\<mu>p \<in> SHOmsgVectors EIG_M ?r p (rho ?r) (HOs ?r p) (SHOs ?r p)"
    by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq)
  with shop
  have msl:"\<mu>p ?q = Some (vals (rho ?r ?q))"
    by (auto simp: EIG_SHOMachine_def EIG_sendMsg_def SHOmsgVectors_def)
  from nxt length_lbl[of l'] children_length[OF l']
  have "extend_vals ?r p (rho ?r p) \<mu>p (rho (Suc ?r) p)"
    by (auto simp: EIG_SHOMachine_def nextState_def EIG_nextState_def
                   next_main_def next_end_def)
  with msl l' show ?thesis
    by (auto simp: extend_vals_def children_length children_butlast_lbl)
qed

text {*
  A process fixes the value @{text "vals l"} of a label at state
  @{text "length_lbl l"}, and then never modifies the value.
*}
(* currently nowhere used *)
lemma keep_vals:
  assumes run: "SHORun EIG_M rho HOs SHOs"
  shows "vals (rho (length_lbl l + n) p) l = vals (rho (length_lbl l) p) l"
     (is "?v n = ?vl")
proof (induct n)
  show "?v 0 = ?vl" by simp
next
  fix n
  assume ih: "?v n = ?vl"
  let ?r = "length_lbl l + n"
  from run obtain \<mu>p
    where nxt: "nextState EIG_M ?r p (rho ?r p) \<mu>p (rho (Suc ?r) p)"
    by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq)
  with ih show "?v (Suc n) = ?vl"
    by (auto simp: EIG_SHOMachine_def nextState_def EIG_nextState_def
                   next_main_def next_end_def extend_vals_def)
qed

subsection {* Lynch's Lemmas and Theorems *}

text {*
  If some process is safely heard by all processes at round @{text r},
  then all processes agree on the value associated to labels of length
  @{text "r+1"} ending in that process.
*}

lemma lynch_6_15:
  assumes run: "SHORun EIG_M rho HOs SHOs"
  and l': "l' \<in> children l"
  and skr: "last_lbl l' \<in> SKr (HOs (length_lbl l)) (SHOs (length_lbl l))"
  shows "vals (rho (length_lbl l') p) l' = vals (rho (length_lbl l') q) l'"
  using assms unfolding SKr_def by (auto simp: sho_correct_vals)

text {*
  Suppose that @{text l} is a non-root label whose last element was well
  heard by all processes at round @{text r}, and that @{text l'} is a
  child of @{text l} corresponding to process @{text q} that is also
  well heard by all processes at round @{text "r+1"}. Then the values
  associated with @{text l} and @{text l'} by any process @{text p}
  are identical.
*}

lemma lynch_6_16_a:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and l: "l \<in> children t"
      and skrl: "last_lbl l \<in> SKr (HOs (length_lbl t)) (SHOs (length_lbl t))"
      and l': "l' \<in> children l"
      and skrl':"last_lbl l' \<in> SKr (HOs (length_lbl l)) (SHOs (length_lbl l))"
    shows "vals (rho (length_lbl l') p) l' = vals (rho (length_lbl l) p) l"
  using assms by (auto simp: SKr_def sho_correct_vals)

text {*
  For any non-leaf label @{text l}, more than half of its children end with a
  process that is well heard by everyone at round @{text "length_lbl l"}.
*}

lemma lynch_6_16_c:
  assumes commR: "EIG_commPerRd (HOs (length_lbl l)) (SHOs (length_lbl l))"
                 (is "EIG_commPerRd (HOs ?r) _")
      and l: "\<not>(is_leaf l)"
  shows "card {l' \<in> children l. last_lbl l' \<in> SKr (HOs ?r) (SHOs ?r)}
         > card (children l) div 2"
    (is "card ?lhs > _")
proof -
  let ?skr = "SKr (HOs ?r) (SHOs ?r)"

  have "last_lbl ` ?lhs = ?skr - set_lbl l"
  proof
    from children_last_set[OF l]
    show "last_lbl ` ?lhs \<subseteq> ?skr - set_lbl l"
      by (auto simp: children_length)
  next
    {
      fix p
      assume p: "p \<in> ?skr" "p \<notin> set_lbl l"
      with  children_last_set[OF l]
      have "p \<in> last_lbl ` children l" by auto
      with p have "p \<in> last_lbl ` ?lhs"
        by (auto simp: image_def children_length)
    }
    thus "?skr - set_lbl l \<subseteq> last_lbl ` ?lhs" by auto
  qed
  moreover
  from last_lbl_inj_on_children[of l]
  have "inj_on last_lbl ?lhs" by (auto simp: inj_on_def)
  ultimately
  have "card ?lhs = card (?skr - set_lbl l)" by (auto dest: card_image)
  also have "\<dots> \<ge> (card ?skr) - (card (set_lbl l))"
    by (simp add: diff_card_le_card_Diff)
  finally have "card ?lhs \<ge> (card ?skr) - ?r"
    using card_set_lbl[of l] by simp

  moreover
  from commR have "card ?skr > (N + f) div 2"
    by (auto simp: EIG_commPerRd_def)
  with not_leaf_length[OF l] f
  have "(card ?skr) - ?r > (N - ?r) div 2" by auto
  with card_children[OF l]
  have "(card ?skr) - ?r > card (children l) div 2" by simp

  ultimately show ?thesis by simp
qed

text {*
  If @{text l} is a non-leaf label such that all of its children corresponding
  to well-heard processes at round @{text "length_lbl l"} have a uniform
  @{text newvals} decoration at round @{text "f+1"}, then @{text l}
  itself is decorated with that same value.
*}
lemma newvals_skr_uniform:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commR: "EIG_commPerRd (HOs (length_lbl l)) (SHOs (length_lbl l))"
                 (is "EIG_commPerRd (HOs ?r) _")
      and notleaf: "\<not>(is_leaf l)"
      and unif: "\<And>l'. \<lbrakk>l' \<in> children l;
                   last_lbl l' \<in> SKr (HOs (length_lbl l)) (SHOs (length_lbl l))
                  \<rbrakk> \<Longrightarrow> newvals (rho (Suc f) p) l' = v"
  shows "newvals (rho (Suc f) p) l = v"
proof -
  from unif
  have "card {l' \<in> children l. last_lbl l' \<in> SKr (HOs ?r) (SHOs ?r)}
      \<le> card {l' \<in> children l. newvals (rho (Suc f) p) l' = v}"
    by (auto intro: card_mono)
  with lynch_6_16_c[of HOs l SHOs, OF commR notleaf]
  have maj: "has_majority v (newvals (rho (Suc f) p)) (children l)"
    by (simp add: has_majority_def)

  from run have "check_newvals (rho (Suc f) p)"
    by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq
                   nextState_def EIG_nextState_def next_end_def)
  with maj notleaf obtain w
    where wmaj: "has_majority w (newvals (rho (Suc f) p)) (children l)"
      and wupd: "newvals (rho (Suc f) p) l = w"
    by (auto simp: check_newvals_def)
  from maj wmaj have "w = v"
    by (auto simp: has_majority_def elim: abs_majoritiesE')
  with wupd show ?thesis by simp
qed

text {*
  A node whose label @{text l} ends with a process which is well heard
  at round @{text "length_lbl l"} will have its @{text newvals} field set
  (at round @{text "f+1"}) to the ``fixed-up'' value given by @{text vals}.
*}

lemma lynch_6_16_d:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and notroot: "l \<in> children t"
      and skr: "last_lbl l \<in> SKr (HOs (length_lbl t)) (SHOs (length_lbl t))"
            (is "_ \<in> SKr (HOs (?len t)) _")
  shows "newvals (rho (Suc f) p) l = fixupval (vals (rho (?len l) p) l)"
    (is "?P l")
using notroot skr proof (induct "Suc f - (?len l)" arbitrary: l t)
  fix l t
  assume "0 = Suc f - ?len l"
  with length_lbl[of l] have leaf: "is_leaf l" by (simp add: is_leaf_def)

  from run have "check_newvals (rho (Suc f) p)"
    by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq
                   nextState_def EIG_nextState_def next_end_def)
  with leaf show "?P l"
    by (auto simp: check_newvals_def is_leaf_def)
next
  fix k l t
  assume ih: "\<And> l' t'.
                \<lbrakk>k = Suc f - length_lbl l'; l' \<in> children t';
                 last_lbl l' \<in> SKr (HOs (?len t')) (SHOs (?len t'))\<rbrakk>
                \<Longrightarrow> ?P l'"
    and flk: "Suc k = Suc f - ?len l"
    and notroot: "l \<in> children t"
    and skr: "last_lbl l \<in> SKr (HOs (?len t)) (SHOs (?len t))"

  let ?v = "fixupval (vals (rho (?len l) p) l)"
  from flk have notlf: "\<not>(is_leaf l)" by (simp add: is_leaf_def)

  {
    fix l'
    assume l': "l' \<in> children l"
       and skr': "last_lbl l' \<in> SKr (HOs (?len l)) (SHOs (?len l))"

    from run notroot skr l' skr'
    have "vals (rho (?len l') p) l' = vals (rho (?len l) p) l"
      by (rule lynch_6_16_a)
    moreover
    from flk l' have "k = Suc f - ?len l'" by (simp add: children_length)
    from this l' skr' have "?P l'" by (rule ih)
    ultimately
    have "newvals (rho (Suc f) p) l' = ?v"
      using notroot l' by (simp add: children_length)
  }
  with run commR notlf show "?P l" by (auto intro: newvals_skr_uniform)
qed

text {*
  Following Lynch~\cite{lynch:distributed}, we introduce some more useful
  concepts for reasoning about the data structure.
*}

text {*
  A label is \emph{common} if all processes agree on the final value it is
  decorated with.
*}

definition common where
  "common rho l \<equiv>
   \<forall>p q. newvals (rho (Suc f) p) l = newvals (rho (Suc f) q) l"

text {*
  The subtrees of a given label are all its possible extensions.
*}

definition subtrees where
  "subtrees h \<equiv> { l . \<exists>t. Rep_Label l = (Rep_Label h) @ t }"

lemma children_in_subtree:
  assumes "l \<in> children h"
  shows "l \<in> subtrees h"
  using label_children[OF assms] by (auto simp: subtrees_def)

lemma subtrees_refl [iff]: "l \<in> subtrees l"
  by (auto simp: subtrees_def)

lemma subtrees_root [iff]: "l \<in> subtrees root_node"
  by (auto simp: subtrees_def)

lemma subtrees_trans:
  assumes "l'' \<in> subtrees l'" and "l' \<in> subtrees l"
  shows "l'' \<in> subtrees l"
  using assms by (auto simp: subtrees_def)

lemma subtrees_antisym:
  assumes "l \<in> subtrees l'" and "l' \<in> subtrees l"
  shows "l' = l"
  using assms by (auto simp: subtrees_def Rep_Label_inject)

lemma subtrees_tree:
  assumes l': "l \<in> subtrees l'" and l'': "l \<in> subtrees l''"
  shows "l' \<in> subtrees l'' \<or> l'' \<in> subtrees l'"
using assms proof (auto simp: subtrees_def append_eq_append_conv2)
  fix xs
  assume "Rep_Label l'' @ xs = Rep_Label l'"
  hence "Rep_Label l' = Rep_Label l'' @ xs" by (rule sym)
  thus "\<exists>ys. Rep_Label l' = Rep_Label l'' @ ys" ..
qed

lemma subtrees_cases:
  assumes l': "l' \<in> subtrees l"
      and self: "l' = l \<Longrightarrow> P"
      and child: "\<And>c. \<lbrakk> c \<in> children l; l' \<in> subtrees c \<rbrakk> \<Longrightarrow> P"
  shows "P"
proof -
  from l' obtain t where t: "Rep_Label l' = (Rep_Label l) @ t"
    by (auto simp: subtrees_def)
  have "l' = l \<or> (\<exists>c \<in> children l. l' \<in> subtrees c)"
  proof (cases t)
    assume "t = []"
    with t show ?thesis by (simp add: Rep_Label_inject)
  next
    fix p t'
    assume cons: "t = p # t'"
    from Rep_Label[of l'] t have "length (Rep_Label l @ t) \<le> Suc f"
      by (simp add: Label_def)
    with cons have notleaf: "\<not>(is_leaf l)"
      by (auto simp: is_leaf_def length_lbl_def)

    let ?c = "Abs_Label (Rep_Label l @ [p])"
    from t cons Rep_Label[of l'] have p: "p \<notin> set_lbl l"
      by (auto simp: Label_def set_lbl_def)
    with notleaf have c: "?c \<in> children l"
      by (auto simp: children_def)
    moreover
    from notleaf p have "Rep_Label l @ [p] \<in> Label"
      by (simp add: Rep_Label_append)
    hence "Rep_Label ?c = (Rep_Label l @ [p])"
      by (simp add: Abs_Label_inverse)
    with cons t have "l' \<in> subtrees ?c"
      by (auto simp: subtrees_def)
    ultimately show ?thesis by blast
  qed
  thus ?thesis by (auto elim!: self child)
qed

lemma subtrees_leaf:
  assumes l: "is_leaf l" and l': "l' \<in> subtrees l"
  shows "l' = l"
using l' proof (rule subtrees_cases)
  fix c
  assume "c \<in> children l"  -- {* impossible *}
  with l show ?thesis by (simp add: children_def)
qed

lemma children_subtrees_equal:
  assumes c: "c \<in> children l" and c': "c' \<in> children l"
      and sub: "c' \<in> subtrees c"
  shows "c' = c"
proof -
  from assms have "Rep_Label c' = Rep_Label c"
    by (auto simp: subtrees_def dest!: label_children)
  thus ?thesis by (simp add: Rep_Label_inject)
qed

text {*
  A set @{text C} of labels is a \emph{subcovering} w.r.t. label @{text l}
  if for all leaf subtrees @{text s} of @{text l} there
  exists some label @{text "h \<in> C"} such that @{text s} is a subtree of
  @{text h} and @{text h} is a subtree of @{text l}.
*}
definition subcovering where
 "subcovering C l \<equiv>
  \<forall>s \<in> subtrees l. is_leaf s \<longrightarrow> (\<exists>h \<in> C. h \<in> subtrees l \<and> s \<in> subtrees h)"

text {*
  A \emph{covering} is a subcovering w.r.t. the root node.
*}
abbreviation covering where
  "covering C \<equiv> subcovering C root_node"

text {*
  The set of labels whose last element is well heard by all processes
  throughout the execution forms a covering, and all these labels are common.
*}

lemma lynch_6_18_a:
  assumes "SHORun EIG_M rho HOs SHOs"
      and "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and "l \<in> children t"
      and "last_lbl l \<in> SKr (HOs (length_lbl t)) (SHOs (length_lbl t))"
  shows "common rho l"
  using assms
  by (auto simp: common_def lynch_6_16_d lynch_6_15
           intro: arg_cong[where f="fixupval"])

lemma lynch_6_18_b:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commG: "EIG_commGlobal HOs SHOs"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
  shows "covering {l. \<exists>t. l \<in> children t \<and> last_lbl l \<in> (SK HOs SHOs)}"
proof (clarsimp simp: subcovering_def)
  fix l
  assume "is_leaf l"
  with card_set_lbl[of l] have "card (set_lbl l) = Suc f"
    by (simp add: is_leaf_def)
  with commG have "N < card (SK HOs SHOs) + card (set_lbl l)"
    by (simp add: EIG_commGlobal_def)
  hence "\<exists>q \<in> set_lbl l . q \<in> SK HOs SHOs"
    by (auto dest: majorities_intersect)
  then obtain l1 q l2 where
    l: "Rep_Label l = (l1 @ [q]) @ l2" and q: "q \<in> SK HOs SHOs"
    unfolding set_lbl_def by (auto intro: split_list_propE)

  let ?h = "Abs_Label (l1 @ [q])"
  from Rep_Label[of l] l have "l1 @ [q] \<in> Label" by (simp add: Label_def)
  hence reph: "Rep_Label ?h = l1 @ [q]" by (rule Abs_Label_inverse)
  hence "length_lbl ?h \<noteq> 0" by (simp add: length_lbl_def)
  hence "?h \<noteq> root_node" by auto
  then obtain t where t: "?h \<in> children t"
    by (auto simp: root_iff_no_child)
  moreover
  from reph q have "last_lbl ?h \<in> SK HOs SHOs" by (simp add: last_lbl_def)
  moreover
  from reph l have "l \<in> subtrees ?h" by (simp add: subtrees_def)
  ultimately
  show "\<exists>h. (\<exists>t. h \<in> children t) \<and> last_lbl h \<in> SK HOs SHOs \<and> l \<in> subtrees h"
    by blast
qed

text {*
  If @{text C} covers the subtree rooted at label @{text l} and if
  @{text "l \<notin> C"} then @{text C} also covers subtrees rooted at
  @{text l}'s children.
*}

lemma lynch_6_19_a:
  assumes cov: "subcovering C l"
      and l: "l \<notin> C"
      and e: "e \<in> children l"
  shows "subcovering C e"
proof (clarsimp simp: subcovering_def)
  fix s
  assume s: "s \<in> subtrees e" and leaf: "is_leaf s"
  from s children_in_subtree[OF e] have "s \<in> subtrees l"
    by (rule subtrees_trans)
  with leaf cov obtain h where h: "h \<in> C" "h \<in> subtrees l" "s \<in> subtrees h"
    by (auto simp: subcovering_def)
  with l obtain e' where e': "e' \<in> children l" "h \<in> subtrees e'"
    by (auto elim: subtrees_cases)
  from `s \<in> subtrees h` `h \<in> subtrees e'` have "s \<in> subtrees e'"
    by (rule subtrees_trans)
  with s have "e \<in> subtrees e' \<or> e' \<in> subtrees e"
    by (rule subtrees_tree)
  with e e' have "e' = e"
    by (auto dest: children_subtrees_equal)
  with e' h show "\<exists>h\<in>C. h \<in> subtrees e \<and> s \<in> subtrees h" by blast
qed

text {*
  If there is a subcovering @{text C} for a label @{text l} such that all labels
  in @{text C} are common, then @{text l} itself is common as well.
*}

lemma lynch_6_19_b:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and cov: "subcovering C l"
      and com: "\<forall>l' \<in> C. common rho l'"
  shows "common rho l"
using cov proof (induct "Suc f - length_lbl l" arbitrary: l)
  fix l
  assume 0: "0 = Suc f - length_lbl l"
    and C: "subcovering C l"
  from 0 length_lbl[of l] have "is_leaf l"
    by (simp add: is_leaf_def)
  with C obtain h where h: "h \<in> C" "h \<in> subtrees l" "l \<in> subtrees h"
    by (auto simp: subcovering_def)
  hence "l \<in> C" by (auto dest: subtrees_antisym)
  with com show "common rho l" ..
next
  fix k l
  assume k: "Suc k = Suc f - length_lbl l"
     and C: "subcovering C l"
     and ih: "\<And>l'. \<lbrakk>k = Suc f - length_lbl l'; subcovering C l'\<rbrakk> \<Longrightarrow> common rho l'"
  show "common rho l"
  proof (cases "l \<in> C")
    case True
    with com show ?thesis ..
  next
    case False
    with C have "\<forall>e \<in> children l. subcovering C e"
      by (blast intro: lynch_6_19_a)
    moreover
    from k have "\<forall>e \<in> children l. k = Suc f - length_lbl e"
      by (auto simp: children_length)
    ultimately
    have com_ch: "\<forall>e \<in> children l. common rho e"
      by (blast intro: ih)

    show ?thesis
    proof (clarsimp simp: common_def)
      fix p q
      from k have notleaf: "\<not>(is_leaf l)" by (simp add: is_leaf_def)
      let ?r = "Suc f"
      from com_ch
      have "\<forall>e \<in> children l. newvals (rho ?r p) e = newvals (rho ?r q) e"
        by (auto simp: common_def)
      hence "\<forall>w. {e \<in> children l. newvals (rho ?r p) e = w}
               = {e \<in> children l. newvals (rho ?r q) e = w}"
        by auto
      moreover
      from run
      have "check_newvals (rho ?r p)" "check_newvals (rho ?r q)"
        by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq nextState_def
                       EIG_nextState_def next_end_def)
      with notleaf have
        "(\<exists>w. has_majority w (newvals (rho ?r p)) (children l)
              \<and> newvals (rho ?r p) l = w)
       \<or> \<not>(\<exists>w. has_majority w (newvals (rho ?r p)) (children l))
              \<and> newvals (rho ?r p) l = undefined"
        "(\<exists>w. has_majority w (newvals (rho ?r q)) (children l)
              \<and> newvals (rho ?r q) l = w)
       \<or> \<not>(\<exists>w. has_majority w (newvals (rho ?r q)) (children l))
              \<and> newvals (rho ?r q) l = undefined"
        by (auto simp: check_newvals_def)
      ultimately show "newvals (rho ?r p) l = newvals (rho ?r q) l"
        by (auto simp: has_majority_def elim: abs_majoritiesE')
    qed
  qed
qed

text {* The root of the tree is a common node. *}

lemma lynch_6_20:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commG: "EIG_commGlobal HOs SHOs"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
  shows "common rho root_node"
using run lynch_6_18_b[OF assms]
proof (rule lynch_6_19_b, clarify)
  fix l t
  assume "l \<in> children t" "last_lbl l \<in> SK HOs SHOs"
  thus "common rho l" by (auto simp: SK_def elim: lynch_6_18_a[OF run commR])
qed

text {*
  A decision is taken only at state @{text "f+1"} and then stays stable.
*}
lemma decide:
  assumes run: "SHORun EIG_M rho HOs SHOs"
  shows "decide (rho r p) =
         (if r < Suc f then None
          else Some (newvals (rho (Suc f) p) root_node))"
     (is "?P r")
proof (induct r)
  from run show "?P 0"
    by (auto simp: EIG_SHOMachine_def SHORun_eq HOinitConfig_eq
                   initState_def EIG_initState_def)
next
  fix r
  assume ih: "?P r"
  from run obtain \<mu>p
    where "EIG_nextState r p (rho r p) \<mu>p (rho (Suc r) p)"
    by (auto simp: EIG_SHOMachine_def SHORun_eq SHOnextConfig_eq
                   nextState_def)
  thus "?P (Suc r)"
  proof (auto simp: EIG_nextState_def next_main_def next_end_def)
    assume "\<not>(r < f)" "r \<noteq> f"
    with ih
    show "decide (rho r p) = Some (newvals (rho (Suc f) p) root_node)"
      by simp
  qed
qed

subsection {* Proof of Agreement, Validity, and Termination *}

text {*
  The Agreement property is an immediate consequence of lemma @{text lynch_6_20}.
*}

theorem Agreement:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commG: "EIG_commGlobal HOs SHOs"
      and commR:  "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and p: "decide (rho m p) = Some v"
      and q: "decide (rho n q) = Some w"
  shows "v = w"
  using p q lynch_6_20[OF run commG commR]
  by (auto simp: decide[OF run] common_def)

text {*
  We now show the Validity property: if all processes initially
  propose the same value @{text v}, then no other value may be decided.

  By lemma @{text sho_correct_vals}, value @{text v} must propagate to
  all children of the root that are well heard at round @{text 0}, and
  lemma @{text lynch_6_16_d} implies that @{text v} is the value assigned
  to all these children by @{text newvals}. Finally, lemma
  @{text newvals_skr_uniform} lets us conclude.
*}

theorem Validity:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and initv: "\<forall>q. the (vals (rho 0 q) root_node) = v"
      and dp: "decide (rho r p) = Some w"
  shows "v = w"
proof -

  have v: "\<forall>q. vals (rho 0 q) root_node = Some v"
  proof
    fix q
    from run have "vals (rho 0 q) root_node \<noteq> None"
      by (auto simp: EIG_SHOMachine_def SHORun_eq HOinitConfig_eq
                     initState_def EIG_initState_def)
    then obtain w where w: "vals (rho 0 q) root_node = Some w"
      by auto
    from initv have "the (vals (rho 0 q) root_node) = v" ..
    with w show "vals (rho 0 q) root_node = Some v" by simp
  qed

  let ?len = length_lbl
  let ?r = "Suc f"

  {
    fix l'
    assume l': "l' \<in> children root_node"
       and skr: "last_lbl l' \<in> SKr (HOs 0) (SHOs 0)"
    with run v have "vals (rho (?len l') p) l' = Some v"
      by (auto dest: sho_correct_vals simp: SKr_def)

    moreover
    from run commR l' skr
    have "newvals (rho ?r p) l' = fixupval (vals (rho (?len l') p) l')"
      by (auto intro: lynch_6_16_d)

    ultimately
    have "newvals (rho ?r p) l' = v" by simp
  }
  with run commR root_node_not_leaf
  have "newvals (rho ?r p) root_node = v"
    by (auto intro: newvals_skr_uniform)
  with dp show ?thesis by (simp add: decide[OF run])
qed

text {* Termination is trivial for \eigbyz{}. *}

theorem Termination:
  assumes "SHORun EIG_M rho HOs SHOs"
  shows "\<exists>r v. decide (rho r p) = Some v"
  using assms by (auto simp: decide)

subsection {* \eigbyz{} Solves Weak Consensus *}

text {*
  Summing up, all (coarse-grained) runs of \eigbyz{} for
  HO and SHO collections that satisfy the communication predicate
  satisfy the Weak Consensus property.
*}

theorem eig_weak_consensus:
  assumes run: "SHORun EIG_M rho HOs SHOs"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and commG: "EIG_commGlobal HOs SHOs"
  shows "weak_consensus (\<lambda>p. the (vals (rho 0 p) root_node)) decide rho"
  unfolding weak_consensus_def
  using Validity[OF run commR]
        Agreement[OF run commG commR]
        Termination[OF run]
  by auto

text {*
  By the reduction theorem, the correctness of the algorithm carries over
  to the fine-grained model of runs.
*}

theorem eig_weak_consensus_fg:
  assumes run: "fg_run EIG_M rho HOs SHOs (\<lambda>r q. undefined)"
      and commR: "\<forall>r. EIG_commPerRd (HOs r) (SHOs r)"
      and commG: "EIG_commGlobal HOs SHOs"
  shows "weak_consensus (\<lambda>p. the (vals (state (rho 0) p) root_node))
                        decide (state \<circ> rho)"
    (is "weak_consensus ?inits _ _")
proof (rule local_property_reduction[OF run weak_consensus_is_local])
  fix crun
  assume crun: "CSHORun EIG_M crun HOs SHOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "SHORun EIG_M crun HOs SHOs" by (unfold SHORun_def)
  from this commR commG
  have "weak_consensus (\<lambda>p. the (vals (crun 0 p) root_node)) decide crun"
    by (rule eig_weak_consensus)
  with init show "weak_consensus ?inits decide crun"
    by (simp add: o_def)
qed

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Products and coproducts as limits and colimits\<close>
theory CZH_UCAT_Limit_Product
  imports
    CZH_UCAT_Limit
    CZH_Elementary_Categories.CZH_ECAT_Discrete
begin

subsection\<open>Product and coproduct\<close>

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

text\<open>
The definition of the product object is a specialization of the
definition presented in Chapter III-4 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
In the definition presented below, the discrete category that is used in the
definition presented in \<^cite>\<open>"mac_lane_categories_2010"\<close> is parameterized by
an index set and the functor from the discrete category is
parameterized by a function from the index set to the set of
the objects of the category.
\<close>

locale is_cat_obj_prod =
  is_cat_limit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> P \<pi> + cf_discrete \<alpha> I A \<CC>
  for \<alpha> I A \<CC> P \<pi>

syntax "_is_cat_obj_prod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_prod \<alpha> I A \<CC> P \<pi>"

locale is_cat_obj_coprod =
  is_cat_colimit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> U \<pi> + cf_discrete \<alpha> I A \<CC>
  for \<alpha> I A \<CC> U \<pi>

syntax "_is_cat_obj_coprod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_coprod \<alpha> I A \<CC> U \<pi>"

text\<open>Rules.\<close>

lemma (in is_cat_obj_prod) is_cat_obj_prod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "P' = P" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A' : I' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_prod_axioms)

mk_ide rf is_cat_obj_prod_def
  |intro is_cat_obj_prodI|
  |dest is_cat_obj_prodD[dest]|
  |elim is_cat_obj_prodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_prodD

lemma (in is_cat_obj_coprod) is_cat_obj_coprod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "U' = U" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : A' >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U' : I' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_coprod_axioms)

mk_ide rf is_cat_obj_coprod_def
  |intro is_cat_obj_coprodI|
  |dest is_cat_obj_coprodD[dest]|
  |elim is_cat_obj_coprodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_coprodD

text\<open>Duality.\<close>

lemma (in is_cat_obj_prod) is_cat_obj_coprod_op:
  "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_cat_obj_coprodI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
    )

lemma (in is_cat_obj_prod) is_cat_obj_coprod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_coprod_op)

lemmas [cat_op_intros] = is_cat_obj_prod.is_cat_obj_coprod_op'

lemma (in is_cat_obj_coprod) is_cat_obj_prod_op:
  "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_cat_obj_prodI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
    )

lemma (in is_cat_obj_coprod) is_cat_obj_prod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_prod_op)

lemmas [cat_op_intros] = is_cat_obj_coprod.is_cat_obj_prod_op'

subsubsection\<open>Universal property\<close>

lemma (in is_cat_obj_prod) cat_obj_prod_unique_cone':
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e :\<rightarrow>: I A \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and> (\<forall>j\<in>\<^sub>\<circ>I. \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f')"
  by
    (
      rule cat_lim_unique_cone'[
        OF assms, unfolded the_cat_discrete_components(1)
        ]
    )

lemma (in is_cat_obj_prod) cat_obj_prod_unique:
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and> \<pi>' = \<pi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) \<CC> f'"
  by (intro cat_lim_unique[OF is_cat_obj_prodD(1)[OF assms]])

lemma (in is_cat_obj_prod) cat_obj_prod_unique':
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and> (\<forall>i\<in>\<^sub>\<circ>I. \<pi>'\<lparr>NTMap\<rparr>\<lparr>i\<rparr> = \<pi>\<lparr>NTMap\<rparr>\<lparr>i\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f')"
proof-
  interpret \<pi>': is_cat_obj_prod \<alpha> I A \<CC> P' \<pi>' by (rule assms(1))
  show ?thesis
    by
      (
        rule cat_lim_unique'[
          OF \<pi>'.is_cat_limit_axioms, unfolded the_cat_discrete_components(1)
          ]
      )
qed

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique_cocone':
  assumes "\<pi>' : :\<rightarrow>: I A \<CC> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e U' : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : U \<mapsto>\<^bsub>\<CC>\<^esub> U' \<and> (\<forall>j\<in>\<^sub>\<circ>I. \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>)"
  by
    (
      rule cat_colim_unique_cocone'[
        OF assms, unfolded the_cat_discrete_components(1)
        ]
    )

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique:
  assumes "\<pi>' : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U' : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : U \<mapsto>\<^bsub>\<CC>\<^esub> U' \<and> \<pi>' = ntcf_const (:\<^sub>C I) \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<pi>"
  by (intro cat_colim_unique[OF is_cat_obj_coprodD(1)[OF assms]])

lemma (in is_cat_obj_coprod) cat_obj_coprod_unique':
  assumes "\<pi>' : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U' : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : U \<mapsto>\<^bsub>\<CC>\<^esub> U' \<and> (\<forall>j\<in>\<^sub>\<circ>I. \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>)"
  by
    (
      rule cat_colim_unique'[
        OF is_cat_obj_coprodD(1)[OF assms], unfolded the_cat_discrete_components
        ]
    )

lemma cat_obj_prod_ex_is_iso_arr:
  assumes "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : P' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> P" and "\<pi>' = \<pi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) \<CC> f"
proof-
  interpret \<pi>: is_cat_obj_prod \<alpha> I A \<CC> P \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_prod \<alpha> I A \<CC> P' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_lim_ex_is_iso_arr[
          OF \<pi>.is_cat_limit_axioms \<pi>'.is_cat_limit_axioms
          ]
      )
qed

lemma cat_obj_prod_ex_is_iso_arr':
  assumes "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : P' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> P"
    and "\<And>j. j \<in>\<^sub>\<circ> I \<Longrightarrow> \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
proof-
  interpret \<pi>: is_cat_obj_prod \<alpha> I A \<CC> P \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_prod \<alpha> I A \<CC> P' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_lim_ex_is_iso_arr'[
          OF \<pi>.is_cat_limit_axioms \<pi>'.is_cat_limit_axioms,
          unfolded the_cat_discrete_components(1)
          ]
      )
qed

lemma cat_obj_coprod_ex_is_iso_arr:
  assumes "\<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<pi>' : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U' : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : U \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> U'" and "\<pi>' = ntcf_const (:\<^sub>C I) \<CC> f \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<pi>"
proof-
  interpret \<pi>: is_cat_obj_coprod \<alpha> I A \<CC> U \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_coprod \<alpha> I A \<CC> U' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_colim_ex_is_iso_arr[
          OF \<pi>.is_cat_colimit_axioms \<pi>'.is_cat_colimit_axioms
          ]
      )
qed

lemma cat_obj_coprod_ex_is_iso_arr':
  assumes "\<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<pi>' : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> U' : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : U \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> U'"
    and "\<And>j. j \<in>\<^sub>\<circ> I \<Longrightarrow> \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
proof-
  interpret \<pi>: is_cat_obj_coprod \<alpha> I A \<CC> U \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_coprod \<alpha> I A \<CC> U' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_colim_ex_is_iso_arr'[
          OF \<pi>.is_cat_colimit_axioms \<pi>'.is_cat_colimit_axioms,
          unfolded the_cat_discrete_components(1)
          ]
      )
qed

subsection\<open>Small product and small coproduct\<close>

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

locale is_tm_cat_obj_prod =
  is_cat_limit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> P \<pi> + tm_cf_discrete \<alpha> I A \<CC>
  for \<alpha> I A \<CC> P \<pi>

syntax "_is_tm_cat_obj_prod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Prod> _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_tm_cat_obj_prod \<alpha> I A \<CC> P \<pi>"

locale is_tm_cat_obj_coprod =
  is_cat_colimit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> U \<pi> + tm_cf_discrete \<alpha> I A \<CC>
  for \<alpha> I A \<CC> U \<pi>

syntax "_is_tm_cat_obj_coprod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ >\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Coprod> _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Coprod> U : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_tm_cat_obj_coprod \<alpha> I A \<CC> U \<pi>"

text\<open>Rules.\<close>

lemma (in is_tm_cat_obj_prod) is_tm_cat_obj_prod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "P' = P" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Prod> A' : I' \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_tm_cat_obj_prod_axioms)

mk_ide rf is_tm_cat_obj_prod_def
  |intro is_tm_cat_obj_prodI|
  |dest is_tm_cat_obj_prodD[dest]|
  |elim is_tm_cat_obj_prodE[elim]|

lemmas [cat_lim_cs_intros] = is_tm_cat_obj_prodD

lemma (in is_tm_cat_obj_coprod)
  is_tm_cat_obj_coprod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "U' = U" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : A' >\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Coprod> U' : I' \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_tm_cat_obj_coprod_axioms)

mk_ide rf is_tm_cat_obj_coprod_def
  |intro is_tm_cat_obj_coprodI|
  |dest is_tm_cat_obj_coprodD[dest]|
  |elim is_tm_cat_obj_coprodE[elim]|

lemmas [cat_lim_cs_intros] = is_tm_cat_obj_coprodD

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

sublocale is_tm_cat_obj_prod \<subseteq> is_cat_obj_prod
  by
    (
      intro is_cat_obj_prodI,
      rule is_cat_limit_axioms,
      rule cf_discrete_axioms
    )

lemmas (in is_tm_cat_obj_prod) tm_cat_obj_prod_is_cat_obj_prod =
  is_cat_obj_prod_axioms

sublocale is_tm_cat_obj_coprod \<subseteq> is_cat_obj_coprod
  by
    (
      intro is_cat_obj_coprodI,
      rule is_cat_colimit_axioms,
      rule cf_discrete_axioms
    )

lemmas (in is_tm_cat_obj_coprod) tm_cat_obj_coprod_is_cat_obj_coprod =
  is_cat_obj_coprod_axioms

sublocale is_tm_cat_obj_prod \<subseteq> is_tm_cat_limit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> P \<pi>
  by
    (
      intro
        is_tm_cat_limitI
        is_tm_cat_coneI
        is_ntcf_axioms
        tm_cf_discrete_the_cf_discrete_is_tm_functor
        cat_cone_obj
        cat_lim_ua_fo
    )

lemmas (in is_tm_cat_obj_prod) tm_cat_obj_prod_is_tm_cat_limit =
  is_tm_cat_limit_axioms

sublocale is_tm_cat_obj_coprod \<subseteq> is_tm_cat_colimit \<alpha> \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I A \<CC>\<close> U \<pi>
  by
    (
      intro
        is_tm_cat_colimitI
        is_tm_cat_coconeI
        is_ntcf_axioms
        tm_cf_discrete_the_cf_discrete_is_tm_functor
        cat_cocone_obj
        cat_colim_ua_of
    )

lemmas (in is_tm_cat_obj_coprod) tm_cat_obj_coprod_is_tm_cat_colimit =
  is_tm_cat_colimit_axioms

text\<open>Duality.\<close>

lemma (in is_tm_cat_obj_prod) is_tm_cat_obj_coprod_op:
  "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_tm_cat_obj_coprodI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)

lemma (in is_tm_cat_obj_prod) is_tm_cat_obj_coprod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_tm_cat_obj_coprod_op)

lemmas [cat_op_intros] = is_tm_cat_obj_prod.is_tm_cat_obj_coprod_op'

lemma (in is_tm_cat_obj_coprod) is_tm_cat_obj_coprod_op:
  "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  using cf_discrete_vdomain_vsubset_Vset
  by (intro is_tm_cat_obj_prodI)
    (cs_concl cs_simp: cat_op_simps cs_intro: cat_op_intros)

lemma (in is_tm_cat_obj_coprod) is_tm_cat_obj_prod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>\<Prod> A : I \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_tm_cat_obj_coprod_op)

lemmas [cat_op_intros] = is_tm_cat_obj_coprod.is_tm_cat_obj_prod_op'

subsection\<open>Finite product and finite coproduct\<close>

locale is_cat_finite_obj_prod = is_cat_obj_prod \<alpha> I A \<CC> P \<pi>
  for \<alpha> I A \<CC> P \<pi> +
  assumes cat_fin_obj_prod_index_in_\<omega>: "I \<in>\<^sub>\<circ> \<omega>"

syntax "_is_cat_finite_obj_prod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_finite_obj_prod \<alpha> I A \<CC> P \<pi>"

locale is_cat_finite_obj_coprod = is_cat_obj_coprod \<alpha> I A \<CC> U \<pi>
  for \<alpha> I A \<CC> U \<pi> +
  assumes cat_fin_obj_coprod_index_in_\<omega>: "I \<in>\<^sub>\<circ> \<omega>"

syntax "_is_cat_finite_obj_coprod" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n U : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_finite_obj_coprod \<alpha> I A \<CC> U \<pi>"

lemma (in is_cat_finite_obj_prod) cat_fin_obj_prod_index_vfinite: "vfinite I"
  using cat_fin_obj_prod_index_in_\<omega> by auto

sublocale is_cat_finite_obj_prod \<subseteq> I: finite_category \<alpha> \<open>:\<^sub>C I\<close>
  by (intro finite_categoryI')
    (
      auto
        simp: NTDom.HomDom.category_axioms the_cat_discrete_components
        intro!: cat_fin_obj_prod_index_vfinite
    )

lemma (in is_cat_finite_obj_coprod) cat_fin_obj_coprod_index_vfinite:
  "vfinite I"
  using cat_fin_obj_coprod_index_in_\<omega> by auto

sublocale is_cat_finite_obj_coprod \<subseteq> I: finite_category \<alpha> \<open>:\<^sub>C I\<close>
  by (intro finite_categoryI')
    (
      auto
        simp: NTDom.HomDom.category_axioms the_cat_discrete_components
        intro!: cat_fin_obj_coprod_index_vfinite
    )

text\<open>Rules.\<close>

lemma (in is_cat_finite_obj_prod)
  is_cat_finite_obj_prod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "P' = P" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n A' : I' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_finite_obj_prod_axioms)

mk_ide rf
  is_cat_finite_obj_prod_def[unfolded is_cat_finite_obj_prod_axioms_def]
  |intro is_cat_finite_obj_prodI|
  |dest is_cat_finite_obj_prodD[dest]|
  |elim is_cat_finite_obj_prodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_obj_prodD

lemma (in is_cat_finite_obj_coprod)
  is_cat_finite_obj_coprod_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "U' = U" and "A' = A" and "I' = I" and "\<CC>' = \<CC>"
  shows "\<pi> : A' >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n U' : I' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_finite_obj_coprod_axioms)

mk_ide rf
  is_cat_finite_obj_coprod_def[unfolded is_cat_finite_obj_coprod_axioms_def]
  |intro is_cat_finite_obj_coprodI|
  |dest is_cat_finite_obj_coprodD[dest]|
  |elim is_cat_finite_obj_coprodE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_finite_obj_coprodD

text\<open>Duality.\<close>

lemma (in is_cat_finite_obj_prod) is_cat_finite_obj_coprod_op:
  "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_finite_obj_coprodI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps
        cs_intro: cat_fin_obj_prod_index_in_\<omega> cat_cs_intros cat_op_intros
    )

lemma (in is_cat_finite_obj_prod) is_cat_finite_obj_coprod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : A >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_finite_obj_coprod_op)

lemmas [cat_op_intros] = is_cat_finite_obj_prod.is_cat_finite_obj_coprod_op'

lemma (in is_cat_finite_obj_coprod) is_cat_finite_obj_prod_op:
  "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_finite_obj_prodI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps
        cs_intro: cat_fin_obj_coprod_index_in_\<omega> cat_cs_intros cat_op_intros
    )

lemma (in is_cat_finite_obj_coprod) is_cat_finite_obj_prod_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : U <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod>\<^sub>.\<^sub>f\<^sub>i\<^sub>n A : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_finite_obj_prod_op)

lemmas [cat_op_intros] = is_cat_finite_obj_coprod.is_cat_finite_obj_prod_op'

subsection\<open>Product and coproduct of two objects\<close>

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

locale is_cat_obj_prod_2 = is_cat_obj_prod \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 a b\<close> \<CC> P \<pi>
  for \<alpha> a b \<CC> P \<pi>

syntax "_is_cat_obj_prod_2" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {_,_} :/ 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_prod_2 \<alpha> a b \<CC> P \<pi>"

locale is_cat_obj_coprod_2 = is_cat_obj_coprod \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 a b\<close> \<CC> P \<pi>
  for \<alpha> a b \<CC> P \<pi>

syntax "_is_cat_obj_coprod_2" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ {_,_} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> _ :/ 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<pi> : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> U : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_coprod_2 \<alpha> a b \<CC> U \<pi>"

abbreviation proj_fst where "proj_fst \<pi> \<equiv> vpfst (\<pi>\<lparr>NTMap\<rparr>)"
abbreviation proj_snd where "proj_snd \<pi> \<equiv> vpsnd (\<pi>\<lparr>NTMap\<rparr>)"

text\<open>Rules.\<close>

lemma (in is_cat_obj_prod_2) is_cat_obj_prod_2_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "P' = P" and "a' = a" and "b' = b" and "\<CC>' = \<CC>"
  shows "\<pi> : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a',b'} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_prod_2_axioms)

mk_ide rf is_cat_obj_prod_2_def
  |intro is_cat_obj_prod_2I|
  |dest is_cat_obj_prod_2D[dest]|
  |elim is_cat_obj_prod_2E[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_prod_2D

lemma (in is_cat_obj_coprod_2) is_cat_obj_coprod_2_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "P' = P" and "a' = a" and "b' = b" and "\<CC>' = \<CC>"
  shows "\<pi> : {a',b'} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> P' : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_coprod_2_axioms)

mk_ide rf is_cat_obj_coprod_2_def
  |intro is_cat_obj_coprod_2I|
  |dest is_cat_obj_coprod_2D[dest]|
  |elim is_cat_obj_coprod_2E[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_coprod_2D

text\<open>Duality.\<close>

lemma (in is_cat_obj_prod_2) is_cat_obj_coprod_2_op:
  "op_ntcf \<pi> : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> P : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (rule is_cat_obj_coprod_2I[OF is_cat_obj_coprod_op])

lemma (in is_cat_obj_prod_2) is_cat_obj_coprod_2_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> P : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_coprod_2_op)

lemmas [cat_op_intros] = is_cat_obj_prod_2.is_cat_obj_coprod_2_op'

lemma (in is_cat_obj_coprod_2) is_cat_obj_prod_2_op:
  "op_ntcf \<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (rule is_cat_obj_prod_2I[OF is_cat_obj_prod_op])

lemma (in is_cat_obj_coprod_2) is_cat_obj_prod_2_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_prod_2_op)

lemmas [cat_op_intros] = is_cat_obj_coprod_2.is_cat_obj_prod_2_op'

text\<open>Product/coproduct of two objects is a finite product/coproduct.\<close>

sublocale is_cat_obj_prod_2 \<subseteq> is_cat_finite_obj_prod \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 a b\<close> \<CC> P \<pi>
proof(intro is_cat_finite_obj_prodI)
  show "2\<^sub>\<nat> \<in>\<^sub>\<circ> \<omega>" by simp
qed (cs_concl cs_shallow cs_simp: two[symmetric] cs_intro: cat_lim_cs_intros)

sublocale is_cat_obj_coprod_2 \<subseteq> is_cat_finite_obj_coprod \<alpha> \<open>2\<^sub>\<nat>\<close> \<open>if2 a b\<close> \<CC> P \<pi>
proof(intro is_cat_finite_obj_coprodI)
  show "2\<^sub>\<nat> \<in>\<^sub>\<circ> \<omega>" by simp
qed (cs_concl cs_shallow cs_simp: two[symmetric] cs_intro: cat_lim_cs_intros)

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

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_lr_in_Obj:
  shows cat_obj_prod_2_left_in_Obj[cat_lim_cs_intros]: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and cat_obj_prod_2_right_in_Obj[cat_lim_cs_intros]: "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
proof-
  have 0: "0 \<in>\<^sub>\<circ> 2\<^sub>\<nat>" and 1: "1\<^sub>\<nat> \<in>\<^sub>\<circ> 2\<^sub>\<nat>" by simp_all
  show "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    by
      (
        intro
          cf_discrete_selector_vrange[OF 0, simplified]
          cf_discrete_selector_vrange[OF 1, simplified]
      )+
qed

lemmas [cat_lim_cs_intros] = is_cat_obj_prod_2.cat_obj_prod_2_lr_in_Obj

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_lr_in_Obj:
  shows cat_obj_coprod_2_left_in_Obj[cat_lim_cs_intros]: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and cat_obj_coprod_2_right_in_Obj[cat_lim_cs_intros]: "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  by
    (
      intro is_cat_obj_prod_2.cat_obj_prod_2_lr_in_Obj[
        OF is_cat_obj_prod_2_op, unfolded cat_op_simps
        ]
    )+

lemmas [cat_lim_cs_intros] = is_cat_obj_coprod_2.cat_obj_coprod_2_lr_in_Obj

text\<open>Utilities/help lemmas.\<close>

lemma helper_I2_proj_fst_proj_snd_iff:
  "(\<forall>j\<in>\<^sub>\<circ>2\<^sub>\<nat>. \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f') \<longleftrightarrow>
    (proj_fst \<pi>' = proj_fst \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f' \<and> proj_snd \<pi>' = proj_snd \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f')"
  unfolding two by auto

lemma helper_I2_proj_fst_proj_snd_iff':
  "(\<forall>j\<in>\<^sub>\<circ>2\<^sub>\<nat>. \<pi>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<pi>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>) \<longleftrightarrow>
    (proj_fst \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_fst \<pi> \<and> proj_snd \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_snd \<pi>)"
  unfolding two by auto

subsubsection\<open>Universal property\<close>

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique_cone':
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e :\<rightarrow>: (2\<^sub>\<nat>) (if2 a b) \<CC> : :\<^sub>C (2\<^sub>\<nat>) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows
    "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and>
      proj_fst \<pi>' = proj_fst \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f' \<and>
      proj_snd \<pi>' = proj_snd \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'"
  by
    (
      rule cat_obj_prod_unique_cone'[
        OF assms, unfolded helper_I2_proj_fst_proj_snd_iff
        ]
    )

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique:
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and> \<pi>' = \<pi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C (2\<^sub>\<nat>)) \<CC> f'"
  by (rule cat_obj_prod_unique[OF is_cat_obj_prod_2D[OF assms]])

lemma (in is_cat_obj_prod_2) cat_obj_prod_2_unique':
  assumes "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows
    "\<exists>!f'. f' : P' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and>
      proj_fst \<pi>' = proj_fst \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f' \<and>
      proj_snd \<pi>' = proj_snd \<pi> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'"
  by
    (
      rule cat_obj_prod_unique'[
        OF is_cat_obj_prod_2D[OF assms],
        unfolded helper_I2_proj_fst_proj_snd_iff
        ]
    )

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique_cocone':
  assumes "\<pi>' : :\<rightarrow>: (2\<^sub>\<nat>) (if2 a b) \<CC> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e P' : :\<^sub>C (2\<^sub>\<nat>) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows
    "\<exists>!f'. f' : P \<mapsto>\<^bsub>\<CC>\<^esub> P' \<and>
      proj_fst \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_fst \<pi> \<and>
      proj_snd \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_snd \<pi>"
  by
    (
      rule cat_obj_coprod_unique_cocone'[
        OF assms, unfolded helper_I2_proj_fst_proj_snd_iff'
        ]
    )

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique:
  assumes "\<pi>' : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> P' : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<exists>!f'. f' : P \<mapsto>\<^bsub>\<CC>\<^esub> P' \<and> \<pi>' = ntcf_const (:\<^sub>C (2\<^sub>\<nat>)) \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<pi>"
  by (rule cat_obj_coprod_unique[OF is_cat_obj_coprod_2D[OF assms]])

lemma (in is_cat_obj_coprod_2) cat_obj_coprod_2_unique':
  assumes "\<pi>' : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> P' : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows
    "\<exists>!f'. f' : P \<mapsto>\<^bsub>\<CC>\<^esub> P' \<and>
      proj_fst \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_fst \<pi> \<and>
      proj_snd \<pi>' = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> proj_snd \<pi>"
  by
    (
      rule cat_obj_coprod_unique'[
        OF is_cat_obj_coprod_2D[OF assms],
        unfolded helper_I2_proj_fst_proj_snd_iff'
        ]
    )

lemma cat_obj_prod_2_ex_is_iso_arr:
  assumes "\<pi> : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<pi>' : P' <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<times> {a,b} : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : P' \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> P" and "\<pi>' = \<pi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C (2\<^sub>\<nat>)) \<CC> f"
proof-
  interpret \<pi>: is_cat_obj_prod_2 \<alpha> a b \<CC> P \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_prod_2 \<alpha> a b \<CC> P' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_obj_prod_ex_is_iso_arr[
          OF \<pi>.is_cat_obj_prod_axioms \<pi>'.is_cat_obj_prod_axioms
          ]
      )
qed

lemma cat_obj_coprod_2_ex_is_iso_arr:
  assumes "\<pi> : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> U : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<pi>' : {a,b} >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<uplus> U' : 2\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  obtains f where "f : U \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<CC>\<^esub> U'" and "\<pi>' = ntcf_const (:\<^sub>C (2\<^sub>\<nat>)) \<CC> f \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<pi>"
proof-
  interpret \<pi>: is_cat_obj_coprod_2 \<alpha> a b \<CC> U \<pi> by (rule assms(1))
  interpret \<pi>': is_cat_obj_coprod_2 \<alpha> a b \<CC> U' \<pi>' by (rule assms(2))
  from that show ?thesis
    by
      (
        elim cat_obj_coprod_ex_is_iso_arr[
          OF \<pi>.is_cat_obj_coprod_axioms \<pi>'.is_cat_obj_coprod_axioms
          ]
      )
qed

subsection\<open>Projection cone\<close>

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

definition ntcf_obj_prod_base :: "V \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
  where "ntcf_obj_prod_base \<CC> I F P f =
    [(\<lambda>j\<in>\<^sub>\<circ>:\<^sub>C I\<lparr>Obj\<rparr>. f j), cf_const (:\<^sub>C I) \<CC> P, :\<rightarrow>: I F \<CC>, :\<^sub>C I, \<CC>]\<^sub>\<circ>"

definition ntcf_obj_coprod_base :: "V \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
  where "ntcf_obj_coprod_base \<CC> I F P f =
    [(\<lambda>j\<in>\<^sub>\<circ>:\<^sub>C I\<lparr>Obj\<rparr>. f j), :\<rightarrow>: I F \<CC>, cf_const (:\<^sub>C I) \<CC> P, :\<^sub>C I, \<CC>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma ntcf_obj_prod_base_components:
  shows "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTMap\<rparr> = (\<lambda>j\<in>\<^sub>\<circ>:\<^sub>C I\<lparr>Obj\<rparr>. f j)"
    and "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTDom\<rparr> = cf_const (:\<^sub>C I) \<CC> P"
    and "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTCod\<rparr> = :\<rightarrow>: I F \<CC>"
    and "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTDGDom\<rparr> = :\<^sub>C I"
    and "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding ntcf_obj_prod_base_def nt_field_simps
  by (simp_all add: nat_omega_simps)

lemma ntcf_obj_coprod_base_components:
  shows "ntcf_obj_coprod_base \<CC> I F P f\<lparr>NTMap\<rparr> = (\<lambda>j\<in>\<^sub>\<circ>:\<^sub>C I\<lparr>Obj\<rparr>. f j)"
    and "ntcf_obj_coprod_base \<CC> I F P f\<lparr>NTDom\<rparr> = :\<rightarrow>: I F \<CC>"
    and "ntcf_obj_coprod_base \<CC> I F P f\<lparr>NTCod\<rparr> = cf_const (:\<^sub>C I) \<CC> P"
    and "ntcf_obj_coprod_base \<CC> I F P f\<lparr>NTDGDom\<rparr> = :\<^sub>C I"
    and "ntcf_obj_coprod_base \<CC> I F P f\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding ntcf_obj_coprod_base_def nt_field_simps
  by (simp_all add: nat_omega_simps)

text\<open>Duality.\<close>

lemma (in cf_discrete) op_ntcf_ntcf_obj_coprod_base[cat_op_simps]:
  "op_ntcf (ntcf_obj_coprod_base \<CC> I F P f) =
    ntcf_obj_prod_base (op_cat \<CC>) I F P f"
proof-
  note [cat_op_simps] = the_cat_discrete_op[OF cf_discrete_vdomain_vsubset_Vset]
  show ?thesis
    unfolding
      ntcf_obj_prod_base_def ntcf_obj_coprod_base_def op_ntcf_def nt_field_simps
    by (simp add: nat_omega_simps cat_op_simps)
qed

lemma (in cf_discrete) op_ntcf_ntcf_obj_prod_base[cat_op_simps]:
  "op_ntcf (ntcf_obj_prod_base \<CC> I F P f) =
    ntcf_obj_coprod_base (op_cat \<CC>) I F P f"
proof-
  note [cat_op_simps] = the_cat_discrete_op[OF cf_discrete_vdomain_vsubset_Vset]
  show ?thesis
    unfolding
      ntcf_obj_prod_base_def ntcf_obj_coprod_base_def op_ntcf_def nt_field_simps
    by (simp add: nat_omega_simps cat_op_simps)
qed

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

mk_VLambda ntcf_obj_prod_base_components(1)
  |vsv ntcf_obj_prod_base_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_obj_prod_base_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_obj_prod_base_NTMap_app[cat_cs_simps]|

mk_VLambda ntcf_obj_coprod_base_components(1)
  |vsv ntcf_obj_coprod_base_NTMap_vsv[cat_cs_intros]|
  |vdomain ntcf_obj_coprod_base_NTMap_vdomain[cat_cs_simps]|
  |app ntcf_obj_coprod_base_NTMap_app[cat_cs_simps]|

subsubsection\<open>Projection natural transformation is a cone\<close>

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone:
  assumes "P \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "\<And>a. a \<in>\<^sub>\<circ> I \<Longrightarrow> f a : P \<mapsto>\<^bsub>\<CC>\<^esub> F a"
  shows "ntcf_obj_prod_base \<CC> I F P f : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e :\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof(intro is_cat_coneI is_tm_ntcfI' is_ntcfI')
  from assms(2) have [cat_cs_intros]:
    "\<lbrakk> a \<in>\<^sub>\<circ> I; P' = P; Fa = F a \<rbrakk> \<Longrightarrow> f a : P' \<mapsto>\<^bsub>\<CC>\<^esub> Fa" for a P' Fa
    by simp
  show "vfsequence (ntcf_obj_prod_base \<CC> I F P f)"
    unfolding ntcf_obj_prod_base_def by auto
  show "vcard (ntcf_obj_prod_base \<CC> I F P f) = 5\<^sub>\<nat>"
    unfolding ntcf_obj_prod_base_def by (auto simp: nat_omega_simps)
  from assms show "cf_const (:\<^sub>C I) \<CC> P : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    by
      (
        cs_concl
          cs_intro:
            cf_discrete_vdomain_vsubset_Vset
            cat_discrete_cs_intros
            cat_cs_intros
      )
  show ":\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    by (cs_concl cs_shallow cs_intro: cat_discrete_cs_intros)
  show "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
    cf_const (:\<^sub>C I) \<CC> P\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> :\<rightarrow>: I F \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
    if "a \<in>\<^sub>\<circ> :\<^sub>C I\<lparr>Obj\<rparr>" for a
  proof-
    from that have "a \<in>\<^sub>\<circ> I" unfolding the_cat_discrete_components by simp
    from that this show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_discrete_cs_simps cs_intro: cat_cs_intros
        )
  qed
  show
    "ntcf_obj_prod_base \<CC> I F P f\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub>
      cf_const (:\<^sub>C I) \<CC> P\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> =
      :\<rightarrow>: I F \<CC>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> ntcf_obj_prod_base \<CC> I F P f\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
    if "g : a \<mapsto>\<^bsub>:\<^sub>C I\<^esub> b" for a b g
  proof-
    note g = the_cat_discrete_is_arrD[OF that]
    from that g(4)[unfolded g(7-9)] g(1)[unfolded g(7-9)] show ?thesis
      unfolding g(7-9)
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cat_discrete_cs_simps
            cs_intro:
              cf_discrete_vdomain_vsubset_Vset
              cat_cs_intros cat_discrete_cs_intros
        )
  qed
qed
  (
    auto simp:
      assms
      ntcf_obj_prod_base_components
      tm_cf_discrete_the_cf_discrete_is_tm_functor
  )

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_coprod_base_is_cat_cocone:
  assumes "P \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "\<And>a. a \<in>\<^sub>\<circ> I \<Longrightarrow> f a : F a \<mapsto>\<^bsub>\<CC>\<^esub> P"
  shows "ntcf_obj_coprod_base \<CC> I F P f :
    :\<rightarrow>: I F \<CC> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e P : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  note [cat_op_simps] =
    the_cat_discrete_op[OF cf_discrete_vdomain_vsubset_Vset]
    cf_discrete.op_ntcf_ntcf_obj_prod_base[OF cf_discrete_op]
    cf_discrete.cf_discrete_the_cf_discrete_op[OF cf_discrete_op]
  have "op_ntcf (ntcf_obj_coprod_base \<CC> I F P f) :
    P <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e op_cf (:\<rightarrow>: I F \<CC>) : op_cat (:\<^sub>C I) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
    unfolding cat_op_simps
    by
      (
        rule tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone[
          OF tm_cf_discrete_op, unfolded cat_op_simps, OF assms
          ]
      )
  from is_cat_cone.is_cat_cocone_op[OF this, unfolded cat_op_simps]
  show ?thesis .
qed

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_prod_base_is_cat_obj_prod:
  assumes "P \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<And>a. a \<in>\<^sub>\<circ> I \<Longrightarrow> f a : P \<mapsto>\<^bsub>\<CC>\<^esub> F a"
    and "\<And>u' r'.
      \<lbrakk> u' : r' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e :\<rightarrow>: I F \<CC> : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<rbrakk> \<Longrightarrow>
        \<exists>!f'.
          f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> P \<and>
          u' = ntcf_obj_prod_base \<CC> I F P f \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) \<CC> f'"
  shows "ntcf_obj_prod_base \<CC> I F P f : P <\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Prod> F : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof
  (
    intro
      is_cat_obj_prodI
      is_cat_limitI
      tm_cf_discrete_ntcf_obj_prod_base_is_cat_cone[OF assms(1,2), simplified]
      assms(1,3)
  )
  show "cf_discrete \<alpha> I F \<CC>"
    by (cs_concl cs_shallow cs_intro: cat_small_discrete_cs_intros)
qed

lemma (in tm_cf_discrete) tm_cf_discrete_ntcf_obj_coprod_base_is_cat_obj_coprod:
  assumes "P \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<And>a. a \<in>\<^sub>\<circ> I \<Longrightarrow> f a : F a \<mapsto>\<^bsub>\<CC>\<^esub> P"
    and "\<And>u' r'. \<lbrakk> u' : :\<rightarrow>: I F \<CC> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e r' : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<rbrakk> \<Longrightarrow>
      \<exists>!f'.
        f' : P \<mapsto>\<^bsub>\<CC>\<^esub> r' \<and>
        u' = ntcf_const (:\<^sub>C I) \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_obj_coprod_base \<CC> I F P f"
  shows "ntcf_obj_coprod_base \<CC> I F P f : F >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    (is \<open>?nc : F >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>\<close>)
proof-
  let ?np = \<open>ntcf_obj_prod_base (op_cat \<CC>) I F P f\<close>
  interpret is_cat_cocone \<alpha> P \<open>:\<^sub>C I\<close> \<CC> \<open>:\<rightarrow>: I F \<CC>\<close> ?nc
    by (intro tm_cf_discrete_ntcf_obj_coprod_base_is_cat_cocone[OF assms(1,2)])
  note [cat_op_simps] =
    the_cat_discrete_op[OF cf_discrete_vdomain_vsubset_Vset]
    cf_discrete.op_ntcf_ntcf_obj_prod_base[OF cf_discrete_op]
    cf_discrete.cf_discrete_the_cf_discrete_op[OF cf_discrete_op]
  have "\<exists>!f'.
    f' : P \<mapsto>\<^bsub>\<CC>\<^esub> r \<and>
    u = ?np \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) (op_cat \<CC>) f'"
    if "u : r <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e :\<rightarrow>: I F (op_cat \<CC>) : :\<^sub>C I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>" for u r
  proof-
    interpret u: is_cat_cone \<alpha> r \<open>:\<^sub>C I\<close> \<open>op_cat \<CC>\<close> \<open>:\<rightarrow>: I F (op_cat \<CC>)\<close> u
      by (rule that)
    from assms(3)[OF u.is_cat_cocone_op[unfolded cat_op_simps]] obtain g
      where g: "g : P \<mapsto>\<^bsub>\<CC>\<^esub> r"
        and op_u: "op_ntcf u = ntcf_const (:\<^sub>C I) \<CC> g \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?nc"
        and g_unique:
          "\<lbrakk> g' : P \<mapsto>\<^bsub>\<CC>\<^esub> r; op_ntcf u = ntcf_const (:\<^sub>C I) \<CC> g' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?nc \<rbrakk> \<Longrightarrow>
            g' = g"
      for g'
      by metis
    show ?thesis
    proof(intro ex1I conjI; (elim conjE)?)
      from op_u have
        "op_ntcf (op_ntcf u) = op_ntcf (ntcf_const (:\<^sub>C I) \<CC> g \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?nc)"
        by simp
      from this g show "u = ?np \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) (op_cat \<CC>) g"
        by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros)
      fix g' assume prems:
        "g' : P \<mapsto>\<^bsub>\<CC>\<^esub> r"
        "u = ?np \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) (op_cat \<CC>) g'"
      from prems(2) have
        "op_ntcf u = op_ntcf (?np \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (:\<^sub>C I) (op_cat \<CC>) g')"
        by simp
      from this prems(1) g have "op_ntcf u = ntcf_const (:\<^sub>C I) \<CC> g' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?nc"
        by
          (
            subst (asm)
              the_cat_discrete_op[OF cf_discrete_vdomain_vsubset_Vset, symmetric]
          )
          (
            cs_prems
              cs_simp:
                cat_op_simps
                op_ntcf_ntcf_vcomp[symmetric]
                is_ntcf.ntcf_op_ntcf_op_ntcf
                op_ntcf_ntcf_obj_coprod_base[symmetric]
                op_ntcf_ntcf_const[symmetric]
              cs_intro: cat_cs_intros cat_op_intros
          )
      from g_unique[OF prems(1) this] show "g' = g" .
    qed (rule g)
  qed
  from is_cat_obj_prod.is_cat_obj_coprod_op
    [
      OF tm_cf_discrete.tm_cf_discrete_ntcf_obj_prod_base_is_cat_obj_prod
        [
          OF tm_cf_discrete_op,
          unfolded cat_op_simps,
          OF assms(1,2) this,
          folded op_ntcf_ntcf_obj_coprod_base
        ],
      unfolded cat_op_simps
    ]
  show "?nc : F >\<^sub>C\<^sub>F\<^sub>.\<^sub>\<Coprod> P : I \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>".
qed

text\<open>\newpage\<close>

end