/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.finset.image

/-!
# Finite types

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines a typeclass to state that a type is finite.

## Main declarations

* `fintype α`:  Typeclass saying that a type is finite. It takes as fields a `finset` and a proof
  that all terms of type `α` are in it.
* `finset.univ`: The finset of all elements of a fintype.

See `data.fintype.card` for the cardinality of a fintype,
the equivalence with `fin (fintype.card α)`, and pigeonhole principles.

## Instances

Instances for `fintype` for
* `{x // p x}` are in this file as `fintype.subtype`
* `option α` are in `data.fintype.option`
* `α × β` are in `data.fintype.prod`
* `α ⊕ β` are in `data.fintype.sum`
* `Σ (a : α), β a` are in `data.fintype.sigma`

These files also contain appropriate `infinite` instances for these types.

`infinite` instances for `ℕ`, `ℤ`, `multiset α`, and `list α` are in `data.fintype.lattice`.

Types which have a surjection from/an injection to a `fintype` are themselves fintypes.
See `fintype.of_injective` and `fintype.of_surjective`.
-/

open function
open_locale nat

universes u v

variables {α β γ : Type*}

/-- `fintype α` means that `α` is finite, i.e. there are only
  finitely many distinct elements of type `α`. The evidence of this
  is a finset `elems` (a list up to permutation without duplicates),
  together with a proof that everything of type `α` is in the list. -/
class fintype (α : Type*) :=
(elems [] : finset α)
(complete : ∀ x : α, x ∈ elems)

namespace finset
variables [fintype α] {s t : finset α}

/-- `univ` is the universal finite set of type `finset α` implied from
  the assumption `fintype α`. -/
def univ : finset α := fintype.elems α

@[simp] theorem mem_univ (x : α) : x ∈ (univ : finset α) :=
fintype.complete x

@[simp] theorem mem_univ_val : ∀ x, x ∈ (univ : finset α).1 := mem_univ

lemma eq_univ_iff_forall : s = univ ↔ ∀ x, x ∈ s := by simp [ext_iff]
lemma eq_univ_of_forall  : (∀ x, x ∈ s) → s = univ := eq_univ_iff_forall.2

@[simp, norm_cast] lemma coe_univ : ↑(univ : finset α) = (set.univ : set α) := by ext; simp
@[simp, norm_cast] lemma coe_eq_univ : (s : set α) = set.univ ↔ s = univ :=
by rw [←coe_univ, coe_inj]

lemma nonempty.eq_univ [subsingleton α] : s.nonempty → s = univ :=
by { rintro ⟨x, hx⟩, refine eq_univ_of_forall (λ y, by rwa subsingleton.elim y x) }

lemma univ_nonempty_iff : (univ : finset α).nonempty ↔ nonempty α :=
by rw [← coe_nonempty, coe_univ, set.nonempty_iff_univ_nonempty]

lemma univ_nonempty [nonempty α] : (univ : finset α).nonempty :=
univ_nonempty_iff.2 ‹_›

lemma univ_eq_empty_iff : (univ : finset α) = ∅ ↔ is_empty α :=
by rw [← not_nonempty_iff, ← univ_nonempty_iff, not_nonempty_iff_eq_empty]

@[simp] lemma univ_eq_empty [is_empty α] : (univ : finset α) = ∅ := univ_eq_empty_iff.2 ‹_›

@[simp] lemma univ_unique [unique α] : (univ : finset α) = {default} :=
finset.ext $ λ x, iff_of_true (mem_univ _) $ mem_singleton.2 $ subsingleton.elim x default

@[simp] theorem subset_univ (s : finset α) : s ⊆ univ := λ a _, mem_univ a

instance : bounded_order (finset α) :=
{ top := univ,
  le_top := subset_univ,
  .. finset.order_bot }

@[simp] lemma top_eq_univ : (⊤ : finset α) = univ := rfl

lemma ssubset_univ_iff {s : finset α} : s ⊂ univ ↔ s ≠ univ := @lt_top_iff_ne_top _ _ _ s

lemma codisjoint_left : codisjoint s t ↔ ∀ ⦃a⦄, a ∉ s → a ∈ t :=
by { classical, simp [codisjoint_iff, eq_univ_iff_forall, or_iff_not_imp_left] }

lemma codisjoint_right : codisjoint s t ↔ ∀ ⦃a⦄, a ∉ t → a ∈ s :=
codisjoint.comm.trans codisjoint_left

section boolean_algebra
variables [decidable_eq α] {a : α}

instance : boolean_algebra (finset α) := generalized_boolean_algebra.to_boolean_algebra

lemma sdiff_eq_inter_compl (s t : finset α) : s \ t = s ∩ tᶜ := sdiff_eq

lemma compl_eq_univ_sdiff (s : finset α) : sᶜ = univ \ s := rfl

@[simp] lemma mem_compl : a ∈ sᶜ ↔ a ∉ s := by simp [compl_eq_univ_sdiff]

lemma not_mem_compl : a ∉ sᶜ ↔ a ∈ s := by rw [mem_compl, not_not]

@[simp, norm_cast] lemma coe_compl (s : finset α) : ↑(sᶜ) = (↑s : set α)ᶜ :=
set.ext $ λ x, mem_compl

@[simp] lemma compl_empty : (∅ : finset α)ᶜ = univ := compl_bot

@[simp] lemma compl_univ : (univ : finset α)ᶜ = ∅ := compl_top

@[simp] lemma compl_eq_empty_iff (s : finset α) : sᶜ = ∅ ↔ s = univ := compl_eq_bot

@[simp] lemma compl_eq_univ_iff (s : finset α) : sᶜ = univ ↔ s = ∅ := compl_eq_top

@[simp] lemma union_compl (s : finset α) : s ∪ sᶜ = univ := sup_compl_eq_top

@[simp] lemma inter_compl (s : finset α) : s ∩ sᶜ = ∅ := inf_compl_eq_bot

@[simp] lemma compl_union (s t : finset α) : (s ∪ t)ᶜ = sᶜ ∩ tᶜ := compl_sup

@[simp] lemma compl_inter (s t : finset α) : (s ∩ t)ᶜ = sᶜ ∪ tᶜ := compl_inf

@[simp] lemma compl_erase : (s.erase a)ᶜ = insert a sᶜ :=
by { ext, simp only [or_iff_not_imp_left, mem_insert, not_and, mem_compl, mem_erase] }

@[simp] lemma compl_insert : (insert a s)ᶜ = sᶜ.erase a :=
by { ext, simp only [not_or_distrib, mem_insert, iff_self, mem_compl, mem_erase] }

@[simp] lemma insert_compl_self (x : α) : insert x ({x}ᶜ : finset α) = univ :=
by rw [←compl_erase, erase_singleton, compl_empty]

@[simp] lemma compl_filter (p : α → Prop) [decidable_pred p] [Π x, decidable (¬p x)] :
  (univ.filter p)ᶜ = univ.filter (λ x, ¬p x) :=
(filter_not _ _).symm

lemma compl_ne_univ_iff_nonempty (s : finset α) : sᶜ ≠ univ ↔ s.nonempty :=
by simp [eq_univ_iff_forall, finset.nonempty]

lemma compl_singleton (a : α) : ({a} : finset α)ᶜ = univ.erase a :=
by rw [compl_eq_univ_sdiff, sdiff_singleton_eq_erase]

lemma insert_inj_on' (s : finset α) : set.inj_on (λ a, insert a s) (sᶜ : finset α) :=
by { rw coe_compl, exact s.insert_inj_on }

lemma image_univ_of_surjective [fintype β] {f : β → α} (hf : surjective f) : univ.image f = univ :=
eq_univ_of_forall $ hf.forall.2 $ λ _, mem_image_of_mem _ $ mem_univ _

end boolean_algebra

lemma map_univ_of_surjective [fintype β] {f : β ↪ α} (hf : surjective f) : univ.map f = univ :=
eq_univ_of_forall $ hf.forall.2 $ λ _, mem_map_of_mem _ $ mem_univ _

@[simp] lemma map_univ_equiv [fintype β] (f : β ≃ α) : univ.map f.to_embedding = univ :=
map_univ_of_surjective f.surjective

@[simp] lemma univ_inter [decidable_eq α] (s : finset α) :
  univ ∩ s = s := ext $ λ a, by simp

@[simp] lemma inter_univ [decidable_eq α] (s : finset α) :
  s ∩ univ = s :=
by rw [inter_comm, univ_inter]

@[simp] lemma piecewise_univ [Π i : α, decidable (i ∈ (univ : finset α))]
  {δ : α → Sort*} (f g : Π i, δ i) : univ.piecewise f g = f :=
by { ext i, simp [piecewise] }

