/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.lazy_list.basic
import data.tree
import data.int.basic
import control.bifunctor
import control.ulift
import tactic.linarith
import testing.slim_check.gen

/-!
# `sampleable` Class

This class permits the creation samples of a given type
controlling the size of those values using the `gen` monad`. It also
helps minimize examples by creating smaller versions of given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`slim_check` requires that `ℕ` have an instance of `sampleable` and for
`prime n` to be decidable.  `slim_check` will then use the instance of
`sampleable` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`slim_check` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `slim_check` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `sampleable` class
  * `sampleable_functor` and `sampleable_bifunctor` class
  * `sampleable_ext` class

### `sampleable`

`sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.

### `sampleable_ext`

`sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type.

### `sampleable_functor` and `sampleable_bifunctor`

`sampleable_functor F` and `sampleable_bifunctor F` makes it possible
to create samples of and shrink `F α` given a sampling function and a
shrinking function for arbitrary `α`.

This allows us to separate the logic for generating the shape of a
collection from the logic for generating its contents. Specifically,
the contents could be generated using either `sampleable` or
`sampleable_ext` instance and the `sampleable_(bi)functor` does not
need to use that information

## Shrinking

Shrinking happens when `slim_check` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `slim_check` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `sampleable` class, beside having the `sample` function, has a
`shrink` function so that we can use specialized knowledge while
shrinking a value. It is not responsible for the whole shrinking process
however. It only has to take one step in the shrinking process.
`slim_check` will repeatedly call `shrink` until no more steps can
be taken. Because `shrink` guarantees that the size of the candidates
it produces is strictly smaller than the argument, we know that
`slim_check` is guaranteed to terminate.

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/
universes u v w

namespace slim_check

variables (α : Type u)

local infix ` ≺ `:50 := has_well_founded.r

/-- `sizeof_lt x y` compares the sizes of `x` and `y`. -/
def sizeof_lt {α} [has_sizeof α] (x y : α) := sizeof x < sizeof y

/-- `shrink_fn α` is the type of functions that shrink an
argument of type `α` -/
@[reducible]
def shrink_fn (α : Type*) [has_sizeof α] := Π x : α, lazy_list { y : α // sizeof_lt y x }

/-- `sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.  -/
class sampleable :=
[wf : has_sizeof α]
(sample [] : gen α)
(shrink : Π x : α, lazy_list { y : α // @sizeof _ wf y < @sizeof _ wf x } := λ _, lazy_list.nil)

attribute [instance, priority 100] has_well_founded_of_has_sizeof default_has_sizeof
attribute [instance, priority 200] sampleable.wf

/-- `sampleable_functor F` makes it possible to create samples of and
shrink `F α` given a sampling function and a shrinking function for
arbitrary `α` -/
class sampleable_functor (F : Type u → Type v) [functor F] :=
[wf : Π α [has_sizeof α], has_sizeof (F α)]
(sample [] : ∀ {α}, gen α → gen (F α))
(shrink : ∀ α [has_sizeof α], shrink_fn α → shrink_fn (F α))
(p_repr : ∀ α, has_repr α → has_repr (F α))

/-- `sampleable_bifunctor F` makes it possible to create samples of
and shrink `F α β` given a sampling function and a shrinking function
for arbitrary `α` and `β` -/
class sampleable_bifunctor (F : Type u → Type v → Type w) [bifunctor F] :=
[wf : Π α β [has_sizeof α] [has_sizeof β], has_sizeof (F α β)]
(sample [] : ∀ {α β}, gen α → gen β → gen (F α β))
(shrink : ∀ α β [has_sizeof α] [has_sizeof β], shrink_fn α → shrink_fn β → shrink_fn (F α β))
(p_repr : ∀ α β, has_repr α → has_repr β → has_repr (F α β))

export sampleable (sample shrink)

/-- This function helps infer the proxy representation and
interpretation in `sampleable_ext` instances. -/
meta def sampleable.mk_trivial_interp : tactic unit :=
tactic.refine ``(id)

/-- `sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class sampleable_ext (α : Sort u) :=
(proxy_repr : Type v)
[wf : has_sizeof proxy_repr]
(interp [] : proxy_repr → α . sampleable.mk_trivial_interp)
[p_repr : has_repr proxy_repr]
(sample [] : gen proxy_repr)
(shrink : shrink_fn proxy_repr)

attribute [instance, priority 100] sampleable_ext.p_repr sampleable_ext.wf

open nat lazy_list

section prio

open sampleable_ext

set_option default_priority 50

instance sampleable_ext.of_sampleable {α} [sampleable α] [has_repr α] : sampleable_ext α :=
{ proxy_repr := α,
  sample := sampleable.sample α,
  shrink := shrink }

instance sampleable.functor {α} {F} [functor F] [sampleable_functor F] [sampleable α] :
  sampleable (F α) :=
{ wf := _,
  sample := sampleable_functor.sample F (sampleable.sample α),
  shrink := sampleable_functor.shrink α sampleable.shrink }

instance sampleable.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F] [sampleable α]
  [sampleable β] : sampleable (F α β) :=
{ wf := _,
  sample := sampleable_bifunctor.sample F (sampleable.sample α) (sampleable.sample β),
  shrink := sampleable_bifunctor.shrink α β sampleable.shrink sampleable.shrink }

set_option default_priority 100

instance sampleable_ext.functor {α} {F} [functor F] [sampleable_functor F] [sampleable_ext α] :
  sampleable_ext (F α) :=
{ wf := _,
  proxy_repr := F (proxy_repr α),
  interp := functor.map (interp _),
  sample := sampleable_functor.sample F (sampleable_ext.sample α),
  shrink := sampleable_functor.shrink _ sampleable_ext.shrink,
  p_repr := sampleable_functor.p_repr _ sampleable_ext.p_repr }

instance sampleable_ext.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F]
  [sampleable_ext α] [sampleable_ext β] : sampleable_ext (F α β) :=
{ wf := _,
  proxy_repr := F (proxy_repr α) (proxy_repr β),
  interp := bifunctor.bimap (interp _) (interp _),
  sample := sampleable_bifunctor.sample F (sampleable_ext.sample α) (sampleable_ext.sample β),
  shrink := sampleable_bifunctor.shrink _ _ sampleable_ext.shrink sampleable_ext.shrink,
  p_repr := sampleable_bifunctor.p_repr _ _ sampleable_ext.p_repr sampleable_ext.p_repr }

end prio

/-- `nat.shrink' k n` creates a list of smaller natural numbers by
successively dividing `n` by 2 and subtracting the difference from
`k`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink' (k : ℕ) : Π n : ℕ, n ≤ k →
  list { m : ℕ // has_well_founded.r m k } → list { m : ℕ // has_well_founded.r m k }
| n hn ls :=
if h : n ≤ 1
  then ls.reverse
  else
    have h₂ : 0 < n, by linarith,
    have 1 * n / 2 < n,
      from nat.div_lt_of_lt_mul (nat.mul_lt_mul_of_pos_right (by norm_num) h₂),
    have n / 2 < n, by simpa,
    let m := n / 2 in
    have h₀ : m ≤ k, from le_trans (le_of_lt this) hn,
    have h₃ : 0 < m,
      by simp only [m, lt_iff_add_one_le, zero_add]; rw [nat.le_div_iff_mul_le]; linarith,
    have h₁ : k - m < k,
      from nat.sub_lt (lt_of_lt_of_le h₂ hn) h₃,
    nat.shrink' m h₀ (⟨k - m, h₁⟩ :: ls)

/-- `nat.shrink n` creates a list of smaller natural numbers by
successively dividing by 2 and subtracting the difference from
`n`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink (n : ℕ) : list { m : ℕ // has_well_founded.r m n } :=
if h : n > 0 then
  have ∀ k, 1 < k → n / k < n, from
    λ k hk,
     nat.div_lt_of_lt_mul
       (suffices 1 * n < k * n, by simpa,
        nat.mul_lt_mul_of_pos_right hk h),
  ⟨n/11, this _ (by norm_num)⟩ :: ⟨n/3, this _ (by norm_num)⟩ :: nat.shrink' n n (le_refl _) []
else
  []

open gen

/--
Transport a `sampleable` instance from a type `α` to a type `β` using
functions between the two, going in both directions.

Function `g` is used to define the well-founded order that
`shrink` is expected to follow.
-/
def sampleable.lift (α : Type u) {β : Type u} [sampleable α] (f : α → β) (g : β → α)
  (h : ∀ (a : α), sizeof (g (f a)) ≤ sizeof a) : sampleable β :=
{ wf := ⟨ sizeof ∘ g ⟩,
  sample := f <$> sample α,
  shrink := λ x,
    have ∀ a,  sizeof a < sizeof (g x) → sizeof (g (f a)) < sizeof (g x),
      by introv h'; solve_by_elim [lt_of_le_of_lt],
    subtype.map f this <$> shrink (g x) }

instance nat.sampleable : sampleable ℕ :=
{ sample := sized $ λ sz, freq [(1, coe <$> choose_any (fin $ succ (sz^3))),
                                (3, coe <$> choose_any (fin $ succ sz))] dec_trivial,
  shrink :=  λ x, lazy_list.of_list $ nat.shrink x }

/-- `iterate_shrink p x` takes a decidable predicate `p` and a
value `x` of some sampleable type and recursively shrinks `x`.
It first calls `shrink x` to get a list of candidate sample,
finds the first that satisfies `p` and recursively tries
to shrink that one. -/
def iterate_shrink {α} [has_to_string α] [sampleable α]
  (p : α → Prop) [decidable_pred p] :
  α → option α :=
well_founded.fix has_well_founded.wf $ λ x f_rec,
  do trace sformat!"{x} : {(shrink x).to_list}" $ pure (),
     y ← (shrink x).find (λ a, p a),
     f_rec y y.property <|> some y.val .

instance fin.sampleable {n} [fact $ 0 < n] : sampleable (fin n) :=
sampleable.lift ℕ fin.of_nat' subtype.val $
λ i, (mod_le _ _ : i % n ≤ i)

@[priority 100]
instance fin.sampleable' {n} : sampleable (fin (succ n)) :=
sampleable.lift ℕ fin.of_nat subtype.val $
λ i, (mod_le _ _ : i % succ n ≤ i)

instance pnat.sampleable : sampleable ℕ+ :=
sampleable.lift ℕ nat.succ_pnat pnat.nat_pred $ λ a,
by unfold_wf; simp only [pnat.nat_pred, succ_pnat, pnat.mk_coe, tsub_zero, succ_sub_succ_eq_sub]

/-- Redefine `sizeof` for `int` to make it easier to use with `nat` -/
def int.has_sizeof : has_sizeof ℤ := ⟨ int.nat_abs ⟩

local attribute [instance, priority 2000] int.has_sizeof

instance int.sampleable : sampleable ℤ :=
{ wf := _,
  sample := sized $ λ sz,
          freq [(1, subtype.val <$> choose (-(sz^3 + 1) : ℤ) (sz^3 + 1) (neg_le_self dec_trivial)),
                (3, subtype.val <$> choose (-(sz + 1)) (sz + 1) (neg_le_self dec_trivial))]
               dec_trivial,
  shrink :=
    λ x, lazy_list.of_list $ (nat.shrink $ int.nat_abs x).bind $
    λ ⟨y,h⟩, [⟨y, h⟩, ⟨-y, by dsimp [sizeof,has_sizeof.sizeof]; rw int.nat_abs_neg; exact h ⟩] }

instance bool.sampleable : sampleable bool :=
{ wf := ⟨ λ b, if b then 1 else 0 ⟩,
  sample := do { x ← choose_any bool,
                 return x },
  shrink := λ b, if h : b then lazy_list.singleton ⟨ff, by cases h; unfold_wf⟩
                          else lazy_list.nil }

/--
Provided two shrinking functions `prod.shrink` shrinks a pair `(x, y)` by
first shrinking `x` and pairing the results with `y` and then shrinking
`y` and pairing the results with `x`.

All pairs either contain `x` untouched or `y` untouched. We rely on
shrinking being repeated for `x` to get maximally shrunken and then
for `y` to get shrunken too.
-/
def prod.shrink {α β} [has_sizeof α] [has_sizeof β]
  (shr_a : shrink_fn α) (shr_b : shrink_fn β) : shrink_fn (α × β)
| ⟨x₀,x₁⟩ :=
  let xs₀ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_a x₀).map $ subtype.map (λ a, (a, x₁))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h),
      xs₁ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_b x₁).map $ subtype.map (λ a, (x₀, a))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h) in
  xs₀.append xs₁

