/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Std.Classes.Order
import Std.Control.ForInStep.Basic

/-!
# Red-black trees

This module implements a type `RBMap α β cmp` which is a functional data structure for
storing a key-value store in a binary search tree.

It is built on the simpler `RBSet α cmp` type, which stores a set of values of type `α`
using the function `cmp : α → α → Ordering` for determining the ordering relation.
The tree will never store two elements that compare `.eq` under the `cmp` function,
but the function does not have to satisfy `cmp x y = .eq → x = y`, and in the map case
`α` is a key-value pair and the `cmp` function only compares the keys.
-/

namespace Std

/--
In a red-black tree, every node has a color which is either "red" or "black"
(this particular choice of colors is conventional). A nil node is considered black.
-/
inductive RBColor where
  /-- A red node is required to have black children. -/
  | red
  /-- Every path from the root to a leaf must pass through the same number of black nodes. -/
  | black
  deriving Repr

/--
A red-black tree. (This is an internal implementation detail of the `RBSet` type,
which includes the invariants of the tree.) This is a binary search tree augmented with
a "color" field which is either red or black for each node and used to implement
the re-balancing operations.
See: [Red–black tree](https://en.wikipedia.org/wiki/Red%E2%80%93black_tree)
-/
inductive RBNode (α : Type u) where
  /-- An empty tree. -/
  | nil
  /-- A node consists of a value `v`, a subtree `l` of smaller items,
  and a subtree `r` of larger items. The color `c` is either `red` or `black`
  and participates in the red-black balance invariant (see `Balanced`). -/
  | node (c : RBColor) (l : RBNode α) (v : α) (r : RBNode α)
  deriving Repr

namespace RBNode
open RBColor

instance : EmptyCollection (RBNode α) := ⟨nil⟩

/-- The minimum element of a tree is the left-most value. -/
protected def min : RBNode α → Option α
  | nil            => none
  | node _ nil v _ => some v
  | node _ l _ _   => l.min

/-- The maximum element of a tree is the right-most value. -/
protected def max : RBNode α → Option α
  | nil            => none
  | node _ _ v nil => some v
  | node _ _ _ r   => r.max

/--
Fold a function in tree order along the nodes. `v₀` is used at `nil` nodes and
`f` is used to combine results at branching nodes.
-/
@[specialize] def fold (v₀ : σ) (f : σ → α → σ → σ) : RBNode α → σ
  | nil          => v₀
  | node _ l v r => f (l.fold v₀ f) v (r.fold v₀ f)

/-- Fold a function on the values from left to right (in increasing order). -/
@[specialize] def foldl (f : σ → α → σ) : (init : σ) → RBNode α → σ
  | b, nil          => b
  | b, node _ l v r => foldl f (f (foldl f b l) v) r

/-- Fold a function on the values from right to left (in decreasing order). -/
@[specialize] def foldr (f : α → σ → σ) : RBNode α → (init : σ) → σ
  | nil,          b => b
  | node _ l v r, b => l.foldr f <| f v <| r.foldr f b

/-- `O(n)`. Convert the tree to a list in ascending order. -/
def toList (t : RBNode α) : List α := t.foldr (·::·) []

/-- Run monadic function `f` on each element of the tree (in increasing order). -/
@[specialize] def forM [Monad m] (f : α → m PUnit) : RBNode α → m PUnit
  | nil          => pure ⟨⟩
  | node _ l v r => do forM f l; f v; forM f r

/-- Fold a monadic function on the values from left to right (in increasing order). -/
@[specialize] def foldlM [Monad m] (f : σ → α → m σ) : (init : σ) → RBNode α → m σ
  | b, nil          => pure b
  | b, node _ l v r => do foldlM f (← f (← foldlM f b l) v) r

/-- Implementation of `for x in t` loops over a `RBNode` (in increasing order). -/
@[inline] protected def forIn [Monad m]
    (as : RBNode α) (init : σ) (f : α → σ → m (ForInStep σ)) : m σ := do
  ForInStep.run <$> visit as init
where
  /-- Inner loop of `forIn`. -/
  @[specialize] visit : RBNode α → σ → m (ForInStep σ)
    | nil,          b => return ForInStep.yield b
    | node _ l v r, b => ForInStep.bindM (visit l b) fun b => ForInStep.bindM (f v b) (visit r ·)

instance : ForIn m (RBNode α) α where
  forIn := RBNode.forIn

/--
An auxiliary data structure (an iterator) over an `RBNode` which lazily
pulls elements from the left.
-/
protected inductive Stream (α : Type _)
  | /-- The stream is empty. -/
    nil
  | /-- We are ready to deliver element `v` with right child `r`,
    and where `tail` represents all the subtrees we have yet to destructure. -/
    cons (v : α) (r : RBNode α) (tail : RBNode.Stream α)

/-- `O(log n)`. Turn a node into a stream, by descending along the left spine. -/
def toStream : RBNode α → (_ : RBNode.Stream α := .nil) → RBNode.Stream α
  | nil, acc => acc
  | node _ l v r, acc => toStream l (.cons v r acc)

namespace Stream

/-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/
def next? : RBNode.Stream α → Option (α × RBNode.Stream α)
  | nil => none
  | cons v r tail => some (v, toStream r tail)

/-- Fold a function on the values from left to right (in increasing order). -/
@[specialize] def foldl (f : σ → α → σ) : (init : σ) → RBNode.Stream α → σ
  | b, nil           => b
  | b, cons v r tail => foldl f (r.foldl f (f b v)) tail

/-- Fold a function on the values from right to left (in decreasing order). -/
@[specialize] def foldr (f : α → σ → σ) : RBNode.Stream α → (init : σ) → σ
  | nil,           b => b
  | cons v r tail, b => f v <| r.foldr f <| tail.foldr f b

/-- `O(n)`. Convert the stream to a list in ascending order. -/
def toList (t : RBNode.Stream α) : List α := t.foldr (·::·) []

end Stream

instance : ToStream (RBNode α) (RBNode.Stream α) := ⟨(·.toStream)⟩
instance : Stream (RBNode.Stream α) α := ⟨Stream.next?⟩

/-- Returns `true` iff every element of the tree satisfies `p`. -/
@[specialize] def all (p : α → Bool) : RBNode α → Bool
  | nil          => true
  | node _ l v r => p v && all p l && all p r

/-- Returns `true` iff any element of the tree satisfies `p`. -/
@[specialize] def any (p : α → Bool) : RBNode α → Bool
  | nil          => false
  | node _ l v r => p v || any p l || any p r

/-- Asserts that `p` holds on every element of the tree. -/
def All (p : α → Prop) : RBNode α → Prop
  | nil          => True
  | node _ l v r => p v ∧ All p l ∧ All p r

theorem All.imp (H : ∀ {x : α}, p x → q x) : ∀ {t : RBNode α}, t.All p → t.All q
  | nil => id
  | node .. => fun ⟨h, hl, hr⟩ => ⟨H h, hl.imp H, hr.imp H⟩

/-- Asserts that `p` holds on some element of the tree. -/
def Any (p : α → Prop) : RBNode α → Prop
  | nil          => False
  | node _ l v r => p v ∨ Any p l ∨ Any p r

/-- True if `x` is an element of `t` "exactly", i.e. up to equality, not the `cmp` relation. -/
def EMem (x : α) (t : RBNode α) : Prop := t.Any (x = ·)

instance : Membership α (RBNode α) := ⟨EMem⟩

/-- True if the specified `cut` matches at least one element of of `t`. -/
def MemP (cut : α → Ordering) (t : RBNode α) : Prop := t.Any (cut · = .eq)

/-- True if `x` is equivalent to an element of `t`. -/
@[reducible] def Mem (cmp : α → α → Ordering) (x : α) (t : RBNode α) : Prop := MemP (cmp x) t

/--
Asserts that `t₁` and `t₂` have the same number of elements in the same order,
and `R` holds pairwise between them. The tree structure is ignored.
-/
@[specialize] def all₂ (R : α → β → Bool) (t₁ : RBNode α) (t₂ : RBNode β) : Bool :=
  let result := StateT.run (s := t₂.toStream) <| t₁.forM fun a s => do
    let (b, s) ← s.next?
    bif R a b then pure (⟨⟩, s) else none
  result matches some (_, .nil)

instance [BEq α] : BEq (RBNode α) where
  beq a b := a.all₂ (· == ·) b

/--
We say that `x < y` under the comparator `cmp` if `cmp x y = .lt`.

* In order to avoid assuming the comparator is always lawful, we use a
  local `∀ [TransCmp cmp]` binder in the relation so that the ordering
  properties of the tree only need to hold if the comparator is lawful.
* The `Nonempty` wrapper is a no-op because this is already a proposition,
  but it prevents the `[TransCmp cmp]` binder from being introduced when we don't want it.
-/
def cmpLT (cmp : α → α → Ordering) (x y : α) : Prop := Nonempty (∀ [TransCmp cmp], cmp x y = .lt)

/-- We say that `x ≈ y` under the comparator `cmp` if `cmp x y = .eq`. See also `cmpLT`. -/
def cmpEq (cmp : α → α → Ordering) (x y : α) : Prop := Nonempty (∀ [TransCmp cmp], cmp x y = .eq)

/-- The first half of Okasaki's `balance`, concerning red-red sequences in the left child. -/
@[inline] def balance1 : RBNode α → α → RBNode α → RBNode α
  | node red (node red a x b) y c, z, d
  | node red a x (node red b y c), z, d => node red (node black a x b) y (node black c z d)
  | a,                             x, b => node black a x b

/-- The second half of Okasaki's `balance`, concerning red-red sequences in the right child. -/
@[inline] def balance2 : RBNode α → α → RBNode α → RBNode α
  | a, x, node red (node red b y c) z d
  | a, x, node red b y (node red c z d) => node red (node black a x b) y (node black c z d)
  | a, x, b                             => node black a x b

/-- Returns `red` if the node is red, otherwise `black`. (Nil nodes are treated as `black`.) -/
@[inline] def isRed : RBNode α → RBColor
  | node c .. => c
  | _         => black

/--
Returns `black` if the node is black, otherwise `red`.
(Nil nodes are treated as `red`, which is not the usual convention but useful for deletion.)
-/
@[inline] def isBlack : RBNode α → RBColor
  | node c .. => c
  | _         => red

/-- Change the color of the root to `black`. -/
def setBlack : RBNode α → RBNode α
  | nil          => nil
  | node _ l v r => node black l v r

section Insert

/--
The core of the `insert` function. This adds an element `x` to a balanced red-black tree.
Importantly, the result of calling `ins` is not a proper red-black tree,
because it has a broken balance invariant.
(See `Balanced.ins` for the balance invariant of `ins`.)
The `insert` function does the final fixup needed to restore the invariant.
-/
@[specialize] def ins (cmp : α → α → Ordering) (x : α) : RBNode α → RBNode α
  | nil => node red nil x nil
  | node red a y b =>
    match cmp x y with
    | Ordering.lt => node red (ins cmp x a) y b
    | Ordering.gt => node red a y (ins cmp x b)
    | Ordering.eq => node red a x b
  | node black a y b =>
    match cmp x y with
    | Ordering.lt => balance1 (ins cmp x a) y b
    | Ordering.gt => balance2 a y (ins cmp x b)
    | Ordering.eq => node black a x b

/--
`insert cmp t v` inserts element `v` into the tree, using the provided comparator
`cmp` to put it in the right place and automatically rebalancing the tree as necessary.
-/
@[specialize] def insert (cmp : α → α → Ordering) (t : RBNode α) (v : α) : RBNode α :=
  match isRed t with
  | red => (ins cmp v t).setBlack
  | black => ins cmp v t

end Insert

/-- Recolor the root of the tree to `red` if possible. -/
def setRed : RBNode α → RBNode α
  | node _ a v b => node red a v b
  | nil          => nil

/-- Rebalancing a tree which has shrunk on the left. -/
def balLeft (l : RBNode α) (v : α) (r : RBNode α) : RBNode α :=
  match l with
  | node red a x b                    => node red (node black a x b) v r
  | l => match r with
    | node black a y b                => balance2 l v (node red a y b)
    | node red (node black a y b) z c => node red (node black l v a) y (balance2 b z (setRed c))
    | r                               => node red l v r -- unreachable

/-- Rebalancing a tree which has shrunk on the right. -/
def balRight (l : RBNode α) (v : α) (r : RBNode α) : RBNode α :=
  match r with
  | node red b y c                    => node red l v (node black b y c)
  | r => match l with
    | node black a x b                => balance1 (node red a x b) v r
    | node red a x (node black b y c) => node red (balance1 (setRed a) x b) y (node black c v r)
    | l                               => node red l v r -- unreachable

/-- The number of nodes in the tree. -/
@[simp] def size : RBNode α → Nat
  | nil => 0
  | node _ x _ y => x.size + y.size + 1

/-- Concatenate two trees with the same black-height. -/
def append : RBNode α → RBNode α → RBNode α
  | nil, x | x, nil => x
  | node red a x b, node red c y d =>
    match append b c with
    | node red b' z c' => node red (node red a x b') z (node red c' y d)
    | bc               => node red a x (node red bc y d)
  | node black a x b, node black c y d =>
    match append b c with
    | node red b' z c' => node red (node black a x b') z (node black c' y d)
    | bc               => balLeft a x (node black bc y d)
  | a@(node black ..), node red b x c => node red (append a b) x c
  | node red a x b, c@(node black ..) => node red a x (append b c)
termination_by _ x y => x.size + y.size

/-! ## erase -/

/--
The core of the `erase` function. The tree returned from this function has a broken invariant,
which is restored in `erase`.
-/
@[specialize] def del (cut : α → Ordering) : RBNode α → RBNode α
  | nil          => nil
  | node _ a y b =>
    match cut y with
    | .lt => match a.isBlack with
      | black => balLeft (del cut a) y b
      | red => node red (del cut a) y b
    | .gt => match b.isBlack with
      | black => balRight a y (del cut b)
      | red => node red a y (del cut b)
    | .eq => append a b

/--
The `erase cut t` function removes an element from the tree `t`.
The `cut` function is used to locate an element in the tree:
it returns `.gt` if we go too high and `.lt` if we go too low;
if it returns `.eq` we will remove the element.
(The function `cmp k` for some key `k` is a valid cut function, but we can also use cuts that
are not of this form as long as they are suitably monotonic.)
-/
@[specialize] def erase (cut : α → Ordering) (t : RBNode α) : RBNode α := (del cut t).setBlack

/-- Finds an element in the tree satisfying the `cut` function. -/
@[specialize] def find? (cut : α → Ordering) : RBNode α → Option α
  | nil => none
  | node _ a y b =>
    match cut y with
    | .lt => find? cut a
    | .gt => find? cut b
    | .eq => some y

/-- `lowerBound? cut` retrieves the largest entry smaller than or equal to `cut`, if it exists. -/
@[specialize] def lowerBound? (cut : α → Ordering) : RBNode α → Option α → Option α
  | nil,          lb => lb
  | node _ a y b, lb =>
    match cut y with
    | .lt => lowerBound? cut a lb
    | .gt => lowerBound? cut b (some y)
    | .eq => some y

/-- Returns the root of the tree, if any. -/
def root? : RBNode α → Option α
  | nil => none
  | node _ _ v _ => some v

/--
`O(n)`. Map a function on every value in the tree.
This requires `IsMonotone` on the function in order to preserve the order invariant.
-/
@[specialize] def map (f : α → β) : RBNode α → RBNode β
  | nil => nil
  | node c l v r => node c (l.map f) (f v) (r.map f)

/-- Converts the tree into an array in increasing sorted order. -/
def toArray (n : RBNode α) : Array α := n.foldl (init := #[]) (·.push ·)

/--
A `RBNode.Path α` is a "cursor" into an `RBNode` which represents the path
from the root to a subtree. Note that the path goes from the target subtree
up to the root, which is reversed from the normal way data is stored in the tree.
See [Zipper](https://en.wikipedia.org/wiki/Zipper_(data_structure)) for more information.
-/
inductive Path (α : Type u) where
  /-- The root of the tree, which is the end of the path of parents. -/
  | root
  /-- A path that goes down the left subtree. -/
  | left (c : RBColor) (parent : Path α) (v : α) (r : RBNode α)
  /-- A path that goes down the right subtree. -/
  | right (c : RBColor) (l : RBNode α) (v : α) (parent : Path α)

/-- Fills the `Path` with a subtree. -/
def Path.fill : Path α → RBNode α → RBNode α
  | .root, t => t
  | .left c parent y b, a
  | .right c a y parent, b => parent.fill (node c a y b)

/--
Like `find?`, but instead of just returning the element, it returns the entire subtree
at the element and a path back to the root for reconstructing the tree.
-/
@[specialize] def zoom (cut : α → Ordering) : RBNode α → (e : Path α := .root) → RBNode α × Path α
  | nil, path => (nil, path)
  | n@(node c a y b), path =>
    match cut y with
    | .lt => zoom cut a (.left c path y b)
    | .gt => zoom cut b (.right c a y path)
    | .eq => (n, path)

/--
This function does the second part of `RBNode.ins`,
which unwinds the stack and rebuilds the tree.
-/
def Path.ins : Path α → RBNode α → RBNode α
  | .root, t => t.setBlack
  | .left red parent y b, a
  | .right red a y parent, b => parent.ins (node red a y b)
  | .left black parent y b, a => parent.ins (balance1 a y b)
  | .right black a y parent, b => parent.ins (balance2 a y b)

/--
`path.insertNew v` inserts element `v` into the tree, assuming that `path` is zoomed in
on a `nil` node such that inserting a new element at this position is valid.
-/
@[inline] def Path.insertNew (path : Path α) (v : α) : RBNode α :=
  path.ins (node red nil v nil)

/--
`path.insert t v` inserts element `v` into the tree, assuming that `(t, path)` was the result of a
previous `zoom` operation (so either the root of `t` is equivalent to `v` or it is empty).
-/
def Path.insert (path : Path α) (t : RBNode α) (v : α) : RBNode α :=
  match t with
  | nil => path.insertNew v
  | node c a _ b => path.fill (node c a v b)

/--
`path.del t c` does the second part of `RBNode.del`, which unwinds the stack
and rebuilds the tree. The `c` argument is the color of the node before the deletion
(we used `t₀.isBlack` for this in `RBNode.del` but the original tree is no longer
available in this formulation).
-/
def Path.del : Path α → RBNode α → RBColor → RBNode α
  | .root, t, _ => t.setBlack
  | .left c parent y b, a, red
  | .right c a y parent, b, red => parent.del (node red a y b) c
  | .left c parent y b, a, black => parent.del (balLeft a y b) c
  | .right c a y parent, b, black => parent.del (balRight a y b) c

/--
`path.erase t v` removes the root element of `t` from the tree, assuming that `(t, path)` was
the result of a previous `zoom` operation.
-/
def Path.erase (path : Path α) (t : RBNode α) : RBNode α :=
  match t with
  | nil => path.fill nil
  | node c a _ b => path.del (a.append b) c

/--
`modify cut f t` uses `cut` to find an element,
then modifies the element using `f` and reinserts it into the tree.

Because the tree structure is not modified,
`f` must not modify the ordering properties of the element.

The element in `t` is used linearly if `t` is unshared.
-/
@[specialize] def modify (cut : α → Ordering) (f : α → α) (t : RBNode α) : RBNode α :=
  match zoom cut t with
  | (nil, _) => t -- TODO: profile whether it would be better to use `path.fill nil` here
  | (node c a x b, path) => path.fill (node c a (f x) b)

/--
`alter cut f t` simultaneously handles inserting, erasing and replacing an element
using a function `f : Option α → Option α`. It is passed the result of `t.find? cut`
and can either return `none` to remove the element or `some a` to replace/insert
the element with `a` (which must have the same ordering properties as the original element).

The element is used linearly if `t` is unshared.
-/
@[specialize] def alter (cut : α → Ordering) (f : Option α → Option α) (t : RBNode α) : RBNode α :=
  match zoom cut t with
  | (nil, path) =>
    match f none with
    | none => t -- TODO: profile whether it would be better to use `path.fill nil` here
    | some y => path.insertNew y
  | (node c a x b, path) =>
    match f (some x) with
    | none => path.del (a.append b) c
    | some y => path.fill (node c a y b)

/--
The ordering invariant of a red-black tree, which is a binary search tree.
This says that every element of a left subtree is less than the root, and
every element in the right subtree is greater than the root, where the
less than relation `x < y` is understood to mean `cmp x y = .lt`.

Because we do not assume that `cmp` is lawful when stating this property,
we write it in such a way that if `cmp` is not lawful then the condition holds trivially.
That way we can prove the ordering invariants without assuming `cmp` is lawful.
-/
def Ordered (cmp : α → α → Ordering) : RBNode α → Prop
  | nil => True
  | node _ a x b => a.All (cmpLT cmp · x) ∧ b.All (cmpLT cmp x ·) ∧ a.Ordered cmp ∧ b.Ordered cmp

/--
The red-black balance invariant. `Balanced t c n` says that the color of the root node is `c`,
and the black-height (the number of black nodes on any path from the root) of the tree is `n`.
Additionally, every red node must have black children.
-/
inductive Balanced : RBNode α → RBColor → Nat → Prop where
  /-- A nil node is balanced with black-height 0, and it is considered black. -/
  | protected nil : Balanced nil black 0
  /-- A red node is balanced with black-height `n`
  if its children are both black with with black-height `n`. -/
  | protected red : Balanced x black n → Balanced y black n → Balanced (node red x v y) red n
  /-- A black node is balanced with black-height `n + 1`
  if its children both have black-height `n`. -/
  | protected black : Balanced x c₁ n → Balanced y c₂ n → Balanced (node black x v y) black (n + 1)

/--
The well-formedness invariant for a red-black tree. The first constructor is the real invariant,
and the others allow us to "cheat" in this file and define `insert` and `erase`,
which have more complex proofs that are delayed to `Std.Data.RBMap.Lemmas`.
-/
inductive WF (cmp : α → α → Ordering) : RBNode α → Prop
  /-- The actual well-formedness invariant: a red-black tree has the
  ordering and balance invariants. -/
  | mk : t.Ordered cmp → t.Balanced c n → WF cmp t
  /-- Inserting into a well-formed tree yields another well-formed tree.
  (See `Ordered.insert` and `Balanced.insert` for the actual proofs.) -/
  | insert : WF cmp t → WF cmp (t.insert cmp a)
  /-- Erasing from a well-formed tree yields another well-formed tree.
  (See `Ordered.erase` and `Balanced.erase` for the actual proofs.) -/
  | erase : WF cmp t → WF cmp (t.erase cut)

end RBNode

open RBNode

/--
An `RBSet` is a self-balancing binary search tree.
The `cmp` function is the comparator that will be used for performing searches;
it should satisfy the requirements of `TransCmp` for it to have sensible behavior.
-/
def RBSet (α : Type u) (cmp : α → α → Ordering) : Type u := {t : RBNode α // t.WF cmp}

/-- `O(1)`. Construct a new empty tree. -/
@[inline] def mkRBSet (α : Type u) (cmp : α → α → Ordering) : RBSet α cmp := ⟨.nil, .mk ⟨⟩ .nil⟩

namespace RBSet

/-- `O(1)`. Construct a new empty tree. -/
@[inline] def empty : RBSet α cmp := mkRBSet ..

instance (α : Type u) (cmp : α → α → Ordering) : EmptyCollection (RBSet α cmp) := ⟨empty⟩

instance (α : Type u) (cmp : α → α → Ordering) : Inhabited (RBSet α cmp) := ⟨∅⟩

/-- `O(1)`. Construct a new tree with one element `v`. -/
@[inline] def single (v : α) : RBSet α cmp :=
  ⟨.node .red .nil v .nil, .mk ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ (.red .nil .nil)⟩

/-- `O(n)`. Fold a function on the values from left to right (in increasing order). -/
@[inline] def foldl (f : σ → α → σ) (init : σ) (t : RBSet α cmp) : σ := t.1.foldl f init

/-- `O(n)`. Fold a function on the values from right to left (in decreasing order). -/
@[inline] def foldr (f : α → σ → σ) (init : σ) (t : RBSet α cmp) : σ := t.1.foldr f init

/-- `O(n)`. Fold a monadic function on the values from left to right (in increasing order). -/
@[inline] def foldlM [Monad m] (f : σ → α → m σ) (init : σ) (t : RBSet α cmp) : m σ :=
  t.1.foldlM f init

/-- `O(n)`. Run monadic function `f` on each element of the tree (in increasing order). -/
@[inline] def forM [Monad m] (f : α → m PUnit) (t : RBSet α cmp) : m PUnit := t.1.forM f

instance : ForIn m (RBSet α cmp) α where
  forIn t := t.1.forIn

instance : ToStream (RBSet α cmp) (RBNode.Stream α) := ⟨fun x => x.1.toStream .nil⟩

/-- `O(1)`. Is the tree empty? -/
@[inline] def isEmpty : RBSet α cmp → Bool
  | ⟨nil, _⟩ => true
  | _        => false

/-- `O(n)`. Convert the tree to a list in ascending order. -/
@[inline] def toList (t : RBSet α cmp) : List α := t.1.toList

/-- `O(log n)`. Returns the entry `a` such that `a ≤ k` for all keys in the RBSet. -/
@[inline] protected def min (t : RBSet α cmp) : Option α := t.1.min

/-- `O(log n)`. Returns the entry `a` such that `a ≥ k` for all keys in the RBSet. -/
@[inline] protected def max (t : RBSet α cmp) : Option α := t.1.max

instance [Repr α] : Repr (RBSet α cmp) where
  reprPrec m prec := Repr.addAppParen ("RBSet.ofList " ++ repr m.toList) prec

/-- `O(log n)`. Insert element `v` into the tree. -/
@[inline] def insert (t : RBSet α cmp) (v : α) : RBSet α cmp := ⟨t.1.insert cmp v, t.2.insert⟩

/--
`O(log n)`. Remove an element from the tree using a cut function.
The `cut` function is used to locate an element in the tree:
it returns `.gt` if we go too high and `.lt` if we go too low;
if it returns `.eq` we will remove the element.
(The function `cmp k` for some key `k` is a valid cut function, but we can also use cuts that
are not of this form as long as they are suitably monotonic.)
-/
@[inline] def erase (t : RBSet α cmp) (cut : α → Ordering) : RBSet α cmp :=
  ⟨t.1.erase cut, t.2.erase⟩

/-- `O(log n)`. Find an element in the tree using a cut function. -/
@[inline] def findP? (t : RBSet α cmp) (cut : α → Ordering) : Option α := t.1.find? cut

/-- `O(log n)`. Returns an element in the tree equivalent to `x` if one exists. -/
@[inline] def find? (t : RBSet α cmp) (x : α) : Option α := t.1.find? (cmp x)

/-- `O(log n)`. Find an element in the tree, or return a default value `v₀`. -/
@[inline] def findPD (t : RBSet α cmp) (cut : α → Ordering) (v₀ : α) : α := (t.findP? cut).getD v₀

/--
`O(log n)`. `lowerBoundP cut` retrieves the largest entry comparing `lt` or `eq` under `cut`,
if it exists.
-/
@[inline] def lowerBoundP? (t : RBSet α cmp) (cut : α → Ordering) : Option α :=
  t.1.lowerBound? cut none

/--
`O(log n)`. `lowerBound? k` retrieves the largest entry smaller than or equal to `k`,
if it exists.
-/
@[inline] def lowerBound? (t : RBSet α cmp) (k : α) : Option α := t.1.lowerBound? (cmp k) none

/-- `O(log n)`. Returns true if the given cut returns `eq` for something in the RBSet. -/
@[inline] def containsP (t : RBSet α cmp) (cut : α → Ordering) : Bool := (t.findP? cut).isSome

/-- `O(log n)`. Returns true if the given key `a` is in the RBSet. -/
@[inline] def contains (t : RBSet α cmp) (a : α) : Bool := (t.find? a).isSome

/-- `O(n log n)`. Build a tree from an unsorted list by inserting them one at a time. -/
@[inline] def ofList (l : List α) (cmp : α → α → Ordering) : RBSet α cmp :=
  l.foldl (fun r p => r.insert p) (mkRBSet α cmp)

/-- `O(n log n)`. Build a tree from an unsorted array by inserting them one at a time. -/
@[inline] def ofArray (l : Array α) (cmp : α → α → Ordering) : RBSet α cmp :=
  l.foldl (fun r p => r.insert p) (mkRBSet α cmp)

/-- `O(n)`. Returns true if the given predicate is true for all items in the RBSet. -/
@[inline] def all (t : RBSet α cmp) (p : α → Bool) : Bool := t.1.all p

/-- `O(n)`. Returns true if the given predicate is true for any item in the RBSet. -/
@[inline] def any (t : RBSet α cmp) (p : α → Bool) : Bool := t.1.any p

/--
Asserts that `t₁` and `t₂` have the same number of elements in the same order,
and `R` holds pairwise between them. The tree structure is ignored.
-/
@[inline] def all₂ (R : α → β → Bool) (t₁ : RBSet α cmpα) (t₂ : RBSet β cmpβ) : Bool :=
  t₁.1.all₂ R t₂.1

/-- True if `x` is an element of `t` "exactly", i.e. up to equality, not the `cmp` relation. -/
def EMem (x : α) (t : RBSet α cmp) : Prop := t.1.EMem x

/-- True if the specified `cut` matches at least one element of of `t`. -/
def MemP (cut : α → Ordering) (t : RBSet α cmp) : Prop := t.1.MemP cut

/-- True if `x` is equivalent to an element of `t`. -/
def Mem (x : α) (t : RBSet α cmp) : Prop := MemP (cmp x) t

instance : Membership α (RBSet α cmp) := ⟨Mem⟩

/--
Returns true if `t₁` and `t₂` are equal as sets (assuming `cmp` and `==` are compatible),
ignoring the internal tree structure.
-/
instance [BEq α] : BEq (RBSet α cmp) where
  beq a b := a.all₂ (· == ·) b

/-- `O(n)`. The number of items in the RBSet. -/
def size (m : RBSet α cmp) : Nat := m.1.size

/-- `O(log n)`. Returns the minimum element of the tree, or panics if the tree is empty. -/
@[inline] def min! [Inhabited α] (t : RBSet α cmp) : α := t.min.getD (panic! "tree is empty")

/-- `O(log n)`. Returns the maximum element of the tree, or panics if the tree is empty. -/
@[inline] def max! [Inhabited α] (t : RBSet α cmp) : α := t.max.getD (panic! "tree is empty")

/--
`O(log n)`. Attempts to find the value with key `k : α` in `t` and panics if there is no such key.
-/
@[inline] def findP! [Inhabited α] (t : RBSet α cmp) (cut : α → Ordering) : α :=
  (t.findP? cut).getD (panic! "key is not in the tree")

/--
`O(log n)`. Attempts to find the value with key `k : α` in `t` and panics if there is no such key.
-/
@[inline] def find! [Inhabited α] (t : RBSet α cmp) (k : α) : α :=
  (t.find? k).getD (panic! "key is not in the tree")

/-- The predicate asserting that the result of `modifyP` is safe to construct. -/
class ModifyWF (t : RBSet α cmp) (cut : α → Ordering) (f : α → α) : Prop where
  /-- The resulting tree is well formed. -/
  wf : (t.1.modify cut f).WF cmp

/--
`O(log n)`. In-place replace an element found by `cut`.
This takes the element out of the tree while `f` runs,
so it uses the element linearly if `t` is unshared.

The `ModifyWF` assumption is required because `f` may change
the ordering properties of the element, which would break the invariants.
-/
def modifyP (t : RBSet α cmp) (cut : α → Ordering) (f : α → α)
    [wf : ModifyWF t cut f] : RBSet α cmp := ⟨t.1.modify cut f, wf.wf⟩

/-- The predicate asserting that the result of `alterP` is safe to construct. -/
class AlterWF (t : RBSet α cmp) (cut : α → Ordering) (f : Option α → Option α) : Prop where
  /-- The resulting tree is well formed. -/
  wf : (t.1.alter cut f).WF cmp

/--
`O(log n)`. `alterP cut f t` simultaneously handles inserting, erasing and replacing an element
using a function `f : Option α → Option α`. It is passed the result of `t.findP? cut`
and can either return `none` to remove the element or `some a` to replace/insert
the element with `a` (which must have the same ordering properties as the original element).

The element is used linearly if `t` is unshared.

The `AlterWF` assumption is required because `f` may change
the ordering properties of the element, which would break the invariants.
-/
def alterP (t : RBSet α cmp) (cut : α → Ordering) (f : Option α → Option α)
    [wf : AlterWF t cut f] : RBSet α cmp := ⟨t.1.alter cut f, wf.wf⟩

/--
`O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`.
If equal keys exist in both, the key from `t₂` is preferred.
-/
def union (t₁ t₂ : RBSet α cmp) : RBSet α cmp :=
  t₂.foldl .insert t₁

/--
`O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`. If equal keys exist in both,
then use `mergeFn a₁ a₂` to produce the new merged value.
-/
def mergeWith (mergeFn : α → α → α) (t₁ t₂ : RBSet α cmp) : RBSet α cmp :=
  t₂.foldl (init := t₁) fun t₁ a₂ =>
    t₁.insert <| match t₁.find? a₂ with | some a₁ => mergeFn a₁ a₂ | none => a₂

/--
`O(n₁ * log (n₁ + n₂))`. Intersects the maps `t₁` and `t₂`
using `mergeFn a b` to produce the new value.
-/
def intersectWith (cmp : α → β → Ordering) (mergeFn : α → β → γ)
    (t₁ : RBSet α cmpα) (t₂ : RBSet β cmpβ) : RBSet γ cmpγ :=
  t₁.foldl (init := ∅) fun acc a =>
    match t₂.findP? (cmp a) with
    | some b => acc.insert <| mergeFn a b
    | none => acc

/-- `O(n * log n)`. Constructs the set of all elements satisfying `p`. -/
def filter (t : RBSet α cmp) (p : α → Bool) : RBSet α cmp :=
  t.foldl (init := ∅) fun acc a => bif p a then acc.insert a else acc

/--
`O(n₁ * (log n₁ + log n₂))`. Constructs the set of all elements of `t₁` that are not in `t₂`.
-/
def sdiff (t₁ t₂ : RBSet α cmp) : RBSet α cmp := t₁.filter (!t₂.contains ·)

end RBSet

/- TODO(Leo): define dRBMap -/

/--
An `RBMap` is a self-balancing binary search tree, used to store a key-value map.
The `cmp` function is the comparator that will be used for performing searches;
it should satisfy the requirements of `TransCmp` for it to have sensible behavior.
-/
def RBMap (α : Type u) (β : Type v) (cmp : α → α → Ordering) : Type (max u v) :=
  RBSet (α × β) (byKey Prod.fst cmp)

/-- `O(1)`. Construct a new empty map. -/
@[inline] def mkRBMap (α : Type u) (β : Type v) (cmp : α → α → Ordering) : RBMap α β cmp :=
  mkRBSet ..

/-- `O(1)`. Construct a new empty map. -/
@[inline] def RBMap.empty {α : Type u} {β : Type v} {cmp : α → α → Ordering} : RBMap α β cmp :=
  mkRBMap ..

instance (α : Type u) (β : Type v) (cmp : α → α → Ordering) : EmptyCollection (RBMap α β cmp) :=
  ⟨RBMap.empty⟩

instance (α : Type u) (β : Type v) (cmp : α → α → Ordering) : Inhabited (RBMap α β cmp) := ⟨∅⟩

/-- `O(1)`. Construct a new tree with one key-value pair `k, v`. -/
@[inline] def RBMap.single (k : α) (v : β) : RBMap α β cmp := RBSet.single (k, v)

namespace RBMap
variable {α : Type u} {β : Type v} {σ : Type w} {cmp : α → α → Ordering}

/-- `O(n)`. Fold a function on the values from left to right (in increasing order). -/
@[inline] def foldl (f : σ → α → β → σ) : (init : σ) → RBMap α β cmp → σ
  | b, ⟨t, _⟩ => t.foldl (fun s (a, b) => f s a b) b

/-- `O(n)`. Fold a function on the values from right to left (in decreasing order). -/
@[inline] def foldr (f : α → β → σ → σ) : (init : σ) → RBMap α β cmp → σ
  | b, ⟨t, _⟩ => t.foldr (fun (a, b) s => f a b s) b

/-- `O(n)`. Fold a monadic function on the values from left to right (in increasing order). -/
@[inline] def foldlM [Monad m] (f : σ → α → β → m σ) : (init : σ) → RBMap α β cmp → m σ
  | b, ⟨t, _⟩ => t.foldlM (fun s (a, b) => f s a b) b

/-- `O(n)`. Run monadic function `f` on each element of the tree (in increasing order). -/
@[inline] def forM [Monad m] (f : α → β → m PUnit) (t : RBMap α β cmp) : m PUnit :=
  t.foldlM (fun _ k v => f k v) ⟨⟩

instance : ForIn m (RBMap α β cmp) (α × β) := inferInstanceAs (ForIn _ (RBSet ..) _)

instance : ToStream (RBMap α β cmp) (RBNode.Stream (α × β)) :=
  inferInstanceAs (ToStream (RBSet ..) _)

/-- `O(n)`. Constructs the array of keys of the map. -/
@[inline] def keysArray (t : RBMap α β cmp) : Array α :=
  t.1.foldl (init := #[]) (·.push ·.1)

/-- `O(n)`. Constructs the list of keys of the map. -/
@[inline] def keysList (t : RBMap α β cmp) : List α :=
  t.1.foldr (init := []) (·.1 :: ·)

/--
An "iterator" over the keys of the map. This is a trivial wrapper over the underlying map,
but it comes with a small API to use it in a `for` loop or convert it to an array or list.
-/
def Keys (α β cmp) := RBMap α β cmp

/--
The keys of the map. This is an `O(1)` wrapper operation, which
can be used in `for` loops or converted to an array or list.
-/
@[inline] def keys (t : RBMap α β cmp) : Keys α β cmp := t

@[inline, inherit_doc keysArray] def Keys.toArray := @keysArray

@[inline, inherit_doc keysList] def Keys.toList := @keysList

instance : CoeHead (Keys α β cmp) (Array α) := ⟨keysArray⟩

instance : CoeHead (Keys α β cmp) (List α) := ⟨keysList⟩

instance : ForIn m (Keys α β cmp) α where
  forIn t init f := t.val.forIn init (f ·.1)

instance : ForM m (Keys α β cmp) α where
  forM t f := t.val.forM (f ·.1)

/-- The result of `toStream` on a `Keys`. -/
def Keys.Stream (α β) := RBNode.Stream (α × β)

/-- A stream over the iterator. -/
def Keys.toStream (t : Keys α β cmp) : Keys.Stream α β := t.1.toStream

/-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/
def Keys.Stream.next? (t : Stream α β) : Option (α × Stream α β) :=
  match inline (RBNode.Stream.next? t) with
  | none => none
  | some ((a, _), t) => some (a, t)

instance : ToStream (Keys α β cmp) (Keys.Stream α β) := ⟨Keys.toStream⟩
instance : Stream (Keys.Stream α β) α := ⟨Keys.Stream.next?⟩

/-- `O(n)`. Constructs the array of values of the map. -/
@[inline] def valuesArray (t : RBMap α β cmp) : Array β :=
  t.1.foldl (init := #[]) (·.push ·.2)

/-- `O(n)`. Constructs the list of values of the map. -/
@[inline] def valuesList (t : RBMap α β cmp) : List β :=
  t.1.foldr (init := []) (·.2 :: ·)

/--
An "iterator" over the values of the map. This is a trivial wrapper over the underlying map,
but it comes with a small API to use it in a `for` loop or convert it to an array or list.
-/
def Values (α β cmp) := RBMap α β cmp

/--
The "keys" of the map. This is an `O(1)` wrapper operation, which
can be used in `for` loops or converted to an array or list.
-/
@[inline] def values (t : RBMap α β cmp) : Values α β cmp := t

@[inline, inherit_doc valuesArray] def Values.toArray := @valuesArray

@[inline, inherit_doc valuesList] def Values.toList := @valuesList

instance : CoeHead (Values α β cmp) (Array β) := ⟨valuesArray⟩

instance : CoeHead (Values α β cmp) (List β) := ⟨valuesList⟩

instance : ForIn m (Values α β cmp) β where
  forIn t init f := t.val.forIn init (f ·.2)

instance : ForM m (Values α β cmp) β where
  forM t f := t.val.forM (f ·.2)

/-- The result of `toStream` on a `Values`. -/
def Values.Stream (α β) := RBNode.Stream (α × β)

/-- A stream over the iterator. -/
def Values.toStream (t : Values α β cmp) : Values.Stream α β := t.1.toStream

/-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/
def Values.Stream.next? (t : Stream α β) : Option (β × Stream α β) :=
  match inline (RBNode.Stream.next? t) with
  | none => none
  | some ((_, b), t) => some (b, t)

instance : ToStream (Values α β cmp) (Values.Stream α β) := ⟨Values.toStream⟩
instance : Stream (Values.Stream α β) β := ⟨Values.Stream.next?⟩

/-- `O(1)`. Is the tree empty? -/
@[inline] def isEmpty : RBMap α β cmp → Bool := RBSet.isEmpty

/-- `O(n)`. Convert the tree to a list in ascending order. -/
@[inline] def toList : RBMap α β cmp → List (α × β) := RBSet.toList

/-- `O(log n)`. Returns the key-value pair `(a, b)` such that `a ≤ k` for all keys in the RBMap. -/
@[inline] protected def min : RBMap α β cmp → Option (α × β) := RBSet.min

/-- `O(log n)`. Returns the key-value pair `(a, b)` such that `a ≥ k` for all keys in the RBMap. -/
@[inline] protected def max : RBMap α β cmp → Option (α × β) := RBSet.max

instance [Repr α] [Repr β] : Repr (RBMap α β cmp) where
  reprPrec m prec := Repr.addAppParen ("RBMap.ofList " ++ repr m.toList) prec

/-- `O(log n)`. Insert key-value pair `(k, v)` into the tree. -/
@[inline] def insert (t : RBMap α β cmp) (k : α) (v : β) : RBMap α β cmp := RBSet.insert t (k, v)

/-- `O(log n)`. Remove an element `k` from the map. -/
@[inline] def erase (t : RBMap α β cmp) (k : α) : RBMap α β cmp := RBSet.erase t (cmp k ·.1)

/-- `O(n log n)`. Build a tree from an unsorted list by inserting them one at a time. -/
@[inline] def ofList (l : List (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp :=
  RBSet.ofList l _

/-- `O(n log n)`. Build a tree from an unsorted array by inserting them one at a time. -/
@[inline] def ofArray (l : Array (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp :=
  RBSet.ofArray l _

/-- `O(log n)`. Find an entry in the tree with key equal to `k`. -/
@[inline] def findEntry? (t : RBMap α β cmp) (k : α) : Option (α × β) := t.findP? (cmp k ·.1)

/-- `O(log n)`. Find the value corresponding to key `k`. -/
@[inline] def find? (t : RBMap α β cmp) (k : α) : Option β := t.findEntry? k |>.map (·.2)

/-- `O(log n)`. Find the value corresponding to key `k`, or return `v₀` if it is not in the map. -/
@[inline] def findD (t : RBMap α β cmp) (k : α) (v₀ : β) : β := (t.find? k).getD v₀

/--
`O(log n)`. `lowerBound? k` retrieves the key-value pair of the largest key
smaller than or equal to `k`, if it exists.
-/
@[inline] def lowerBound? (t : RBMap α β cmp) (k : α) : Option (α × β) :=
   RBSet.lowerBoundP? t (cmp k ·.1)

/-- `O(log n)`. Returns true if the given key `a` is in the RBMap. -/
@[inline] def contains (t : RBMap α β cmp) (a : α) : Bool := (t.findEntry? a).isSome

/-- `O(n)`. Returns true if the given predicate is true for all items in the RBMap. -/
@[inline] def all (t : RBMap α β cmp) (p : α → β → Bool) : Bool := RBSet.all t fun (a, b) => p a b

/-- `O(n)`. Returns true if the given predicate is true for any item in the RBMap. -/
@[inline] def any (t : RBMap α β cmp) (p : α → β → Bool) : Bool := RBSet.any t fun (a, b) => p a b

/--
Asserts that `t₁` and `t₂` have the same number of elements in the same order,
and `R` holds pairwise between them. The tree structure is ignored.
-/
@[inline] def all₂ (R : α × β → γ × δ → Bool) (t₁ : RBMap α β cmpα) (t₂ : RBMap γ δ cmpγ) : Bool :=
  RBSet.all₂ R t₁ t₂

/-- Asserts that `t₁` and `t₂` have the same set of keys (up to equality). -/
@[inline] def eqKeys (t₁ : RBMap α β cmp) (t₂ : RBMap α γ cmp) : Bool :=
  t₁.all₂ (cmp ·.1 ·.1 = .eq) t₂

/--
Returns true if `t₁` and `t₂` have the same keys and values
(assuming `cmp` and `==` are compatible), ignoring the internal tree structure.
-/
instance [BEq α] [BEq β] : BEq (RBMap α β cmp) := inferInstanceAs (BEq (RBSet ..))

/-- `O(n)`. The number of items in the RBMap. -/
def size : RBMap α β cmp → Nat := RBSet.size

/-- `O(log n)`. Returns the minimum element of the map, or panics if the map is empty. -/
@[inline] def min! [Inhabited α] [Inhabited β] : RBMap α β cmp → α × β := RBSet.min!

/-- `O(log n)`. Returns the maximum element of the map, or panics if the map is empty. -/
@[inline] def max! [Inhabited α] [Inhabited β] : RBMap α β cmp → α × β := RBSet.max!

/-- Attempts to find the value with key `k : α` in `t` and panics if there is no such key. -/
@[inline] def find! [Inhabited β] (t : RBMap α β cmp) (k : α) : β :=
  (t.find? k).getD (panic! "key is not in the map")

/--
`O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`, if a key `a : α` exists in both,
then use `mergeFn a b₁ b₂` to produce the new merged value.
-/
def mergeWith (mergeFn : α → β → β → β) (t₁ t₂ : RBMap α β cmp) : RBMap α β cmp :=
  RBSet.mergeWith (fun (_, b₁) (a, b₂) => (a, mergeFn a b₁ b₂)) t₁ t₂

/--
`O(n₁ * log (n₁ + n₂))`. Intersects the maps `t₁` and `t₂`
using `mergeFn a b` to produce the new value.
-/
def intersectWith (mergeFn : α → β → γ → δ)
    (t₁ : RBMap α β cmp) (t₂ : RBMap α γ cmp) : RBMap α δ cmp :=
  RBSet.intersectWith (cmp ·.1 ·.1) (fun (a, b₁) (_, b₂) => (a, mergeFn a b₁ b₂)) t₁ t₂

/-- `O(n * log n)`. Constructs the set of all elements satisfying `p`. -/
def filter (t : RBMap α β cmp) (p : α → β → Bool) : RBMap α β cmp :=
  RBSet.filter t fun (a, b) => p a b

/--
`O(n₁ * (log n₁ + log n₂))`. Constructs the set of all elements of `t₁` that are not in `t₂`.
-/
def sdiff (t₁ t₂ : RBMap α β cmp) : RBMap α β cmp := t₁.filter fun a _ => !t₂.contains a

end RBMap
end Std
open Std

@[inherit_doc RBMap.ofList]
abbrev List.toRBMap (l : List (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp :=
  RBMap.ofList l cmp


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.limits.constructions.epi_mono
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.Pullbacks
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Pullbacks

/-!
# Relating monomorphisms and epimorphisms to limits and colimits

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

If `F` preserves (resp. reflects) pullbacks, then it preserves (resp. reflects) monomorphisms.

We also provide the dual version for epimorphisms.

-/

universe v₁ v₂ u₁ u₂

namespace CategoryTheory

open Category Limits

variable {C : Type u₁} {D : Type u₂} [Category.{v₁} C] [Category.{v₂} D]

variable (F : C ⥤ D)

/- warning: category_theory.preserves_mono_of_preserves_limit -> CategoryTheory.preserves_mono_of_preservesLimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.PreservesLimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingCospan (CategoryTheory.Limits.WidePullbackShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.cospan.{u1, u3} C _inst_1 X X Y f f) F] [_inst_4 : CategoryTheory.Mono.{u1, u3} C _inst_1 X Y f], CategoryTheory.Mono.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f)
but is expected to have type
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.PreservesLimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingCospan (CategoryTheory.Limits.WidePullbackShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.cospan.{u1, u3} C _inst_1 X X Y f f) F] [_inst_4 : CategoryTheory.Mono.{u1, u3} C _inst_1 X Y f], CategoryTheory.Mono.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f)
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_mono_of_preserves_limit CategoryTheory.preserves_mono_of_preservesLimitₓ'. -/
/-- If `F` preserves pullbacks, then it preserves monomorphisms. -/
theorem preserves_mono_of_preservesLimit {X Y : C} (f : X ⟶ Y) [PreservesLimit (cospan f f) F]
    [Mono f] : Mono (F.map f) :=
  by
  have := is_limit_pullback_cone_map_of_is_limit F _ (pullback_cone.is_limit_mk_id_id f)
  simp_rw [F.map_id] at this
  apply pullback_cone.mono_of_is_limit_mk_id_id _ this
#align category_theory.preserves_mono_of_preserves_limit CategoryTheory.preserves_mono_of_preservesLimit

#print CategoryTheory.preservesMonomorphisms_of_preservesLimitsOfShape /-
instance (priority := 100) preservesMonomorphisms_of_preservesLimitsOfShape
    [PreservesLimitsOfShape WalkingCospan F] : F.PreservesMonomorphisms
    where preserves X Y f hf := preserves_mono_of_preserves_limit F f
#align category_theory.preserves_monomorphisms_of_preserves_limits_of_shape CategoryTheory.preservesMonomorphisms_of_preservesLimitsOfShape
-/

/- warning: category_theory.reflects_mono_of_reflects_limit -> CategoryTheory.reflects_mono_of_reflectsLimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.ReflectsLimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingCospan (CategoryTheory.Limits.WidePullbackShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.cospan.{u1, u3} C _inst_1 X X Y f f) F] [_inst_4 : CategoryTheory.Mono.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f)], CategoryTheory.Mono.{u1, u3} C _inst_1 X Y f
but is expected to have type
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.ReflectsLimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingCospan (CategoryTheory.Limits.WidePullbackShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.cospan.{u1, u3} C _inst_1 X X Y f f) F] [_inst_4 : CategoryTheory.Mono.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f)], CategoryTheory.Mono.{u1, u3} C _inst_1 X Y f
Case conversion may be inaccurate. Consider using '#align category_theory.reflects_mono_of_reflects_limit CategoryTheory.reflects_mono_of_reflectsLimitₓ'. -/
/-- If `F` reflects pullbacks, then it reflects monomorphisms. -/
theorem reflects_mono_of_reflectsLimit {X Y : C} (f : X ⟶ Y) [ReflectsLimit (cospan f f) F]
    [Mono (F.map f)] : Mono f :=
  by
  have := pullback_cone.is_limit_mk_id_id (F.map f)
  simp_rw [← F.map_id] at this
  apply pullback_cone.mono_of_is_limit_mk_id_id _ (is_limit_of_is_limit_pullback_cone_map F _ this)
#align category_theory.reflects_mono_of_reflects_limit CategoryTheory.reflects_mono_of_reflectsLimit

#print CategoryTheory.reflectsMonomorphisms_of_reflectsLimitsOfShape /-
instance (priority := 100) reflectsMonomorphisms_of_reflectsLimitsOfShape
    [ReflectsLimitsOfShape WalkingCospan F] : F.ReflectsMonomorphisms
    where reflects X Y f hf := reflects_mono_of_reflects_limit F f
#align category_theory.reflects_monomorphisms_of_reflects_limits_of_shape CategoryTheory.reflectsMonomorphisms_of_reflectsLimitsOfShape
-/

/- warning: category_theory.preserves_epi_of_preserves_colimit -> CategoryTheory.preserves_epi_of_preservesColimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.PreservesColimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingSpan (CategoryTheory.Limits.WidePushoutShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.span.{u1, u3} C _inst_1 X Y Y f f) F] [_inst_4 : CategoryTheory.Epi.{u1, u3} C _inst_1 X Y f], CategoryTheory.Epi.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f)
but is expected to have type
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.PreservesColimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingSpan (CategoryTheory.Limits.WidePushoutShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.span.{u1, u3} C _inst_1 X Y Y f f) F] [_inst_4 : CategoryTheory.Epi.{u1, u3} C _inst_1 X Y f], CategoryTheory.Epi.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f)
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_epi_of_preserves_colimit CategoryTheory.preserves_epi_of_preservesColimitₓ'. -/
/-- If `F` preserves pushouts, then it preserves epimorphisms. -/
theorem preserves_epi_of_preservesColimit {X Y : C} (f : X ⟶ Y) [PreservesColimit (span f f) F]
    [Epi f] : Epi (F.map f) :=
  by
  have := is_colimit_pushout_cocone_map_of_is_colimit F _ (pushout_cocone.is_colimit_mk_id_id f)
  simp_rw [F.map_id] at this
  apply pushout_cocone.epi_of_is_colimit_mk_id_id _ this