lemma piecewise_compl [decidable_eq α] (s : finset α) [Π i : α, decidable (i ∈ s)]
  [Π i : α, decidable (i ∈ sᶜ)] {δ : α → Sort*} (f g : Π i, δ i) :
  sᶜ.piecewise f g = s.piecewise g f :=
by { ext i, simp [piecewise] }

@[simp] lemma piecewise_erase_univ {δ : α → Sort*} [decidable_eq α] (a : α) (f g : Π a, δ a) :
  (finset.univ.erase a).piecewise f g = function.update f a (g a) :=
by rw [←compl_singleton, piecewise_compl, piecewise_singleton]

lemma univ_map_equiv_to_embedding {α β : Type*} [fintype α] [fintype β] (e : α ≃ β) :
  univ.map e.to_embedding = univ :=
eq_univ_iff_forall.mpr (λ b, mem_map.mpr ⟨e.symm b, mem_univ _, by simp⟩)

@[simp] lemma univ_filter_exists (f : α → β) [fintype β]
  [decidable_pred (λ y, ∃ x, f x = y)] [decidable_eq β] :
  finset.univ.filter (λ y, ∃ x, f x = y) = finset.univ.image f :=
by { ext, simp }

/-- Note this is a special case of `(finset.image_preimage f univ _).symm`. -/
lemma univ_filter_mem_range (f : α → β) [fintype β]
  [decidable_pred (λ y, y ∈ set.range f)] [decidable_eq β] :
  finset.univ.filter (λ y, y ∈ set.range f) = finset.univ.image f :=
univ_filter_exists f

lemma coe_filter_univ (p : α → Prop) [decidable_pred p] : (univ.filter p : set α) = {x | p x} :=
by rw [coe_filter, coe_univ, set.sep_univ]

end finset

open finset function

namespace fintype

instance decidable_pi_fintype {α} {β : α → Type*} [∀ a, decidable_eq (β a)] [fintype α] :
  decidable_eq (Π a, β a) :=
λ f g, decidable_of_iff (∀ a ∈ fintype.elems α, f a = g a)
  (by simp [function.funext_iff, fintype.complete])

instance decidable_forall_fintype {p : α → Prop} [decidable_pred p] [fintype α] :
  decidable (∀ a, p a) :=
decidable_of_iff (∀ a ∈ @univ α _, p a) (by simp)

instance decidable_exists_fintype {p : α → Prop} [decidable_pred p] [fintype α] :
  decidable (∃ a, p a) :=
decidable_of_iff (∃ a ∈ @univ α _, p a) (by simp)

instance decidable_mem_range_fintype [fintype α] [decidable_eq β] (f : α → β) :
  decidable_pred (∈ set.range f) :=
λ x, fintype.decidable_exists_fintype

section bundled_homs

instance decidable_eq_equiv_fintype [decidable_eq β] [fintype α] :
  decidable_eq (α ≃ β) :=
λ a b, decidable_of_iff (a.1 = b.1) equiv.coe_fn_injective.eq_iff

instance decidable_eq_embedding_fintype [decidable_eq β] [fintype α] :
  decidable_eq (α ↪ β) :=
λ a b, decidable_of_iff ((a : α → β) = b) function.embedding.coe_injective.eq_iff

@[to_additive]
instance decidable_eq_one_hom_fintype [decidable_eq β] [fintype α] [has_one α] [has_one β]:
  decidable_eq (one_hom α β) :=
λ a b, decidable_of_iff ((a : α → β) = b) (injective.eq_iff one_hom.coe_inj)

@[to_additive]
instance decidable_eq_mul_hom_fintype [decidable_eq β] [fintype α] [has_mul α] [has_mul β]:
  decidable_eq (α →ₙ* β) :=
λ a b, decidable_of_iff ((a : α → β) = b) (injective.eq_iff mul_hom.coe_inj)

@[to_additive]
instance decidable_eq_monoid_hom_fintype [decidable_eq β] [fintype α]
  [mul_one_class α] [mul_one_class β]:
  decidable_eq (α →* β) :=
λ a b, decidable_of_iff ((a : α → β) = b) (injective.eq_iff monoid_hom.coe_inj)

instance decidable_eq_monoid_with_zero_hom_fintype [decidable_eq β] [fintype α]
  [mul_zero_one_class α] [mul_zero_one_class β] :
  decidable_eq (α →*₀ β) :=
λ a b, decidable_of_iff ((a : α → β) = b) (injective.eq_iff monoid_with_zero_hom.coe_inj)

instance decidable_eq_ring_hom_fintype [decidable_eq β] [fintype α]
  [semiring α] [semiring β]:
  decidable_eq (α →+* β) :=
λ a b, decidable_of_iff ((a : α → β) = b) (injective.eq_iff ring_hom.coe_inj)

end bundled_homs

instance decidable_injective_fintype [decidable_eq α] [decidable_eq β] [fintype α] :
  decidable_pred (injective : (α → β) → Prop) := λ x, by unfold injective; apply_instance

instance decidable_surjective_fintype [decidable_eq β] [fintype α] [fintype β] :
  decidable_pred (surjective : (α → β) → Prop) := λ x, by unfold surjective; apply_instance

instance decidable_bijective_fintype [decidable_eq α] [decidable_eq β] [fintype α] [fintype β] :
  decidable_pred (bijective : (α → β) → Prop) := λ x, by unfold bijective; apply_instance

instance decidable_right_inverse_fintype [decidable_eq α] [fintype α] (f : α → β) (g : β → α) :
  decidable (function.right_inverse f g) :=
show decidable (∀ x, g (f x) = x), by apply_instance

instance decidable_left_inverse_fintype [decidable_eq β] [fintype β] (f : α → β) (g : β → α) :
  decidable (function.left_inverse f g) :=
show decidable (∀ x, f (g x) = x), by apply_instance

/-- Construct a proof of `fintype α` from a universal multiset -/
def of_multiset [decidable_eq α] (s : multiset α) (H : ∀ x : α, x ∈ s) :
  fintype α :=
⟨s.to_finset, by simpa using H⟩

/-- Construct a proof of `fintype α` from a universal list -/
def of_list [decidable_eq α] (l : list α) (H : ∀ x : α, x ∈ l) :
  fintype α :=
⟨l.to_finset, by simpa using H⟩

instance (α : Type*) : subsingleton (fintype α) :=
⟨λ ⟨s₁, h₁⟩ ⟨s₂, h₂⟩, by congr; simp [finset.ext_iff, h₁, h₂]⟩

