-- graphs as 1D CW complexes

import data.list.perm
import algebra.big_operators
import data.nat.parity
import data.zmod.basic
import tactic
import myequiv

namespace graphs

open function
open equiv
open_locale big_operators

universe u
variables {V : Type u}

-- For this definition of a graph, V is the edge set and D is the set
-- of "darts," which comprise the two ends of an edge.  An edge is
-- modeled as an orbit of a fixed-point-free involution of the darts.
--
-- In the language of CW complexes, ϕ is the attachment map for the
-- boundary of each 1-cell.
structure graph (V : Type u) :=
(D : Type u) (ε : perm D) (ϕ : D → V) (ε_inv : involutive ε) (ε_fp_free : ¬has_fixed_point ε)

-- Vertex adjacency relation
def graph.adj (g : graph V) (v w : V) : Prop := ∃ (d : g.D), v = g.ϕ d ∧ w = g.ϕ (g.ε d)

def swap {α : Type u} (p : α × α) : α × α := ⟨p.2, p.1⟩

inductive sym2_rel (α : Type u) : (α × α) → (α × α) → Prop
| refl (x y : α) : sym2_rel ⟨x,y⟩ ⟨x,y⟩
| swap (x y : α) : sym2_rel ⟨x,y⟩ ⟨y,x⟩

-- The symmetric square is the cartesian product α × α modulo `swap`.
def sym2 (α : Type u) := quot (sym2_rel α)

-- The type sym2 α is the same thing as sets with exactly one or two elements.
def sym2_to_finset {α : Type u} [decidable_eq α] (s : sym2 α) : finset α :=
begin
  induction s,
  exact {s.1, s.2},
  cases s_p, refl,
  ext, simp, rw or_comm,
end

def sym2_to_finset_card_eq {α : Type u} [decidable_eq α] (s : sym2 α) : (sym2_to_finset s).card = 1 ∨ (sym2_to_finset s).card = 2 :=
begin
  induction s,
  cases s,
  by_cases heq : s_fst = s_snd,
  left, rw heq, simp [sym2_to_finset, quot.rec],
  right,
  change ({s_fst, s_snd} : finset α).card = 2,
  dsimp only [has_insert.insert, finset.val],
  have nmem : s_fst ∉ ({s_snd} : multiset α), by simpa,
  have h := multiset.ndinsert_of_not_mem nmem,
  simp_rw [h], simp [finset.card],
end