#align category_theory.preserves_epi_of_preserves_colimit CategoryTheory.preserves_epi_of_preservesColimit

#print CategoryTheory.preservesEpimorphisms_of_preservesColimitsOfShape /-
instance (priority := 100) preservesEpimorphisms_of_preservesColimitsOfShape
    [PreservesColimitsOfShape WalkingSpan F] : F.PreservesEpimorphisms
    where preserves X Y f hf := preserves_epi_of_preserves_colimit F f
#align category_theory.preserves_epimorphisms_of_preserves_colimits_of_shape CategoryTheory.preservesEpimorphisms_of_preservesColimitsOfShape
-/

/- warning: category_theory.reflects_epi_of_reflects_colimit -> CategoryTheory.reflects_epi_of_reflectsColimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.ReflectsColimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingSpan (CategoryTheory.Limits.WidePushoutShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.span.{u1, u3} C _inst_1 X Y Y f f) F] [_inst_4 : CategoryTheory.Epi.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f)], CategoryTheory.Epi.{u1, u3} C _inst_1 X Y f
but is expected to have type
  forall {C : Type.{u3}} {D : Type.{u4}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] [_inst_2 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2) {X : C} {Y : C} (f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y) [_inst_3 : CategoryTheory.Limits.ReflectsColimit.{0, 0, u1, u2, u3, u4} C _inst_1 D _inst_2 CategoryTheory.Limits.WalkingSpan (CategoryTheory.Limits.WidePushoutShape.category.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.Limits.span.{u1, u3} C _inst_1 X Y Y f f) F] [_inst_4 : CategoryTheory.Epi.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f)], CategoryTheory.Epi.{u1, u3} C _inst_1 X Y f