/-- Given a predicate that can be represented by a finset, the subtype
associated to the predicate is a fintype. -/
protected def subtype {p : α → Prop} (s : finset α) (H : ∀ x : α, x ∈ s ↔ p x) :
  fintype {x // p x} :=
⟨⟨s.1.pmap subtype.mk (λ x, (H x).1),
  s.nodup.pmap $ λ a _ b _, congr_arg subtype.val⟩,
λ ⟨x, px⟩, multiset.mem_pmap.2 ⟨x, (H x).2 px, rfl⟩⟩

/-- Construct a fintype from a finset with the same elements. -/
def of_finset {p : set α} (s : finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) : fintype p :=
fintype.subtype s H

/-- If `f : α → β` is a bijection and `α` is a fintype, then `β` is also a fintype. -/
def of_bijective [fintype α] (f : α → β) (H : function.bijective f) : fintype β :=
⟨univ.map ⟨f, H.1⟩,
λ b, let ⟨a, e⟩ := H.2 b in e ▸ mem_map_of_mem _ (mem_univ _)⟩

/-- If `f : α → β` is a surjection and `α` is a fintype, then `β` is also a fintype. -/
def of_surjective [decidable_eq β] [fintype α] (f : α → β) (H : function.surjective f) :
  fintype β :=
⟨univ.image f, λ b, let ⟨a, e⟩ := H b in e ▸ mem_image_of_mem _ (mem_univ _)⟩

end fintype

namespace finset
variables [fintype α] [decidable_eq α] {s t : finset α}

instance decidable_codisjoint : decidable (codisjoint s t) :=
decidable_of_iff _ codisjoint_left.symm

instance decidable_is_compl : decidable (is_compl s t) := decidable_of_iff' _ is_compl_iff

end finset

section inv

namespace function

variables [fintype α] [decidable_eq β]

namespace injective

variables {f : α → β} (hf : function.injective f)

/--
The inverse of an `hf : injective` function `f : α → β`, of the type `↥(set.range f) → α`.
This is the computable version of `function.inv_fun` that requires `fintype α` and `decidable_eq β`,
or the function version of applying `(equiv.of_injective f hf).symm`.
This function should not usually be used for actual computation because for most cases,
an explicit inverse can be stated that has better computational properties.
This function computes by checking all terms `a : α` to find the `f a = b`, so it is O(N) where
`N = fintype.card α`.
-/
def inv_of_mem_range : set.range f → α :=
λ b, finset.choose (λ a, f a = b) finset.univ ((exists_unique_congr (by simp)).mp
  (hf.exists_unique_of_mem_range b.property))

lemma left_inv_of_inv_of_mem_range (b : set.range f) :
  f (hf.inv_of_mem_range b) = b :=
(finset.choose_spec (λ a, f a = b) _ _).right

@[simp] lemma right_inv_of_inv_of_mem_range (a : α) :
  hf.inv_of_mem_range (⟨f a, set.mem_range_self a⟩) = a :=
hf (finset.choose_spec (λ a', f a' = f a) _ _).right

lemma inv_fun_restrict [nonempty α] :
  (set.range f).restrict (inv_fun f) = hf.inv_of_mem_range :=
begin
  ext ⟨b, h⟩,
  apply hf,
  simp [hf.left_inv_of_inv_of_mem_range, @inv_fun_eq _ _ _ f b (set.mem_range.mp h)]
end

lemma inv_of_mem_range_surjective : function.surjective hf.inv_of_mem_range :=
λ a, ⟨⟨f a, set.mem_range_self a⟩, by simp⟩

end injective

namespace embedding
variables (f : α ↪ β) (b : set.range f)

/--
The inverse of an embedding `f : α ↪ β`, of the type `↥(set.range f) → α`.
This is the computable version of `function.inv_fun` that requires `fintype α` and `decidable_eq β`,
or the function version of applying `(equiv.of_injective f f.injective).symm`.
This function should not usually be used for actual computation because for most cases,
an explicit inverse can be stated that has better computational properties.
This function computes by checking all terms `a : α` to find the `f a = b`, so it is O(N) where
`N = fintype.card α`.
-/
def inv_of_mem_range : α :=
f.injective.inv_of_mem_range b

@[simp] lemma left_inv_of_inv_of_mem_range :
  f (f.inv_of_mem_range b) = b :=
f.injective.left_inv_of_inv_of_mem_range b

@[simp] lemma right_inv_of_inv_of_mem_range (a : α) :
  f.inv_of_mem_range ⟨f a, set.mem_range_self a⟩ = a :=
f.injective.right_inv_of_inv_of_mem_range a

lemma inv_fun_restrict [nonempty α] :
  (set.range f).restrict (inv_fun f) = f.inv_of_mem_range :=
begin
  ext ⟨b, h⟩,
  apply f.injective,
  simp [f.left_inv_of_inv_of_mem_range, @inv_fun_eq _ _ _ f b (set.mem_range.mp h)]
end

lemma inv_of_mem_range_surjective : function.surjective f.inv_of_mem_range :=
λ a, ⟨⟨f a, set.mem_range_self a⟩, by simp⟩

end embedding

end function

end inv

namespace fintype

/-- Given an injective function to a fintype, the domain is also a
fintype. This is noncomputable because injectivity alone cannot be
used to construct preimages. -/
noncomputable def of_injective [fintype β] (f : α → β) (H : function.injective f) : fintype α :=
by letI := classical.dec; exact
if hα : nonempty α then by letI := classical.inhabited_of_nonempty hα;
  exact of_surjective (inv_fun f) (inv_fun_surjective H)
else ⟨∅, λ x, (hα ⟨x⟩).elim⟩

/-- If `f : α ≃ β` and `α` is a fintype, then `β` is also a fintype. -/
def of_equiv (α : Type*) [fintype α] (f : α ≃ β) : fintype β := of_bijective _ f.bijective

/-- Any subsingleton type with a witness is a fintype (with one term). -/
def of_subsingleton (a : α) [subsingleton α] : fintype α :=
⟨{a}, λ b, finset.mem_singleton.2 (subsingleton.elim _ _)⟩

@[simp] theorem univ_of_subsingleton (a : α) [subsingleton α] :
  @univ _ (of_subsingleton a) = {a} := rfl

@[priority 100] -- see Note [lower instance priority]
instance of_is_empty [is_empty α] : fintype α := ⟨∅, is_empty_elim⟩

/-- Note: this lemma is specifically about `fintype.of_is_empty`. For a statement about
arbitrary `fintype` instances, use `finset.univ_eq_empty`. -/
-- no-lint since while `finset.univ_eq_empty` can prove this, it isn't applicable for `dsimp`.
@[simp, nolint simp_nf] theorem univ_of_is_empty [is_empty α] : @univ α _ = ∅ := rfl

end fintype

namespace set
variables {s t : set α}

/-- Construct a finset enumerating a set `s`, given a `fintype` instance.  -/
def to_finset (s : set α) [fintype s] : finset α :=
(@finset.univ s _).map $ function.embedding.subtype _

@[congr]
lemma to_finset_congr {s t : set α} [fintype s] [fintype t] (h : s = t) :
  to_finset s = to_finset t :=
by cc

@[simp] theorem mem_to_finset {s : set α} [fintype s] {a : α} : a ∈ s.to_finset ↔ a ∈ s :=
by simp [to_finset]

/-- Many `fintype` instances for sets are defined using an extensionally equal `finset`.
Rewriting `s.to_finset` with `set.to_finset_of_finset` replaces the term with such a `finset`. -/
theorem to_finset_of_finset {p : set α} (s : finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) :
  @set.to_finset _ p (fintype.of_finset s H) = s :=
finset.ext (λ x, by rw [mem_to_finset, H])

/-- Membership of a set with a `fintype` instance is decidable.

Using this as an instance leads to potential loops with `subtype.fintype` under certain decidability
assumptions, so it should only be declared a local instance. -/
def decidable_mem_of_fintype [decidable_eq α] (s : set α) [fintype s] (a) : decidable (a ∈ s) :=
decidable_of_iff _ mem_to_finset

@[simp] theorem coe_to_finset (s : set α) [fintype s] : (↑s.to_finset : set α) = s :=
set.ext $ λ _, mem_to_finset

@[simp] lemma to_finset_nonempty {s : set α} [fintype s] : s.to_finset.nonempty ↔ s.nonempty :=
by rw [←finset.coe_nonempty, coe_to_finset]

@[simp] theorem to_finset_inj {s t : set α} [fintype s] [fintype t] :
  s.to_finset = t.to_finset ↔ s = t :=
⟨λ h, by rw [←s.coe_to_finset, h, t.coe_to_finset], λ h, by simp [h]; congr⟩

@[mono]
lemma to_finset_subset_to_finset [fintype s] [fintype t] : s.to_finset ⊆ t.to_finset ↔ s ⊆ t :=
by simp [finset.subset_iff, set.subset_def]

@[simp] lemma to_finset_ssubset [fintype s] {t : finset α} : s.to_finset ⊂ t ↔ s ⊂ t :=
by rw [←finset.coe_ssubset, coe_to_finset]

@[simp] lemma subset_to_finset {s : finset α} [fintype t] : s ⊆ t.to_finset ↔ ↑s ⊆ t :=
by rw [←finset.coe_subset, coe_to_finset]

@[simp] lemma ssubset_to_finset {s : finset α} [fintype t] : s ⊂ t.to_finset ↔ ↑s ⊂ t :=
by rw [←finset.coe_ssubset, coe_to_finset]

@[mono]
lemma to_finset_ssubset_to_finset [fintype s] [fintype t] : s.to_finset ⊂ t.to_finset ↔ s ⊂ t :=
by simp only [finset.ssubset_def, to_finset_subset_to_finset, ssubset_def]

@[simp] lemma to_finset_subset [fintype s] {t : finset α} : s.to_finset ⊆ t ↔ s ⊆ t :=
by rw [←finset.coe_subset, coe_to_finset]

alias to_finset_subset_to_finset ↔ _ to_finset_mono
alias to_finset_ssubset_to_finset ↔ _ to_finset_strict_mono

@[simp] lemma disjoint_to_finset [fintype s] [fintype t] :
  disjoint s.to_finset t.to_finset ↔ disjoint s t :=
by simp only [←disjoint_coe, coe_to_finset]

section decidable_eq
variables [decidable_eq α] (s t) [fintype s] [fintype t]

@[simp] lemma to_finset_inter [fintype ↥(s ∩ t)] : (s ∩ t).to_finset = s.to_finset ∩ t.to_finset :=
by { ext, simp }

@[simp] lemma to_finset_union [fintype ↥(s ∪ t)] : (s ∪ t).to_finset = s.to_finset ∪ t.to_finset :=
by { ext, simp }

@[simp] lemma to_finset_diff [fintype ↥(s \ t)] : (s \ t).to_finset = s.to_finset \ t.to_finset :=
by { ext, simp }

@[simp] lemma to_finset_symm_diff [fintype ↥(s ∆ t)] :
  (s ∆ t).to_finset = s.to_finset ∆ t.to_finset :=
by { ext, simp [mem_symm_diff, finset.mem_symm_diff] }

@[simp] lemma to_finset_compl [fintype α] [fintype ↥sᶜ] : sᶜ.to_finset = s.to_finsetᶜ :=
by { ext, simp }

end decidable_eq

/- TODO The `↥` circumvents an elaboration bug. See comment on `set.to_finset_univ`. -/
@[simp] lemma to_finset_empty [fintype ↥(∅ : set α)] : (∅ : set α).to_finset = ∅ := by { ext, simp }

/- TODO Without the coercion arrow (`↥`) there is an elaboration bug in the following two;
it essentially infers `fintype.{v} (set.univ.{u} : set α)` with `v` and `u` distinct.
Reported in leanprover-community/lean#672 -/
@[simp] lemma to_finset_univ [fintype α] [fintype ↥(set.univ : set α)] :
  (set.univ : set α).to_finset = finset.univ :=
by { ext, simp }

@[simp] lemma to_finset_eq_empty [fintype s] : s.to_finset = ∅ ↔ s = ∅ :=
by rw [←to_finset_empty, to_finset_inj]

@[simp] lemma to_finset_eq_univ [fintype α] [fintype s] : s.to_finset = finset.univ ↔ s = univ :=
by rw [← coe_inj, coe_to_finset, coe_univ]

@[simp] lemma to_finset_set_of [fintype α] (p : α → Prop) [decidable_pred p] [fintype {x | p x}] :
  {x | p x}.to_finset = finset.univ.filter p :=
by { ext, simp }

@[simp] lemma to_finset_ssubset_univ [fintype α] {s : set α} [fintype s] :
  s.to_finset ⊂ finset.univ ↔ s ⊂ univ :=
by rw [← coe_ssubset, coe_to_finset, coe_univ]

@[simp]
lemma to_finset_image [decidable_eq β] (f : α → β) (s : set α) [fintype s] [fintype (f '' s)] :
  (f '' s).to_finset = s.to_finset.image f :=
finset.coe_injective $ by simp

@[simp] lemma to_finset_range [decidable_eq α] [fintype β] (f : β → α) [fintype (set.range f)] :
  (set.range f).to_finset = finset.univ.image f :=
by { ext, simp }

/- TODO The `↥` circumvents an elaboration bug. See comment on `set.to_finset_univ`. -/
lemma to_finset_singleton (a : α) [fintype ↥({a} : set α)] : ({a} : set α).to_finset = {a} :=
by { ext, simp }

/- TODO The `↥` circumvents an elaboration bug. See comment on `set.to_finset_univ`. -/
@[simp] lemma to_finset_insert [decidable_eq α] {a : α} {s : set α}
  [fintype ↥(insert a s : set α)] [fintype s] :
  (insert a s).to_finset = insert a s.to_finset :=
by { ext, simp }

lemma filter_mem_univ_eq_to_finset [fintype α] (s : set α) [fintype s] [decidable_pred (∈ s)] :
  finset.univ.filter (∈ s) = s.to_finset :=
by { ext, simp only [mem_filter, finset.mem_univ, true_and, mem_to_finset] }

end set

@[simp] lemma finset.to_finset_coe (s : finset α) [fintype ↥(s : set α)] :
  (s : set α).to_finset = s :=
ext $ λ _, set.mem_to_finset

instance (n : ℕ) : fintype (fin n) :=
⟨⟨list.fin_range n, list.nodup_fin_range n⟩, list.mem_fin_range⟩

lemma fin.univ_def (n : ℕ) : (univ : finset (fin n)) = ⟨list.fin_range n, list.nodup_fin_range n⟩ :=
rfl

@[simp] lemma fin.image_succ_above_univ {n : ℕ} (i : fin (n + 1)) :
  univ.image i.succ_above = {i}ᶜ :=
by { ext m, simp }

@[simp] lemma fin.image_succ_univ (n : ℕ) : (univ : finset (fin n)).image fin.succ = {0}ᶜ :=
by rw [← fin.succ_above_zero, fin.image_succ_above_univ]

@[simp] lemma fin.image_cast_succ (n : ℕ) :
  (univ : finset (fin n)).image fin.cast_succ = {fin.last n}ᶜ :=
by rw [← fin.succ_above_last, fin.image_succ_above_univ]

/- The following three lemmas use `finset.cons` instead of `insert` and `finset.map` instead of
`finset.image` to reduce proof obligations downstream. -/

/-- Embed `fin n` into `fin (n + 1)` by prepending zero to the `univ` -/
lemma fin.univ_succ (n : ℕ) :
  (univ : finset (fin (n + 1))) =
    cons 0 (univ.map ⟨fin.succ, fin.succ_injective _⟩) (by simp [map_eq_image]) :=
by simp [map_eq_image]

/-- Embed `fin n` into `fin (n + 1)` by appending a new `fin.last n` to the `univ` -/
lemma fin.univ_cast_succ (n : ℕ) :
  (univ : finset (fin (n + 1))) =
    cons (fin.last n) (univ.map fin.cast_succ.to_embedding) (by simp [map_eq_image]) :=
by simp [map_eq_image]

/-- Embed `fin n` into `fin (n + 1)` by inserting
around a specified pivot `p : fin (n + 1)` into the `univ` -/
lemma fin.univ_succ_above (n : ℕ) (p : fin (n + 1)) :
  (univ : finset (fin (n + 1))) = cons p (univ.map $ (fin.succ_above p).to_embedding) (by simp) :=
by simp [map_eq_image]

@[instance, priority 10] def unique.fintype {α : Type*} [unique α] : fintype α :=
fintype.of_subsingleton default

/-- Short-circuit instance to decrease search for `unique.fintype`,
since that relies on a subsingleton elimination for `unique`. -/
instance fintype.subtype_eq (y : α) : fintype {x // x = y} :=
fintype.subtype {y} (by simp)

/-- Short-circuit instance to decrease search for `unique.fintype`,
since that relies on a subsingleton elimination for `unique`. -/
instance fintype.subtype_eq' (y : α) : fintype {x // y = x} :=
fintype.subtype {y} (by simp [eq_comm])

@[simp] theorem fintype.univ_empty : @univ empty _ = ∅ := rfl

@[simp] theorem fintype.univ_pempty : @univ pempty _ = ∅ := rfl

instance : fintype unit := fintype.of_subsingleton ()

theorem fintype.univ_unit : @univ unit _ = {()} := rfl

instance : fintype punit := fintype.of_subsingleton punit.star

@[simp] theorem fintype.univ_punit : @univ punit _ = {punit.star} := rfl

instance : fintype bool := ⟨⟨{tt, ff}, by simp⟩, λ x, by cases x; simp⟩

@[simp] theorem fintype.univ_bool : @univ bool _ = {tt, ff} := rfl

instance additive.fintype : Π [fintype α], fintype (additive α) := id

instance multiplicative.fintype : Π [fintype α], fintype (multiplicative α) := id

/-- Given that `α × β` is a fintype, `α` is also a fintype. -/
def fintype.prod_left {α β} [decidable_eq α] [fintype (α × β)] [nonempty β] : fintype α :=
⟨(fintype.elems (α × β)).image prod.fst,
  λ a, let ⟨b⟩ := ‹nonempty β› in by simp; exact ⟨b, fintype.complete _⟩⟩

/-- Given that `α × β` is a fintype, `β` is also a fintype. -/
def fintype.prod_right {α β} [decidable_eq β] [fintype (α × β)] [nonempty α] : fintype β :=
⟨(fintype.elems (α × β)).image prod.snd,
  λ b, let ⟨a⟩ := ‹nonempty α› in by simp; exact ⟨a, fintype.complete _⟩⟩

instance (α : Type*) [fintype α] : fintype (ulift α) :=
fintype.of_equiv _ equiv.ulift.symm

instance (α : Type*) [fintype α] : fintype (plift α) :=
fintype.of_equiv _ equiv.plift.symm

instance (α : Type*) [fintype α] : fintype αᵒᵈ := ‹fintype α›
instance (α : Type*) [finite α] : finite αᵒᵈ := ‹finite α›

instance (α : Type*) [fintype α] : fintype (lex α) := ‹fintype α›

section finset

/-! ### `fintype (s : finset α)` -/

instance finset.fintype_coe_sort {α : Type u} (s : finset α) : fintype s :=
⟨s.attach, s.mem_attach⟩

@[simp] lemma finset.univ_eq_attach {α : Type u} (s : finset α) :
  (univ : finset s) = s.attach :=
rfl

end finset

lemma fintype.coe_image_univ [fintype α] [decidable_eq β] {f : α → β} :
  ↑(finset.image f finset.univ) = set.range f :=
by { ext x, simp }

instance list.subtype.fintype [decidable_eq α] (l : list α) : fintype {x // x ∈ l} :=
fintype.of_list l.attach l.mem_attach

instance multiset.subtype.fintype [decidable_eq α] (s : multiset α) : fintype {x // x ∈ s} :=
fintype.of_multiset s.attach s.mem_attach

instance finset.subtype.fintype (s : finset α) : fintype {x // x ∈ s} :=
⟨s.attach, s.mem_attach⟩

instance finset_coe.fintype (s : finset α) : fintype (↑s : set α) :=
finset.subtype.fintype s

lemma finset.attach_eq_univ {s : finset α} : s.attach = finset.univ := rfl

instance plift.fintype_Prop (p : Prop) [decidable p] : fintype (plift p) :=
⟨if h : p then {⟨h⟩} else ∅, λ ⟨h⟩, by simp [h]⟩

instance Prop.fintype : fintype Prop :=
⟨⟨{true, false}, by simp [true_ne_false]⟩, classical.cases (by simp) (by simp)⟩

@[simp] lemma fintype.univ_Prop : (finset.univ : finset Prop) = {true, false} :=
finset.eq_of_veq $ by simp; refl

instance subtype.fintype (p : α → Prop) [decidable_pred p] [fintype α] : fintype {x // p x} :=
fintype.subtype (univ.filter p) (by simp)

/-- A set on a fintype, when coerced to a type, is a fintype. -/
def set_fintype [fintype α] (s : set α) [decidable_pred (∈ s)] : fintype s :=
subtype.fintype (λ x, x ∈ s)

section
variables (α)

/-- The `αˣ` type is equivalent to a subtype of `α × α`. -/
@[simps]
def _root_.units_equiv_prod_subtype [monoid α] :
  αˣ ≃ {p : α × α // p.1 * p.2 = 1 ∧ p.2 * p.1 = 1} :=
{ to_fun := λ u, ⟨(u, ↑u⁻¹), u.val_inv, u.inv_val⟩,
  inv_fun := λ p, units.mk (p : α × α).1 (p : α × α).2 p.prop.1 p.prop.2,
  left_inv := λ u, units.ext rfl,
  right_inv := λ p, subtype.ext $ prod.ext rfl rfl}

/-- In a `group_with_zero` `α`, the unit group `αˣ` is equivalent to the subtype of nonzero
elements. -/
@[simps]
def _root_.units_equiv_ne_zero [group_with_zero α] : αˣ ≃ {a : α // a ≠ 0} :=
⟨λ a, ⟨a, a.ne_zero⟩, λ a, units.mk0 _ a.prop, λ _, units.ext rfl, λ _, subtype.ext rfl⟩

end

namespace fintype

/-- Given `fintype α`, `finset_equiv_set` is the equiv between `finset α` and `set α`. (All
sets on a finite type are finite.) -/
noncomputable def finset_equiv_set [fintype α] : finset α ≃ set α :=
{ to_fun := coe,
  inv_fun := by { classical, exact λ s, s.to_finset },
  left_inv := λ s, by convert finset.to_finset_coe s,
  right_inv := λ s, by { classical, exact s.coe_to_finset } }

@[simp] lemma finset_equiv_set_apply [fintype α] (s : finset α) : finset_equiv_set s = s := rfl

@[simp]

end fintype

instance quotient.fintype [fintype α] (s : setoid α)
  [decidable_rel ((≈) : α → α → Prop)] : fintype (quotient s) :=
fintype.of_surjective quotient.mk (λ x, quotient.induction_on x (λ x, ⟨x, rfl⟩))

instance psigma.fintype_prop_left {α : Prop} {β : α → Type*} [decidable α] [∀ a, fintype (β a)] :
  fintype (Σ' a, β a) :=
if h : α then fintype.of_equiv (β h) ⟨λ x, ⟨h, x⟩, psigma.snd, λ _, rfl, λ ⟨_, _⟩, rfl⟩
else ⟨∅, λ x, h x.1⟩

instance psigma.fintype_prop_right {α : Type*} {β : α → Prop} [∀ a, decidable (β a)] [fintype α] :
  fintype (Σ' a, β a) :=
fintype.of_equiv {a // β a} ⟨λ ⟨x, y⟩, ⟨x, y⟩, λ ⟨x, y⟩, ⟨x, y⟩, λ ⟨x, y⟩, rfl, λ ⟨x, y⟩, rfl⟩

instance psigma.fintype_prop_prop {α : Prop} {β : α → Prop} [decidable α] [∀ a, decidable (β a)] :
  fintype (Σ' a, β a) :=
if h : ∃ a, β a then ⟨{⟨h.fst, h.snd⟩}, λ ⟨_, _⟩, by simp⟩ else ⟨∅, λ ⟨x, y⟩, h ⟨x, y⟩⟩

instance pfun_fintype (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, fintype (α hp)] : fintype (Π hp : p, α hp) :=
if hp : p then fintype.of_equiv (α hp) ⟨λ a _, a, λ f, f hp, λ _, rfl, λ _, rfl⟩
          else ⟨singleton (λ h, (hp h).elim), by simp [hp, function.funext_iff]⟩

lemma mem_image_univ_iff_mem_range
  {α β : Type*} [fintype α] [decidable_eq β] {f : α → β} {b : β} :
  b ∈ univ.image f ↔ b ∈ set.range f :=
by simp

namespace fintype

section choose
open fintype equiv

variables [fintype α] (p : α → Prop) [decidable_pred p]

/-- Given a fintype `α` and a predicate `p`, associate to a proof that there is a unique element of
`α` satisfying `p` this unique element, as an element of the corresponding subtype. -/
def choose_x (hp : ∃! a : α, p a) : {a // p a} :=
⟨finset.choose p univ (by simp; exact hp), finset.choose_property _ _ _⟩

/-- Given a fintype `α` and a predicate `p`, associate to a proof that there is a unique element of
`α` satisfying `p` this unique element, as an element of `α`. -/
def choose (hp : ∃! a, p a) : α := choose_x p hp

lemma choose_spec (hp : ∃! a, p a) : p (choose p hp) :=
(choose_x p hp).property

@[simp] lemma choose_subtype_eq {α : Type*} (p : α → Prop) [fintype {a : α // p a}]
  [decidable_eq α] (x : {a : α // p a})
  (h : ∃! (a : {a // p a}), (a : α) = x := ⟨x, rfl, λ y hy, by simpa [subtype.ext_iff] using hy⟩) :
  fintype.choose (λ (y : {a : α // p a}), (y : α) = x) h = x :=
by rw [subtype.ext_iff, fintype.choose_spec (λ (y : {a : α // p a}), (y : α) = x) _]

end choose

section bijection_inverse
open function

variables [fintype α] [decidable_eq β] {f : α → β}

/--
`bij_inv f` is the unique inverse to a bijection `f`. This acts
  as a computable alternative to `function.inv_fun`. -/
def bij_inv (f_bij : bijective f) (b : β) : α :=
fintype.choose (λ a, f a = b)
begin
  rcases f_bij.right b with ⟨a', fa_eq_b⟩,
  rw ← fa_eq_b,
  exact ⟨a', ⟨rfl, (λ a h, f_bij.left h)⟩⟩
end

lemma left_inverse_bij_inv (f_bij : bijective f) : left_inverse (bij_inv f_bij) f :=
λ a, f_bij.left (choose_spec (λ a', f a' = f a) _)

lemma right_inverse_bij_inv (f_bij : bijective f) : right_inverse (bij_inv f_bij) f :=
λ b, choose_spec (λ a', f a' = b) _

lemma bijective_bij_inv (f_bij : bijective f) : bijective (bij_inv f_bij) :=
⟨(right_inverse_bij_inv _).injective, (left_inverse_bij_inv _).surjective⟩

end bijection_inverse
end fintype

section trunc

/--
For `s : multiset α`, we can lift the existential statement that `∃ x, x ∈ s` to a `trunc α`.
-/
def trunc_of_multiset_exists_mem {α} (s : multiset α) : (∃ x, x ∈ s) → trunc α :=
quotient.rec_on_subsingleton s $ λ l h,
  match l, h with
    | [],       _ := false.elim (by tauto)
    | (a :: _), _ := trunc.mk a
  end

/--
A `nonempty` `fintype` constructively contains an element.
-/
def trunc_of_nonempty_fintype (α) [nonempty α] [fintype α] : trunc α :=
trunc_of_multiset_exists_mem finset.univ.val (by simp)

/--
By iterating over the elements of a fintype, we can lift an existential statement `∃ a, P a`
to `trunc (Σ' a, P a)`, containing data.
-/
def trunc_sigma_of_exists {α} [fintype α] {P : α → Prop} [decidable_pred P] (h : ∃ a, P a) :
  trunc (Σ' a, P a) :=
@trunc_of_nonempty_fintype (Σ' a, P a) (exists.elim h $ λ a ha, ⟨⟨a, ha⟩⟩) _

end trunc

namespace multiset

variables [fintype α] [decidable_eq α]

@[simp] lemma count_univ (a : α) :
  count a finset.univ.val = 1 :=
count_eq_one_of_mem finset.univ.nodup (finset.mem_univ _)

end multiset

/-- Auxiliary definition to show `exists_seq_of_forall_finset_exists`. -/
noncomputable def seq_of_forall_finset_exists_aux
  {α : Type*} [decidable_eq α] (P : α → Prop) (r : α → α → Prop)
  (h : ∀ (s : finset α), ∃ y, (∀ x ∈ s, P x) → (P y ∧ (∀ x ∈ s, r x y))) : ℕ → α
| n := classical.some (h (finset.image (λ (i : fin n), seq_of_forall_finset_exists_aux i)
        (finset.univ : finset (fin n))))
using_well_founded {dec_tac := `[exact i.2]}

/-- Induction principle to build a sequence, by adding one point at a time satisfying a given
relation with respect to all the previously chosen points.

More precisely, Assume that, for any finite set `s`, one can find another point satisfying
some relation `r` with respect to all the points in `s`. Then one may construct a
function `f : ℕ → α` such that `r (f m) (f n)` holds whenever `m < n`.
We also ensure that all constructed points satisfy a given predicate `P`. -/
lemma exists_seq_of_forall_finset_exists {α : Type*} (P : α → Prop) (r : α → α → Prop)
  (h : ∀ (s : finset α), (∀ x ∈ s, P x) → ∃ y, P y ∧ (∀ x ∈ s, r x y)) :
  ∃ (f : ℕ → α), (∀ n, P (f n)) ∧ (∀ m n, m < n → r (f m) (f n)) :=
begin
  classical,
  haveI : nonempty α,
  { rcases h ∅ (by simp) with ⟨y, hy⟩,
    exact ⟨y⟩ },
  choose! F hF using h,
  have h' : ∀ (s : finset α), ∃ y, (∀ x ∈ s, P x) → (P y ∧ (∀ x ∈ s, r x y)) := λ s, ⟨F s, hF s⟩,
  set f := seq_of_forall_finset_exists_aux P r h' with hf,
  have A : ∀ (n : ℕ), P (f n),
  { assume n,
    induction n using nat.strong_induction_on with n IH,
    have IH' : ∀ (x : fin n), P (f x) := λ n, IH n.1 n.2,
    rw [hf, seq_of_forall_finset_exists_aux],
    exact (classical.some_spec (h' (finset.image (λ (i : fin n), f i)
      (finset.univ : finset (fin n)))) (by simp [IH'])).1 },
  refine ⟨f, A, λ m n hmn, _⟩,
  nth_rewrite 1 hf,
  rw seq_of_forall_finset_exists_aux,
  apply (classical.some_spec (h' (finset.image (λ (i : fin n), f i)
    (finset.univ : finset (fin n)))) (by simp [A])).2,
  exact finset.mem_image.2 ⟨⟨m, hmn⟩, finset.mem_univ _, rfl⟩,
end

/-- Induction principle to build a sequence, by adding one point at a time satisfying a given
symmetric relation with respect to all the previously chosen points.

More precisely, Assume that, for any finite set `s`, one can find another point satisfying
some relation `r` with respect to all the points in `s`. Then one may construct a
function `f : ℕ → α` such that `r (f m) (f n)` holds whenever `m ≠ n`.
We also ensure that all constructed points satisfy a given predicate `P`. -/
lemma exists_seq_of_forall_finset_exists' {α : Type*} (P : α → Prop) (r : α → α → Prop)
  [is_symm α r]
  (h : ∀ (s : finset α), (∀ x ∈ s, P x) → ∃ y, P y ∧ (∀ x ∈ s, r x y)) :
  ∃ (f : ℕ → α), (∀ n, P (f n)) ∧ (∀ m n, m ≠ n → r (f m) (f n)) :=
begin
  rcases exists_seq_of_forall_finset_exists P r h with ⟨f, hf, hf'⟩,
  refine ⟨f, hf, λ m n hmn, _⟩,
  rcases lt_trichotomy m n with h|rfl|h,
  { exact hf' m n h },
  { exact (hmn rfl).elim },
  { apply symm,
    exact hf' n m h }
end


/-
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 v₂ u 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`.
structure 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))

-- This works as an instance even though `exact` itself is not a class, as long as the goal is
-- literally of the form `epi (image_to_kernel f g h.w)` (where `h : exact f g`). If the proof of
-- `f ≫ g = 0` looks different, we are out of luck and have to add the instance by hand.
attribute [instance] exact.epi
attribute [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

/-- A reformulation of `preadditive.exact_of_iso_of_exact` that does not involve the arrow
category. -/
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₂)
  (α : A₁ ≅ A₂) (β : B₁ ≅ B₂) (γ : C₁ ≅ C₂) (hsq₁ : α.hom ≫ f₂ = f₁ ≫ β.hom)
  (hsq₂ : β.hom ≫ g₂ = g₁ ≫ γ.hom)
  (h : exact f₁ g₁) :
  exact f₂ g₂ :=
preadditive.exact_of_iso_of_exact f₁ g₁ f₂ g₂ (arrow.iso_mk α β hsq₁) (arrow.iso_mk β γ hsq₂) rfl h

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]

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

lemma exact_comp_inv_hom_comp (i : D ≅ B) (h : exact f g) : exact (f ≫ i.inv) (i.hom ≫ g) :=
exact_comp_hom_inv_comp i.symm h

lemma exact_comp_hom_inv_comp_iff (i : B ≅ D) : exact (f ≫ i.hom) (i.inv ≫ g) ↔ exact f g :=
⟨λ h, by simpa using exact_comp_inv_hom_comp i h, exact_comp_hom_inv_comp i⟩

lemma exact_epi_comp (hgh : exact g h) [epi f] : exact (f ≫ g) h :=
begin
  refine ⟨by simp [hgh.w], _⟩,
  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, exact exact_epi_comp w }, λ w, exact_epi_comp w⟩

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

/-- The dual of this lemma is only true when `V` is abelian, see `abelian.exact_epi_comp_iff`. -/
lemma exact_comp_mono_iff [mono h] : exact f (g ≫ h) ↔ exact f g :=
begin
  refine ⟨λ hfg, ⟨zero_of_comp_mono h (by rw [category.assoc, hfg.1]), _⟩, λ h, exact_comp_mono h⟩,
  rw ← (iso.eq_comp_inv _).1 (image_to_kernel_comp_mono _ _ h hfg.1),
  haveI := hfg.2, 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 (h : exact f g) : epi (factor_thru_kernel_subobject g f h.w) :=
begin
  rw ←factor_thru_image_subobject_comp_image_to_kernel,
  apply epi_comp,
end

instance (h : exact f g) : epi (kernel.lift g f h.w) :=
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 (h : exact (0 : A ⟶ B) g) :
  (kernel_subobject g).arrow = 0 :=
begin
  rw [←cancel_epi (image_to_kernel (0 : A ⟶ B) g h.w),
    ←cancel_epi (factor_thru_image_subobject (0 : A ⟶ B))],
  simp
end

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

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 (h : 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 h.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 (h : 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 _ _ h, zero_comp, comp_zero]

@[simp, reassoc] lemma fork_ι_comp_cofork_π (h : exact f g) (s : kernel_fork g)
  (t : cokernel_cofork f) : fork.ι s ≫ cofork.π t = 0 :=
comp_eq_zero_of_exact f g h (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]

lemma 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

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

lemma 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 exactI exact_zero_mono _,
  λ 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 exactI exact_epi_zero _,
  λ 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

namespace functor
variables [has_zero_morphisms V] [has_kernels V] {W : Type u₂} [category.{v₂} W]
variables [has_images W] [has_zero_morphisms W] [has_kernels W]

/-- A functor reflects exact sequences if any composable pair of morphisms that is mapped to an
    exact pair is itself exact. -/
class reflects_exact_sequences (F : V ⥤ W) :=
(reflects : ∀ {A B C : V} (f : A ⟶ B) (g : B ⟶ C), exact (F.map f) (F.map g) → exact f g)

lemma exact_of_exact_map (F : V ⥤ W) [reflects_exact_sequences F] {A B C : V} {f : A ⟶ B}
  {g : B ⟶ C} (hfg : exact (F.map f) (F.map g)) : exact f g :=
reflects_exact_sequences.reflects f g hfg

end functor

end category_theory


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.bicategory.functor

/-!
# Free bicategories

We define the free bicategory over a quiver. In this bicategory, the 1-morphisms are freely
generated by the arrows in the quiver, and the 2-morphisms are freely generated by the formal
identities, the formal unitors, and the formal associators modulo the relation derived from the
axioms of a bicategory.

## Main definitions

* `free_bicategory B`: the free bicategory over a quiver `B`.
* `free_bicategory.lift F`: the pseudofunctor from `free_bicategory B` to `C` associated with a
  prefunctor `F` from `B` to `C`.
-/

universes w w₁ w₂ v v₁ v₂ u u₁ u₂

namespace category_theory
open category bicategory
open_locale bicategory

/-- Free bicategory over a quiver. Its objects are the same as those in the underlying quiver. -/
def free_bicategory (B : Type u) := B

instance (B : Type u) : Π [inhabited B], inhabited (free_bicategory B) := id

namespace free_bicategory

section
variables {B : Type u} [quiver.{v+1} B]

/-- 1-morphisms in the free bicategory. -/
inductive hom : B → B → Type (max u v)
| of {a b : B} (f : a ⟶ b) : hom a b
| id (a : B) : hom a a
| comp {a b c : B} (f : hom a b) (g : hom b c) : hom a c

instance (a b : B) [inhabited (a ⟶ b)] : inhabited (hom a b) := ⟨hom.of default⟩

/-- Representatives of 2-morphisms in the free bicategory. -/
@[nolint has_nonempty_instance]
inductive hom₂ : Π {a b : B}, hom a b → hom a b → Type (max u v)
| id {a b} (f : hom a b) : hom₂ f f
| vcomp {a b} {f g h : hom a b} (η : hom₂ f g) (θ : hom₂ g h) : hom₂ f h
| whisker_left {a b c} (f : hom a b) {g h : hom b c} (η : hom₂ g h) : hom₂ (f.comp g) (f.comp h)
-- `η` cannot be earlier than `h` since it is a recursive argument.
| whisker_right {a b c} {f g : hom a b} (h : hom b c) (η : hom₂ f g) : hom₂ (f.comp h) (g.comp h)
| associator {a b c d} (f : hom a b) (g : hom b c) (h : hom c d) :
    hom₂ ((f.comp g).comp h) (f.comp (g.comp h))
| associator_inv {a b c d} (f : hom a b) (g : hom b c) (h : hom c d) :
    hom₂ (f.comp (g.comp h)) ((f.comp g).comp h)
| right_unitor     {a b} (f : hom a b) : hom₂ (f.comp (hom.id b)) f
| right_unitor_inv {a b} (f : hom a b) : hom₂ f (f.comp (hom.id b))
| left_unitor      {a b} (f : hom a b) : hom₂ ((hom.id a).comp f) f
| left_unitor_inv  {a b} (f : hom a b) : hom₂ f ((hom.id a).comp f)

section
variables {B}

-- The following notations are only used in the definition of `rel` to simplify the notation.
local infixr (name := vcomp) ` ≫ ` := hom₂.vcomp
local notation (name := id) `𝟙` := hom₂.id
local notation (name := whisker_left) f ` ◁ ` η := hom₂.whisker_left f η
local notation (name := whisker_right) η ` ▷ ` h := hom₂.whisker_right h η
local notation (name := associator) `α_` := hom₂.associator
local notation (name := left_unitor) `λ_` := hom₂.left_unitor
local notation (name := right_unitor) `ρ_` := hom₂.right_unitor
local notation (name := associator_inv) `α⁻¹_` := hom₂.associator_inv
local notation (name := left_unitor_inv) `λ⁻¹_` := hom₂.left_unitor_inv
local notation (name := right_unitor_inv) `ρ⁻¹_` := hom₂.right_unitor_inv

/-- Relations between 2-morphisms in the free bicategory. -/
inductive rel : Π {a b : B} {f g : hom a b}, hom₂ f g → hom₂ f g → Prop
| vcomp_right {a b} {f g h : hom a b} (η : hom₂ f g) (θ₁ θ₂ : hom₂ g h) :
    rel θ₁ θ₂ → rel (η ≫ θ₁) (η ≫ θ₂)
| vcomp_left {a b} {f g h : hom a b} (η₁ η₂ : hom₂ f g) (θ : hom₂ g h) :
    rel η₁ η₂ → rel (η₁ ≫ θ) (η₂ ≫ θ)
| id_comp {a b} {f g : hom a b} (η : hom₂ f g) :
    rel (𝟙 f ≫ η) η
| comp_id {a b} {f g : hom a b} (η : hom₂ f g) :
    rel (η ≫ 𝟙 g) η
| assoc {a b} {f g h i : hom a b} (η : hom₂ f g) (θ : hom₂ g h) (ι : hom₂ h i) :
    rel ((η ≫ θ) ≫ ι) (η ≫ (θ ≫ ι))
| whisker_left {a b c} (f : hom a b) (g h : hom b c) (η η' : hom₂ g h) :
    rel η η' → rel (f ◁ η) (f ◁ η')
| whisker_left_id {a b c} (f : hom a b) (g : hom b c) :
    rel (f ◁ 𝟙 g) (𝟙 (f.comp g))
| whisker_left_comp {a b c} (f : hom a b) {g h i : hom b c} (η : hom₂ g h) (θ : hom₂ h i) :
    rel (f ◁ (η ≫ θ)) (f ◁ η ≫ f ◁ θ)
| id_whisker_left {a b} {f g : hom a b} (η : hom₂ f g) :
    rel (hom.id a ◁ η) (λ_ f ≫ η ≫ λ⁻¹_ g)
| comp_whisker_left
    {a b c d} (f : hom a b) (g : hom b c) {h h' : hom c d} (η : hom₂ h h') :
    rel ((f.comp g) ◁ η) (α_ f g h ≫ f ◁ g ◁ η ≫ α⁻¹_ f g h')
| whisker_right {a b c} (f g : hom a b) (h : hom b c) (η η' : hom₂ f g) :
    rel η η' → rel (η ▷ h) (η' ▷ h)
| id_whisker_right {a b c} (f : hom a b) (g : hom b c) :
    rel (𝟙 f ▷ g) (𝟙 (f.comp g))
| comp_whisker_right {a b c} {f g h : hom a b} (i : hom b c) (η : hom₂ f g) (θ : hom₂ g h) :
    rel ((η ≫ θ) ▷ i) (η ▷ i ≫ θ ▷ i)
| whisker_right_id {a b} {f g : hom a b} (η : hom₂ f g) :
    rel (η ▷ hom.id b) (ρ_ f ≫ η ≫ ρ⁻¹_ g)
| whisker_right_comp
    {a b c d} {f f' : hom a b} (g : hom b c) (h : hom c d) (η : hom₂ f f') :
    rel (η ▷ (g.comp h)) (α⁻¹_ f g h ≫ η ▷ g ▷ h ≫ α_ f' g h)
| whisker_assoc
    {a b c d} (f : hom a b) {g g' : hom b c} (η : hom₂ g g') (h : hom c d) :
    rel ((f ◁ η) ▷ h) (α_ f g h ≫ f ◁ (η ▷ h)≫ α⁻¹_ f g' h)
| whisker_exchange {a b c} {f g : hom a b} {h i : hom b c} (η : hom₂ f g) (θ : hom₂ h i) :
    rel (f ◁ θ ≫ η ▷ i) (η ▷ h ≫ g ◁ θ)
| associator_hom_inv {a b c d} (f : hom a b) (g : hom b c) (h : hom c d) :
    rel (α_ f g h ≫ α⁻¹_ f g h) (𝟙 ((f.comp g).comp h))
| associator_inv_hom {a b c d} (f : hom a b) (g : hom b c) (h : hom c d) :
    rel (α⁻¹_ f g h ≫ α_ f g h) (𝟙 (f.comp (g.comp h)))
| left_unitor_hom_inv {a b} (f : hom a b) :
    rel (λ_ f ≫ λ⁻¹_ f) (𝟙 ((hom.id a).comp f))
| left_unitor_inv_hom {a b} (f : hom a b) :
    rel (λ⁻¹_ f ≫ λ_ f) (𝟙 f)
| right_unitor_hom_inv {a b} (f : hom a b) :
    rel (ρ_ f ≫ ρ⁻¹_ f) (𝟙 (f.comp (hom.id b)))
| right_unitor_inv_hom {a b} (f : hom a b) :
    rel (ρ⁻¹_ f ≫ ρ_ f) (𝟙 f)
| pentagon {a b c d e} (f : hom a b) (g : hom b c) (h : hom c d) (i : hom d e) :
    rel (α_ f g h ▷ i ≫ α_ f (g.comp h) i ≫ f ◁ α_ g h i)
        (α_ (f.comp g) h i ≫ α_ f g (h.comp i))
| triangle {a b c} (f : hom a b) (g : hom b c) :
    rel (α_ f (hom.id b) g ≫ f ◁ λ_ g) (ρ_ f ▷ g)

end

variables {B}

instance hom_category (a b : B) : category (hom a b) :=
{ hom       := λ f g, quot (@rel _ _ _ _ f g),
  id        := λ f, quot.mk rel (hom₂.id f),
  comp      := λ f g h, quot.map₂ hom₂.vcomp rel.vcomp_right rel.vcomp_left,
  id_comp'  := by { rintros f g ⟨η⟩, exact quot.sound (rel.id_comp η) },
  comp_id'  := by { rintros f g ⟨η⟩, exact quot.sound (rel.comp_id η) },
  assoc'    := by { rintros f g h i ⟨η⟩ ⟨θ⟩ ⟨ι⟩, exact quot.sound (rel.assoc η θ ι) } }

/-- Bicategory structure on the free bicategory. -/
instance bicategory : bicategory (free_bicategory B) :=
{ hom   := λ a b : B, hom a b,
  id    := hom.id,
  comp  := λ a b c, hom.comp,
  hom_category := free_bicategory.hom_category,
  whisker_left := λ a b c f g h η,
    quot.map (hom₂.whisker_left f) (rel.whisker_left f g h) η,
  whisker_left_id' := λ a b c f g, quot.sound (rel.whisker_left_id f g),
  whisker_left_comp' := by
  { rintros a b c f g h i ⟨η⟩ ⟨θ⟩, exact quot.sound (rel.whisker_left_comp f η θ) },
  id_whisker_left' := by
  { rintros a b f g ⟨η⟩, exact quot.sound (rel.id_whisker_left η) },
  comp_whisker_left' := by
  { rintros a b c d f g h h' ⟨η⟩, exact quot.sound (rel.comp_whisker_left f g η) },
  whisker_right := λ a b c f g η h,
    quot.map (hom₂.whisker_right h) (rel.whisker_right f g h) η,
  id_whisker_right' := λ a b c f g, quot.sound (rel.id_whisker_right f g),
  comp_whisker_right' := by
  { rintros a b c f g h ⟨η⟩ ⟨θ⟩ i, exact quot.sound (rel.comp_whisker_right i η θ) },
  whisker_right_id' := by
  { rintros a b f g ⟨η⟩, exact quot.sound (rel.whisker_right_id η) },
  whisker_right_comp' := by
  { rintros a b c d f f' ⟨η⟩ g h, exact quot.sound (rel.whisker_right_comp g h η) },
  whisker_assoc' := by
  { rintros a b c d f g g' ⟨η⟩ h, exact quot.sound (rel.whisker_assoc f η h) },
  whisker_exchange' := by
  { rintros a b c f g h i ⟨η⟩ ⟨θ⟩, exact quot.sound (rel.whisker_exchange η θ) },
  associator := λ a b c d f g h,
  { hom := quot.mk rel (hom₂.associator f g h),
    inv := quot.mk rel (hom₂.associator_inv f g h),
    hom_inv_id' := quot.sound (rel.associator_hom_inv f g h),
    inv_hom_id' := quot.sound (rel.associator_inv_hom f g h) },
  left_unitor := λ a b f,
  { hom := quot.mk rel (hom₂.left_unitor f),
    inv := quot.mk rel (hom₂.left_unitor_inv f),
    hom_inv_id' := quot.sound (rel.left_unitor_hom_inv f),
    inv_hom_id' := quot.sound (rel.left_unitor_inv_hom f) },
  right_unitor := λ a b f,
  { hom := quot.mk rel (hom₂.right_unitor f),
    inv := quot.mk rel (hom₂.right_unitor_inv f),
    hom_inv_id' := quot.sound (rel.right_unitor_hom_inv f),
    inv_hom_id' := quot.sound (rel.right_unitor_inv_hom f) },
  pentagon' := λ a b c d e f g h i, quot.sound (rel.pentagon f g h i),
  triangle' := λ a b c f g, quot.sound (rel.triangle f g) }

variables {a b c d : free_bicategory B}

@[simp] lemma mk_vcomp {f g h : a ⟶ b} (η : hom₂ f g) (θ : hom₂ g h) :
  quot.mk rel (η.vcomp θ) = (quot.mk rel η ≫ quot.mk rel θ : f ⟶ h) := rfl
@[simp] lemma mk_whisker_left (f : a ⟶ b) {g h : b ⟶ c} (η : hom₂ g h) :
  quot.mk rel (hom₂.whisker_left f η) = (f ◁ quot.mk rel η : f ≫ g ⟶ f ≫ h) := rfl
@[simp] lemma mk_whisker_right {f g : a ⟶ b} (η : hom₂ f g) (h : b ⟶ c) :
  quot.mk rel (hom₂.whisker_right h η) = (quot.mk rel η ▷ h : f ≫ h ⟶ g ≫ h) := rfl

variables (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d)

lemma id_def : hom.id a = 𝟙 a := rfl
lemma comp_def : hom.comp f g = f ≫ g := rfl
@[simp] lemma mk_id : quot.mk _ (hom₂.id f) = 𝟙 f := rfl
@[simp] lemma mk_associator_hom : quot.mk _ (hom₂.associator f g h) = (α_ f g h).hom := rfl
@[simp]

/-- Canonical prefunctor from `B` to `free_bicategory B`. -/
@[simps]
def of : prefunctor B (free_bicategory B) :=
{ obj := id,
  map := λ a b, hom.of }

end

section
variables {B : Type u₁} [quiver.{v₁+1} B] {C : Type u₂} [category_struct.{v₂} C]
variables (F : prefunctor B C)

/-- Auxiliary definition for `lift`. -/
@[simp]
def lift_hom : ∀ {a b : B}, hom a b → (F.obj a ⟶ F.obj b)
| _ _ (hom.of f)      := F.map f
| _ _ (hom.id a)      := 𝟙 (F.obj a)
| _ _ (hom.comp f g)  := lift_hom f ≫ lift_hom g

@[simp] lemma lift_hom_id (a : free_bicategory B) : lift_hom F (𝟙 a) = 𝟙 (F.obj a) := rfl
@[simp] lemma lift_hom_comp {a b c : free_bicategory B} (f : a ⟶ b) (g : b ⟶ c) :
  lift_hom F (f ≫ g) = lift_hom F f ≫ lift_hom F g := rfl

end

section
variables {B : Type u₁} [quiver.{v₁+1} B] {C : Type u₂} [bicategory.{w₂ v₂} C]
variables (F : prefunctor B C)

/-- Auxiliary definition for `lift`. -/
@[simp]
def lift_hom₂ : ∀ {a b : B} {f g : hom a b}, hom₂ f g → (lift_hom F f ⟶ lift_hom F g)
| _ _ _ _ (hom₂.id _)                   := 𝟙 _
| _ _ _ _ (hom₂.associator _ _ _)       := (α_ _ _ _).hom
| _ _ _ _ (hom₂.associator_inv _ _ _)   := (α_ _ _ _).inv
| _ _ _ _ (hom₂.left_unitor _)          := (λ_ _).hom
| _ _ _ _ (hom₂.left_unitor_inv _)      := (λ_ _).inv
| _ _ _ _ (hom₂.right_unitor _)         := (ρ_ _).hom
| _ _ _ _ (hom₂.right_unitor_inv _)     := (ρ_ _).inv
| _ _ _ _ (hom₂.vcomp η θ)              := lift_hom₂ η ≫ lift_hom₂ θ
| _ _ _ _ (hom₂.whisker_left f η)       := lift_hom F f ◁ lift_hom₂ η
| _ _ _ _ (hom₂.whisker_right h η)      := lift_hom₂ η ▷ lift_hom F h

local attribute [simp] whisker_exchange

lemma lift_hom₂_congr {a b : B} {f g : hom a b} {η θ : hom₂ f g} (H : rel η θ) :
  lift_hom₂ F η = lift_hom₂ F θ :=
by induction H; tidy

/--
A prefunctor from a quiver `B` to a bicategory `C` can be lifted to a pseudofunctor from
`free_bicategory B` to `C`.
-/
@[simps]
def lift : pseudofunctor (free_bicategory B) C :=
{ obj       := F.obj,
  map       := λ a b, lift_hom F,
  map₂      := λ a b f g, quot.lift (lift_hom₂ F) (λ η θ H, lift_hom₂_congr F H),
  map_id    := λ a, iso.refl _,
  map_comp  := λ a b c f g, iso.refl _ }

end

end free_bicategory

end category_theory