-- def sym2_to_finset_equiv {α : Type u} [decidable_eq α] : sym2 α ≃ {x : finset α // x.card = 1 ∨ x.card = 2} :=
-- begin
--   use (λ s, ⟨sym2_to_finset s, sym2_to_finset_card_eq s⟩),
-- end

@[reducible] def edge_setoid (g : graph V) := perm.psetoid g.ε
@[reducible] def graph.edges (g : graph V) := quotient (edge_setoid g)

@[reducible] def graph.dart_edge (g : graph V) (d : g.D) : g.edges := @quotient.mk _ (edge_setoid g) d

instance {g : graph V} [decidable_eq g.D] [fintype g.D] (d₁ d₂ : g.D) : decidable (@setoid.r _ (edge_setoid g) d₁ d₂) :=
begin
  change decidable (perm.same_cycle g.ε d₁ d₂),
  apply_instance,
end

-- There is a map g.edges → sym2 V given by taking the vertices
-- incident to the given edge's darts.
def graph.edges.boundary {g : graph V} (e : g.edges) : sym2 V :=
begin
  induction e, exact quot.mk (sym2_rel V) ⟨g.ϕ e, g.ϕ (g.ε e)⟩,
  simp, apply quot.sound,
  have h := involution_same_cycle g.ε g.ε_inv e_p,
  cases h,
  rw h, exact sym2_rel.refl _ _,
  rw ← h, rw g.ε_inv, exact sym2_rel.swap _ _,
end

-- Get the boundary as a 1- or 2-element set.
def graph.edges.boundary_set {g : graph V} [decidable_eq V] (e : g.edges) : {x : finset V // x.card = 1 ∨ x.card = 2} :=
⟨sym2_to_finset e.boundary, sym2_to_finset_card_eq e.boundary⟩

inductive rel_darts (r : V → V → Prop) : Type u
| loop (v : V) (h : r v v) : bool → rel_darts
| edge (v w : V) (neq : v ≠ w) (h : r v w) : rel_darts

def rel_darts.ε₀ {r : V → V → Prop} (sym : symmetric r) : rel_darts r → rel_darts r
| (rel_darts.loop v h b) := rel_darts.loop v h (!b)
| (rel_darts.edge v w neq h) := rel_darts.edge w v (ne.symm neq) (sym h)

lemma rel_darts.ε₀.involutive {r : V → V → Prop} (sym : symmetric r) : involutive (rel_darts.ε₀ sym) :=
begin
  intro x,
  cases x,
  simp_rw [rel_darts.ε₀, bnot_bnot], tauto,
  simp [rel_darts.ε₀],
end

lemma rel_darts.ε₀.fixed_point_free {r : V → V → Prop} (sym : symmetric r) : ¬has_fixed_point (rel_darts.ε₀ sym) :=
begin
  rintro ⟨x, h⟩,
  cases x, simp [rel_darts.ε₀] at h, cases x_a, tauto, tauto,
  simp [rel_darts.ε₀] at h, tauto,
end

def rel_darts.ε {r : V → V → Prop} (sym : symmetric r) : perm (rel_darts r) :=
involutive.to_equiv (rel_darts.ε₀ sym) (rel_darts.ε₀.involutive sym)

def rel_darts.ϕ (r : V → V → Prop) : rel_darts r → V
| (rel_darts.loop v _ _) := v
| (rel_darts.edge v _ _ _) := v

-- Construct a graph from a relation.  There is exactly one edge
-- between x and y if r x y.  This includes the case of having exactly
-- one loop edge at x if r x x.
def from_rel {r : V → V → Prop} (sym : symmetric r) : graph V :=
⟨rel_darts r, rel_darts.ε sym, rel_darts.ϕ r, rel_darts.ε₀.involutive sym, rel_darts.ε₀.fixed_point_free sym⟩

-- This theorem asserts that the graph produced by from_rel has the correct adjacency relation.
theorem from_rel_recover_adj [decidable_eq V] {r : V → V → Prop} (sym : symmetric r) : ∀ (v w : V), r v w ↔ (from_rel sym).adj v w :=
begin
  intros v w,
  by_cases heq : v = w, {
    rw ←heq,
    split,
    intro h,
    use rel_darts.loop v h tt,
    dsimp [from_rel, rel_darts.ε, rel_darts.ε₀, involutive.to_equiv, rel_darts.ϕ],
    tauto,
    rintro ⟨d, h⟩,
    cases d;
    dsimp [from_rel, rel_darts.ϕ, rel_darts.ε, involutive.to_equiv, rel_darts.ε₀] at h,
    rwa h.1,
    rwa [←h.1, ←h.2] at d_h,
  }, {
    split,
    intro h,
    use rel_darts.edge v w heq h,
    dsimp [from_rel, rel_darts.ε, rel_darts.ε₀, involutive.to_equiv, rel_darts.ϕ],
    tauto,
    rintro ⟨d, h⟩,
    cases d;
    dsimp [from_rel, rel_darts.ϕ, rel_darts.ε, involutive.to_equiv, rel_darts.ε₀] at h,
    rw [h.1, h.2] at heq, tauto,
    rwa [h.1, h.2],
  },
end

def graph.darts_at (g : graph V) (v : V) := {d : g.D | g.ϕ d = v}

lemma graph.darts_at.as_filter (g : graph V) [decidable_eq g.D] [decidable_eq V] [fintype g.D] (v : V)
: g.darts_at v = ↑(finset.univ.filter (λ d, g.ϕ d = v)) :=
begin
  dunfold graph.darts_at,
  simp,
end

instance fintype.darts_at (g : graph V) [decidable_eq g.D] [decidable_eq V] [fintype g.D] (v : V) : fintype (g.darts_at v) :=
begin
  rw graph.darts_at.as_filter g v,
  apply_instance,
end

lemma graph.darts_at.as_filter_card (g : graph V) [decidable_eq g.D] [decidable_eq V] [fintype g.D]  (v : V)
: fintype.card (g.darts_at v) = (finset.univ.filter (λ d, g.ϕ d = v)).card :=
begin
  simp_rw [graph.darts_at.as_filter g v],
  set fs := finset.filter (λ (d : g.D), g.ϕ d = v) finset.univ with fs_eq,
  set fss : set g.D := ↑fs with fss_eq,
  set fst : Type u := ↥fss with fst_eq,
  have equ_card : fintype.card fst = fintype.card fss, refl,
  transitivity (fintype.card fst),
  congr,
  rw equ_card, simp, refl,
end

-- The degree of a vertex is the number of incident darts.  For
-- non-loop edges, this works out as one would expect.  Loop edges are
-- counted twice, also as one would expect.
def graph.deg (g : graph V) [decidable_eq g.D] [decidable_eq V] [fintype g.D] (v : V) : ℕ := fintype.card (g.darts_at v)

def graph.nverts [fintype V] (g : graph V) : ℕ := fintype.card V
def graph.nedges (g : graph V) [fintype g.D] [decidable_eq g.D] : ℕ := fintype.card g.edges
def graph.ndarts (g : graph V) [fintype g.D] : ℕ := fintype.card g.D

lemma edges_have_two_darts (g : graph V) [fintype g.D] [decidable_eq g.D] (e : g.edges)
: (finset.univ.filter (λ d, g.dart_edge d = e)).card = 2 :=
begin
  induction e,
  have h : (finset.univ.filter (λ d, g.dart_edge d = g.dart_edge e)) = {e, g.ε e}, {
    ext, split, {
      intro h,
      rw finset.mem_filter at h,
      have h₂ := h.2,
      simp at h₂,
      change perm.same_cycle g.ε a e at h₂,
      cases equiv.involution_same_cycle g.ε g.ε_inv h₂,
      rw h_1, simp,
      rw ← h_1, rw g.ε_inv, simp,
    }, {
      intro h,
      simp at h, cases h,
      rw h, simp,
      rw finset.mem_filter, use fintype.complete a, simp, use 1, rw h, simp, rw g.ε_inv,
    },
  },
  change (finset.filter (λ (d : g.D), g.dart_edge d = g.dart_edge e) finset.univ).card = 2,
  rw h,
  have hneq : e ≠ g.ε e := λ heq, g.ε_fp_free ⟨e, eq.symm heq⟩,
  have nmem : e ∉ ({g.ε e} : multiset g.D), by simpa,
  have h := multiset.ndinsert_of_not_mem nmem,
  simp [finset.card], simp at h, rw h, simp,
end

lemma graph.dart_edge_is_fintype_surj (g : graph V) [fintype g.D] [decidable_eq g.D] : finset.univ.image g.dart_edge = finset.univ :=
begin
  ext, split, intro h,
  apply fintype.complete,
  intro h,
  rw finset.mem_image,
  induction a, use a, split, apply fintype.complete, refl, refl,
end

lemma graph.ndarts_eq_twice_nedges (g : graph V) [fintype g.D] [decidable_eq g.D] : g.ndarts = 2 * g.nedges :=
begin
  calc g.ndarts = ∑ (d : g.D), 1 : by simp; refl
            ... = ∑ d, (λ e, 1) (g.dart_edge d) : by simp
            ... = ∑ e in finset.univ.image g.dart_edge, (finset.univ.filter (λ d, g.dart_edge d = e)).card •ℕ ((λ e, 1) e)
                : by rw finset.sum_comp
            ... = ∑ e in finset.univ.image g.dart_edge, (finset.univ.filter (λ d, g.dart_edge d = e)).card
                : by dsimp; simp
            ... = ∑ (e : g.edges), (finset.univ.filter (λ d, g.dart_edge d = e)).card : by rw g.dart_edge_is_fintype_surj
            ... = ∑ (e : g.edges), 2 : by simp_rw [edges_have_two_darts]
            ... = 2 * g.nedges : by simp; ring,
end

lemma graph.ndarts_eq_sum_degrees (g : graph V) [fintype g.D] [decidable_eq g.D] [fintype V] [decidable_eq V]
: g.ndarts = ∑ (v : V), g.deg v :=
begin
  have him : finset.univ.image g.ϕ ⊆ finset.univ, apply finset.subset_univ,
  rw ← finset.sum_sdiff him,
  have hzero : ∑ (x : V) in finset.univ \ finset.image g.ϕ finset.univ, (finset.univ.filter (λ (d : g.D), g.ϕ d = x)).card = 0, {
    rw ← finset.sum_filter_ne_zero, simp,
    intros v hd hnf,
    simp [hd],
  },
  dunfold graph.deg,
  simp_rw [graph.darts_at.as_filter_card g, hzero],
  rw ← finset.card_eq_sum_card_image,
  simp,
  refl,
end

lemma graph.handshake (g : graph V) [fintype g.D] [decidable_eq g.D] [fintype V] [decidable_eq V]
: ∑ (v : V), g.deg v = 2 * g.nedges :=
begin
  rw ← graph.ndarts_eq_sum_degrees,
  rw ← graph.ndarts_eq_twice_nedges,
end

lemma zmod_nz (n : zmod 2) : n ≠ 0 ↔ n = 1 :=
begin
  split,
  intro h,
  cases n, cases n_val, norm_cast at h,
  cases n_val, refl,
  change n_val + 2 < 2 at n_is_lt, exfalso, linarith [n_is_lt],
  intro h, subst n,
  intro abs, cases abs,
end

lemma zmod_red_opts (n : ℕ) : (↑n : zmod 2) = 0 ∨ (↑n : zmod 2) = 1 :=
begin
  by_cases h : (↑n : zmod 2) = 0,
  left, exact h,
  right, rwa ←zmod_nz,
end

lemma zmod_even (n : ℕ) : (↑n : zmod 2) = 0 ↔ n.even :=
begin
  rw nat.even_iff,
  split,
  intro h,
  have h'' := congr_arg (λ (x : zmod 2), x.val) h,
  change (↑n : zmod 2).val = 0 at h'',
  rwa zmod.val_cast_nat at h'',
  intro h,
  rw ←zmod.val_cast_nat at h,
  simp at h,
  exact h,
end

lemma zmod_odd (n : ℕ) : (↑n : zmod 2) = 1 ↔ ¬n.even :=
begin
  have h := not_iff_not_of_iff (zmod_even n),
  rw ←zmod_nz,
  exact h,
end

-- A finite graph has an even number of odd-degree vertices
lemma graph.handshake_mod_2 (g : graph V) [fintype g.D] [decidable_eq g.D] [fintype V] [decidable_eq V]
: (finset.univ.filter (λ v, ¬(g.deg v).even)).card.even :=
begin
  have h₁ := graph.handshake g,
  let red : ℕ →+ zmod 2 := nat.cast_add_monoid_hom _,
  have h₂ := congr_arg red h₁,
  rw add_monoid_hom.map_sum red g.deg finset.univ at h₂,
  have him : finset.univ.filter (λ v, red (g.deg v) = 1) ⊆ finset.univ, apply finset.subset_univ,
  rw ← finset.sum_sdiff him at h₂,
  have hzero : ∑ (x : V) in finset.univ \ finset.univ.filter (λ (v : V), red (g.deg v) = 1), red (g.deg x) = 0, {
    rw ← finset.sum_filter_ne_zero, simp,
    have hfilt : finset.filter (λ (x : V), ¬red (g.deg x) = 0) (finset.univ \ finset.filter (λ (v : V), red (g.deg v) = 1) finset.univ) = ∅, {
      ext, simp, intro h, rw ←zmod_nz at h, simp at h, exact h,
    },
    simp at hfilt,
    rw hfilt,
    simp,
  },
  rw hzero at h₂,
  have h₃ : ∑ (x : V) in finset.univ.filter (λ (v : V), red (g.deg v) = 1), red (g.deg x) = ∑ (x : V) in finset.univ.filter (λ (v : V), red (g.deg v) = 1), 1, {
    rw finset.sum_filter,
    have hite : ∀ n : ℕ, (if red n = 1 then red n else 0) = red n, {
      intro n, split_ifs, refl, rw ←zmod_nz at h, simp at h, simp [h],
    },
    simp_rw [hite],
    rw finset.sum_filter,
    have hite' : ∀ n : ℕ, (if red n = 1 then 1 else 0) = red n, {
      intro n, split_ifs, cc, rw ←zmod_nz at h, simp at h, simp [h],
    },
    simp_rw [hite'],
  },
  rw h₃ at h₂,
  simp at h₂,
  rw ← zmod_even,
  simp_rw [zmod_odd] at h₂,
  simp at h₂,
  exact h₂,
end

-- Given an odd-degree vertex v, the number of odd-degree vertices not equal to v is odd.
lemma graph.card_other_odd_vertices_is_odd (g : graph V) [fintype g.D] [decidable_eq g.D] [fintype V] [decidable_eq V]
(v : V) (hv : ¬(g.deg v).even)
: ¬(finset.univ.filter (λ w, ¬(g.deg w).even ∧ v ≠ w)).card.even :=
begin
  rw ←finset.filter_filter,
  rw finset.filter_ne,
  rcases graph.handshake_mod_2 g with ⟨k, h⟩,
  set s := finset.univ.filter (λ v : V, ¬(g.deg v).even) with s_eq,
  have hmem : v ∈ s, {
    simpa,
  },
  have h'' := finset.card_erase_of_mem hmem,
  have hnz := finset.card_ne_zero_of_mem hmem,
  rw ←s_eq at h ⊢,
  rw h at hnz h'', cases k, exfalso, simp at hnz, exact hnz,
  change _ = 2 * k + 1 at h'',
  rw h'',
  exact nat.two_not_dvd_two_mul_add_one k,
end

-- Given an odd-degree vertex, there is another odd-degree vertex.
lemma graph.exist_other_odd_vertex (g : graph V) [fintype g.D] [decidable_eq g.D] [fintype V] [decidable_eq V]
(v : V) (hv : ¬(g.deg v).even)
: ∃ (w : V), w ≠ v ∧ ¬(g.deg w).even :=
begin
  have h := graph.card_other_odd_vertices_is_odd g v hv,
  rw ← nat.even_succ at h,
  rcases h with ⟨k, h⟩,
  change _ + 1 = _ at h,
  cases k,
  exfalso, linarith,
  rw nat.succ_eq_add_one at h,
  have ne : (finset.univ.filter (λ (w : V), ¬(g.deg w).even ∧ v ≠ w)).nonempty, {
    rw ← finset.card_pos,
    linarith,
  },
  induction ne,
  use ne_w,
  simp at ne_h, tauto,
end

end graphs


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.homology.image_to_kernel

/-!
# Exact sequences

In a category with zero morphisms, images, and equalizers we say that `f : A ⟶ B` and `g : B ⟶ C`
are exact if `f ≫ g = 0` and the natural map `image f ⟶ kernel g` is an epimorphism.

In any preadditive category this is equivalent to the homology at `B` vanishing.

However in general it is weaker than other reasonable definitions of exactness,
particularly that
1. the inclusion map `image.ι f` is a kernel of `g` or
2. `image f ⟶ kernel g` is an isomorphism or
3. `image_subobject f = kernel_subobject f`.
However when the category is abelian, these all become equivalent;
these results are found in `category_theory/abelian/exact.lean`.

# Main results
* Suppose that cokernels exist and that `f` and `g` are exact.
  If `s` is any kernel fork over `g` and `t` is any cokernel cofork over `f`,
  then `fork.ι s ≫ cofork.π t = 0`.
* Precomposing the first morphism with an epimorphism retains exactness.
  Postcomposing the second morphism with a monomorphism retains exactness.
* If `f` and `g` are exact and `i` is an isomorphism,
  then `f ≫ i.hom` and `i.inv ≫ g` are also exact.

# Future work
* Short exact sequences, split exact sequences, the splitting lemma (maybe only for abelian
  categories?)
* Two adjacent maps in a chain complex are exact iff the homology vanishes

-/

universes v u

open category_theory
open category_theory.limits

variables {V : Type u} [category.{v} V]
variables [has_images V]

namespace category_theory

/--
Two morphisms `f : A ⟶ B`, `g : B ⟶ C` are called exact if `w : f ≫ g = 0` and the natural map
`image_to_kernel f g w : image_subobject f ⟶ kernel_subobject g` is an epimorphism.

In any preadditive category, this is equivalent to `w : f ≫ g = 0` and `homology f g w ≅ 0`.

In an abelian category, this is equivalent to `image_to_kernel f g w` being an isomorphism,
and hence equivalent to the usual definition,
`image_subobject f = kernel_subobject g`.
-/
-- One nice feature of this definition is that we have
-- `epi f → exact g h → exact (f ≫ g) h` and `exact f g → mono h → exact f (g ≫ h)`,
-- which do not necessarily hold in a non-abelian category with the usual definition of `exact`.
class exact [has_zero_morphisms V] [has_kernels V] {A B C : V} (f : A ⟶ B) (g : B ⟶ C) : Prop :=
(w : f ≫ g = 0)
(epi : epi (image_to_kernel f g w))

attribute [instance] exact.epi
attribute [simp, reassoc] exact.w

section
variables [has_zero_object V] [preadditive V] [has_kernels V] [has_cokernels V]
open_locale zero_object

/--
In any preadditive category,
composable morphisms `f g` are exact iff they compose to zero and the homology vanishes.
-/
lemma preadditive.exact_iff_homology_zero {A B C : V} (f : A ⟶ B) (g : B ⟶ C) :
  exact f g ↔ ∃ w : f ≫ g = 0, nonempty (homology f g w ≅ 0) :=
⟨λ h, ⟨h.w, ⟨cokernel.of_epi _⟩⟩,
  λ h, begin
    obtain ⟨w, ⟨i⟩⟩ := h,
    exact ⟨w, preadditive.epi_of_cokernel_zero ((cancel_mono i.hom).mp (by ext))⟩,
  end⟩

lemma preadditive.exact_of_iso_of_exact {A₁ B₁ C₁ A₂ B₂ C₂ : V}
  (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁) (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂)
  (α : arrow.mk f₁ ≅ arrow.mk f₂) (β : arrow.mk g₁ ≅ arrow.mk g₂) (p : α.hom.right = β.hom.left)
  (h : exact f₁ g₁) :
  exact f₂ g₂ :=
begin
  rw preadditive.exact_iff_homology_zero at h ⊢,
  rcases h with ⟨w₁, ⟨i⟩⟩,
  suffices w₂ : f₂ ≫ g₂ = 0, from ⟨w₂, ⟨(homology.map_iso w₁ w₂ α β p).symm.trans i⟩⟩,
  rw [← cancel_epi α.hom.left, ← cancel_mono β.inv.right, comp_zero, zero_comp, ← w₁],
  simp only [← arrow.mk_hom f₁, ← arrow.left_hom_inv_right α.hom,
      ← arrow.mk_hom g₁, ← arrow.left_hom_inv_right β.hom, p],
  simp only [arrow.mk_hom, is_iso.inv_hom_id_assoc, category.assoc, ← arrow.inv_right,
    is_iso.iso.inv_hom]
end

lemma preadditive.exact_iff_exact_of_iso {A₁ B₁ C₁ A₂ B₂ C₂ : V}
  (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁) (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂)
  (α : arrow.mk f₁ ≅ arrow.mk f₂) (β : arrow.mk g₁ ≅ arrow.mk g₂) (p : α.hom.right = β.hom.left) :
  exact f₁ g₁ ↔ exact f₂ g₂ :=
⟨preadditive.exact_of_iso_of_exact _ _ _ _ _ _ p,
preadditive.exact_of_iso_of_exact _ _ _ _ α.symm β.symm
  begin
    rw ← cancel_mono α.hom.right,
    simp only [iso.symm_hom, ← comma.comp_right, α.inv_hom_id],
    simp only [p, ←comma.comp_left, arrow.id_right, arrow.id_left, iso.inv_hom_id],
    refl
  end⟩

end

section
variables [has_zero_morphisms V] [has_kernels V]

lemma comp_eq_zero_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
  (p : image_subobject f = kernel_subobject g) : f ≫ g = 0 :=
begin
  rw [←image_subobject_arrow_comp f, category.assoc],
  convert comp_zero,
  rw p,
  simp,
end

lemma image_to_kernel_is_iso_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
  (p : image_subobject f = kernel_subobject g) :
  is_iso (image_to_kernel f g (comp_eq_zero_of_image_eq_kernel f g p)) :=
begin
  refine ⟨⟨subobject.of_le _ _ p.ge, _⟩⟩,
  dsimp [image_to_kernel],
  simp only [subobject.of_le_comp_of_le, subobject.of_le_refl],
  simp,
end

-- We'll prove the converse later, when `V` is abelian.
lemma exact_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
  (p : image_subobject f = kernel_subobject g) : exact f g :=
{ w := comp_eq_zero_of_image_eq_kernel f g p,
  epi := begin
    haveI := image_to_kernel_is_iso_of_image_eq_kernel f g p,
    apply_instance,
  end }

end

variables {A B C D : V} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
local attribute [instance] epi_comp

section
variables [has_zero_morphisms V] [has_equalizers V]

instance exact_comp_hom_inv_comp [exact f g] (i : B ≅ D) : exact (f ≫ i.hom) (i.inv ≫ g) :=
begin
  refine ⟨by simp, _⟩,
  rw image_to_kernel_comp_hom_inv_comp,
  apply_instance,
end

instance exact_comp_inv_hom_comp [exact f g] (i : D ≅ B) : exact (f ≫ i.inv) (i.hom ≫ g) :=
category_theory.exact_comp_hom_inv_comp i.symm

lemma exact_comp_hom_inv_comp_iff (i : B ≅ D) : exact (f ≫ i.hom) (i.inv ≫ g) ↔ exact f g :=
begin
  refine ⟨_, by { introI, apply_instance }⟩,
  introI,
  have : exact ((f ≫ i.hom) ≫ i.inv) (i.hom ≫ i.inv ≫ g) := infer_instance,
  simpa using this
end

lemma exact_epi_comp [exact g h] [epi f] : exact (f ≫ g) h :=
begin
  refine ⟨by simp, _⟩,
  rw image_to_kernel_comp_left,
  apply_instance,
end

@[simp]
lemma exact_iso_comp [is_iso f] : exact (f ≫ g) h ↔ exact g h :=
⟨λ w, by { rw ←is_iso.inv_hom_id_assoc f g, exactI exact_epi_comp, }, λ w, by exactI exact_epi_comp⟩

lemma exact_comp_mono [exact f g] [mono h] : exact f (g ≫ h) :=
begin
  refine ⟨by simp, _⟩,
  rw image_to_kernel_comp_right f g h exact.w,
  apply_instance,
end

@[simp]

lemma exact_kernel_subobject_arrow : exact (kernel_subobject f).arrow f :=
begin
  refine ⟨by simp, _⟩,
  apply @is_iso.epi_of_iso _ _ _ _ _ _,
  exact ⟨⟨factor_thru_image_subobject _, by { ext, simp, }, by { ext, simp, }⟩⟩,
end

lemma exact_kernel_ι : exact (kernel.ι f) f :=
by { rw [←kernel_subobject_arrow', exact_iso_comp], exact exact_kernel_subobject_arrow }

instance [exact f g] : epi (factor_thru_kernel_subobject g f (by simp)) :=
begin
  rw ←factor_thru_image_subobject_comp_image_to_kernel,
  apply epi_comp,
end

instance [exact f g] : epi (kernel.lift g f (by simp)) :=
begin
  rw ←factor_thru_kernel_subobject_comp_kernel_subobject_iso,
  apply epi_comp
end

variables (A)

lemma kernel_subobject_arrow_eq_zero_of_exact_zero_left [exact (0 : A ⟶ B) g] :
  (kernel_subobject g).arrow = 0 :=
begin
  rw [←cancel_epi (image_to_kernel (0 : A ⟶ B) g exact.w),
    ←cancel_epi (factor_thru_image_subobject (0 : A ⟶ B))],
  simp
end

lemma kernel_ι_eq_zero_of_exact_zero_left [exact (0 : A ⟶ B) g] :
  kernel.ι g = 0 :=
by { rw ←kernel_subobject_arrow', simp [kernel_subobject_arrow_eq_zero_of_exact_zero_left A], }

lemma exact_zero_left_of_mono [has_zero_object V] [mono g] : exact (0 : A ⟶ B) g :=
⟨by simp, image_to_kernel_epi_of_zero_of_mono _⟩

end

section has_cokernels
variables [has_zero_morphisms V] [has_equalizers V] [has_cokernels V] (f g)

@[simp, reassoc] lemma kernel_comp_cokernel [exact f g] : kernel.ι g ≫ cokernel.π f = 0 :=
begin
  rw [←kernel_subobject_arrow', category.assoc],
  convert comp_zero,
  apply zero_of_epi_comp (image_to_kernel f g exact.w) _,
  rw [image_to_kernel_arrow_assoc, ←image_subobject_arrow, category.assoc, ←iso.eq_inv_comp],
  ext,
  simp,
end

lemma comp_eq_zero_of_exact [exact f g] {X Y : V} {ι : X ⟶ B} (hι : ι ≫ g = 0) {π : B ⟶ Y}
  (hπ : f ≫ π = 0) : ι ≫ π = 0 :=
by rw [←kernel.lift_ι _ _ hι, ←cokernel.π_desc _ _ hπ, category.assoc, kernel_comp_cokernel_assoc,
  zero_comp, comp_zero]

@[simp, reassoc] lemma fork_ι_comp_cofork_π [exact f g] (s : kernel_fork g)
  (t : cokernel_cofork f) : fork.ι s ≫ cofork.π t = 0 :=
comp_eq_zero_of_exact f g (kernel_fork.condition s) (cokernel_cofork.condition t)

end has_cokernels

section
variables [has_zero_object V]

open_locale zero_object

section
variables [has_zero_morphisms V] [has_kernels V]

instance exact_of_zero {A C : V} (f : A ⟶ 0) (g : 0 ⟶ C) : exact f g :=
begin
  obtain rfl : f = 0 := by ext,
  obtain rfl : g = 0 := by ext,
  fsplit,
  { simp, },
  { exact image_to_kernel_epi_of_zero_of_mono 0, },
end

instance exact_zero_mono {B C : V} (f : B ⟶ C) [mono f] : exact (0 : (0 ⟶ B)) f :=
⟨by simp, infer_instance⟩

instance exact_epi_zero {A B : V} (f : A ⟶ B) [epi f] : exact f (0 : (B ⟶ 0)) :=
⟨by simp, infer_instance⟩

end

section
variables [preadditive V]

lemma mono_iff_exact_zero_left [has_kernels V]{B C : V} (f : B ⟶ C) :
  mono f ↔ exact (0 : (0 ⟶ B)) f :=
⟨λ h, by { resetI, apply_instance, },
  λ h, preadditive.mono_of_kernel_iso_zero
      ((kernel_subobject_iso f).symm ≪≫ iso_zero_of_epi_zero (by simpa using h.epi))⟩

lemma epi_iff_exact_zero_right [has_equalizers V] {A B : V} (f : A ⟶ B) :
  epi f ↔ exact f (0 : (B ⟶ 0)) :=
⟨λ h, by { resetI, apply_instance, },
  λ h, begin
    have e₁ := h.epi,
    rw image_to_kernel_zero_right at e₁,
    have e₂ : epi (((image_subobject f).arrow ≫ inv (kernel_subobject 0).arrow) ≫
      (kernel_subobject 0).arrow) := @epi_comp _ _ _ _ _ _ e₁ _ _,
    rw [category.assoc, is_iso.inv_hom_id, category.comp_id] at e₂,
    rw [←image_subobject_arrow] at e₂,
    resetI,
    haveI : epi (image.ι f) := epi_of_epi (image_subobject_iso f).hom (image.ι f),
    apply epi_of_epi_image,
  end⟩

end

end

end category_theory


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import category_theory.fin_category
import category_theory.limits.cones
import category_theory.adjunction.basic
import order.bounded_lattice

/-!
# Filtered categories

A category is filtered if every finite diagram admits a cocone.
We give a simple characterisation of this condition as
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

Filtered colimits are often better behaved than arbitrary colimits.
See `category_theory/limits/types` for some details.

Filtered categories are nice because colimits indexed by filtered categories tend to be
easier to describe than general colimits (and often often preserved by functors).

In this file we show that any functor from a finite category to a filtered category admits a cocone:
* `cocone_nonempty [fin_category J] [is_filtered C] (F : J ⥤ C) : nonempty (cocone F)`
More generally,
for any finite collection of objects and morphisms between them in a filtered category
(even if not closed under composition) there exists some object `Z` receiving maps from all of them,
so that all the triangles (one edge from the finite set, two from morphisms to `Z`) commute.
This formulation is often more useful in practice. We give two variants,
`sup_exists'`, which takes a single finset of objects, and a finset of morphisms
(bundled with their sources and targets), and
`sup_exists`, which takes a finset of objects, and an indexed family (indexed by source and target)
of finsets of morphisms.

## Future work
* Finite limits commute with filtered colimits
* Forgetful functors for algebraic categories typically preserve filtered colimits.
-/

universes v v₁ u u₁-- declare the `v`'s first; see `category_theory.category` for an explanation

namespace category_theory

variables (C : Type u) [category.{v} C]

/--
A category `is_filtered_or_empty` if
1. for every pair of objects there exists another object "to the right", and
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal.
-/
class is_filtered_or_empty : Prop :=
(cocone_objs : ∀ (X Y : C), ∃ Z (f : X ⟶ Z) (g : Y ⟶ Z), true)
(cocone_maps : ∀ ⦃X Y : C⦄ (f g : X ⟶ Y), ∃ Z (h : Y ⟶ Z), f ≫ h = g ≫ h)

/--
A category `is_filtered` if
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

See https://stacks.math.columbia.edu/tag/002V. (They also define a diagram being filtered.)
-/
class is_filtered extends is_filtered_or_empty C : Prop :=
[nonempty : nonempty C]

@[priority 100]
instance is_filtered_or_empty_of_semilattice_sup
  (α : Type u) [semilattice_sup α] : is_filtered_or_empty α :=
{ cocone_objs := λ X Y, ⟨X ⊔ Y, hom_of_le le_sup_left, hom_of_le le_sup_right, trivial⟩,
  cocone_maps := λ X Y f g, ⟨Y, 𝟙 _, (by ext)⟩, }

@[priority 100]
instance is_filtered_of_semilattice_sup_top
  (α : Type u) [semilattice_sup_top α] : is_filtered α :=
{ nonempty := ⟨⊤⟩,
  ..category_theory.is_filtered_or_empty_of_semilattice_sup α }

namespace is_filtered

variables {C} [is_filtered C]

/--
`max j j'` is an arbitrary choice of object to the right of both `j` and `j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def max (j j' : C) : C :=
(is_filtered_or_empty.cocone_objs j j').some

/--
`left_to_max j j'` is an arbitrarily choice of morphism from `j` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def left_to_max (j j' : C) : j ⟶ max j j' :=
(is_filtered_or_empty.cocone_objs j j').some_spec.some

/--
`right_to_max j j'` is an arbitrarily choice of morphism from `j'` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def right_to_max (j j' : C) : j' ⟶ max j j' :=
(is_filtered_or_empty.cocone_objs j j').some_spec.some_spec.some

/--
`coeq f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of object
which admits a morphism `coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq {j j' : C} (f f' : j ⟶ j') : C :=
(is_filtered_or_empty.cocone_maps f f').some

/--
`coeq_hom f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of morphism
`coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq_hom {j j' : C} (f f' : j ⟶ j') : j' ⟶ coeq f f' :=
(is_filtered_or_empty.cocone_maps f f').some_spec.some

/--
`coeq_condition f f'`, for morphisms `f f' : j ⟶ j'`, is the proof that
`f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
-/
@[simp, reassoc]
lemma coeq_condition {j j' : C} (f f' : j ⟶ j') : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f' :=
(is_filtered_or_empty.cocone_maps f f').some_spec.some_spec

open category_theory.limits

/--
Any finite collection of objects in a filtered category has an object "to the right".
-/
lemma sup_objs_exists (O : finset C) : ∃ (S : C), ∀ {X}, X ∈ O → _root_.nonempty (X ⟶ S) :=
begin
  classical,
  apply finset.induction_on O,
  { exact ⟨is_filtered.nonempty.some, (by rintros - ⟨⟩)⟩, },
  { rintros X O' nm ⟨S', w'⟩,
    use max X S',
    rintros Y mY,
    by_cases h : X = Y,
    { subst h, exact ⟨left_to_max _ _⟩, },
    { exact ⟨(w' (by finish)).some ≫ right_to_max _ _⟩, }, }
end

variables (O : finset C) (H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y))

/--
Given any `finset` of objects `{X, ...}` and
indexed collection of `finset`s of morphisms `{f, ...}` in `C`,
there exists an object `S`, with a morphism `T X : X ⟶ S` from each `X`,
such that the triangles commute: `f ≫ T X = T Y`, for `f : X ⟶ Y` in the `finset`.
-/
lemma sup_exists :
  ∃ (S : C) (T : Π {X : C}, X ∈ O → (X ⟶ S)), ∀ {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y},
    (⟨X, Y, mX, mY, f⟩ : (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y)) ∈ H → f ≫ T mY = T mX :=
begin
  classical,
  apply finset.induction_on H,
  { obtain ⟨S, f⟩ := sup_objs_exists O,
    refine ⟨S, λ X mX, (f mX).some, _⟩,
    rintros - - - - - ⟨⟩, },
  { rintros ⟨X, Y, mX, mY, f⟩ H' nmf ⟨S', T', w'⟩,
    refine ⟨coeq (f ≫ T' mY) (T' mX), λ Z mZ, T' mZ ≫ coeq_hom (f ≫ T' mY) (T' mX), _⟩,
    intros X' Y' mX' mY' f' mf',
    rw [←category.assoc],
    by_cases h : X = X' ∧ Y = Y',
    { rcases h with ⟨rfl, rfl⟩,
      by_cases hf : f = f',
      { subst hf,
        apply coeq_condition, },
      { rw @w' _ _ mX mY f' (by simpa [hf ∘ eq.symm] using mf') }, },
    { rw @w' _ _ mX' mY' f' (by finish), }, },
end

/--
An arbitrary choice of object "to the right"
of a finite collection of objects `O` and morphisms `H`,
making all the triangles commute.
-/
noncomputable
def sup : C :=
(sup_exists O H).some

/--
The morphisms to `sup O H`.
-/
noncomputable
def to_sup {X : C} (m : X ∈ O) :
  X ⟶ sup O H :=
(sup_exists O H).some_spec.some m

/--
The triangles of consisting of a morphism in `H` and the maps to `sup O H` commute.
-/
lemma to_sup_commutes
  {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y}
  (mf : (⟨X, Y, mX, mY, f⟩ : Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) ∈ H) :
  f ≫ to_sup O H mY = to_sup O H mX :=
(sup_exists O H).some_spec.some_spec mX mY mf

variables {J : Type v} [small_category J] [fin_category J]

/--
If we have `is_filtered C`, then for any functor `F : J ⥤ C` with `fin_category J`,
there exists a cocone over `F`.
-/
lemma cocone_nonempty (F : J ⥤ C) : _root_.nonempty (cocone F) :=
begin
  classical,
  let O := (finset.univ.image F.obj),
  let H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) :=
    finset.univ.bUnion (λ X : J, finset.univ.bUnion (λ Y : J, finset.univ.image (λ f : X ⟶ Y,
      ⟨F.obj X, F.obj Y, by simp, by simp, F.map f⟩))),
  obtain ⟨Z, f, w⟩ := sup_exists O H,
  refine ⟨⟨Z, ⟨λ X, f (by simp), _⟩⟩⟩,
  intros j j' g,
  dsimp,
  simp only [category.comp_id],
  apply w,
  simp only [finset.mem_univ, finset.mem_bUnion, exists_and_distrib_left,
    exists_prop_of_true, finset.mem_image],
  exact ⟨j, rfl, j', g, (by simp)⟩,
end

/--
An arbitrary choice of cocone over `F : J ⥤ C`, for `fin_category J` and `is_filtered C`.
-/
noncomputable def cocone (F : J ⥤ C) : cocone F :=
(cocone_nonempty F).some

variables {D : Type u₁} [category.{v₁} D]

/--
If `C` is filtered, and we have a functor `R : C ⥤ D` with a left adjoint, then `D` is filtered.
-/
lemma of_right_adjoint {L : D ⥤ C} {R : C ⥤ D} (h : L ⊣ R) : is_filtered D :=
{ cocone_objs := λ X Y,
    ⟨_, h.hom_equiv _ _ (left_to_max _ _), h.hom_equiv _ _ (right_to_max _ _), ⟨⟩⟩,
  cocone_maps := λ X Y f g,
    ⟨_, h.hom_equiv _ _ (coeq_hom _ _),
     by rw [← h.hom_equiv_naturality_left, ← h.hom_equiv_naturality_left, coeq_condition]⟩,
  nonempty := is_filtered.nonempty.map R.obj }

/-- If `C` is filtered, and we have a right adjoint functor `R : C ⥤ D`, then `D` is filtered. -/
lemma of_is_right_adjoint (R : C ⥤ D) [is_right_adjoint R] : is_filtered D :=
of_right_adjoint (adjunction.of_right_adjoint R)

/-- Being filtered is preserved by equivalence of categories. -/
lemma of_equivalence (h : C ≌ D) : is_filtered D :=
of_right_adjoint h.symm.to_adjunction

end is_filtered

end category_theory