Case conversion may be inaccurate. Consider using '#align category_theory.reflects_epi_of_reflects_colimit CategoryTheory.reflects_epi_of_reflectsColimitₓ'. -/
/-- If `F` reflects pushouts, then it reflects epimorphisms. -/
theorem reflects_epi_of_reflectsColimit {X Y : C} (f : X ⟶ Y) [ReflectsColimit (span f f) F]
    [Epi (F.map f)] : Epi f :=
  by
  have := pushout_cocone.is_colimit_mk_id_id (F.map f)
  simp_rw [← F.map_id] at this
  apply
    pushout_cocone.epi_of_is_colimit_mk_id_id _
      (is_colimit_of_is_colimit_pushout_cocone_map F _ this)
#align category_theory.reflects_epi_of_reflects_colimit CategoryTheory.reflects_epi_of_reflectsColimit

#print CategoryTheory.reflectsEpimorphisms_of_reflectsColimitsOfShape /-
instance (priority := 100) reflectsEpimorphisms_of_reflectsColimitsOfShape
    [ReflectsColimitsOfShape WalkingSpan F] : F.ReflectsEpimorphisms
    where reflects X Y f hf := reflects_epi_of_reflects_colimit F f
#align category_theory.reflects_epimorphisms_of_reflects_colimits_of_shape CategoryTheory.reflectsEpimorphisms_of_reflectsColimitsOfShape
-/