instance prod.sampleable : sampleable_bifunctor.{u v} prod :=
{ wf := _,
  sample := λ α β sama samb, do
              { ⟨x⟩ ← (uliftable.up $ sama : gen (ulift.{max u v} α)),
                ⟨y⟩ ← (uliftable.up $ samb : gen (ulift.{max u v} β)),
                pure (x,y) },
  shrink := @prod.shrink,
  p_repr := @prod.has_repr }

instance sigma.sampleable {α β} [sampleable α] [sampleable β] : sampleable (Σ _ : α, β) :=
sampleable.lift (α × β) (λ ⟨x,y⟩, ⟨x,y⟩) (λ ⟨x,y⟩, ⟨x,y⟩) $ λ ⟨x,y⟩, le_refl _

/-- shrinking function for sum types -/
def sum.shrink {α β} [has_sizeof α] [has_sizeof β] (shrink_α : shrink_fn α)
  (shrink_β : shrink_fn β) : shrink_fn (α ⊕ β)
| (sum.inr x) := (shrink_β x).map $ subtype.map sum.inr $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim
| (sum.inl x) := (shrink_α x).map $ subtype.map sum.inl $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim

instance sum.sampleable : sampleable_bifunctor.{u v} sum :=
{ wf := _,
  sample := λ (α : Type u) (β : Type v) sam_α sam_β,
            (@uliftable.up_map gen.{u} gen.{max u v} _ _ _ _ (@sum.inl α β) sam_α <|>
             @uliftable.up_map gen.{v} gen.{max v u} _ _ _ _ (@sum.inr α β) sam_β),
  shrink := λ α β Iα Iβ shr_α shr_β, @sum.shrink _ _ Iα Iβ shr_α shr_β,
  p_repr := @sum.has_repr }

instance rat.sampleable : sampleable ℚ :=
sampleable.lift (ℤ × ℕ+) (λ x, prod.cases_on x rat.mk_pnat) (λ r, (r.num, ⟨r.denom, r.pos⟩)) $
begin
  intro i,
  rcases i with ⟨x,⟨y,hy⟩⟩; unfold_wf;
  dsimp [rat.mk_pnat],
  mono*,
  { rw [← int.coe_nat_le, ← int.abs_eq_nat_abs, ← int.abs_eq_nat_abs],
    apply int.abs_div_le_abs },
  { change _ - 1 ≤ y-1,
    apply tsub_le_tsub_right,
    apply nat.div_le_of_le_mul,
    suffices : 1 * y ≤ x.nat_abs.gcd y * y, { simpa },
    apply nat.mul_le_mul_right,
    apply gcd_pos_of_pos_right _ hy }
end

/-- `sampleable_char` can be specialized into customized `sampleable char` instances.

The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `characters` with uniform probabilities.  -/
def sampleable_char (length : nat) (characters : string) : sampleable char :=
{ sample := do { x ← choose_nat 0 length dec_trivial,
                 if x.val = 0 then do
                   n ← sample ℕ,
                   pure $ char.of_nat n
                 else do
                   i ← choose_nat 0 (characters.length - 1) dec_trivial,
                   pure (characters.mk_iterator.nextn i).curr },
  shrink := λ _, lazy_list.nil }

instance char.sampleable : sampleable char :=
sampleable_char 3 " 0123abcABC:,;`\\/"

variables {α}

section list_shrink

