MathClasses.theory.categories
Require Import
abstract_algebra theory.setoids interfaces.functors theory.jections.
Notation "x ⇛ y" := (∀ a, x a ⟶ y a) (at level 90, right associativity) : mc_scope.
Definition id_nat_trans `{Arrows D} `{!CatId D} `(F: C → D): F ⇛ F := λ _, cat_id.
Section NaturalTransformation.
Context `{Category C} `{Category D} `{!Functor (F: C → D) Fa} `{!Functor (G: C → D) Ga}.
Class NaturalTransformation (η: F ⇛ G): Prop :=
natural: ∀ `(f: x ⟶ y), η y ◎ fmap F f = fmap G f ◎ η x.
End NaturalTransformation.
Section UniversalArrow.
Context `{Category D} `{Category C} `{!Functor (F: D → C) Fa}.
Class UniversalArrow `(u: c ⟶ F r) (wit: ∀ `(f: c ⟶ F d), r ⟶ d): Prop :=
universal_arrow: ∀ (d: D) (f: c ⟶ F d), is_sole ((f =) ∘ (◎ u) ∘ fmap F) (wit f).
End UniversalArrow.
Section adjunction.
Context `{Category C} `{Category D}
F `{!Functor (F: C → D) F'}
G `{!Functor (G: D → C) G'}.
Class φAdjunction (φ: ∀ `(F c ⟶ d), (c ⟶ G d)) `{∀ c d, Inverse (@φ c d)}: Prop :=
{ φ_adjunction_left_functor: Functor F _
; φ_adjunction_right_functor: Functor G _
; φ_adjunction_bijective: ∀ c d, Bijective (@φ c d)
; φ_adjunction_natural_left `(f: F c ⟶ d) `(k: d ⟶ d'): φ (k ◎ f) = fmap G k ◎ φ f
; φ_adjunction_natural_right `(f: F c ⟶ d) `(h: c' ⟶ c): φ (f ◎ fmap F h) = φ f ◎ h }.
Class ηAdjunction (η: id ⇛ G ∘ F) (uniwit: ∀ `(c ⟶ G d), F c ⟶ d): Prop :=
{ η_adjunction_left_functor: Functor F _
; η_adjunction_right_functor: Functor G _
; η_adjunction_natural: NaturalTransformation η
; η_adjunction_universal: ∀ c: C, UniversalArrow (η c: c ⟶ G (F c)) (@uniwit c) }.
Class ηεAdjunction (η: id ⇛ G ∘ F) (ε: F ∘ G ⇛ id): Prop :=
{ ηε_adjunction_left_functor: Functor F _
; ηε_adjunction_right_functor: Functor G _
; ηε_adjunction_η_natural: NaturalTransformation η
; ηε_adjunction_ε_natural: NaturalTransformation ε
; ηε_adjunction_identity_at_G: ∀ a, fmap G (ε a) ◎ η (G a) = id_nat_trans G a
; ηε_adjunction_identity_at_F: ∀ a, ε (F a) ◎ fmap F (η a) = id_nat_trans F a }.
End adjunction.
Section contents.
Context `{Category X}.
Class Mono `(a: x ⟶ y): Prop :=
mono: ∀ z (f g: z ⟶ x), a ◎ f = a ◎ g → f = g.
Section isomorphy.
Definition iso_arrows {x y: X} (a: x ⟶ y) (b: y ⟶ x): Prop
:= a ◎ b = cat_id ∧ b ◎ a = cat_id.
Global Instance: HeteroSymmetric (@iso_arrows).
Proof. unfold iso_arrows. repeat intro. intuition. Qed.
Definition is_iso {x y: X} (a: x ⟶ y): Prop := ex (iso_arrows a).
Definition isos_unique (x y: X) (a: x ⟶ y) (b b': y ⟶ x): iso_arrows a b → iso_arrows a b' → b = b'.
Proof. intros [P Q] [R S]. rewrite <- left_identity. rewrite <- S, <-associativity, P. apply right_identity. Qed.
Definition iso: Equiv X := λ x y, ex (uncurry (@iso_arrows x y)).
Definition isoT: X → X → Type := λ x y, sig (uncurry (@iso_arrows x y)).
Program Instance: Reflexive iso := λ x, ex_intro _ (cat_id, cat_id) _.
Next Obligation. split; apply left_identity. Qed.
Instance: Symmetric iso.
Proof. intros ? ? [[f f'] ?]. ∃ (f', f). unfold uncurry. apply (hetero_symmetric). assumption. Qed.
Instance: Transitive iso.
Proof with assumption.
intros ? ? ? [[f f'] [U V]] [[g g'] [W Z]].
∃ (g ◎ f, f' ◎ g').
split; simpl in ×.
rewrite <- associativity, (associativity f f' g'), U, left_identity...
rewrite <- associativity, (associativity g' g f), Z, left_identity...
Qed.
Global Instance iso_equivalence: Equivalence iso := {}.
Global Instance iso_setoid: @Setoid X iso := {}.
Lemma arrows_between_isomorphic_objects (a b c d: X)
(ab: a ⟶ b) (ba: b ⟶ a) (cd: c ⟶ d) (dc: d ⟶ c) (ac: a ⟶ c) (bd: b ⟶ d):
iso_arrows ab ba → iso_arrows cd dc →
ac ◎ ba = dc ◎ bd →
bd ◎ ab = cd ◎ ac.
Proof. intros [H1 H4] [H2 H5] H3.
rewrite <- (left_identity (bd ◎ ab)).
rewrite <- H2.
rewrite <- associativity.
rewrite (associativity dc bd ab).
rewrite <- H3.
rewrite <- associativity.
rewrite H4.
rewrite right_identity.
reflexivity.
Qed.
Program Definition refl_arrows (x: X): isoT x x := (cat_id, cat_id).
Next Obligation. split; apply left_identity. Qed.
End isomorphy.
Section initiality.
Class InitialArrow (x: X): Type := initial_arrow: ∀ y, x ⟶ y.
Class Initial (x: X) `{InitialArrow x}: Prop :=
initial_arrow_unique: ∀ y f', initial_arrow y = f'.
Definition initial (x: X): Type := ∀ y: X, sig (λ a: x ⟶ y, ∀ a': x ⟶ y, a = a').
Lemma initials_unique' (x x': X) `{Initial x} `{Initial x'}:
iso_arrows (initial_arrow x': x ⟶ x') (initial_arrow x).
Proof with reflexivity.
split. rewrite <- (H4 _ cat_id), <- H4...
rewrite <- (H2 _ cat_id), <- H2...
Qed.
Program Lemma initials_unique (x x': X) (a: initial x) (b: initial x'): iso_arrows (a x') (b x).
Proof.
split.
destruct (b x') as [? e1]. rewrite <- e1. apply e1.
destruct (a x) as [? e0]. rewrite <- e0. apply e0.
Qed.
End initiality.
Section products.
Context {I: Type} (component: I → X).
Section def.
Context (product: X).
Class ElimProduct: Type := tuple_proj: ∀ i, product ⟶ component i.
Class IntroProduct: Type := make_tuple: ∀ x, (∀ i, x ⟶ component i) → (x ⟶ product).
Class Product `{ElimProduct} `{IntroProduct}: Prop :=
product_factors: ∀ c ccomp, is_sole (λ h', ∀ i, ccomp i = tuple_proj i ◎ h')
(make_tuple c ccomp).
Lemma tuple_round_trip `{Product} (x: X) (h: ∀ i, x ⟶ component i) i:
tuple_proj i ◎ make_tuple x h = h i.
Proof. symmetry. apply product_factors. Qed.
End def.
Lemma products_unique `{Product c} `{Product c'}:
iso_arrows
(make_tuple c c' (tuple_proj c'))
(make_tuple c' c (tuple_proj c)).
Proof with intuition.
unfold iso_arrows.
revert c H1 H2 H3 c' H4 H5 H6.
cut (∀ `{Product x} `{Product y},
make_tuple x y (tuple_proj y) ◎ make_tuple y x (tuple_proj x) = cat_id)...
pose proof (proj2 (product_factors x x (tuple_proj x))) as Q.
rewrite (Q cat_id)... rewrite Q...
rewrite associativity.
repeat rewrite tuple_round_trip...
rewrite right_identity...
Qed.
End products.
Class Producer: Type := product I: (I → X) → X.
Class HasProducts `{Producer}
`{∀ I c, ElimProduct c (product I c)}
`{∀ I c, IntroProduct c (product I c)}: Prop :=
makes_products: ∀ I (c: I → X), Product c (product I c).
End contents.
Arguments Producer : clear implicits.
Arguments HasProducts _ {Arrows Eq CatComp H1 H2 H3} : rename.
Arguments product {X Producer I} _.
abstract_algebra theory.setoids interfaces.functors theory.jections.
Notation "x ⇛ y" := (∀ a, x a ⟶ y a) (at level 90, right associativity) : mc_scope.
Definition id_nat_trans `{Arrows D} `{!CatId D} `(F: C → D): F ⇛ F := λ _, cat_id.
Section NaturalTransformation.
Context `{Category C} `{Category D} `{!Functor (F: C → D) Fa} `{!Functor (G: C → D) Ga}.
Class NaturalTransformation (η: F ⇛ G): Prop :=
natural: ∀ `(f: x ⟶ y), η y ◎ fmap F f = fmap G f ◎ η x.
End NaturalTransformation.
Section UniversalArrow.
Context `{Category D} `{Category C} `{!Functor (F: D → C) Fa}.
Class UniversalArrow `(u: c ⟶ F r) (wit: ∀ `(f: c ⟶ F d), r ⟶ d): Prop :=
universal_arrow: ∀ (d: D) (f: c ⟶ F d), is_sole ((f =) ∘ (◎ u) ∘ fmap F) (wit f).
End UniversalArrow.
Section adjunction.
Context `{Category C} `{Category D}
F `{!Functor (F: C → D) F'}
G `{!Functor (G: D → C) G'}.
Class φAdjunction (φ: ∀ `(F c ⟶ d), (c ⟶ G d)) `{∀ c d, Inverse (@φ c d)}: Prop :=
{ φ_adjunction_left_functor: Functor F _
; φ_adjunction_right_functor: Functor G _
; φ_adjunction_bijective: ∀ c d, Bijective (@φ c d)
; φ_adjunction_natural_left `(f: F c ⟶ d) `(k: d ⟶ d'): φ (k ◎ f) = fmap G k ◎ φ f
; φ_adjunction_natural_right `(f: F c ⟶ d) `(h: c' ⟶ c): φ (f ◎ fmap F h) = φ f ◎ h }.
Class ηAdjunction (η: id ⇛ G ∘ F) (uniwit: ∀ `(c ⟶ G d), F c ⟶ d): Prop :=
{ η_adjunction_left_functor: Functor F _
; η_adjunction_right_functor: Functor G _
; η_adjunction_natural: NaturalTransformation η
; η_adjunction_universal: ∀ c: C, UniversalArrow (η c: c ⟶ G (F c)) (@uniwit c) }.
Class ηεAdjunction (η: id ⇛ G ∘ F) (ε: F ∘ G ⇛ id): Prop :=
{ ηε_adjunction_left_functor: Functor F _
; ηε_adjunction_right_functor: Functor G _
; ηε_adjunction_η_natural: NaturalTransformation η
; ηε_adjunction_ε_natural: NaturalTransformation ε
; ηε_adjunction_identity_at_G: ∀ a, fmap G (ε a) ◎ η (G a) = id_nat_trans G a
; ηε_adjunction_identity_at_F: ∀ a, ε (F a) ◎ fmap F (η a) = id_nat_trans F a }.
End adjunction.
Section contents.
Context `{Category X}.
Class Mono `(a: x ⟶ y): Prop :=
mono: ∀ z (f g: z ⟶ x), a ◎ f = a ◎ g → f = g.
Section isomorphy.
Definition iso_arrows {x y: X} (a: x ⟶ y) (b: y ⟶ x): Prop
:= a ◎ b = cat_id ∧ b ◎ a = cat_id.
Global Instance: HeteroSymmetric (@iso_arrows).
Proof. unfold iso_arrows. repeat intro. intuition. Qed.
Definition is_iso {x y: X} (a: x ⟶ y): Prop := ex (iso_arrows a).
Definition isos_unique (x y: X) (a: x ⟶ y) (b b': y ⟶ x): iso_arrows a b → iso_arrows a b' → b = b'.
Proof. intros [P Q] [R S]. rewrite <- left_identity. rewrite <- S, <-associativity, P. apply right_identity. Qed.
Definition iso: Equiv X := λ x y, ex (uncurry (@iso_arrows x y)).
Definition isoT: X → X → Type := λ x y, sig (uncurry (@iso_arrows x y)).
Program Instance: Reflexive iso := λ x, ex_intro _ (cat_id, cat_id) _.
Next Obligation. split; apply left_identity. Qed.
Instance: Symmetric iso.
Proof. intros ? ? [[f f'] ?]. ∃ (f', f). unfold uncurry. apply (hetero_symmetric). assumption. Qed.
Instance: Transitive iso.
Proof with assumption.
intros ? ? ? [[f f'] [U V]] [[g g'] [W Z]].
∃ (g ◎ f, f' ◎ g').
split; simpl in ×.
rewrite <- associativity, (associativity f f' g'), U, left_identity...
rewrite <- associativity, (associativity g' g f), Z, left_identity...
Qed.
Global Instance iso_equivalence: Equivalence iso := {}.
Global Instance iso_setoid: @Setoid X iso := {}.
Lemma arrows_between_isomorphic_objects (a b c d: X)
(ab: a ⟶ b) (ba: b ⟶ a) (cd: c ⟶ d) (dc: d ⟶ c) (ac: a ⟶ c) (bd: b ⟶ d):
iso_arrows ab ba → iso_arrows cd dc →
ac ◎ ba = dc ◎ bd →
bd ◎ ab = cd ◎ ac.
Proof. intros [H1 H4] [H2 H5] H3.
rewrite <- (left_identity (bd ◎ ab)).
rewrite <- H2.
rewrite <- associativity.
rewrite (associativity dc bd ab).
rewrite <- H3.
rewrite <- associativity.
rewrite H4.
rewrite right_identity.
reflexivity.
Qed.
Program Definition refl_arrows (x: X): isoT x x := (cat_id, cat_id).
Next Obligation. split; apply left_identity. Qed.
End isomorphy.
Section initiality.
Class InitialArrow (x: X): Type := initial_arrow: ∀ y, x ⟶ y.
Class Initial (x: X) `{InitialArrow x}: Prop :=
initial_arrow_unique: ∀ y f', initial_arrow y = f'.
Definition initial (x: X): Type := ∀ y: X, sig (λ a: x ⟶ y, ∀ a': x ⟶ y, a = a').
Lemma initials_unique' (x x': X) `{Initial x} `{Initial x'}:
iso_arrows (initial_arrow x': x ⟶ x') (initial_arrow x).
Proof with reflexivity.
split. rewrite <- (H4 _ cat_id), <- H4...
rewrite <- (H2 _ cat_id), <- H2...
Qed.
Program Lemma initials_unique (x x': X) (a: initial x) (b: initial x'): iso_arrows (a x') (b x).
Proof.
split.
destruct (b x') as [? e1]. rewrite <- e1. apply e1.
destruct (a x) as [? e0]. rewrite <- e0. apply e0.
Qed.
End initiality.
Section products.
Context {I: Type} (component: I → X).
Section def.
Context (product: X).
Class ElimProduct: Type := tuple_proj: ∀ i, product ⟶ component i.
Class IntroProduct: Type := make_tuple: ∀ x, (∀ i, x ⟶ component i) → (x ⟶ product).
Class Product `{ElimProduct} `{IntroProduct}: Prop :=
product_factors: ∀ c ccomp, is_sole (λ h', ∀ i, ccomp i = tuple_proj i ◎ h')
(make_tuple c ccomp).
Lemma tuple_round_trip `{Product} (x: X) (h: ∀ i, x ⟶ component i) i:
tuple_proj i ◎ make_tuple x h = h i.
Proof. symmetry. apply product_factors. Qed.
End def.
Lemma products_unique `{Product c} `{Product c'}:
iso_arrows
(make_tuple c c' (tuple_proj c'))
(make_tuple c' c (tuple_proj c)).
Proof with intuition.
unfold iso_arrows.
revert c H1 H2 H3 c' H4 H5 H6.
cut (∀ `{Product x} `{Product y},
make_tuple x y (tuple_proj y) ◎ make_tuple y x (tuple_proj x) = cat_id)...
pose proof (proj2 (product_factors x x (tuple_proj x))) as Q.
rewrite (Q cat_id)... rewrite Q...
rewrite associativity.
repeat rewrite tuple_round_trip...
rewrite right_identity...
Qed.
End products.
Class Producer: Type := product I: (I → X) → X.
Class HasProducts `{Producer}
`{∀ I c, ElimProduct c (product I c)}
`{∀ I c, IntroProduct c (product I c)}: Prop :=
makes_products: ∀ I (c: I → X), Product c (product I c).
End contents.
Arguments Producer : clear implicits.
Arguments HasProducts _ {Arrows Eq CatComp H1 H2 H3} : rename.
Arguments product {X Producer I} _.