end CategoryTheory


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

import category_theory.limits.constructions.pullbacks
import category_theory.limits.shapes.biproducts
import category_theory.limits.shapes.images
import category_theory.limits.constructions.limits_of_products_and_equalizers
import category_theory.abelian.non_preadditive

/-!
# Abelian categories

This file contains the definition and basic properties of abelian categories.

There are many definitions of abelian category. Our definition is as follows:
A category is called abelian if it is preadditive,
has a finite products, kernels and cokernels,
and if every monomorphism and epimorphism is normal.

It should be noted that if we also assume coproducts, then preadditivity is
actually a consequence of the other properties, as we show in
`non_preadditive_abelian.lean`. However, this fact is of little practical
relevance, since essentially all interesting abelian categories come with a
preadditive structure. In this way, by requiring preadditivity, we allow the
user to pass in the preadditive structure the specific category they are
working with has natively.

## Main definitions

* `abelian` is the type class indicating that a category is abelian. It extends `preadditive`.
* `abelian.image f` is `kernel (cokernel.π f)`, and
* `abelian.coimage f` is `cokernel (kernel.ι f)`.

## Main results

* In an abelian category, mono + epi = iso.
* If `f : X ⟶ Y`, then the map `factor_thru_image f : X ⟶ image f` is an epimorphism, and the map
  `factor_thru_coimage f : coimage f ⟶ Y` is a monomorphism.
