# Theory Category

(*  Title:       Category
Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category"

theory Category
imports Main "HOL-Library.FuncSet"
begin

text ‹
This theory develops an object-free'' definition of category loosely following
\<^cite>‹"AHS"›, Sec. 3.52-3.53.
We define the notion category'' in terms of axioms that concern a single
partial binary operation on a type, some of whose elements are to be regarded
as the arrows'' of the category.

An advantage is that only one piece of data (the composition operation) is required
to specify a category, so the use of records is not required to bundle up several
separate objects.  A related advantage is the fact that functors and natural
transformations can be defined simply to be functions that satisfy certain axioms,
rather than more complex composite objects.
One disadvantage is that the notions of object'' and identity arrow'' are
conflated, though this is easy to get used to.  Perhaps a more significant disadvantage
is that each arrow of a category must carry along the information about its domain
and codomain. This implies, for example, that the arrows of a category of sets and
functions cannot be directly identified with functions, but rather only with functions that
have been equipped with their domain and codomain sets.

To represent the partiality of the composition operation of a category, we assume that the
composition for a category has a unique zero element, which we call ‹null›,
and we consider arrows to be composable'' if and only if their composite is non-null.
Functors and natural transformations are required to map arrows to arrows and be
extensional'' in the sense that they map non-arrows to null.  This is so that
equality of functors and natural transformations coincides with their extensional equality
as functions in HOL.
The fact that we co-opt an element of the arrow type to serve as ‹null› means that
it is not possible to define a category whose arrows exhaust the elements of a given type.
This presents a disadvantage in some situations.  For example, we cannot construct a
discrete category whose arrows are directly identified with the set of \emph{all}
elements of a given type @{typ 'a}; instead, we must pass to a larger type
(such as @{typ "'a option"}) so that there is an element available for use as ‹null›.
The presence of ‹null›, however, is crucial to our being able to define a
system of introduction and elimination rules that can be applied automatically to establish
that a given expression denotes an arrow.  Without ‹null›, we would be able to
define an introduction rule to infer, say, that the composition of composable arrows
is composable, but not an elimination rule to infer that arrows are composable from
the fact that their composite is an arrow.  Having the ability to do both is critical
to the usability of the theory.
›

text ‹
A \emph{partial magma} is a partial binary operation ‹OP› defined on the set
of elements at a type @{typ 'a}.  As discussed above,
we assume the existence of a unique element ‹null› of type @{typ 'a}
that is a zero for ‹OP›, and we use ‹null› to represent undefined''.
A \emph{partial magma} consists simply of a partial binary operation.
We represent the partiality by assuming the existence of a unique value ‹null›
that behaves as a zero for the operation.
›

locale partial_magma =
fixes OP :: "'a ⇒ 'a ⇒ 'a"
assumes ex_un_null: "∃!n. ∀t. OP n t = n ∧ OP t n = n"
begin

definition null :: 'a
where "null = (THE n. ∀t. OP n t = n ∧ OP t n = n)"

lemma null_eqI:
assumes "⋀t. OP n t = n ∧ OP t n = n"
shows "n = null"
using assms null_def ex_un_null the1_equality [of "λn. ∀t. OP n t = n ∧ OP t n = n"]
by auto

lemma null_is_zero [simp]:
shows "OP null t = null" and "OP t null = null"
using null_def ex_un_null theI' [of "λn. ∀t. OP n t = n ∧ OP t n = n"]
by auto

end

section "Partial Composition"

text ‹
A \emph{partial composition} is formally the same thing as a partial magma,
except that we think of the operation as an operation of composition'',
and we regard elements ‹f› and ‹g› of type @{typ 'a} as \emph{composable}
if their composition is non-null.
›

type_synonym 'a comp = "'a ⇒ 'a ⇒ 'a"

locale partial_composition =
partial_magma C
for C :: "'a comp" (infixr "⋅" 55)
begin

text ‹
An \emph{identity} is a self-composable element ‹a› such that composition of
any other element ‹f› with ‹a› on either the left or the right results in
‹f› whenever the composition is defined.
›

definition ide
where "ide a ≡ a ⋅ a ≠ null ∧
(∀f. (f ⋅ a ≠ null ⟶ f ⋅ a = f) ∧ (a ⋅ f ≠ null ⟶ a ⋅ f = f))"

text ‹
A \emph{domain} of an element ‹f› is an identity ‹a› for which composition of
‹f› with ‹a› on the right is defined.
The notion \emph{codomain} is defined similarly, using composition on the left.
Note that, although these definitions are completely dual, the choice of terminology
implies that we will think of composition as being written in traditional order,
as opposed to diagram order.  It is pretty much essential to do it this way, to maintain
compatibility with the notation for function application once we start working with
functors and natural transformations.
›

definition domains
where "domains f ≡ {a. ide a ∧ f ⋅ a ≠ null}"

definition codomains
where "codomains f ≡ {b. ide b ∧ b ⋅ f ≠ null}"

lemma domains_null:
shows "domains null = {}"

lemma codomains_null:
shows "codomains null = {}"

lemma self_domain_iff_ide:
shows "a ∈ domains a ⟷ ide a"
using ide_def domains_def by auto

lemma self_codomain_iff_ide:
shows "a ∈ codomains a ⟷ ide a"
using ide_def codomains_def by auto

text ‹
An element ‹f› is an \emph{arrow} if either it has a domain or it has a codomain.
In an arbitrary partial magma it is possible for ‹f› to have one but not the other,
but the ‹category› locale will include assumptions to rule this out.
›

definition arr
where "arr f ≡ domains f ≠ {} ∨ codomains f ≠ {}"

lemma not_arr_null [simp]:
shows "¬ arr null"
by (simp add: arr_def domains_null codomains_null)

text ‹
Using the notions of domain and codomain, we can define \emph{homs}.
The predicate @{term "in_hom f a b"} expresses @{term f} is an arrow from @{term a}
to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
It is convenient to have both of these, though passing back and forth sometimes involves
extra work.  We choose @{term "in_hom"} as the more fundamental notion.
›

definition in_hom     ("«_ : _ → _»")
where "«f : a → b» ≡ a ∈ domains f ∧ b ∈ codomains f"

abbreviation hom
where "hom a b ≡ {f. «f : a → b»}"

lemma arrI:
assumes "«f : a → b»"
shows "arr f"
using assms arr_def in_hom_def by auto

lemma ide_in_hom [intro]:
shows "ide a ⟷ «a : a → a»"
using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce

text ‹
Arrows @{term "f"} @{term "g"} for which the composite @{term "g ⋅ f"} is defined
are \emph{sequential}.
›

abbreviation seq
where "seq g f ≡ arr (g ⋅ f)"

lemma comp_arr_ide:
assumes "ide a" and "seq f a"
shows "f ⋅ a = f"
using assms ide_in_hom ide_def not_arr_null by metis

lemma comp_ide_arr:
assumes "ide b" and "seq b f"
shows "b ⋅ f = f"
using assms ide_in_hom ide_def not_arr_null by metis

text ‹
The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
arbitrarily from the set of codomains.
›

definition dom
where "dom f = (if domains f ≠ {} then (SOME a. a ∈ domains f) else null)"

definition cod
where "cod f = (if codomains f ≠ {} then (SOME b. b ∈ codomains f) else null)"

lemma dom_null [simp]:
shows "dom null = null"

lemma cod_null [simp]:
shows "cod null = null"

lemma dom_in_domains:
assumes "domains f ≠ {}"
shows "dom f ∈ domains f"
using assms dom_def someI [of "λa. a ∈ domains f"] by auto

lemma cod_in_codomains:
assumes "codomains f ≠ {}"
shows "cod f ∈ codomains f"
using assms cod_def someI [of "λb. b ∈ codomains f"] by auto

end

section "Categories"

text‹
A \emph{category} is defined to be a partial magma whose composition satisfies an
extensionality condition, an associativity condition, and the requirement that every
arrow have both a domain and a codomain.
The associativity condition involves four matching conditions''
(‹match_1›, ‹match_2›, ‹match_3›, and ‹match_4›)
which constrain the domain of definition of the composition, and a fifth condition
(‹comp_assoc'›) which states that the results of the two ways of composing
three elements are equal.  In the presence of the ‹comp_assoc'› axiom
‹match_4› can be derived from ‹match_3› and vice versa.
›

locale category = partial_composition +
assumes ext: "g ⋅ f ≠ null ⟹ seq g f"
and has_domain_iff_has_codomain: "domains f ≠ {} ⟷ codomains f ≠ {}"
and match_1: "⟦ seq h g; seq (h ⋅ g) f ⟧ ⟹ seq g f"
and match_2: "⟦ seq h (g ⋅ f); seq g f ⟧ ⟹ seq h g"
and match_3: "⟦ seq g f; seq h g ⟧ ⟹ seq (h ⋅ g) f"
and comp_assoc': "⟦ seq g f; seq h g ⟧ ⟹ (h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
begin

text‹
Associativity of composition holds unconditionally.  This was not the case in
previous, weaker versions of this theory, and I did not notice this for some
time after updating to the current axioms.  It is obviously an advantage that
no additional hypotheses have to be verified in order to apply associativity,
but a disadvantage is that this fact is now too readily applicable,''
so that if it is made a default simplification it tends to get in the way of
applying other simplifications that we would also like to be able to apply automatically.
So, it now seems best not to make this fact a default simplification, but rather
to invoke it explicitly where it is required.
›

lemma comp_assoc:
shows "(h ⋅ g) ⋅ f = h ⋅ g ⋅ f"
by (metis comp_assoc' ex_un_null ext match_1 match_2)

lemma match_4:
assumes "seq g f" and "seq h g"
shows "seq h (g ⋅ f)"
using assms match_3 comp_assoc by auto

lemma domains_comp:
assumes "seq g f"
shows "domains (g ⋅ f) = domains f"
proof -
have "domains (g ⋅ f) = {a. ide a ∧ seq (g ⋅ f) a}"
using domains_def ext by auto
also have "... = {a. ide a ∧ seq f a}"
using assms ide_def match_1 match_3 by meson
also have "... = domains f"
using domains_def ext by auto
finally show ?thesis by blast
qed

lemma codomains_comp:
assumes "seq g f"
shows "codomains (g ⋅ f) = codomains g"
proof -
have "codomains (g ⋅ f) = {b. ide b ∧ seq b (g ⋅ f)}"
using codomains_def ext by auto
also have "... = {b. ide b ∧ seq b g}"
using assms ide_def match_2 match_4 by meson
also have "... = codomains g"
using codomains_def ext by auto
finally show ?thesis by blast
qed

lemma has_domain_iff_arr:
shows "domains f ≠ {} ⟷ arr f"

lemma has_codomain_iff_arr:
shows "codomains f ≠ {} ⟷ arr f"
using has_domain_iff_arr has_domain_iff_has_codomain by auto

text‹
A consequence of the category axioms is that domains and codomains, if they exist,
are unique.
›

lemma domain_unique:
assumes "a ∈ domains f" and "a' ∈ domains f"
shows "a = a'"
proof -
have "ide a ∧ seq f a ∧ ide a' ∧ seq f a'"
using assms domains_def ext by force
thus ?thesis
using match_1 ide_def not_arr_null by metis
qed

lemma codomain_unique:
assumes "b ∈ codomains f" and "b' ∈ codomains f"
shows "b = b'"
proof -
have "ide b ∧ seq b f ∧ ide b' ∧ seq b' f"
using assms codomains_def ext by force
thus ?thesis
using match_2 ide_def not_arr_null by metis
qed

lemma domains_simp:
assumes "arr f"
shows "domains f = {dom f}"
using assms dom_in_domains has_domain_iff_arr domain_unique by auto

lemma codomains_simp:
assumes "arr f"
shows "codomains f = {cod f}"
using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto

lemma domains_char:
shows "domains f = (if arr f then {dom f} else {})"
using dom_in_domains has_domain_iff_arr domain_unique by auto

lemma codomains_char:
shows "codomains f = (if arr f then {cod f} else {})"
using cod_in_codomains has_codomain_iff_arr codomain_unique by auto

text‹
A consequence of the following lemma is that the notion @{term "arr"} is redundant,
given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}.  However, I have retained it
because I have not been able to find a set of usefully powerful simplification rules
expressed only in terms of @{term "in_hom"} that does not result in looping in many
situations.
›

lemma arr_iff_in_hom:
shows "arr f ⟷ «f : dom f → cod f»"
using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
by auto

lemma in_homI [intro]:
assumes "arr f" and "dom f = a" and "cod f = b"
shows "«f : a → b»"
using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
in_hom_def
by auto

lemma in_homE [elim]:
assumes "«f : a → b»"
and "arr f ⟹ dom f = a ⟹ cod f = b ⟹ T"
shows "T"
using assms in_hom_def domains_char codomains_char has_domain_iff_arr
by (metis empty_iff singleton_iff)

text‹
To obtain the only if'' direction in the next two results and in similar results later
for composition and the application of functors and natural transformations,
is the reason for assuming the existence of @{term null} as a special element of the
arrow type, as opposed to, say, using option types to represent partiality.
The presence of @{term null} allows us not only to make the upward'' inference that
the domain of an arrow is again an arrow, but also to make the downward'' inference
that if @{term "dom f"} is an arrow then so is @{term f}.  Similarly, we will be able
to infer not only that if @{term f} and @{term g} are composable arrows then
@{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
‹f› and ‹g› are composable arrows.  These inferences allow most necessary
facts about what terms denote arrows to be deduced automatically from minimal
assumptions.  Typically all that is required is to assume or establish that certain
terms denote arrows in particular homs at the point where those terms are first
introduced, and then similar facts about related terms can be derived automatically.
Without this feature, nearly every proof would involve many tedious additional steps
to establish that each of the terms appearing in the proof (including all its subterms)
in fact denote arrows.
›

lemma arr_dom_iff_arr:
shows "arr (dom f) ⟷ arr f"
using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
by fastforce

lemma arr_cod_iff_arr:
shows "arr (cod f) ⟷ arr f"
using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
by fastforce

lemma arr_dom [simp]:
assumes "arr f"
shows "arr (dom f)"
using assms arr_dom_iff_arr by simp

lemma arr_cod [simp]:
assumes "arr f"
shows "arr (cod f)"
using assms arr_cod_iff_arr by simp

lemma seqI [simp]:
assumes "arr f" and "arr g" and "dom g = cod f"
shows "seq g f"
proof -
have "ide (cod f) ∧ seq (cod f) f"
using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
moreover have "ide (cod f) ∧ seq g (cod f)"
using assms(2-3) domains_def domains_simp ext by fastforce
ultimately show ?thesis
using match_4 ide_def ext by metis
qed

text ‹
This version of ‹seqI› is useful as an introduction rule, but not as useful
as a simplification, because it requires finding the intermediary term ‹b›.
Sometimes \emph{auto} is able to do this, but other times it is more expedient
just to invoke this rule and fill in the missing terms manually, especially
when dealing with a chain of compositions.
›

lemma seqI' [intro]:
assumes "«f : a → b»" and "«g : b → c»"
shows "seq g f"
using assms by fastforce

lemma compatible_iff_seq:
shows "domains g ∩ codomains f ≠ {} ⟷ seq g f"
proof
show "domains g ∩ codomains f ≠ {} ⟹ seq g f"
using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
domain_unique codomain_unique
by (metis Int_emptyI seqI)
show "seq g f ⟹ domains g ∩ codomains f ≠ {}"
proof -
assume gf: "seq g f"
have 1: "cod f ∈ codomains f"
using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_simp by blast
have "ide (cod f) ∧ seq (cod f) f"
using 1 codomains_def ext by auto
hence "seq g (cod f)"
using gf has_domain_iff_arr match_2 domains_null ide_def by metis
thus ?thesis
using domains_def 1 codomains_def by auto
qed
qed

text‹
The following is another example of a crucial downward'' rule that would not be possible
without a reserved @{term null} value.
›

lemma seqE [elim]:
assumes "seq g f"
and "arr f ⟹ arr g ⟹ dom g = cod f ⟹ T"
shows "T"
using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
domains_comp codomains_comp domains_char codomain_unique
by (metis Int_emptyI singletonD)

lemma comp_in_homI [intro]:
assumes "«f : a → b»" and "«g : b → c»"
shows "«g ⋅ f : a → c»"
proof
show 1: "seq g f" using assms compatible_iff_seq by blast
show "dom (g ⋅ f) = a"
using assms 1 domains_comp domains_simp by blast
show "cod (g ⋅ f) = c"
using assms 1 codomains_comp codomains_simp by blast
qed

lemma comp_in_homI' [simp]:
assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
shows "«g ⋅ f : a → c»"
using assms by auto

lemma comp_in_homE [elim]:
assumes "«g ⋅ f : a → c»"
obtains b where "«f : a → b»" and "«g : b → c»"
using assms in_hom_def domains_comp codomains_comp
by (metis arrI in_homI seqE)

text ‹
The next two rules are useful as simplifications, but they slow down the
simplifier too much to use them by default.  So it is necessary to guess when
they are needed and cite them explicitly.  This is usually not too difficult.
›

lemma comp_arr_dom:
assumes "arr f" and "dom f = a"
shows "f ⋅ a = f"
using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto

lemma comp_cod_arr:
assumes "arr f" and "cod f = b"
shows "b ⋅ f = f"
using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto

lemma ide_char:
shows "ide a ⟷ arr a ∧ dom a = a ∧ cod a = a"
using ide_in_hom by auto

text ‹
In some contexts, this rule causes the simplifier to loop, but it is too useful
not to have as a default simplification.  In cases where it is a problem, usually
a method like \emph{blast} or \emph{force} will succeed if this rule is cited
explicitly.
›

lemma ideD [simp]:
assumes "ide a"
shows "arr a" and "dom a = a" and "cod a = a"
using assms ide_char by auto

lemma ide_dom [simp]:
assumes "arr f"
shows "ide (dom f)"
using assms dom_in_domains has_domain_iff_arr domains_def by auto

lemma ide_cod [simp]:
assumes "arr f"
shows "ide (cod f)"
using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto

lemma dom_eqI:
assumes "ide a" and "seq f a"
shows "dom f = a"
using assms cod_in_codomains codomain_unique ide_char
by (metis seqE)

lemma cod_eqI:
assumes "ide b" and "seq b f"
shows "cod f = b"
using assms dom_in_domains domain_unique ide_char
by (metis seqE)

lemma dom_eqI':
assumes "a ∈ domains f"
shows "a = dom f"
using assms dom_in_domains domain_unique by blast

lemma cod_eqI':
assumes "a ∈ codomains f"
shows "a = cod f"
using assms cod_in_codomains codomain_unique by blast

lemma ide_char':
shows "ide a ⟷ arr a ∧ (dom a = a ∨ cod a = a)"
using ide_dom ide_cod ide_char by metis

lemma dom_dom:
shows "dom (dom f) = dom f"
by (metis dom_null domains_char ideD(2) ide_dom dom_def)

lemma cod_cod:
shows "cod (cod f) = cod f"
by (metis arr_cod_iff_arr cod_def has_codomain_iff_arr ideD(3) ide_cod)

lemma dom_cod:
shows "dom (cod f) = cod f"
by (metis arr_cod_iff_arr cod_def has_codomain_iff_arr has_domain_iff_arr ideD(2)
ide_cod dom_def)

lemma cod_dom:
shows "cod (dom f) = dom f"
by (metis cod_null has_domain_iff_arr ideD(3) ide_dom dom_def)

lemma dom_comp [simp]:
assumes "seq g f"
shows "dom (g ⋅ f) = dom f"
using assms by (simp add: dom_def domains_comp)

lemma cod_comp [simp]:
assumes "seq g f"
shows "cod (g ⋅ f) = cod g"
using assms by (simp add: cod_def codomains_comp)

lemma comp_ide_self [simp]:
assumes "ide a"
shows "a ⋅ a = a"
using assms comp_arr_ide arrI by auto

lemma ide_compE [elim]:
assumes "ide (g ⋅ f)"
and "seq g f ⟹ seq f g ⟹ g ⋅ f = dom f ⟹ g ⋅ f = cod g ⟹ T"
shows "T"
using assms dom_comp cod_comp ide_char ide_in_hom
by (metis seqE seqI)

text ‹
The next two results are sometimes useful for performing manipulations at the
head of a chain of composed arrows.  I have adopted the convention that such
chains are canonically represented in right-associated form.  This makes it
easy to perform manipulations at the tail'' of a chain, but more difficult
to perform them at the head''.  These results take care of the rote manipulations
using associativity that are needed to either permute or combine arrows at the
›

lemma comp_permute:
assumes "f ⋅ g = k ⋅ l" and "seq f g" and "seq g h"
shows "f ⋅ g ⋅ h = k ⋅ l ⋅ h"
using assms by (metis comp_assoc)

lemma comp_reduce:
assumes "f ⋅ g = k" and "seq f g" and "seq g h"
shows "f ⋅ g ⋅ h = k ⋅ h"
using assms comp_assoc by auto

text‹
Here we define some common configurations of arrows.
These are defined as abbreviations, because we want all diagrammatic'' assumptions
in a theorem to reduce readily to a conjunction of assertions of the basic forms
@{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
›

abbreviation endo
where "endo f ≡ seq f f"

abbreviation antipar
where "antipar f g ≡ seq g f ∧ seq f g"

abbreviation span
where "span f g ≡ arr f ∧ arr g ∧ dom f = dom g"

abbreviation cospan
where "cospan f g ≡ arr f ∧ arr g ∧ cod f = cod g"

abbreviation par
where "par f g ≡ arr f ∧ arr g ∧ dom f = dom g ∧ cod f = cod g"

end

end