variables [has_sizeof α] (shr : Π x : α, lazy_list { y : α // sizeof_lt y x })

lemma list.sizeof_cons_lt_right (a b : α) {xs : list α} (h : sizeof a < sizeof b) :
  sizeof (a :: xs) < sizeof (b :: xs) :=
by unfold_wf; assumption

lemma list.sizeof_cons_lt_left (x : α) {xs xs' : list α} (h : sizeof xs < sizeof xs') :
  sizeof (x :: xs) < sizeof (x :: xs') :=
by unfold_wf; assumption

lemma list.sizeof_append_lt_left {xs ys ys' : list α} (h : sizeof ys < sizeof ys') :
  sizeof (xs ++ ys) < sizeof (xs ++ ys') :=
begin
  induction xs,
  { apply h },
  { unfold_wf,
    simp only [list.sizeof, add_lt_add_iff_left],
    exact xs_ih }
end

lemma list.one_le_sizeof (xs : list α) : 1 ≤ sizeof xs :=
by cases xs; unfold_wf; linarith

/--
`list.shrink_removes` shrinks a list by removing chunks of size `k` in
the middle of the list.
-/
def list.shrink_removes (k : ℕ) (hk : 0 < k) : Π (xs : list α) n,
  n = xs.length → lazy_list { ys : list α // sizeof_lt ys xs }
| xs n hn :=
  if hkn : k > n then lazy_list.nil
  else
  if hkn' : k = n then
    have 1 < xs.sizeof,
      by { subst_vars, cases xs, { contradiction },
           unfold_wf, apply lt_of_lt_of_le,
           show 1 < 1 + has_sizeof.sizeof xs_hd + 1, { linarith },
           { mono, apply list.one_le_sizeof, } },
    lazy_list.singleton ⟨[], this ⟩
  else
    have h₂ : k < xs.length, from hn ▸ lt_of_le_of_ne (le_of_not_gt hkn) hkn',
    match list.split_at k xs, rfl : Π ys, ys = list.split_at k xs → _ with
    |  ⟨xs₁,xs₂⟩, h :=
      have h₄ : xs₁ = xs.take k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have h₃ : xs₂ = xs.drop k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have sizeof xs₂ < sizeof xs,
        by rw h₃; solve_by_elim [list.sizeof_drop_lt_sizeof_of_lt_length],
      have h₁ : n - k = xs₂.length,
        by simp only [h₃, ←hn, list.length_drop],
      have h₅ : ∀ (a : list α), sizeof_lt a xs₂ → sizeof_lt (xs₁ ++ a) xs,
        by intros a h; rw [← list.take_append_drop k xs, ← h₃, ← h₄];
          solve_by_elim [list.sizeof_append_lt_left],
      lazy_list.cons ⟨xs₂, this⟩ $ subtype.map ((++) xs₁) h₅ <$> list.shrink_removes xs₂ (n - k) h₁
    end

/--
`list.shrink_one xs` shrinks list `xs` by shrinking only one item in
the list.
-/
def list.shrink_one : shrink_fn (list α)
| [] := lazy_list.nil
| (x :: xs) :=
  lazy_list.append
    (subtype.map (λ x', x' :: xs) (λ a,  list.sizeof_cons_lt_right _ _) <$> shr x)
    (subtype.map ((::) x) (λ _, list.sizeof_cons_lt_left _) <$> list.shrink_one xs)

/-- `list.shrink_with shrink_f xs` shrinks `xs` by first
considering `xs` with chunks removed in the middle (starting with
chunks of size `xs.length` and halving down to `1`) and then
shrinks only one element of the list.

This strategy is taken directly from Haskell's QuickCheck -/
def list.shrink_with (xs : list α) :
  lazy_list { ys : list α // sizeof_lt ys xs } :=
let n := xs.length in
lazy_list.append
  ((lazy_list.cons n $ (shrink n).reverse.map subtype.val).bind (λ k,
    if hk : 0 < k
    then list.shrink_removes k hk xs n rfl
    else lazy_list.nil ))
  (list.shrink_one shr _)

end list_shrink

instance list.sampleable : sampleable_functor list.{u} :=
{ wf := _,
  sample := λ α sam_α, list_of sam_α,
  shrink := λ α Iα shr_α, @list.shrink_with _ Iα shr_α,
  p_repr := @list.has_repr }

instance Prop.sampleable_ext : sampleable_ext Prop :=
{ proxy_repr := bool,
  interp := coe,
  sample := choose_any bool,
  shrink := λ _, lazy_list.nil }

/-- `no_shrink` is a type annotation to signal that
a certain type is not to be shrunk. It can be useful in
combination with other types: e.g. `xs : list (no_shrink ℤ)`
will result in the list being cut down but individual
integers being kept as is. -/
def no_shrink (α : Type*) := α

instance no_shrink.inhabited {α} [inhabited α] : inhabited (no_shrink α) :=
⟨ (default α : α) ⟩

/-- Introduction of the `no_shrink` type. -/
def no_shrink.mk {α} (x : α) : no_shrink α := x

/-- Selector of the `no_shrink` type. -/
def no_shrink.get {α} (x : no_shrink α) : α := x

instance no_shrink.sampleable {α} [sampleable α] : sampleable (no_shrink α) :=
{ sample := no_shrink.mk <$> sample α }

instance string.sampleable : sampleable string :=
{ sample := do { x ← list_of (sample char), pure x.as_string },
  .. sampleable.lift (list char) list.as_string string.to_list $ λ _, le_refl _ }

/-- implementation of `sampleable (tree α)` -/
def tree.sample (sample : gen α) : ℕ → gen (tree α) | n :=
if h : n > 0
then have n / 2 < n, from div_lt_self h (by norm_num),
     tree.node <$> sample <*> tree.sample (n / 2) <*> tree.sample (n / 2)
else pure tree.nil

/-- `rec_shrink x f_rec` takes the recursive call `f_rec` introduced
by `well_founded.fix` and turns it into a shrinking function whose
result is adequate to use in a recursive call. -/
def rec_shrink {α : Type*} [has_sizeof α] (t : α)
  (sh : Π x : α, sizeof_lt x t → lazy_list { y : α // sizeof_lt y x }) :
  shrink_fn { t' : α // sizeof_lt t' t }
| ⟨t',ht'⟩ := (λ t'' : { y : α // sizeof_lt y t' },
    ⟨⟨t''.val, lt_trans t''.property ht'⟩, t''.property⟩ ) <$> sh t' ht'

lemma tree.one_le_sizeof {α} [has_sizeof α] (t : tree α) : 1 ≤ sizeof t :=
by cases t; unfold_wf; linarith

instance : functor tree :=
{ map := @tree.map }

/--
Recursion principle for shrinking tree-like structures.
-/
def rec_shrink_with [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x })) :
  shrink_fn α :=
well_founded.fix (sizeof_measure_wf _) $ λ t f_rec,
lazy_list.join
    (lazy_list.of_list $
      shrink_a t $ λ ⟨t', h⟩, rec_shrink _ f_rec _)

lemma rec_shrink_with_eq [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x }))
  (x : α) :
  rec_shrink_with shrink_a x =
  lazy_list.join
    (lazy_list.of_list $ shrink_a x $ λ t', rec_shrink _ (λ x h', rec_shrink_with shrink_a x) _) :=
begin
  conv_lhs { rw [rec_shrink_with, well_founded.fix_eq], },
  congr, ext ⟨y, h⟩, refl
end

/-- `tree.shrink_with shrink_f t` shrinks `xs` by using the empty tree,
each subtrees, and by shrinking the subtree to recombine them.

This strategy is taken directly from Haskell's QuickCheck -/
def tree.shrink_with [has_sizeof α] (shrink_a : shrink_fn α) : shrink_fn (tree α) :=
rec_shrink_with $ λ t,
match t with
| tree.nil := λ f_rec, []
| (tree.node x t₀ t₁) :=
λ f_rec,
  have h₂ : sizeof_lt tree.nil (tree.node x t₀ t₁),
    by clear _match; have := tree.one_le_sizeof t₀;
       dsimp [sizeof_lt, sizeof, has_sizeof.sizeof] at *;
       unfold_wf; linarith,
  have h₀ : sizeof_lt t₀ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  have h₁ : sizeof_lt t₁ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  [lazy_list.of_list [⟨tree.nil, h₂⟩, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩],
   (prod.shrink shrink_a (prod.shrink f_rec f_rec) (x, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩)).map
    $ λ ⟨⟨y,⟨t'₀, _⟩,⟨t'₁, _⟩⟩,hy⟩, ⟨tree.node y t'₀ t'₁,
      by revert hy; dsimp [sizeof_lt]; unfold_wf; intro; linarith⟩]
end

instance sampleable_tree : sampleable_functor tree :=
{ wf := _,
  sample := λ α sam_α, sized $ tree.sample sam_α,
  shrink := λ α Iα shr_α, @tree.shrink_with _ Iα shr_α,
  p_repr := @tree.has_repr }

/-- Type tag that signals to `slim_check` to use small values for a given type. -/
def small (α : Type*) := α

/-- Add the `small` type tag -/
def small.mk {α} (x : α) : small α := x

/-- Type tag that signals to `slim_check` to use large values for a given type. -/
def large (α : Type*) := α

/-- Add the `large` type tag -/
def large.mk {α} (x : α) : large α := x

instance small.functor : functor small := id.monad.to_functor
instance large.functor : functor large := id.monad.to_functor
instance small.inhabited [inhabited α] : inhabited (small α) := ⟨ (default α : α) ⟩
instance large.inhabited [inhabited α] : inhabited (large α) := ⟨ (default α : α) ⟩

instance small.sampleable_functor : sampleable_functor small :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n / 5 + 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance large.sampleable_functor : sampleable_functor large :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n * 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance ulift.sampleable_functor : sampleable_functor ulift.{u v} :=
{ wf := λ α h, ⟨ λ ⟨x⟩, @sizeof α h x ⟩,
  sample := λ α samp, uliftable.up_map ulift.up $ samp,
  shrink := λ α _ shr ⟨x⟩, (shr x).map (subtype.map ulift.up (λ a h, h)),
  p_repr := λ α h, ⟨ @repr α h ∘ ulift.down ⟩ }

/-!
## Subtype instances

The following instances are meant to improve the testing of properties of the form
`∀ i j, i ≤ j, ...`

The naive way to test them is to choose two numbers `i` and `j` and check that
the proper ordering is satisfied. Instead, the following instances make it
so that `j` will be chosen with considerations to the required ordering
constraints. The benefit is that we will not have to discard any choice
of `j`.
 -/

/-! ### Subtypes of `ℕ` -/

instance nat_le.sampleable {y} : slim_check.sampleable { x : ℕ // x ≤ y } :=
{ sample :=
         do { ⟨x,h⟩ ← slim_check.gen.choose_nat 0 y dec_trivial,
              pure ⟨x, h.2⟩},
  shrink := λ ⟨x, h⟩, (λ a : subtype _, subtype.rec_on a $
    λ x' h', ⟨⟨x', le_trans (le_of_lt h') h⟩, h'⟩) <$> shrink x }

instance nat_ge.sampleable {x} : slim_check.sampleable { y : ℕ // x ≤ y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y, by norm_num⟩ },
  shrink := λ ⟨y, h⟩, (λ a : { y' // sizeof y' < sizeof (y - x) },
    subtype.rec_on a $ λ δ h', ⟨⟨x + δ, nat.le_add_right _ _⟩, lt_tsub_iff_left.mp h'⟩) <$>
      shrink (y - x) }

/- there is no `nat_lt.sampleable` instance because if `y = 0`, there is no valid choice
to satisfy `x < y` -/

instance nat_gt.sampleable {x} : slim_check.sampleable { y : ℕ // x < y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y+1, by linarith⟩ },
  shrink := λ x, shrink _ }

/-! ### Subtypes of any `linear_ordered_add_comm_group` -/

instance le.sampleable {y : α} [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { x : α // x ≤ y } :=
{ sample :=
         do { x ← sample α,
              pure ⟨y - |x|, sub_le_self _ (abs_nonneg _) ⟩ },
  shrink := λ _, lazy_list.nil }

instance ge.sampleable {x : α}  [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { y : α // x ≤ y } :=
{ sample :=
         do { y ← sample α,
              pure ⟨x + |y|, by norm_num [abs_nonneg]⟩ },
  shrink := λ _, lazy_list.nil }

/-!
### Subtypes of `ℤ`

Specializations of `le.sampleable` and `ge.sampleable` for `ℤ` to help instance search.
-/

instance int_le.sampleable {y : ℤ} : slim_check.sampleable { x : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨y - n, int.sub_left_le_of_le_add $ by simp⟩) (λ ⟨i, h⟩, (y - i).nat_abs)
  (λ n, by unfold_wf; simp [int_le.sampleable._match_1]; ring)

instance int_ge.sampleable {x : ℤ} : slim_check.sampleable { y : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨x + n, by simp⟩) (λ ⟨i, h⟩, (i - x).nat_abs)
  (λ n, by unfold_wf; simp [int_ge.sampleable._match_1]; ring)

instance int_lt.sampleable {y} : slim_check.sampleable { x : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨y - (n+1), int.sub_left_lt_of_lt_add $
    by linarith [int.coe_nat_nonneg n]⟩)
  (λ ⟨i, h⟩, (y - i - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_lt.sampleable._match_1]; ring)

instance int_gt.sampleable {x} : slim_check.sampleable { y : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨x + (n+1), by linarith⟩) (λ ⟨i, h⟩, (i - x - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_gt.sampleable._match_1]; ring)

/-! ### Subtypes of any `list` -/

instance perm.slim_check {xs : list α} : slim_check.sampleable { ys : list α // list.perm xs ys } :=
{ sample := permutation_of xs,
  shrink := λ _, lazy_list.nil }

instance perm'.slim_check {xs : list α} :
  slim_check.sampleable { ys : list α // list.perm ys xs } :=
{ sample := subtype.map id (@list.perm.symm α _) <$> permutation_of xs,
  shrink := λ _, lazy_list.nil }

setup_tactic_parser
open tactic

/--
Print (at most) 10 samples of a given type to stdout for debugging.
-/
def print_samples {t : Type u} [has_repr t] (g : gen t) : io unit := do
xs ← io.run_rand $ uliftable.down $
  do { xs ← (list.range 10).mmap $ g.run ∘ ulift.up,
       pure ⟨xs.map repr⟩ },
xs.mmap' io.put_str_ln

/-- Create a `gen α` expression from the argument of `#sample` -/
meta def mk_generator (e : expr) : tactic (expr × expr) := do
t ← infer_type e,
match t with
| `(gen %%t) := do
  repr_inst ← mk_app ``has_repr [t] >>= mk_instance,
  pure (repr_inst, e)
| _ := do
  samp_inst ← to_expr ``(sampleable_ext %%e) >>= mk_instance,
  repr_inst ← mk_mapp ``sampleable_ext.p_repr [e, samp_inst],
  gen ← mk_mapp ``sampleable_ext.sample [none, samp_inst],
  pure (repr_inst, gen)
end

/--
`#sample my_type`, where `my_type` has an instance of `sampleable`, prints ten random
values of type `my_type` of using an increasing size parameter.

```lean
#sample nat
-- prints
-- 0
-- 0
-- 2
-- 24
-- 64
-- 76
-- 5
-- 132
-- 8
-- 449
-- or some other sequence of numbers

#sample list int
-- prints
-- []
-- [1, 1]
-- [-7, 9, -6]
-- [36]
-- [-500, 105, 260]
-- [-290]
-- [17, 156]
-- [-2364, -7599, 661, -2411, -3576, 5517, -3823, -968]
-- [-643]
-- [11892, 16329, -15095, -15461]
-- or whatever
```
-/
@[user_command]
meta def sample_cmd (_ : parse $ tk "#sample") : lean.parser unit :=
do e ← texpr,
   of_tactic $ do
     e ← i_to_expr e,
     (repr_inst, gen) ← mk_generator e,
     print_samples ← mk_mapp ``print_samples [none, repr_inst, gen],
     sample ← eval_expr (io unit) print_samples,
     unsafe_run_io sample

end slim_check


import category_theory.quotient
import category_theory.groupoid
import group_theory.subgroup.basic

open set
open classical function relation
local attribute [instance] prop_decidable

namespace category_theory
namespace groupoid
namespace free

universes u v u' v'

variable {V : Type u}
variable [quiver.{v+1} V]

inductive word : V → V → Sort*
| nil {c : V} : word c c
| cons_p {c d e : V} (p : c ⟶ d) (w : word d e) : word c e
| cons_n {c d e : V} (p : d ⟶ c) (w : word d e) : word c e

def word.length : Π {c d : V}, word c d → ℕ
| _ _ word.nil := 0
| _ _ (word.cons_p _ t) := t.length.succ
| _ _ (word.cons_n _ t) := t.length.succ

@[pattern]
def letter_p {c d : V} (p : c ⟶ d) : word c d := (word.cons_p p word.nil)
@[pattern]
def letter_n {c d : V} (p : c ⟶ d) : word d c := (word.cons_n p word.nil)

def word.append  : Π {c d e : V}, word c d → word d e → word c e
| _ _ _ (word.nil) w := w
| _ _ _ (word.cons_p p u) w := word.cons_p p (u.append w)
| _ _ _ (word.cons_n p u) w := word.cons_n p (u.append w)

@[simp] lemma word.nil_append {c d : V} {p : word c d} : word.nil.append p = p := rfl

@[simp] lemma word.append_nil {c d : V} {p : word c d} : p.append word.nil = p := by
{ induction p, refl, all_goals { dsimp only [word.append], rw p_ih, }, }

@[simp] lemma word.cons_p_append {c d e b : V} (f : c ⟶ d) (u : word d e) (w : word e b) :
  (word.cons_p f u).append w = word.cons_p f (u.append w) := rfl

@[simp] lemma word.cons_n_append {c d e b : V} (f : d ⟶ c) (u : word d e) (w : word e b) :
  (word.cons_n f u).append w = word.cons_n f (u.append w) := rfl

@[simp] lemma word.append_assoc {c d e f : V} {p : word c d} {q : word d e} {r : word e f} :
  (p.append q).append r = p.append (q.append r) := by
{ induction p, refl, all_goals { dsimp only [word.append], rw p_ih, }, }

infix ` ≫* `:100 := word.append

def word.reverse : Π {c d : V}, word c d → word d c
| _ _ (word.nil) := word.nil
| _ _ (word.cons_p p u) := (u.reverse.append (letter_n p))
| _ _ (word.cons_n p u) := (u.reverse.append (letter_p p))

@[simp] def word.reverse_nil (c : V) : (word.nil : word c c).reverse = word.nil := rfl

@[simp] lemma word.reverse_letter_p {c d : V} (p : c ⟶ d) : (letter_p p).reverse = letter_n p := by
{ dsimp only [letter_p, letter_n, word.reverse], simp, }

@[simp] lemma word.reverse_letter_n {c d : V} (p : d ⟶ c) : (letter_n p).reverse = letter_p p := by
{ dsimp only [letter_p, letter_n, word.reverse], simp, }

@[simp] lemma word.reverse_cons_p {c d e : V} (p : c ⟶ d) (w : word d e) :
  (word.cons_p p w).reverse =  w.reverse.append (letter_n p) := rfl

@[simp] lemma word.reverse_cons_n {c d e : V} (p : d ⟶ c) (w : word d e) :
  (word.cons_n p w).reverse =  w.reverse.append (letter_p p) := rfl

@[simp] lemma word.reverse_append {c d e : V} (u : word c d) (w : word d e) :
  (u.append w).reverse =  w.reverse.append (u.reverse) := by
{ induction u,
  { simp only [word.nil_append, word.reverse_nil, word.append_nil], },
  { unfold word.append, -- should that be made into a lemma word.cons_p_append ?
    simp only [u_ih, word.reverse_cons_p, word.append_assoc], },
  { unfold word.append,
    simp only [u_ih, word.reverse_cons_n, word.append_assoc], }, }

@[simp] lemma word.reverse_reverse  {c d : V} (w : word c d) : w.reverse.reverse = w := by
{ induction w,
  { dsimp only [word.reverse], refl, },
  { simp only [w_ih, word.reverse_cons_p, word.reverse_append, word.reverse_letter_n], refl, },
  { simp only [w_ih, word.reverse_cons_n, word.reverse_append, word.reverse_letter_p], refl, }, }

def red_step {c  d : V} (p : word c d) (q : word c d) : Prop :=
  (∃ (a b : V) (q₀ : word c a) (q₁ : word a d) (f : a ⟶ b), p = q₀ ≫*  (letter_p f) ≫* (letter_n f) ≫* q₁ ∧ q = q₀ ≫* q₁)
∨ (∃ (a b : V) (q₀ : word c a) (q₁ : word a d) (f : b ⟶ a), p = q₀ ≫* (letter_n f) ≫* (letter_p f) ≫* q₁ ∧ q = q₀ ≫* q₁)

@[simp]
lemma red_step.reverse {c d : V} (p₀ p₁ : word c d) : red_step p₀.reverse p₁.reverse ↔ red_step p₀ p₁ :=
begin
  suffices : ∀ c d (p₀ p₁ : word c d),  red_step p₀ p₁ → red_step p₀.reverse p₁.reverse,
  { split, rotate, exact this c d p₀ p₁,
    rintro h,
    rw  [←word.reverse_reverse p₀, ←word.reverse_reverse p₁],
    exact this d c _ _ h, },
  rintro c d p₀ p₁ (⟨u,v,r₀,r₁,f,rfl,rfl⟩|⟨u,v,r₀,r₁,f,rfl,rfl⟩),
  { left, use [u,v,r₁.reverse,r₀.reverse,f], simp, },
  { right, use [u,v,r₁.reverse,r₀.reverse,f], simp, },
end

@[simp]
lemma red_step.append_left_congr  {c d e : V} {p₀ p₁ : word c d} {q : word d e} :
  red_step p₀ p₁ → red_step (p₀ ≫* q) (p₁ ≫* q) :=
begin
  rintro (⟨u,v,r₀,r₁,f,rfl,rfl⟩|⟨u,v,r₀,r₁,f,rfl,rfl⟩),
  { left, use [u,v,r₀,r₁.append q,f],simp, },
  { right, use [u,v,r₀,r₁.append q,f],simp, },
end

@[simp]
lemma red_step.append_right_congr  {c d e : V} {p : word c d} {q₀ q₁ : word d e} :
  red_step q₀ q₁ → red_step (p ≫* q₀) (p ≫* q₁) :=
begin
  rintro (⟨u,v,r₀,r₁,f,rfl,rfl⟩|⟨u,v,r₀,r₁,f,rfl,rfl⟩),
  { left, use [u,v,p.append r₀,r₁,f],simp, },
  { right, use [u,v,p.append r₀,r₁,f],simp, },
end

def free_groupoid (V : Type u) [Q : quiver.{v+1} V] := V
instance free_groupoid_quiver : quiver (free_groupoid V) := { hom := λ c d, quot (@red_step V _ c d) }

def quot_comp { c d e : free_groupoid V} (p : c ⟶ d) (q : d ⟶ e) : c ⟶ e :=
quot.lift_on
  p
  (λ pp, quot.lift_on q
    (λ qq, quot.mk _ (pp ≫* qq))
    (λ q₀ q₁ redq, quot.sound $ red_step.append_right_congr redq))
  (λ p₀ p₁ redp, quot.induction_on q $ λ qq, quot.sound $ red_step.append_left_congr redp)

def quot_id (c : free_groupoid V)  := quot.mk (@red_step V _ c c) (word.nil)

instance free_groupoid_category_struct : category_struct (free_groupoid V)  :=
{ to_quiver := free.free_groupoid_quiver
, id := quot_id
, comp := λ a b c p q, quot_comp p q }

lemma id_quot_comp { c d : free_groupoid V} (p : c ⟶ d) : quot_comp (𝟙 c) p = p :=
quot.induction_on p $ λ pp, quot.eqv_gen_sound $ eqv_gen.refl pp

lemma quot_comp_id { c d : free_groupoid V} (p : c ⟶ d) : quot_comp p (𝟙 d) = p :=
quot.induction_on p $ λ pp, quot.eqv_gen_sound $  by {simp, exact eqv_gen.refl pp}

lemma quot_comp_assoc { c d e f : free_groupoid V}
  (p : c ⟶ d) (q : d ⟶ e)  (r : e ⟶ f) :
  quot_comp (quot_comp p q) r = quot_comp p (quot_comp q r) :=
quot.induction_on₃ p q r $ λ pp qq rr, by {dsimp [quot_comp], simp,}

instance free_groupoid_category : category (free_groupoid V)  :=
{ to_category_struct := free.free_groupoid_category_struct
  , id_comp' := λ a b p, id_quot_comp p
  , comp_id' := λ a b p, quot_comp_id p
  , assoc' := λ a b c d p q r, quot_comp_assoc p q r }

def quot_inv {c d : free_groupoid V} (p : c ⟶ d) : d  ⟶ c :=
quot.lift_on p
  (λ pp, quot.mk (@red_step V (_inst_1) d c) pp.reverse)
  (λ p₀ p₁ redp , quot.sound $ by {simp only [red_step.reverse], exact redp })

lemma quot_inv_inv {c d : free_groupoid V} (p : c ⟶ d) : (quot_inv $ quot_inv p) = p :=
begin
  apply quot.induction_on p,
  rintro pp,
  apply quot.eqv_gen_sound,
  simp only [word.reverse_reverse],
  exact eqv_gen.refl _,
end

lemma quot_comp_inv {c d : free_groupoid V} (p : c ⟶ d)  : (quot_inv p) ≫ p = 𝟙 d :=
begin
  apply quot.induction_on p,
  rintro pp,
  dsimp only [quot_comp, quot_inv],
  simp only [quot.lift_on_mk],
  apply quot.eqv_gen_sound,
  induction pp with _ c d e f w ih c d e f w ih,
  { exact eqv_gen.refl _ },
  { refine eqv_gen.trans _ (w.reverse ≫* w) _ _ _,
    { apply eqv_gen.rel,
      right,
      use [d,c,w.reverse,w,f],
      unfold letter_p,
      simp only [word.reverse_cons_p, word.append_assoc, word.cons_p_append, word.nil_append, eq_self_iff_true, and_self], },
    { apply ih (quot.mk _ w) }, },
  { refine eqv_gen.trans _ (w.reverse ≫* w) _ _ _,
    { apply eqv_gen.rel,
      left,
      use [d,c,w.reverse,w,f],
      unfold letter_n,
      simp only [word.append_assoc, word.nil_append, eq_self_iff_true, word.reverse_cons_n, and_true, word.cons_n_append], },
    { apply ih (quot.mk _ w) }, },

end

lemma quot_inv_comp {c d : free_groupoid V} (p : c ⟶ d)  : quot_comp p (quot_inv p) = 𝟙 c :=
begin
  nth_rewrite 0 ←quot_inv_inv p,
  apply quot_comp_inv,
end

instance : groupoid (free_groupoid V) :=
{ to_category := free.free_groupoid_category
, inv := λ a b p, quot_inv p
, inv_comp' := λ a b p, (quot_comp_inv p)
, comp_inv' := λ a b p, quot_inv_comp p }

@[simp]
lemma quot_cons_p {c d e : V} (f : c ⟶ d) (w : word d e) :
  (quot.mk (@red_step V _ c e) (word.cons_p f w)) =
  quot_comp (quot.mk (@red_step V _ c d) (letter_p f )) (quot.mk (@red_step V _ d e) w) := rfl

@[simp]
lemma quot_cons_n {c d e : V} (f : d ⟶ c) (w : word d e) :
  (quot.mk (@red_step V _ c e) (word.cons_n f w)) =
  quot_comp (quot.mk (@red_step V _ c d) (letter_n f )) (quot.mk (@red_step V _ d e) w) := rfl

def ι : prefunctor V (free_groupoid V) :=
{ obj := λ x, x
, map := λ x y p, quot.mk _ (letter_p p)}

def lift_word {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : Π {x y : V} (w : word x y), (φ.obj x) ⟶ (φ.obj y)
| x _ (word.nil) := 𝟙 (φ.obj x)
| x z (@word.cons_p _ _ _ y _ p w) := (φ.map p) ≫ (lift_word w)
| x z (@word.cons_n _ _ _ y _ p w) := (G'.inv $ φ.map p) ≫ (lift_word w)

@[simp]
lemma lift_word_nil {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : Π (x : V),  (lift_word φ (word.nil : word x x)) = 𝟙 (φ.obj x) :=
by { rintro x, dsimp only [lift_word], refl, }

@[simp]
lemma lift_word_cons_p {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') {x y z : V} (f : x ⟶ y) (w : word y z): (lift_word φ $ word.cons_p f w) = (φ.map f) ≫ (lift_word φ w) := rfl

@[simp]
lemma lift_word_cons_n {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') {x y z : V} (f : y ⟶ x) (w : word y z): (lift_word φ $ word.cons_n f w) = (inv $ φ.map f) ≫ (lift_word φ w) := rfl

@[simp]
lemma lift_word_letter_p {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : Π (x y : V) (u : x ⟶ y),  (lift_word φ ( letter_p u : word x y)) = φ.map u :=
by { rintro x y p, dsimp [lift_word, letter_p, lift_word_nil], simp, }

@[simp]
lemma lift_word_letter_n {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : Π (x y : V) (u : y ⟶ x),  (lift_word φ (letter_n u : word x y)) = G'.inv (φ.map u) :=
by { rintro x y p, dsimp [lift_word, letter_n, lift_word_nil], simp, }

@[simp]
lemma lift_word_append {V' : Type u'} [G' : groupoid V'] (φ : prefunctor V V')
  {x y z : V} (u : word x y) (w : word y z) : lift_word φ (u ≫* w) = (lift_word φ u) ≫ (lift_word φ w) :=
begin
  induction u,
  { simp only [word.nil_append, lift_word_nil, category.id_comp], },
  { simp only [u_ih, word.cons_p_append, lift_word_cons_p, category.assoc], },
  { simp only [u_ih, word.cons_n_append, lift_word_cons_n, category.assoc], },
end

--mathlib
@[simp] lemma _root_.category_theory.groupoid.inv_id {V : Type*} [G : groupoid V] (v : V) : G.inv (𝟙 v) = 𝟙 v := sorry
@[simp] lemma _root_.category_theory.groupoid.inv_comp'' {V : Type*} [G : groupoid V]
  {u v w : V} (f : u ⟶ v) (g : v ⟶ w) : G.inv (f ≫ g) = (G.inv g) ≫ (G.inv f) := sorry
@[simp] lemma _root_.category_theory.groupoid.inv_inv {V : Type*} [G : groupoid V] (u v : V) [f : u ⟶ v] : G.inv (G.inv f) = f :=
  calc G.inv (G.inv f) = (G.inv (G.inv f)) ≫ (𝟙 v) : by rw category.comp_id
                  ... = (G.inv (G.inv f)) ≫ (G.inv f ≫ f) : by rw ←groupoid.inv_comp
                  ... = (G.inv (G.inv f) ≫ G.inv f) ≫ f : by rw ←category.assoc
                  ... = (𝟙 u) ≫ f : by rw groupoid.inv_comp
                  ... = f : by rw category.id_comp

@[simp]
lemma lift_word_reverse {V' : Type u'} [G' : groupoid V'] (φ : prefunctor V V')
  {x y : V} (u : word x y) : lift_word φ (u.reverse) = G'.inv (lift_word φ u) :=
begin
  induction u,
  { simp only [word.reverse_nil, lift_word_nil, inv_id], },
  { simp only [u_ih, word.reverse_cons_p, lift_word_append, lift_word_letter_n, lift_word_cons_p, inv_comp''], },
  { simp only [u_ih, word.reverse_cons_n, lift_word_append, lift_word_letter_p, lift_word_cons_n, inv_comp'', inv_inv], },
end

def lift_word_congr {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : Π {x y : V} (w₀ w₁ : word x y) (redw : red_step w₀ w₁), lift_word φ w₀ = lift_word φ w₁ :=
begin
  rintros x y w₀ w₁ redw,
  dsimp [red_step] at redw,
  rcases redw with (⟨u,v,r₀,r₁,p,rfl,rfl⟩|⟨u,v,r₀,r₁,p,rfl,rfl⟩),
  { rw [←word.reverse_letter_p p],
    simp only [word.append_assoc, lift_word_append, lift_word_reverse],
    nth_rewrite_lhs 1 ←category.assoc,
    rw groupoid.comp_inv, simp only [category.id_comp], },
  { rw [←word.reverse_letter_n p],
    simp only [word.append_assoc, lift_word_append, lift_word_reverse],
    nth_rewrite_lhs 1 ←category.assoc,
    rw groupoid.comp_inv, simp only [category.id_comp], },
end

def lift {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : free_groupoid V ⥤ V' :=
{ obj := φ.obj
, map := λ x y, quot.lift (λ p, lift_word φ p) (λ p₀ p₁ (redp : red_step p₀ p₁), lift_word_congr φ p₀ p₁ redp)
, map_id' := λ x, by { dsimp only [lift_word,category_struct.id], refl,  }
, map_comp' := λ x y z f g, by { refine quot.induction_on₂ f g _, rintro ff gg, dsimp only [lift_word,category_struct.comp,quot_comp], simp only [lift_word_append], }, }

--mathlib (stolen from functor.ext)
lemma _root_.category_theory.functor.ext' {C D : Type*} [category C] [category D] {F G : C ⥤ D}
  (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ (X Y : C) (f : X ⟶ Y), F.map f = by {rw [h_obj X, h_obj Y], exact G.map f}) :
  F = G :=
begin
  cases F with F_obj _ _ _, cases G with G_obj _ _ _,
  obtain rfl : F_obj = G_obj, by { ext X, apply h_obj },
  congr,
  funext X Y f,
  simpa using h_map X Y f
end

--mathlib (stolen from functor.ext),
@[ext] lemma ext {V : Type u} [Q : quiver.{v+1} V] {V' : Type u'} [Q' : quiver.{v'+1} V'] {F G : prefunctor V V'}
  (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ (X Y : V) (f : X ⟶ Y), F.map f = by {rw [h_obj X, h_obj Y], exact G.map f}) : F = G :=
begin
  cases F with F_obj _, cases G with G_obj _,
  obtain rfl : F_obj = G_obj, by { ext X, apply h_obj },
  congr,
  funext X Y f,
  simpa using h_map X Y f,
end

lemma lift_spec {V : Type u} [Q : quiver.{v+1} V] {V' : Type u'} [G' : groupoid V']
  (φ : prefunctor V V') : ι.comp (lift φ).to_prefunctor = φ :=
begin
  ext, rotate,
  rcases φ with ⟨φo,φm⟩,
  { rintro x, dsimp only, refl, },
  { subst_vars, apply lift_word_letter_p, },
end

-- mathlib?
@[simp]
lemma _root_.category_theory.functor.groupoid_map_inv  {C D : Type*} [G : groupoid C] [H : groupoid D] (φ : C ⥤ D)
  {c d : C} (f : c ⟶ d) :
  φ.map (G.inv f) = H.inv (φ.map f) :=
calc φ.map (G.inv f) = (φ.map $ G.inv f) ≫ (𝟙 $ φ.obj c) : by rw [category.comp_id]
                 ... = (φ.map $ G.inv f) ≫ ((φ.map f) ≫ (H.inv $ φ.map f)) : by rw [comp_inv]
                 ... = ((φ.map $ G.inv f) ≫ (φ.map f)) ≫ (H.inv $ φ.map f) : by rw [category.assoc]
                 ... = (φ.map $ G.inv f ≫ f) ≫ (H.inv $ φ.map f) : by rw [functor.map_comp']
                 ... = (H.inv $ φ.map f) : by rw [inv_comp,functor.map_id,category.id_comp]

lemma lift_unique (V' : Type u') [G' : groupoid V']
  (φ : prefunctor V V') (Φ : free_groupoid V ⥤ V') : (ι.comp Φ.to_prefunctor) = φ → Φ = (lift φ) :=
begin
  rintro h, subst h,
  fapply functor.ext',
  { rintro x, dsimp [lift,ι], refl, },
  { rintro X Y f,
    simp only [eq_mpr_eq_cast, cast_eq],
    refine quot.induction_on f _,
    refine word.rec _ _ _,
    { rintro x, convert functor.map_id Φ x, },
    { rintro x y z p w IHw,
      rw [quot_cons_p],
      have : Φ.map (quot_comp (quot.mk red_step  $ letter_p p ) (quot.mk red_step w)) = Φ.map ((quot.mk red_step  $ letter_p p ) ≫  (quot.mk red_step w)), by refl,
      simp only [this, functor.map_comp, IHw],
      congr, },
    { rintro x y z p w IHw,
      rw [quot_cons_n],
      have : Φ.map (quot_comp (quot.mk red_step  $ letter_n p ) (quot.mk red_step w)) = Φ.map ((quot.mk red_step $ letter_n p ) ≫  (quot.mk red_step w)), by refl,
      simp only [this, functor.map_comp, IHw, functor.map_comp],
      apply congr_arg2,
      { dsimp [lift,ι], rw ←word.reverse_letter_p,
        convert functor.groupoid_map_inv Φ (quot.mk red_step  $ letter_p p ) , },
      { refl, }, }, },

end

end free
end groupoid
end category_theory


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Casts and heterogeneous equality. See also init.datatypes and init.logic.
-/

import logic.eq logic.quantifiers
open eq.ops

namespace heq
  universe variable u
  variables {A B C : Type.{u}} {a a' : A} {b b' : B} {c : C}

  theorem drec_on {C : Π {B : Type} (b : B), a == b → Type} (H₁ : a == b) (H₂ : C a (refl a)) :
    C b H₁ :=
  heq.rec (λ H₁ : a == a, show C a H₁, from H₂) H₁ H₁

  theorem to_cast_eq (H : a == b) : cast (type_eq_of_heq H) a = b :=
  drec_on H !cast_eq
end heq

section
  universe variables u v
  variables {A A' B C : Type.{u}} {P P' : A → Type.{v}} {a a' : A} {b : B}

  theorem hcongr_fun {f : Π x, P x} {f' : Π x, P' x} (a : A) (H₁ : f == f') (H₂ : P = P') :
    f a == f' a :=
  begin
    cases H₂, cases H₁, reflexivity
  end

  theorem hcongr {P' : A' → Type} {f : Π a, P a} {f' : Π a', P' a'} {a : A} {a' : A'}
      (Hf : f == f') (HP : P == P') (Ha : a == a') : f a == f' a' :=
  begin
    cases Ha, cases HP, cases Hf, reflexivity
  end

  theorem hcongr_arg (f : Πx, P x) {a b : A} (H : a = b) : f a == f b :=
  H ▸ (heq.refl (f a))
end

section
  variables {A : Type} {B : A → Type} {C : Πa, B a → Type} {D : Πa b, C a b → Type}
  variables {a a' : A} {b : B a} {b' : B a'} {c : C a b} {c' : C a' b'}

  theorem hcongr_arg2 (f : Πa b, C a b) (Ha : a = a') (Hb : b == b') : f a b == f a' b' :=
  hcongr (hcongr_arg f Ha) (hcongr_arg C Ha) Hb

  theorem hcongr_arg3 (f : Πa b c, D a b c) (Ha : a = a') (Hb : b == b') (Hc : c == c')
      : f a b c == f a' b' c' :=
  hcongr (hcongr_arg2 f Ha Hb) (hcongr_arg2 D Ha Hb) Hc
end

section
  universe variables u v
  variables {A A' B C : Type.{u}} {P P' : A → Type.{v}} {a a' : A} {b : B}

  -- should H₁ be explicit (useful in e.g. hproof_irrel)
  theorem eq_rec_to_heq {H₁ : a = a'} {p : P a} {p' : P a'} (H₂ : eq.rec_on H₁ p = p') : p == p' :=
  by subst H₁; subst H₂

  theorem cast_to_heq {H₁ : A = B} (H₂ : cast H₁ a = b) : a == b :=
  eq_rec_to_heq H₂

  theorem hproof_irrel {a b : Prop} (H : a = b) (H₁ : a) (H₂ : b) : H₁ == H₂ :=
  eq_rec_to_heq (proof_irrel (cast H H₁) H₂)

  --TODO: generalize to eq.rec. This is a special case of rec_on_comp in eq.lean
  theorem cast_trans (Hab : A = B) (Hbc : B = C) (a : A) :
    cast Hbc (cast Hab a) = cast (Hab ⬝ Hbc) a :=
  by subst Hab

  theorem pi_eq (H : P = P') : (Π x, P x) = (Π x, P' x) :=
  by subst H

  theorem rec_on_app (H : P = P') (f : Π x, P x) (a : A) : eq.rec_on H f a == f a :=
  by subst H

  theorem rec_on_pull (H : P = P') (f : Π x, P x) (a : A) :
    eq.rec_on H f a = eq.rec_on (congr_fun H a) (f a) :=
  eq_of_heq (calc
    eq.rec_on H f a == f a                   : rec_on_app H f a
      ... == eq.rec_on (congr_fun H a) (f a) : heq.symm (eq_rec_heq (congr_fun H a) (f a)))

  theorem cast_app (H : P = P') (f : Π x, P x) (a : A) : cast (pi_eq H) f a == f a :=
  by subst H
end

-- function extensionality wrt heterogeneous equality
theorem hfunext {A : Type} {B : A → Type} {B' : A → Type} {f : Π x, B x} {g : Π x, B' x}
                (H : ∀ a, f a == g a) : f == g :=
cast_to_heq (funext (λ a, eq_of_heq (heq.trans (cast_app (funext (λ x, type_eq_of_heq (H x))) f a) (H a))))

section
  variables {A : Type} {B : A → Type} {C : Πa, B a → Type} {D : Πa b, C a b → Type}
            {E : Πa b c, D a b c → Type} {F : Type}
  variables {a a' : A}
            {b : B a} {b' : B a'}
            {c : C a b} {c' : C a' b'}
            {d : D a b c} {d' : D a' b' c'}

  theorem hcongr_arg4 (f : Πa b c d, E a b c d)
    (Ha : a = a') (Hb : b == b') (Hc : c == c') (Hd : d == d') : f a b c d == f a' b' c' d' :=
  hcongr (hcongr_arg3 f Ha Hb Hc) (hcongr_arg3 E Ha Hb Hc) Hd

  theorem dcongr_arg2 (f : Πa, B a → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b')
      : f a b = f a' b' :=
  eq_of_heq (hcongr_arg2 f Ha (eq_rec_to_heq Hb))

  theorem dcongr_arg3 (f : Πa b, C a b → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b')
      (Hc : cast (dcongr_arg2 C Ha Hb) c = c') : f a b c = f a' b' c' :=
  eq_of_heq (hcongr_arg3 f Ha (eq_rec_to_heq Hb) (eq_rec_to_heq Hc))

  theorem dcongr_arg4 (f : Πa b c, D a b c → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b')
      (Hc : cast (dcongr_arg2 C Ha Hb) c = c')
      (Hd : cast (dcongr_arg3 D Ha Hb Hc) d = d') : f a b c d = f a' b' c' d' :=
  eq_of_heq (hcongr_arg4 f Ha (eq_rec_to_heq Hb) (eq_rec_to_heq Hc) (eq_rec_to_heq Hd))

  -- mixed versions (we want them for example if C a' b' is a subsingleton, like a proposition.
  -- Then proving eq is easier than proving heq)
  theorem hdcongr_arg3 (f : Πa b, C a b → F) (Ha : a = a') (Hb : b == b')
      (Hc : cast (eq_of_heq (hcongr_arg2 C Ha Hb)) c = c')
        : f a b c = f a' b' c' :=
  eq_of_heq (hcongr_arg3 f Ha Hb (eq_rec_to_heq Hc))

  theorem hhdcongr_arg4 (f : Πa b c, D a b c → F) (Ha : a = a') (Hb : b == b')
      (Hc : c == c')
      (Hd : cast (dcongr_arg3 D Ha (!eq.rec_on_irrel_arg ⬝ heq.to_cast_eq Hb)
                                   (!eq.rec_on_irrel_arg ⬝ heq.to_cast_eq Hc)) d = d')
        : f a b c d = f a' b' c' d' :=
  eq_of_heq (hcongr_arg4 f Ha Hb Hc (eq_rec_to_heq Hd))

  theorem hddcongr_arg4 (f : Πa b c, D a b c → F) (Ha : a = a') (Hb : b == b')
      (Hc : cast (eq_of_heq (hcongr_arg2 C Ha Hb)) c = c')
      (Hd : cast (hdcongr_arg3 D Ha Hb Hc) d = d')
        : f a b c d = f a' b' c' d' :=
  eq_of_heq (hcongr_arg4 f Ha Hb (eq_rec_to_heq Hc) (eq_rec_to_heq Hd))
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.wlog

section wlog

example {x y : ℕ} (a : x = 1) : true :=
begin
  suffices : false, trivial,
  wlog h : x = y,
  { guard_target x = y ∨ y = x,
    admit },
  { guard_hyp h : x = y,
    guard_hyp a : x = 1,
    admit }
end

example {x y : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog h : x ≤ y,
  { guard_hyp h : x ≤ y,
    guard_target false,
    admit }
end

example {x y z : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog : x ≤ y + z using x y,
  { guard_target x ≤ y + z ∨ y ≤ x + z,
    admit },
  { guard_hyp case : x ≤ y + z,
    guard_target false,
    admit },
end

example {x : ℕ} (S₀ S₁ : set ℕ) (P : ℕ → Prop)
  (h : x ∈ S₀ ∪ S₁) : true :=
begin
  suffices : false, trivial,
  wlog h' : x ∈ S₀ using S₀ S₁,
  { guard_target x ∈ S₀ ∨ x ∈ S₁,
    admit },
  { guard_hyp h  : x ∈ S₀ ∪ S₁,
    guard_hyp h' : x ∈ S₀,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n m i using [n m i, n i m, i n m],
  { guard_target p n m i ∨ p n i m ∨ p i n m,
    admit },
  { guard_hyp case : p n m i,
    admit }
end

example {n m i : ℕ} {p : ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n using [n m i, m n i, i n m],
  { guard_target p n ∨ p m ∨ p i,
    admit },
  { guard_hyp case : p n,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → Prop} {q : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : q n m i, trivial,
  have h : p n i ∨ p i m ∨ p m i, from sorry,
  wlog : p n i := h using n m i,
  { guard_hyp h : p n i,
    guard_target q n m i,
    admit },
  { guard_hyp h : p i m,
    guard_hyp this : q i m n,
    guard_target q n m i,
    admit },
  { guard_hyp h : p m i,
    guard_hyp this : q m i n,
    guard_target q n m i,
    admit },
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B using B C,
    { assumption },
    { exact or.inl ⟨hyp_left, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B using B C,
    { assumption },
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    wlog x_in : x ∈ B := hyp.2 using B C,
    { exact or.inl ⟨hyp.1, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B := hyp_right using B C,
    { exact or.inl ⟨hyp_left, x_in⟩ }, },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

end wlog


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel, Bhavik Mehta
-/
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.binary_products

/-!
# Pullbacks

We define a category `walking_cospan` (resp. `walking_span`), which is the index category
for the given data for a pullback (resp. pushout) diagram. Convenience methods `cospan f g`
and `span f g` construct functors from the walking (co)span, hitting the given morphisms.

We define `pullback f g` and `pushout f g` as limits and colimits of such functors.

## References
* [Stacks: Fibre products](https://stacks.math.columbia.edu/tag/001U)
* [Stacks: Pushouts](https://stacks.math.columbia.edu/tag/0025)
-/

noncomputable theory

open category_theory

namespace category_theory.limits

universes v u u₂

local attribute [tidy] tactic.case_bash

/--
The type of objects for the diagram indexing a pullback, defined as a special case of
`wide_pullback_shape`.
-/
abbreviation walking_cospan : Type v := wide_pullback_shape walking_pair

/-- The left point of the walking cospan. -/
@[pattern] abbreviation walking_cospan.left : walking_cospan := some walking_pair.left
/-- The right point of the walking cospan. -/
@[pattern] abbreviation walking_cospan.right : walking_cospan := some walking_pair.right
/-- The central point of the walking cospan. -/
@[pattern] abbreviation walking_cospan.one : walking_cospan := none

/--
The type of objects for the diagram indexing a pushout, defined as a special case of
`wide_pushout_shape`.
-/
abbreviation walking_span : Type v := wide_pushout_shape walking_pair

/-- The left point of the walking span. -/
@[pattern] abbreviation walking_span.left : walking_span := some walking_pair.left
/-- The right point of the walking span. -/
@[pattern] abbreviation walking_span.right : walking_span := some walking_pair.right
/-- The central point of the walking span. -/
@[pattern] abbreviation walking_span.zero : walking_span := none

namespace walking_cospan

/-- The type of arrows for the diagram indexing a pullback. -/
abbreviation hom : walking_cospan → walking_cospan → Type v := wide_pullback_shape.hom

/-- The left arrow of the walking cospan. -/
@[pattern] abbreviation hom.inl : left ⟶ one := wide_pullback_shape.hom.term _
/-- The right arrow of the walking cospan. -/
@[pattern] abbreviation hom.inr : right ⟶ one := wide_pullback_shape.hom.term _
/-- The identity arrows of the walking cospan. -/
@[pattern] abbreviation hom.id (X : walking_cospan) : X ⟶ X := wide_pullback_shape.hom.id X

instance (X Y : walking_cospan) : subsingleton (X ⟶ Y) := by tidy

end walking_cospan

namespace walking_span

/-- The type of arrows for the diagram indexing a pushout. -/
abbreviation hom : walking_span → walking_span → Type v := wide_pushout_shape.hom

/-- The left arrow of the walking span. -/
@[pattern] abbreviation hom.fst : zero ⟶ left := wide_pushout_shape.hom.init _
/-- The right arrow of the walking span. -/
@[pattern] abbreviation hom.snd : zero ⟶ right := wide_pushout_shape.hom.init _
/-- The identity arrows of the walking span. -/
@[pattern] abbreviation hom.id (X : walking_span) : X ⟶ X := wide_pushout_shape.hom.id X

instance (X Y : walking_span) : subsingleton (X ⟶ Y) := by tidy

end walking_span

open walking_span.hom walking_cospan.hom wide_pullback_shape.hom wide_pushout_shape.hom

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

/-- `cospan f g` is the functor from the walking cospan hitting `f` and `g`. -/
def cospan {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) : walking_cospan ⥤ C :=
wide_pullback_shape.wide_cospan Z
  (λ j, walking_pair.cases_on j X Y) (λ j, walking_pair.cases_on j f g)

/-- `span f g` is the functor from the walking span hitting `f` and `g`. -/
def span {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) : walking_span ⥤ C :=
wide_pushout_shape.wide_span X
  (λ j, walking_pair.cases_on j Y Z) (λ j, walking_pair.cases_on j f g)

@[simp] lemma cospan_left {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (cospan f g).obj walking_cospan.left = X := rfl
@[simp] lemma span_left {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
  (span f g).obj walking_span.left = Y := rfl

@[simp] lemma cospan_right {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (cospan f g).obj walking_cospan.right = Y := rfl
@[simp] lemma span_right {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
  (span f g).obj walking_span.right = Z := rfl

@[simp] lemma cospan_one {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (cospan f g).obj walking_cospan.one = Z := rfl
@[simp] lemma span_zero {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
  (span f g).obj walking_span.zero = X := rfl

@[simp] lemma cospan_map_inl {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (cospan f g).map walking_cospan.hom.inl = f := rfl
@[simp] lemma span_map_fst {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
  (span f g).map walking_span.hom.fst = f := rfl

@[simp] lemma cospan_map_inr {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (cospan f g).map walking_cospan.hom.inr = g := rfl
@[simp] lemma span_map_snd {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) :
  (span f g).map walking_span.hom.snd = g := rfl

lemma cospan_map_id {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (w : walking_cospan) :
  (cospan f g).map (walking_cospan.hom.id w) = 𝟙 _ := rfl
lemma span_map_id {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) (w : walking_span) :
  (span f g).map (walking_span.hom.id w) = 𝟙 _ := rfl

/-- Every diagram indexing an pullback is naturally isomorphic (actually, equal) to a `cospan` -/
@[simps {rhs_md := semireducible}]
def diagram_iso_cospan (F : walking_cospan ⥤ C) :
  F ≅ cospan (F.map inl) (F.map inr) :=
nat_iso.of_components (λ j, eq_to_iso (by tidy)) (by tidy)

/-- Every diagram indexing a pushout is naturally isomorphic (actually, equal) to a `span` -/
@[simps {rhs_md := semireducible}]
def diagram_iso_span (F : walking_span ⥤ C) :
  F ≅ span (F.map fst) (F.map snd) :=
nat_iso.of_components (λ j, eq_to_iso (by tidy)) (by tidy)

variables {X Y Z : C}

/-- A pullback cone is just a cone on the cospan formed by two morphisms `f : X ⟶ Z` and
    `g : Y ⟶ Z`.-/
abbreviation pullback_cone (f : X ⟶ Z) (g : Y ⟶ Z) := cone (cospan f g)

namespace pullback_cone
variables {f : X ⟶ Z} {g : Y ⟶ Z}

/-- The first projection of a pullback cone. -/
abbreviation fst (t : pullback_cone f g) : t.X ⟶ X := t.π.app walking_cospan.left

/-- The second projection of a pullback cone. -/
abbreviation snd (t : pullback_cone f g) : t.X ⟶ Y := t.π.app walking_cospan.right

/-- This is a slightly more convenient method to verify that a pullback cone is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def is_limit_aux (t : pullback_cone f g) (lift : Π (s : pullback_cone f g), s.X ⟶ t.X)
  (fac_left : ∀ (s : pullback_cone f g), lift s ≫ t.fst = s.fst)
  (fac_right : ∀ (s : pullback_cone f g), lift s ≫ t.snd = s.snd)
  (uniq : ∀ (s : pullback_cone f g) (m : s.X ⟶ t.X)
    (w : ∀ j : walking_cospan, m ≫ t.π.app j = s.π.app j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, option.cases_on j
    (by { rw [← s.w inl, ← t.w inl, ←category.assoc], congr, exact fac_left s, } )
    (λ j', walking_pair.cases_on j' (fac_left s) (fac_right s)),
  uniq' := uniq }

/-- This is another convenient method to verify that a pullback cone is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def is_limit_aux' (t : pullback_cone f g)
  (create : Π (s : pullback_cone f g),
    {l // l ≫ t.fst = s.fst ∧ l ≫ t.snd = s.snd ∧
            ∀ {m}, m ≫ t.fst = s.fst → m ≫ t.snd = s.snd → m = l}) :
limits.is_limit t :=
pullback_cone.is_limit_aux t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s, (create s).2.2.1)
  (λ s m w, (create s).2.2.2 (w walking_cospan.left) (w walking_cospan.right))

/-- A pullback cone on `f` and `g` is determined by morphisms `fst : W ⟶ X` and `snd : W ⟶ Y`
    such that `fst ≫ f = snd ≫ g`. -/
@[simps]
def mk {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) : pullback_cone f g :=
{ X := W,
  π := { app := λ j, option.cases_on j (fst ≫ f) (λ j', walking_pair.cases_on j' fst snd) } }

@[simp] lemma mk_π_app_left {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (mk fst snd eq).π.app walking_cospan.left = fst := rfl
@[simp] lemma mk_π_app_right {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (mk fst snd eq).π.app walking_cospan.right = snd := rfl
@[simp] lemma mk_π_app_one {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (mk fst snd eq).π.app walking_cospan.one = fst ≫ f := rfl

@[simp] lemma mk_fst {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (mk fst snd eq).fst = fst := rfl
@[simp] lemma mk_snd {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (mk fst snd eq).snd = snd := rfl

@[reassoc] lemma condition (t : pullback_cone f g) : fst t ≫ f = snd t ≫ g :=
(t.w inl).trans (t.w inr).symm

/-- To check whether a morphism is equalized by the maps of a pullback cone, it suffices to check
  it for `fst t` and `snd t` -/
lemma equalizer_ext (t : pullback_cone f g) {W : C} {k l : W ⟶ t.X}
  (h₀ : k ≫ fst t = l ≫ fst t) (h₁ : k ≫ snd t = l ≫ snd t) :
  ∀ (j : walking_cospan), k ≫ t.π.app j = l ≫ t.π.app j
| (some walking_pair.left) := h₀
| (some walking_pair.right) := h₁
| none := by rw [← t.w inl, reassoc_of h₀]

lemma is_limit.hom_ext {t : pullback_cone f g} (ht : is_limit t) {W : C} {k l : W ⟶ t.X}
  (h₀ : k ≫ fst t = l ≫ fst t) (h₁ : k ≫ snd t = l ≫ snd t) : k = l :=
ht.hom_ext $ equalizer_ext _ h₀ h₁

/-- If `t` is a limit pullback cone over `f` and `g` and `h : W ⟶ X` and `k : W ⟶ Y` are such that
    `h ≫ f = k ≫ g`, then we have `l : W ⟶ t.X` satisfying `l ≫ fst t = h` and `l ≫ snd t = k`.
    -/
def is_limit.lift' {t : pullback_cone f g} (ht : is_limit t) {W : C} (h : W ⟶ X) (k : W ⟶ Y)
  (w : h ≫ f = k ≫ g) : {l : W ⟶ t.X // l ≫ fst t = h ∧ l ≫ snd t = k} :=
⟨ht.lift $ pullback_cone.mk _ _ w, ht.fac _ _, ht.fac _ _⟩

/--
This is a more convenient formulation to show that a `pullback_cone` constructed using
`pullback_cone.mk` is a limit cone.
-/
def is_limit.mk {W : C} {fst : W ⟶ X} {snd : W ⟶ Y} (eq : fst ≫ f = snd ≫ g)
  (lift : Π (s : pullback_cone f g), s.X ⟶ W)
  (fac_left : ∀ (s : pullback_cone f g), lift s ≫ fst = s.fst)
  (fac_right : ∀ (s : pullback_cone f g), lift s ≫ snd = s.snd)
  (uniq : ∀ (s : pullback_cone f g) (m : s.X ⟶ W)
    (w_fst : m ≫ fst = s.fst) (w_snd : m ≫ snd = s.snd), m = lift s) :
  is_limit (mk fst snd eq) :=
is_limit_aux _ lift fac_left fac_right
  (λ s m w, uniq s m (w walking_cospan.left) (w walking_cospan.right))

/-- The flip of a pullback square is a pullback square. -/
def flip_is_limit {W : C} {h : W ⟶ X} {k : W ⟶ Y}
  {comm : h ≫ f = k ≫ g} (t : is_limit (mk _ _ comm.symm)) :
  is_limit (mk _ _ comm) :=
is_limit_aux' _ $ λ s,
begin
  refine ⟨(is_limit.lift' t _ _ s.condition.symm).1,
          (is_limit.lift' t _ _ _).2.2,
          (is_limit.lift' t _ _ _).2.1, λ m m₁ m₂, t.hom_ext _⟩,
  apply (mk k h _).equalizer_ext,
  { rwa (is_limit.lift' t _ _ _).2.1 },
  { rwa (is_limit.lift' t _ _ _).2.2 },
end

/--
The pullback cone `(𝟙 X, 𝟙 X)` for the pair `(f, f)` is a limit if `f` is a mono. The converse is
shown in `mono_of_pullback_is_id`.
-/
def is_limit_mk_id_id (f : X ⟶ Y) [mono f] :
  is_limit (mk (𝟙 X) (𝟙 X) rfl : pullback_cone f f) :=
is_limit.mk _
  (λ s, s.fst)
  (λ s, category.comp_id _)
  (λ s, by rw [←cancel_mono f, category.comp_id, s.condition])
  (λ s m m₁ m₂, by simpa using m₁)

/--
`f` is a mono if the pullback cone `(𝟙 X, 𝟙 X)` is a limit for the pair `(f, f)`. The converse is
given in `pullback_cone.is_id_of_mono`.
-/
lemma mono_of_is_limit_mk_id_id (f : X ⟶ Y)
  (t : is_limit (mk (𝟙 X) (𝟙 X) rfl : pullback_cone f f)) :
  mono f :=
⟨λ Z g h eq, by { rcases pullback_cone.is_limit.lift' t _ _ eq with ⟨_, rfl, rfl⟩, refl } ⟩

end pullback_cone

/-- A pushout cocone is just a cocone on the span formed by two morphisms `f : X ⟶ Y` and
    `g : X ⟶ Z`.-/
abbreviation pushout_cocone (f : X ⟶ Y) (g : X ⟶ Z) := cocone (span f g)

namespace pushout_cocone

variables {f : X ⟶ Y} {g : X ⟶ Z}

/-- The first inclusion of a pushout cocone. -/
abbreviation inl (t : pushout_cocone f g) : Y ⟶ t.X := t.ι.app walking_span.left

/-- The second inclusion of a pushout cocone. -/
abbreviation inr (t : pushout_cocone f g) : Z ⟶ t.X := t.ι.app walking_span.right

/-- This is a slightly more convenient method to verify that a pushout cocone is a colimit cocone.
    It only asks for a proof of facts that carry any mathematical content -/
def is_colimit_aux (t : pushout_cocone f g) (desc : Π (s : pushout_cocone f g), t.X ⟶ s.X)
  (fac_left : ∀ (s : pushout_cocone f g), t.inl ≫ desc s = s.inl)
  (fac_right : ∀ (s : pushout_cocone f g), t.inr ≫ desc s = s.inr)
  (uniq : ∀ (s : pushout_cocone f g) (m : t.X ⟶ s.X)
    (w : ∀ j : walking_span, t.ι.app j ≫ m = s.ι.app j), m = desc s) :
  is_colimit t :=
{ desc := desc,
  fac' := λ s j, option.cases_on j (by { simp [← s.w fst, ← t.w fst, fac_left s] } )
                    (λ j', walking_pair.cases_on j' (fac_left s) (fac_right s)),
  uniq' := uniq }

/-- This is another convenient method to verify that a pushout cocone is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def is_colimit_aux' (t : pushout_cocone f g)
  (create : Π (s : pushout_cocone f g),
    {l // t.inl ≫ l = s.inl ∧ t.inr ≫ l = s.inr ∧
            ∀ {m}, t.inl ≫ m = s.inl → t.inr ≫ m = s.inr → m = l}) :
is_colimit t :=
is_colimit_aux t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s, (create s).2.2.1)
  (λ s m w, (create s).2.2.2 (w walking_cospan.left) (w walking_cospan.right))

/-- A pushout cocone on `f` and `g` is determined by morphisms `inl : Y ⟶ W` and `inr : Z ⟶ W` such
    that `f ≫ inl = g ↠ inr`. -/
@[simps]
def mk {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) : pushout_cocone f g :=
{ X := W,
  ι := { app := λ j, option.cases_on j (f ≫ inl) (λ j', walking_pair.cases_on j' inl inr) } }

@[simp] lemma mk_ι_app_left {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
  (mk inl inr eq).ι.app walking_span.left = inl := rfl
@[simp] lemma mk_ι_app_right {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
  (mk inl inr eq).ι.app walking_span.right = inr := rfl
@[simp] lemma mk_ι_app_zero {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
  (mk inl inr eq).ι.app walking_span.zero = f ≫ inl := rfl

@[simp] lemma mk_inl {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
  (mk inl inr eq).inl = inl := rfl
@[simp] lemma mk_inr {W : C} (inl : Y ⟶ W) (inr : Z ⟶ W) (eq : f ≫ inl = g ≫ inr) :
  (mk inl inr eq).inr = inr := rfl

@[reassoc] lemma condition (t : pushout_cocone f g) : f ≫ (inl t) = g ≫ (inr t) :=
(t.w fst).trans (t.w snd).symm

/-- To check whether a morphism is coequalized by the maps of a pushout cocone, it suffices to check
  it for `inl t` and `inr t` -/
lemma coequalizer_ext (t : pushout_cocone f g) {W : C} {k l : t.X ⟶ W}
  (h₀ : inl t ≫ k = inl t ≫ l) (h₁ : inr t ≫ k = inr t ≫ l) :
  ∀ (j : walking_span), t.ι.app j ≫ k = t.ι.app j ≫ l
| (some walking_pair.left) := h₀
| (some walking_pair.right) := h₁
| none := by rw [← t.w fst, category.assoc, category.assoc, h₀]

lemma is_colimit.hom_ext {t : pushout_cocone f g} (ht : is_colimit t) {W : C} {k l : t.X ⟶ W}
  (h₀ : inl t ≫ k = inl t ≫ l) (h₁ : inr t ≫ k = inr t ≫ l) : k = l :=
ht.hom_ext $ coequalizer_ext _ h₀ h₁

/-- If `t` is a colimit pushout cocone over `f` and `g` and `h : Y ⟶ W` and `k : Z ⟶ W` are
    morphisms satisfying `f ≫ h = g ≫ k`, then we have a factorization `l : t.X ⟶ W` such that
    `inl t ≫ l = h` and `inr t ≫ l = k`. -/
def is_colimit.desc' {t : pushout_cocone f g} (ht : is_colimit t) {W : C} (h : Y ⟶ W) (k : Z ⟶ W)
  (w : f ≫ h = g ≫ k) : {l : t.X ⟶ W // inl t ≫ l = h ∧ inr t ≫ l = k } :=
⟨ht.desc $ pushout_cocone.mk _ _ w, ht.fac _ _, ht.fac _ _⟩

/--
This is a more convenient formulation to show that a `pushout_cocone` constructed using
`pushout_cocone.mk` is a colimit cocone.
-/
def is_colimit.mk {W : C} {inl : Y ⟶ W} {inr : Z ⟶ W} (eq : f ≫ inl = g ≫ inr)
  (desc : Π (s : pushout_cocone f g), W ⟶ s.X)
  (fac_left : ∀ (s : pushout_cocone f g), inl ≫ desc s = s.inl)
  (fac_right : ∀ (s : pushout_cocone f g), inr ≫ desc s = s.inr)
  (uniq : ∀ (s : pushout_cocone f g) (m : W ⟶ s.X)
    (w_inl : inl ≫ m = s.inl) (w_inr : inr ≫ m = s.inr), m = desc s) :
  is_colimit (mk inl inr eq) :=
is_colimit_aux _ desc fac_left fac_right
  (λ s m w, uniq s m (w walking_cospan.left) (w walking_cospan.right))

/-- The flip of a pushout square is a pushout square. -/
def flip_is_colimit {W : C} {h : Y ⟶ W} {k : Z ⟶ W}
  {comm : f ≫ h = g ≫ k} (t : is_colimit (mk _ _ comm.symm)) :
  is_colimit (mk _ _ comm) :=
is_colimit_aux' _ $ λ s,
begin
  refine ⟨(is_colimit.desc' t _ _ s.condition.symm).1,
          (is_colimit.desc' t _ _ _).2.2,
          (is_colimit.desc' t _ _ _).2.1, λ m m₁ m₂, t.hom_ext _⟩,
  apply (mk k h _).coequalizer_ext,
  { rwa (is_colimit.desc' t _ _ _).2.1 },
  { rwa (is_colimit.desc' t _ _ _).2.2 },
end

end pushout_cocone

/-- This is a helper construction that can be useful when verifying that a category has all
    pullbacks. Given `F : walking_cospan ⥤ C`, which is really the same as
    `cospan (F.map inl) (F.map inr)`, and a pullback cone on `F.map inl` and `F.map inr`, we
    get a cone on `F`.

    If you're thinking about using this, have a look at `has_pullbacks_of_has_limit_cospan`,
    which you may find to be an easier way of achieving your goal. -/
@[simps]
def cone.of_pullback_cone
  {F : walking_cospan ⥤ C} (t : pullback_cone (F.map inl) (F.map inr)) : cone F :=
{ X := t.X,
  π := t.π ≫ (diagram_iso_cospan F).inv }

/-- This is a helper construction that can be useful when verifying that a category has all
    pushout. Given `F : walking_span ⥤ C`, which is really the same as
    `span (F.map fst) (F.mal snd)`, and a pushout cocone on `F.map fst` and `F.map snd`,
    we get a cocone on `F`.

    If you're thinking about using this, have a look at `has_pushouts_of_has_colimit_span`, which
    you may find to be an easiery way of achieving your goal.  -/
@[simps]
def cocone.of_pushout_cocone
  {F : walking_span ⥤ C} (t : pushout_cocone (F.map fst) (F.map snd)) : cocone F :=
{ X := t.X,
  ι := (diagram_iso_span F).hom ≫ t.ι }

/-- Given `F : walking_cospan ⥤ C`, which is really the same as `cospan (F.map inl) (F.map inr)`,
    and a cone on `F`, we get a pullback cone on `F.map inl` and `F.map inr`. -/
@[simps]
def pullback_cone.of_cone
  {F : walking_cospan ⥤ C} (t : cone F) : pullback_cone (F.map inl) (F.map inr) :=
{ X := t.X,
  π := t.π ≫ (diagram_iso_cospan F).hom }

/-- Given `F : walking_span ⥤ C`, which is really the same as `span (F.map fst) (F.map snd)`,
    and a cocone on `F`, we get a pushout cocone on `F.map fst` and `F.map snd`. -/
@[simps]
def pushout_cocone.of_cocone
  {F : walking_span ⥤ C} (t : cocone F) : pushout_cocone (F.map fst) (F.map snd) :=
{ X := t.X,
  ι := (diagram_iso_span F).inv ≫ t.ι }

/--
`has_pullback f g` represents a particular choice of limiting cone
for the pair of morphisms `f : X ⟶ Z` and `g : Y ⟶ Z`.
-/
abbreviation has_pullback {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) := has_limit (cospan f g)
/--
`has_pushout f g` represents a particular choice of colimiting cocone
for the pair of morphisms `f : X ⟶ Y` and `g : X ⟶ Z`.
-/
abbreviation has_pushout {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) := has_colimit (span f g)

/-- `pullback f g` computes the pullback of a pair of morphisms with the same target. -/
abbreviation pullback {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] :=
limit (cospan f g)
/-- `pushout f g` computes the pushout of a pair of morphisms with the same source. -/
abbreviation pushout {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [has_pushout f g] :=
colimit (span f g)

/-- The first projection of the pullback of `f` and `g`. -/
abbreviation pullback.fst {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] :
  pullback f g ⟶ X :=
limit.π (cospan f g) walking_cospan.left

/-- The second projection of the pullback of `f` and `g`. -/
abbreviation pullback.snd {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] :
  pullback f g ⟶ Y :=
limit.π (cospan f g) walking_cospan.right

/-- The first inclusion into the pushout of `f` and `g`. -/
abbreviation pushout.inl {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] :
  Y ⟶ pushout f g :=
colimit.ι (span f g) walking_span.left

/-- The second inclusion into the pushout of `f` and `g`. -/
abbreviation pushout.inr {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] :
  Z ⟶ pushout f g :=
colimit.ι (span f g) walking_span.right

/-- A pair of morphisms `h : W ⟶ X` and `k : W ⟶ Y` satisfying `h ≫ f = k ≫ g` induces a morphism
    `pullback.lift : W ⟶ pullback f g`. -/
abbreviation pullback.lift {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) : W ⟶ pullback f g :=
limit.lift _ (pullback_cone.mk h k w)

/-- A pair of morphisms `h : Y ⟶ W` and `k : Z ⟶ W` satisfying `f ≫ h = g ≫ k` induces a morphism
    `pushout.desc : pushout f g ⟶ W`. -/
abbreviation pushout.desc {W X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g]
  (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) : pushout f g ⟶ W :=
colimit.desc _ (pushout_cocone.mk h k w)

@[simp, reassoc]
lemma pullback.lift_fst {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) : pullback.lift h k w ≫ pullback.fst = h :=
limit.lift_π _ _

@[simp, reassoc]
lemma pullback.lift_snd {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) : pullback.lift h k w ≫ pullback.snd = k :=
limit.lift_π _ _

@[simp, reassoc]
lemma pushout.inl_desc {W X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g]
  (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) : pushout.inl ≫ pushout.desc h k w = h :=
colimit.ι_desc _ _

@[simp, reassoc]
lemma pushout.inr_desc {W X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g]
  (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) : pushout.inr ≫ pushout.desc h k w = k :=
colimit.ι_desc _ _

/-- A pair of morphisms `h : W ⟶ X` and `k : W ⟶ Y` satisfying `h ≫ f = k ≫ g` induces a morphism
    `l : W ⟶ pullback f g` such that `l ≫ pullback.fst = h` and `l ≫ pullback.snd = k`. -/
def pullback.lift' {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  (h : W ⟶ X) (k : W ⟶ Y) (w : h ≫ f = k ≫ g) :
  {l : W ⟶ pullback f g // l ≫ pullback.fst = h ∧ l ≫ pullback.snd = k} :=
⟨pullback.lift h k w, pullback.lift_fst _ _ _, pullback.lift_snd _ _ _⟩

/-- A pair of morphisms `h : Y ⟶ W` and `k : Z ⟶ W` satisfying `f ≫ h = g ≫ k` induces a morphism
    `l : pushout f g ⟶ W` such that `pushout.inl ≫ l = h` and `pushout.inr ≫ l = k`. -/
def pullback.desc' {W X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g]
  (h : Y ⟶ W) (k : Z ⟶ W) (w : f ≫ h = g ≫ k) :
  {l : pushout f g ⟶ W // pushout.inl ≫ l = h ∧ pushout.inr ≫ l = k} :=
⟨pushout.desc h k w, pushout.inl_desc _ _ _, pushout.inr_desc _ _ _⟩

@[reassoc]
lemma pullback.condition {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g] :
  (pullback.fst : pullback f g ⟶ X) ≫ f = pullback.snd ≫ g :=
pullback_cone.condition _

@[reassoc]
lemma pushout.condition {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] :
  f ≫ (pushout.inl : Y ⟶ pushout f g) = g ≫ pushout.inr :=
pushout_cocone.condition _

/-- Two morphisms into a pullback are equal if their compositions with the pullback morphisms are
    equal -/
@[ext] lemma pullback.hom_ext {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  {W : C} {k l : W ⟶ pullback f g} (h₀ : k ≫ pullback.fst = l ≫ pullback.fst)
  (h₁ : k ≫ pullback.snd = l ≫ pullback.snd) : k = l :=
limit.hom_ext $ pullback_cone.equalizer_ext _ h₀ h₁

/-- The pullback cone built from the pullback projections is a pullback. -/
def pullback_is_pullback {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] :
  is_limit (pullback_cone.mk (pullback.fst : pullback f g ⟶ _) pullback.snd pullback.condition) :=
pullback_cone.is_limit.mk _ (λ s, pullback.lift s.fst s.snd s.condition)
  (by simp) (by simp) (by tidy)

/-- The pullback of a monomorphism is a monomorphism -/
instance pullback.fst_of_mono {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  [mono g] : mono (pullback.fst : pullback f g ⟶ X) :=
⟨λ W u v h, pullback.hom_ext h $ (cancel_mono g).1 $ by simp [← pullback.condition, reassoc_of h]⟩

/-- The pullback of a monomorphism is a monomorphism -/
instance pullback.snd_of_mono {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_pullback f g]
  [mono f] : mono (pullback.snd : pullback f g ⟶ Y) :=
⟨λ W u v h, pullback.hom_ext ((cancel_mono f).1 $ by simp [pullback.condition, reassoc_of h]) h⟩

/-- Two morphisms out of a pushout are equal if their compositions with the pushout morphisms are
    equal -/
@[ext] lemma pushout.hom_ext {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g]
  {W : C} {k l : pushout f g ⟶ W} (h₀ : pushout.inl ≫ k = pushout.inl ≫ l)
  (h₁ : pushout.inr ≫ k = pushout.inr ≫ l) : k = l :=
colimit.hom_ext $ pushout_cocone.coequalizer_ext _ h₀ h₁

/-- The pushout of an epimorphism is an epimorphism -/
instance pushout.inl_of_epi {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] [epi g] :
  epi (pushout.inl : Y ⟶ pushout f g) :=
⟨λ W u v h, pushout.hom_ext h $ (cancel_epi g).1 $ by simp [← pushout.condition_assoc, h] ⟩

/-- The pushout of an epimorphism is an epimorphism -/
instance pushout.inr_of_epi {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z} [has_pushout f g] [epi f] :
  epi (pushout.inr : Z ⟶ pushout f g) :=
⟨λ W u v h, pushout.hom_ext ((cancel_epi f).1 $ by simp [pushout.condition_assoc, h]) h⟩

section

variables {D : Type u₂} [category.{v} D] (G : C ⥤ D)

/--
The comparison morphism for the pullback of `f,g`.
This is an isomorphism iff `G` preserves the pullback of `f,g`; see
`category_theory/limits/preserves/shapes/pullbacks.lean`
-/
def pullback_comparison (f : X ⟶ Z) (g : Y ⟶ Z)
  [has_pullback f g] [has_pullback (G.map f) (G.map g)] :
  G.obj (pullback f g) ⟶ pullback (G.map f) (G.map g) :=
pullback.lift (G.map pullback.fst) (G.map pullback.snd)
  (by simp only [←G.map_comp, pullback.condition])

@[simp, reassoc]
lemma pullback_comparison_comp_fst (f : X ⟶ Z) (g : Y ⟶ Z)
  [has_pullback f g] [has_pullback (G.map f) (G.map g)] :
  pullback_comparison G f g ≫ pullback.fst = G.map pullback.fst :=
pullback.lift_fst _ _ _

@[simp, reassoc]
lemma pullback_comparison_comp_snd (f : X ⟶ Z) (g : Y ⟶ Z)
  [has_pullback f g] [has_pullback (G.map f) (G.map g)] :
  pullback_comparison G f g ≫ pullback.snd = G.map pullback.snd :=
pullback.lift_snd _ _ _

@[simp, reassoc]
lemma map_lift_pullback_comparison (f : X ⟶ Z) (g : Y ⟶ Z)
  [has_pullback f g] [has_pullback (G.map f) (G.map g)]
  {W : C} {h : W ⟶ X} {k : W ⟶ Y} (w : h ≫ f = k ≫ g) :
    G.map (pullback.lift _ _ w) ≫ pullback_comparison G f g =
      pullback.lift (G.map h) (G.map k) (by simp only [←G.map_comp, w]) :=
by { ext; simp [← G.map_comp] }

end

variables (C)

/--
`has_pullbacks` represents a choice of pullback for every pair of morphisms

See https://stacks.math.columbia.edu/tag/001W.
-/
abbreviation has_pullbacks := has_limits_of_shape walking_cospan C

/-- `has_pushouts` represents a choice of pushout for every pair of morphisms -/
abbreviation has_pushouts := has_colimits_of_shape walking_span C

/-- If `C` has all limits of diagrams `cospan f g`, then it has all pullbacks -/
lemma has_pullbacks_of_has_limit_cospan
  [Π {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}, has_limit (cospan f g)] :
  has_pullbacks C :=
{ has_limit := λ F, has_limit_of_iso (diagram_iso_cospan F).symm }

/-- If `C` has all colimits of diagrams `span f g`, then it has all pushouts -/
lemma has_pushouts_of_has_colimit_span
  [Π {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z}, has_colimit (span f g)] :
  has_pushouts C :=
{ has_colimit := λ F, has_colimit_of_iso (diagram_iso_span F) }

end category_theory.limits