* Factoring through the image and coimage is a strong epi-mono factorisation. This means that
  * every abelian category has images. We instantiated this in such a way that `abelian.image f` is
    definitionally equal to `limits.image f`, and
  * there is a canonical isomorphism `coimage_iso_image : coimage f ≅ image f` such that
    `coimage.π f ≫ (coimage_iso_image f).hom ≫ image.ι f = f`. The lemma stating this is called
    `full_image_factorisation`.
* Every epimorphism is a cokernel of its kernel. Every monomorphism is a kernel of its cokernel.
* The pullback of an epimorphism is an epimorphism. The pushout of a monomorphism is a monomorphism.
  (This is not to be confused with the fact that the pullback of a monomorphism is a monomorphism,
  which is true in any category).

## Implementation notes

The typeclass `abelian` does not extend `non_preadditive_abelian`,
to avoid having to deal with comparing the two `has_zero_morphisms` instances
(one from `preadditive` in `abelian`, and the other a field of `non_preadditive_abelian`).
As a consequence, at the beginning of this file we trivially build
a `non_preadditive_abelian` instance from an `abelian` instance,
and use this to restate a number of theorems,
in each case just reusing the proof from `non_preadditive_abelian.lean`.

We don't show this yet, but abelian categories are finitely complete and finitely cocomplete.
However, the limits we can construct at this level of generality will most likely be less nice than
the ones that can be created in specific applications. For this reason, we adopt the following
convention:

* If the statement of a theorem involves limits, the existence of these limits should be made an
  explicit typeclass parameter.
* If a limit only appears in a proof, but not in the statement of a theorem, the limit should not
  be a typeclass parameter, but instead be created using `abelian.has_pullbacks` or a similar
  definition.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
* [P. Aluffi, *Algebra: Chaper 0*][aluffi2016]

-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

namespace category_theory

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

variables (C)

/--
A (preadditive) category `C` is called abelian if it has all finite products,
all kernels and cokernels, and if every monomorphism is the kernel of some morphism
and every epimorphism is the cokernel of some morphism.

(This definition implies the existence of zero objects:
finite products give a terminal object, and in a preadditive category
any terminal object is a zero object.)
-/
class abelian extends preadditive C :=
[has_finite_products : has_finite_products C]
[has_kernels : has_kernels C]
[has_cokernels : has_cokernels C]
(normal_mono : Π {X Y : C} (f : X ⟶ Y) [mono f], normal_mono f)
(normal_epi : Π {X Y : C} (f : X ⟶ Y) [epi f], normal_epi f)

attribute [instance, priority 100] abelian.has_finite_products
attribute [instance, priority 100] abelian.has_kernels abelian.has_cokernels

end category_theory

open category_theory

namespace category_theory.abelian
variables {C : Type u} [category.{v} C] [abelian C]

/-- An abelian category has finite biproducts. -/
@[priority 100]
instance has_finite_biproducts : has_finite_biproducts C :=
limits.has_finite_biproducts.of_has_finite_products

@[priority 100]
instance has_binary_biproducts : has_binary_biproducts C :=
limits.has_binary_biproducts_of_finite_biproducts _

@[priority 100]
instance has_zero_object : has_zero_object C :=
has_zero_object_of_has_initial_object

section to_non_preadditive_abelian

/-- Every abelian category is, in particular, `non_preadditive_abelian`. -/
def non_preadditive_abelian : non_preadditive_abelian C := { ..‹abelian C› }

end to_non_preadditive_abelian

section strong
local attribute [instance] abelian.normal_epi abelian.normal_mono

/-- In an abelian category, every epimorphism is strong. -/
lemma strong_epi_of_epi {P Q : C} (f : P ⟶ Q) [epi f] : strong_epi f := by apply_instance

/-- In an abelian category, every monomorphism is strong. -/
lemma strong_mono_of_mono {P Q : C} (f : P ⟶ Q) [mono f] : strong_mono f := by apply_instance

end strong

section mono_epi_iso
variables {X Y : C} (f : X ⟶ Y)

local attribute [instance] strong_epi_of_epi

/-- In an abelian category, a monomorphism which is also an epimorphism is an isomorphism. -/
lemma is_iso_of_mono_of_epi [mono f] [epi f] : is_iso f :=
is_iso_of_mono_of_strong_epi _

end mono_epi_iso

section factor
local attribute [instance] non_preadditive_abelian

variables {P Q : C} (f : P ⟶ Q)

section

lemma mono_of_zero_kernel (R : C)
  (l : is_limit (kernel_fork.of_ι (0 : R ⟶ P) (show 0 ≫ f = 0, by simp))) : mono f :=
non_preadditive_abelian.mono_of_zero_kernel _ _ l

lemma mono_of_kernel_ι_eq_zero (h : kernel.ι f = 0) : mono f :=
mono_of_kernel_zero h

lemma epi_of_zero_cokernel (R : C)
  (l : is_colimit (cokernel_cofork.of_π (0 : Q ⟶ R) (show f ≫ 0 = 0, by simp))) : epi f :=
non_preadditive_abelian.epi_of_zero_cokernel _ _ l

lemma epi_of_cokernel_π_eq_zero (h : cokernel.π f = 0) : epi f :=
begin
  apply epi_of_zero_cokernel _ (cokernel f),
  simp_rw ←h,
  exact is_colimit.of_iso_colimit (colimit.is_colimit (parallel_pair f 0)) (iso_of_π _)
end

end

namespace images

/-- The kernel of the cokernel of `f` is called the image of `f`. -/
protected abbreviation image : C := kernel (cokernel.π f)

/-- The inclusion of the image into the codomain. -/
protected abbreviation image.ι : images.image f ⟶ Q :=
kernel.ι (cokernel.π f)

/-- There is a canonical epimorphism `p : P ⟶ image f` for every `f`. -/
protected abbreviation factor_thru_image : P ⟶ images.image f :=
kernel.lift (cokernel.π f) f $ cokernel.condition f

/-- `f` factors through its image via the canonical morphism `p`. -/
@[simp, reassoc] protected lemma image.fac :
  images.factor_thru_image f ≫ image.ι f = f :=
kernel.lift_ι _ _ _

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : epi (images.factor_thru_image f) :=
show epi (non_preadditive_abelian.factor_thru_image f), by apply_instance

section
variables {f}

lemma image_ι_comp_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : images.image.ι f ≫ g = 0 :=
zero_of_epi_comp (images.factor_thru_image f) $ by simp [h]

end

instance mono_factor_thru_image [mono f] : mono (images.factor_thru_image f) :=
mono_of_mono_fac $ image.fac f

instance is_iso_factor_thru_image [mono f] : is_iso (images.factor_thru_image f) :=
is_iso_of_mono_of_epi _

/-- Factoring through the image is a strong epi-mono factorisation. -/
@[simps] def image_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := images.image f,
  m := image.ι f,
  m_mono := by apply_instance,
  e := images.factor_thru_image f,
  e_strong_epi := strong_epi_of_epi _ }

end images

namespace coimages

/-- The cokernel of the kernel of `f` is called the coimage of `f`. -/
protected abbreviation coimage : C := cokernel (kernel.ι f)

/-- The projection onto the coimage. -/
protected abbreviation coimage.π : P ⟶ coimages.coimage f :=
cokernel.π (kernel.ι f)

/-- There is a canonical monomorphism `i : coimage f ⟶ Q`. -/
protected abbreviation factor_thru_coimage : coimages.coimage f ⟶ Q :=
cokernel.desc (kernel.ι f) f $ kernel.condition f

/-- `f` factors through its coimage via the canonical morphism `p`. -/
protected lemma coimage.fac : coimage.π f ≫ coimages.factor_thru_coimage f = f :=
cokernel.π_desc _ _ _

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : mono (coimages.factor_thru_coimage f) :=
show mono (non_preadditive_abelian.factor_thru_coimage f), by apply_instance

section
variables {f}

lemma comp_coimage_π_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : f ≫ coimages.coimage.π g = 0 :=
zero_of_comp_mono (coimages.factor_thru_coimage g) $ by simp [h]

end

instance epi_factor_thru_coimage [epi f] : epi (coimages.factor_thru_coimage f) :=
epi_of_epi_fac $ coimage.fac f

instance is_iso_factor_thru_coimage [epi f] : is_iso (coimages.factor_thru_coimage f) :=
is_iso_of_mono_of_epi _

/-- Factoring through the coimage is a strong epi-mono factorisation. -/
@[simps] def coimage_strong_epi_mono_factorisation : strong_epi_mono_factorisation f :=
{ I := coimages.coimage f,
  m := coimages.factor_thru_coimage f,
  m_mono := by apply_instance,
  e := coimage.π f,
  e_strong_epi := strong_epi_of_epi _ }

end coimages

end factor

section has_strong_epi_mono_factorisations

/-- An abelian category has strong epi-mono factorisations. -/
@[priority 100] instance : has_strong_epi_mono_factorisations C :=
has_strong_epi_mono_factorisations.mk $ λ X Y f, images.image_strong_epi_mono_factorisation f

/- In particular, this means that it has well-behaved images. -/
example : has_images C := by apply_instance
example : has_image_maps C := by apply_instance

end has_strong_epi_mono_factorisations

section images
variables {X Y : C} (f : X ⟶ Y)

/-- There is a canonical isomorphism between the coimage and the image of a morphism. -/
abbreviation coimage_iso_image : coimages.coimage f ≅ images.image f :=
is_image.iso_ext (coimages.coimage_strong_epi_mono_factorisation f).to_mono_is_image
  (images.image_strong_epi_mono_factorisation f).to_mono_is_image

/-- There is a canonical isomorphism between the abelian image and the categorical image of a
    morphism. -/
abbreviation image_iso_image : images.image f ≅ image f :=
is_image.iso_ext (images.image_strong_epi_mono_factorisation f).to_mono_is_image (image.is_image f)

/-- There is a canonical isomorphism between the abelian coimage and the categorical image of a
    morphism. -/
abbreviation coimage_iso_image' : coimages.coimage f ≅ image f :=
is_image.iso_ext (coimages.coimage_strong_epi_mono_factorisation f).to_mono_is_image
  (image.is_image f)

lemma full_image_factorisation : coimages.coimage.π f ≫ (coimage_iso_image f).hom ≫
  images.image.ι f = f :=
by rw [limits.is_image.iso_ext_hom,
  ←images.image_strong_epi_mono_factorisation_to_mono_factorisation_m, is_image.lift_fac,
  coimages.coimage_strong_epi_mono_factorisation_to_mono_factorisation_m, coimages.coimage.fac]

end images

section cokernel_of_kernel
variables {X Y : C} {f : X ⟶ Y}

local attribute [instance] non_preadditive_abelian

/-- In an abelian category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epi_is_cokernel_of_kernel [epi f] (s : fork f 0) (h : is_limit s) :
  is_colimit (cokernel_cofork.of_π f (kernel_fork.condition s)) :=
non_preadditive_abelian.epi_is_cokernel_of_kernel s h

/-- In an abelian category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def mono_is_kernel_of_cokernel [mono f] (s : cofork f 0) (h : is_colimit s) :
  is_limit (kernel_fork.of_ι f (cokernel_cofork.condition s)) :=
non_preadditive_abelian.mono_is_kernel_of_cokernel s h

end cokernel_of_kernel

section

@[priority 100]
instance has_equalizers : has_equalizers C :=
preadditive.has_equalizers_of_has_kernels

/-- Any abelian category has pullbacks -/
@[priority 100]
instance has_pullbacks : has_pullbacks C :=
has_pullbacks_of_has_binary_products_of_has_equalizers C

end

section

@[priority 100]
instance has_coequalizers : has_coequalizers C :=
preadditive.has_coequalizers_of_has_cokernels

/-- Any abelian category has pushouts -/
@[priority 100]
instance has_pushouts : has_pushouts C :=
has_pushouts_of_has_binary_coproducts_of_has_coequalizers C

@[priority 100]
instance has_finite_limits : has_finite_limits C :=
limits.finite_limits_from_equalizers_and_finite_products

@[priority 100]
instance has_finite_colimits : has_finite_colimits C :=
limits.finite_colimits_from_coequalizers_and_finite_coproducts

end

namespace pullback_to_biproduct_is_kernel
variables [limits.has_pullbacks C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-! This section contains a slightly technical result about pullbacks and biproducts.
    We will need it in the proof that the pullback of an epimorphism is an epimorpism. -/

/-- The canonical map `pullback f g ⟶ X ⊞ Y` -/
abbreviation pullback_to_biproduct : pullback f g ⟶ X ⊞ Y :=
biprod.lift pullback.fst pullback.snd

/-- The canonical map `pullback f g ⟶ X ⊞ Y` induces a kernel cone on the map
    `biproduct X Y ⟶ Z` induced by `f` and `g`. A slightly more intuitive way to think of
    this may be that it induces an equalizer fork on the maps induced by `(f, 0)` and
    `(0, g)`. -/
abbreviation pullback_to_biproduct_fork : kernel_fork (biprod.desc f (-g)) :=
kernel_fork.of_ι (pullback_to_biproduct f g) $
by rw [biprod.lift_desc, comp_neg, pullback.condition, add_right_neg]

/-- The canonical map `pullback f g ⟶ X ⊞ Y` is a kernel of the map induced by
    `(f, -g)`. -/
def is_limit_pullback_to_biproduct : is_limit (pullback_to_biproduct_fork f g) :=
fork.is_limit.mk _
  (λ s, pullback.lift (fork.ι s ≫ biprod.fst) (fork.ι s ≫ biprod.snd) $
    sub_eq_zero.1 $ by rw [category.assoc, category.assoc, ←comp_sub, sub_eq_add_neg, ←comp_neg,
      ←biprod.desc_eq, kernel_fork.condition s])
  (λ s,
  begin
    ext; rw [fork.ι_of_ι, category.assoc],
    { rw [biprod.lift_fst, pullback.lift_fst] },
    { rw [biprod.lift_snd, pullback.lift_snd] }
  end)
  (λ s m h, by ext; simp [fork.ι_eq_app_zero, ←h walking_parallel_pair.zero])

end pullback_to_biproduct_is_kernel

namespace biproduct_to_pushout_is_cokernel
variables [limits.has_pushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` -/
abbreviation biproduct_to_pushout : Y ⊞ Z ⟶ pushout f g :=
biprod.desc pushout.inl pushout.inr

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` induces a cokernel cofork on the map
    `X ⟶ Y ⊞ Z` induced by `f` and `-g`. -/
abbreviation biproduct_to_pushout_cofork : cokernel_cofork (biprod.lift f (-g)) :=
cokernel_cofork.of_π (biproduct_to_pushout f g) $
by rw [biprod.lift_desc, neg_comp, pushout.condition, add_right_neg]

/-- The cofork induced by the canonical map `Y ⊞ Z ⟶ pushout f g` is in fact a colimit cokernel
    cofork. -/
def is_colimit_biproduct_to_pushout : is_colimit (biproduct_to_pushout_cofork f g) :=
cofork.is_colimit.mk _
  (λ s, pushout.desc (biprod.inl ≫ cofork.π s) (biprod.inr ≫ cofork.π s) $
    sub_eq_zero.1 $ by rw [←category.assoc, ←category.assoc, ←sub_comp, sub_eq_add_neg, ←neg_comp,
      ←biprod.lift_eq, cofork.condition s, zero_comp])
  (λ s, by ext; simp)
  (λ s m h, by ext; simp [cofork.π_eq_app_one, ←h walking_parallel_pair.one] )

end biproduct_to_pushout_is_cokernel

section epi_pullback
variables [limits.has_pullbacks C] {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-- In an abelian category, the pullback of an epimorphism is an epimorphism.
    Proof from [aluffi2016, IX.2.3], cf. [borceux-vol2, 1.7.6] -/
instance epi_pullback_of_epi_f [epi f] : epi (pullback.snd : pullback f g ⟶ Y) :=
-- It will suffice to consider some morphism e : Y ⟶ R such that
-- pullback.snd ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (0, e) : X ⊞ Y⟶ R.
  let u := biprod.desc (0 : X ⟶ R) e,
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then f ≫ d = 0:
  have : f ≫ d = 0, calc
    f ≫ d = (biprod.inl ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inl_desc
    ... = biprod.inl ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inl_desc _ _,
  -- But f is an epimorphism, so d = 0...
  have : d = 0 := (cancel_epi f).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inr ≫ u : by rw biprod.inr_desc
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inr ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inr ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

/-- In an abelian category, the pullback of an epimorphism is an epimorphism. -/
instance epi_pullback_of_epi_g [epi g] : epi (pullback.fst : pullback f g ⟶ X) :=
-- It will suffice to consider some morphism e : X ⟶ R such that
-- pullback.fst ≫ e = 0 and show that e = 0.
epi_of_cancel_zero _ $ λ R e h,
begin
  -- Consider the morphism u := (e, 0) : X ⊞ Y ⟶ R.
  let u := biprod.desc e (0 : Y ⟶ R),
  -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
  have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa,
  -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
  -- cokernel of pullback_to_biproduct f g
  have := epi_is_cokernel_of_kernel _
    (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g),
  -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
  obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu,
  change Z ⟶ R at d,
  change biprod.desc f (-g) ≫ d = u at hd,
  -- But then (-g) ≫ d = 0:
  have : (-g) ≫ d = 0, calc
    (-g) ≫ d = (biprod.inr ≫ biprod.desc f (-g)) ≫ d : by rw biprod.inr_desc
    ... = biprod.inr ≫ u : by rw [category.assoc, hd]
    ... = 0 : biprod.inr_desc _ _,
  -- But g is an epimorphism, thus so is -g, so d = 0...
  have : d = 0 := (cancel_epi (-g)).1 (by simpa),
  -- ...or, in other words, e = 0.
  calc
    e = biprod.inl ≫ u : by rw biprod.inl_desc
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ d : by rw ←hd
    ... = biprod.inl ≫ biprod.desc f (-g) ≫ 0 : by rw this
    ... = (biprod.inl ≫ biprod.desc f (-g)) ≫ 0 : by rw ←category.assoc
    ... = 0 : has_zero_morphisms.comp_zero _ _
end

lemma epi_snd_of_is_limit [epi f] {s : pullback_cone f g} (hs : is_limit s) : epi s.snd :=
begin
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _),
  { refl },
  { exact abelian.epi_pullback_of_epi_f _ _ }
end

lemma epi_fst_of_is_limit [epi g] {s : pullback_cone f g} (hs : is_limit s) : epi s.fst :=
begin
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _),
  { refl },
  { exact abelian.epi_pullback_of_epi_g _ _ }
end

/-- Suppose `f` and `g` are two morphisms with a common codomain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the mono part of this
    factorization, then any pullback of `g` along `f` is an epimorphism. -/
lemma epi_fst_of_factor_thru_epi_mono_factorization
  (g₁ : Y ⟶ W) [epi g₁] (g₂ : W ⟶ Z) [mono g₂] (hg : g₁ ≫ g₂ = g) (f' : X ⟶ W) (hf : f' ≫ g₂ = f)
  (t : pullback_cone f g) (ht : is_limit t) : epi t.fst :=
by apply epi_fst_of_is_limit _ _ (pullback_cone.is_limit_of_factors f g g₂ f' g₁ hf hg t ht)

end epi_pullback

section mono_pushout
variables [limits.has_pushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

instance mono_pushout_of_mono_f [mono f] : mono (pushout.inr : Z ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift (0 : R ⟶ Y) e,
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ f = 0, calc
    d ≫ f = d ≫ biprod.lift f (-g) ≫ biprod.fst : by rw biprod.lift_fst
    ... = u ≫ biprod.fst : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_fst _ _,
  have : d = 0 := (cancel_mono f).1 (by simpa),
  calc
    e = u ≫ biprod.snd : by rw biprod.lift_snd
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.snd : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.snd : by rw category.assoc
    ... = 0 : zero_comp
end

instance mono_pushout_of_mono_g [mono g] : mono (pushout.inl : Y ⟶ pushout f g) :=
mono_of_cancel_zero _ $ λ R e h,
begin
  let u := biprod.lift e (0 : R ⟶ Z),
  have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa,
  have := mono_is_kernel_of_cokernel _
    (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g),
  obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu,
  change R ⟶ X at d,
  change d ≫ biprod.lift f (-g) = u at hd,
  have : d ≫ (-g) = 0, calc
    d ≫ (-g) = d ≫ biprod.lift f (-g) ≫ biprod.snd : by rw biprod.lift_snd
    ... = u ≫ biprod.snd : by rw [←category.assoc, hd]
    ... = 0 : biprod.lift_snd _ _,
  have : d = 0 := (cancel_mono (-g)).1 (by simpa),
  calc
    e = u ≫ biprod.fst : by rw biprod.lift_fst
    ... = (d ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw ←hd
    ... = (0 ≫ biprod.lift f (-g)) ≫ biprod.fst : by rw this
    ... = 0 ≫ biprod.lift f (-g) ≫ biprod.fst : by rw category.assoc
    ... = 0 : zero_comp
end

lemma mono_inr_of_is_colimit [mono f] {s : pushout_cocone f g} (hs : is_colimit s) : mono s.inr :=
begin
  convert mono_of_mono_fac
    (is_colimit.comp_cocone_point_unique_up_to_iso_hom hs (colimit.is_colimit _) _),
  { refl },
  { exact abelian.mono_pushout_of_mono_f _ _ }
end

/-- Suppose `f` and `g` are two morphisms with a common domain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the epi part of this
    factorization, then any pushout of `g` along `f` is a monomorphism. -/
lemma mono_inl_of_factor_thru_epi_mono_factorization (f : X ⟶ Y) (g : X ⟶ Z)
  (g₁ : X ⟶ W) [epi g₁] (g₂ : W ⟶ Z) [mono g₂] (hg : g₁ ≫ g₂ = g) (f' : W ⟶ Y) (hf : g₁ ≫ f' = f)
  (t : pushout_cocone f g) (ht : is_colimit t) : mono t.inl :=
by apply mono_inl_of_is_colimit _ _ (pushout_cocone.is_colimit_of_factors _ _ _ _ _ hf hg t ht)

end mono_pushout

end category_theory.abelian

namespace category_theory.non_preadditive_abelian

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

/-- Every non_preadditive_abelian category can be promoted to an abelian category. -/
def abelian : abelian C :=
{ has_finite_products := by apply_instance,
/- We need the `convert`s here because the instances we have are slightly different from the
   instances we need: `has_kernels` depends on an instance of `has_zero_morphisms`. In the
   case of `non_preadditive_abelian`, this instance is an explicit argument. However, in the case
   of `abelian`, the `has_zero_morphisms` instance is derived from `preadditive`. So we need to
   transform an instance of "has kernels with non_preadditive_abelian.has_zero_morphisms" to an
   instance of "has kernels with non_preadditive_abelian.preadditive.has_zero_morphisms". Luckily,
   we have a `subsingleton` instance for `has_zero_morphisms`, so `convert` can immediately close
   the goal it creates for the two instances of `has_zero_morphisms`, and the proof is complete. -/
  has_kernels := by convert (by apply_instance : limits.has_kernels C),
  has_cokernels := by convert (by apply_instance : limits.has_cokernels C),
  normal_mono := by { introsI, convert normal_mono f },
  normal_epi := by { introsI, convert normal_epi f },
  ..non_preadditive_abelian.preadditive }

end category_theory.non_preadditive_abelian


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.bool.default

namespace Mathlib

/-
Simplification lemmas for ite.

We don't prove them at logic.lean because it is easier to prove them using
the tactic framework.
-/

@[simp] theorem if_true_right_eq_or (p : Prop) [h : Decidable p] (q : Prop) : ite p q True = (¬p ∨ q) := sorry

@[simp] theorem if_true_left_eq_or (p : Prop) [h : Decidable p] (q : Prop) : ite p True q = (p ∨ q) := sorry

@[simp] theorem if_false_right_eq_and (p : Prop) [h : Decidable p] (q : Prop) : ite p q False = (p ∧ q) := sorry

@[simp] theorem if_false_left_eq_and (p : Prop) [h : Decidable p] (q : Prop) : ite p False q = (¬p ∧ q) := sorry


import data.equiv.basic
import tactic.dec_trivial
import tactic.derive_fintype

import chess.board

/-!

# Definitions and theorems about chess board movements

## Summary

A `move` on a particular `board` is a pair of squares whose start square
contains a `piece` and whose end square does not.

Moves may be combined into `sequence`s of moves, which encapsulate
multiple sequential moves all iteratively satisfying the above
condition.

## Main definitions

1. The `move` itself, which requires specifying the particular `board`
it will occur on

2. `perform_move`, which yields the `board` whose playfield has the
start and end squares of a `move` suitably modified

3. A move `sequence`, rooted on a starting board, containing a sequence
of start and end squares which can be treated as iterated moves.

## Implementation notes

1. `move` and `sequence` are implemented independently of each other.
`sequence.moves` can be used to extract a `move` from a particular
index into a `sequence`. `sequence`s are also currently finite, and
therefore also may automatically infer proofs of move conditions via
`dec_trivial`.

2. Currently, no legality checks or piece math whatsoever is performed,
meaning `move`s are not yet programmatically confirmed to be
legal. Captures are similarly not yet supported.

-/

namespace chess

variables {m n : Type}

variables [fintype m] [fintype n] [decidable_eq m] [decidable_eq n]
variables {ι : Type} [fintype ι] [decidable_eq ι]

variables {K : Type}

variables (b : board m n ι K)

/--
A move is a (distinct) start and end square whose start square is
occupied and whose end square is not.

No inhabited instance because the board might be
made up of a single occupied position.

(Captures are not implemented yet.)
-/
@[derive [decidable_eq, fintype], nolint has_inhabited_instance]
structure move :=
(start_square : m × n)
(end_square : m × n)
(occupied_start : b.contents.occupied_at start_square . tactic.exact_dec_trivial)
(unoccupied_end : ¬ b.contents.occupied_at end_square . tactic.exact_dec_trivial)

variable {b}
variable (f : move b)

namespace move

/-- Start squares are occupied before a move. -/
@[simp] lemma before_occupied_start :
    b.contents.occupied_at f.start_square := f.occupied_start

/-- End squares are unoccupied before a move. -/
@[simp] lemma before_unoccupied_end :
    ¬ b.contents.occupied_at f.end_square := f.unoccupied_end

/-- Start squares are unoccupied after a move. -/
@[simp] lemma after_unoccupied_start :
    ¬ (b.contents.move_piece f.start_square f.end_square).occupied_at f.start_square :=
by simp only [playfield.move_piece_occupied_start, before_unoccupied_end, not_false_iff]

/-- End squares are occupied after a move. -/
@[simp] lemma after_occupied_end :
    (b.contents.move_piece f.start_square f.end_square).occupied_at f.end_square :=
by simp only [before_occupied_start, playfield.move_piece_occupied_end]

/-- Other squares are unchanged after a move. -/
@[simp] lemma before_after_same {pos : m × n}
    (h : pos ≠ f.start_square) (h' : pos ≠ f.end_square) :
    b.contents.move_piece f.start_square f.end_square pos = b.contents pos :=
b.contents.move_piece_diff h h'

/-- Other occupation are unchanged after a move. -/
@[simp] lemma before_after_same_occupied {pos : m × n}
    (h : pos ≠ f.start_square) (h' : pos ≠ f.end_square) :
    (b.contents.move_piece f.start_square f.end_square).occupied_at pos =
      b.contents.occupied_at pos :=
by simp only [h, h', ne.def, playfield.move_piece_occupied_diff, not_false_iff]

/-- The start and end squares of a move are distinct. -/
lemma diff_squares : f.start_square ≠ f.end_square :=
λ H, f.unoccupied_end (H ▸ f.occupied_start)

/-- The piece that is being moved. -/
def piece : K := b.piece_at f.start_square f.occupied_start

/-- Pieces do not become superimposed after a move. -/
lemma no_superimposed (pos pos') (hne : pos ≠ pos')
    (h : (b.contents.move_piece f.start_square f.end_square).occupied_at pos) :
    b.contents.move_piece f.start_square f.end_square pos ≠
      b.contents.move_piece f.start_square f.end_square pos' :=
λ H, hne (b.contents.retains_injectivity b.injects f.occupied_start h H)

variables (f)

/--
A `move` retains all indices, ignoring empty squares,
present on the `board` it operates on.
-/
lemma retains_surjectivity :
  function.surjective (b.contents.move_piece f.start_square f.end_square).index_at :=
b.contents.index_at_retains_surjectivity b.contains f.before_occupied_start

/-- A `move` retains accesing indices injectively on the `board` it operates on. -/
lemma retains_injectivity :
  (b.contents.move_piece f.start_square f.end_square).some_injective :=
b.contents.retains_injectivity b.injects f.before_occupied_start

/-- A valid `move` on a `board` retains a valid board state. -/
def perform_move : board m n ι K :=
{ pieces := b.pieces,
  contents := b.contents.move_piece f.start_square f.end_square,
  contains := f.retains_surjectivity,
  injects := f.retains_injectivity }

-- The length of the sequence
variables {o : ℕ}

/--
Define the mapping of `playfield`s after performing successive `move_piece`s
using the pairs of positions in the provided `elements`,
starting from the `start_board`.
-/
def scan_contents
  (start_board: board m n ι K)
  (elements : fin o → (m × n) × (m × n)) : fin (o + 1) → playfield m n ι :=
start_board.contents.move_sequence (vector.of_fn elements)

variables (m n ι K o)

/--
A move `sequence` represents a sequential set of moves from a starting `board`.

No inhabited instance because boards do not have an inhabited instance.
-/
@[nolint has_inhabited_instance]
structure sequence :=
(start_board : board m n ι K)
(elements : fin o → (m × n) × (m × n))
(all_occupied_start' :
  ∀ (e : fin o),
    ((scan_contents start_board elements) e.cast_succ).occupied_at (elements e).fst . tactic.exact_dec_trivial)
(all_unoccupied_end' :
  ∀ (e : fin o),
    ¬ ((scan_contents start_board elements) e.cast_succ).occupied_at (elements e).snd . tactic.exact_dec_trivial)

namespace sequence

variables {m n ι K o}
variables (s : sequence m n ι K o)

/-- Shorthand for referring to the contents at a sequence index `ixₒ : fin (o + 1)`. -/
def contents_at (ixₒ : fin (o + 1)) : playfield m n ι :=
(scan_contents s.start_board s.elements) ixₒ

/-- Shorthand for referring to the contents at a sequence index `ixₒ : fin (o + 1)`. -/
lemma contents_at_def (ixₒ : fin (o + 1)) :
  s.contents_at ixₒ = (scan_contents s.start_board s.elements) ixₒ := rfl

/-- Every scanned board is occupied at the start square of the upcoming move. -/
lemma all_occupied_start (e : fin o) : (s.contents_at e.cast_succ).occupied_at (s.elements e).fst :=
s.all_occupied_start' e

/-- Every scanned board is unoccupied at the end square of the upcoming move. -/
lemma all_unoccupied_end (e : fin o) : ¬ (s.contents_at e.cast_succ).occupied_at (s.elements e).snd :=
s.all_unoccupied_end' e

open playfield vector

/-- The first contents in a `scan_contents` `sequence` is of the `start_board`. -/
@[simp] lemma sequence_zero : s.contents_at 0 = s.start_board.contents :=
by simp only [contents_at_def, scan_contents, move_sequence_def, nth_zero, scanl_head]

/-- Any `contents_at` a step in the `sequence` is the result of performing a `move_piece` using
the `sequence.elements` at that step. -/
lemma sequence_step (e : fin o) :
  s.contents_at e.succ =
    (s.contents_at e.cast_succ).move_piece (s.elements e).fst (s.elements e).snd :=
by simp only [contents_at_def, scan_contents, move_sequence_def, scanl_nth, nth_of_fn]

/-- Every `playfield` in a sequence of moves contains all the indices it can. -/
lemma retains_surjectivity (ixₒ : fin (o + 1)) :
  function.surjective (s.contents_at ixₒ).index_at :=
begin
  apply fin.induction_on ixₒ,
  { rw sequence_zero,
    exact s.start_board.contains },
  { intros ix h,
    rw sequence_step,
    apply playfield.index_at_retains_surjectivity _ h,
    exact s.all_occupied_start _ },
end

/-- Every `playfield` in a sequence of moves injectively accesses the indices. -/
lemma retains_injectivity (ixₒ : fin (o + 1)) : (s.contents_at ixₒ).some_injective :=
begin
  apply fin.induction_on ixₒ,
  { simpa only [sequence_zero] using s.start_board.injects },
  { intros ix h,
    simp only [sequence_step],
    apply playfield.retains_injectivity _ h,
    exact s.all_occupied_start _ },
end

/-- Pieces do not disappear after any `move_piece` in a `sequence`. -/
lemma retains_pieces (ixₒ : fin (o + 1)) (ixᵢ : ι) :
  ixᵢ ∈ (s.contents_at ixₒ) :=
exists.elim (s.retains_surjectivity ixₒ ixᵢ) (λ pos h, h ▸ playfield.index_at_in pos)

/-- Pieces do not become superimposed after any `move` in a `sequence`. -/
lemma no_superimposed (ixₒ : fin (o + 1)) (pos pos') (hne : pos ≠ pos')
    (h : (s.contents_at ixₒ).occupied_at pos) :
      (s.contents_at ixₒ) pos ≠ (s.contents_at ixₒ) pos' :=
λ H, hne (s.retains_injectivity _ h H)

/-- The board which results from applying the first `ix₀ + 1` `move`s in the `sequence`. -/
def boards (ixₒ : fin (o + 1)) : board m n ι K :=
{ contents := s.contents_at ixₒ,
  pieces := s.start_board.pieces,
  contains := s.retains_surjectivity ixₒ,
  injects := s.retains_injectivity ixₒ }

/-- The board which results from applying all `move`s in the `sequence`. -/
def end_board : board m n ι K := s.boards (fin.last o)

variables {b}
variables (s)

/-- The `ix₀`'th `move` in the `sequence`. -/
def moves (ixₒ : fin o) : chess.move (s.boards ixₒ.cast_succ) :=
{ start_square := (s.elements ixₒ).fst,
  end_square := (s.elements ixₒ).snd,
  occupied_start := by { simpa only [boards] using s.all_occupied_start _ },
  unoccupied_end := by { simpa only [boards] using s.all_unoccupied_end _ } }

/--
Any square which is not the `start_square` or `end_square` of any `move`
in the `sequence` is fixed across all `move`s (i.e. contains the same piece or remains empty).
-/
lemma fixes_unmentioned_squares
  (ixᵢ : ι)
  {pos}
  {h_pos: s.start_board.contents pos = ixᵢ}
  (h_unmentioned : ∀ ixₒ, pos ≠ (s.elements ixₒ).fst ∧ pos ≠ (s.elements ixₒ).snd) :
    ∀ ixₒ, (s.boards ixₒ).contents pos = ixᵢ :=
begin
  dsimp [boards, scan_contents],
  intro ix,
  apply fin.induction_on ix,
  { simpa only [sequence_zero] using h_pos },
  { intros ix' h,
    simpa only [sequence_step, move_piece_diff,
                h_unmentioned, ne.def, not_false_iff] using h },
end

end sequence
end move

namespace board

variable (b)

/--
Assert the existence of a `sequence` of length `o` from a `start_board` to a given end board.
-/
def has_sequence_len (end_board: board m n ι K) (o : ℕ) :=
    ∃ (s : chess.move.sequence m n ι K o), b ≈ s.start_board ∧ end_board ≈ s.end_board

/-- Assert the existence of a `sequence` from a `start_board` to a given end board. -/
def has_sequence_to (end_board: board m n ι K) :=
    ∃ (o : ℕ), b.has_sequence_len end_board o

end board

end chess