import Lean

section utils
open Lean

/-- True Notation -/
notation "⊤" => True

/-- False Notation -/
notation "⊥" => False

/- plain numbers can't be used as identifiers so line number identifiers are prefixed with `L` -/
private abbrev mkLineId (n : Nat) : TSyntax [] := TSyntax.mk (mkIdent s!"L{n}")

/- theorem names are mildly obfuscated to avoid name clashes -/
private abbrev mkThmId (n : Name) : TSyntax [] := TSyntax.mk (mkIdent s!"T@{n}")

end utils

/-- Theorem Declaration

    Syntax: `thm <name> <vars> : <hyps> ⊢ <goal>`

    - `name` is the theorem name to be used in the `THM` proof command
    - `vars` is a space separated list of propositional variables
    - `hyps` is a comma separated list of hypotheses for the theorem
    - `goal` is the main theorem statement
-/
macro doc?:(docComment)? "thm " name:ident vars:ident* " : " hyps:term,* " ⊢ " goal:term " := " prf:term : command =>
  -- TODO: make docstrings work in a meaningful way
  -- TODO: can we get rid of the walrus?
  let ln := mkThmId name.getId
  `($[$doc?]? theorem $ln $[($vars : Prop)]* $[(_ : $hyps := by first | assumption | fail "missing hypothesis")]* : $goal := $prf)

/-- Basic Hilbert Proof Commands -/
declare_syntax_cat hbasic

/-- Proof Command

  Syntax: `proof <cmds> qed`

  - `cmds` is a sequence of proof commands on separate numbered lines

  Proof commands are of the shape `<lnum> <cmd> <args>` where `lnum` is the line number, `cmd` is the command name and `args` are the command arguments.
  Line numbers must be positive and increasing at each step.
  The last line of the proof should match the main statement of the theorem being proved.
-/
syntax "proof" (noWs "[" num "]")? withPosition(colGe hbasic)* "qed" : term

/- Syntax Checking -/
abbrev checkCMD := Lean.Parser.checkLineEq "command (MP, DT, HYP, LEM)"
abbrev checkTHM := Lean.Parser.checkLineEq "theorem name"
abbrev checkARG := Lean.Parser.checkColGt "proposition"
abbrev checkREF := Lean.Parser.checkLineEq "line number"

open Lean.Parser (semicolonOrLinebreak)

/-- Modus Ponens

  Syntax: `<lnum> MP <lref>`

  - `lnum` is the current line number
  - `lref` is a line reference for a conditional statement

  When the statement referred to by `lref` is `A → B` then this proof command searches for the hypothesis `A` among the previous lines.
  If `A` is found then it assigns `B` to the current line number.
-/
syntax num ws (checkCMD "MP ") (checkREF num) semicolonOrLinebreak : hbasic

/-- Deduction Theorem

  Syntax: `<lnum> DT`

  When the current goal is `A → B` then this proof command assigns `A` to the current line number and sets the goal to `B`.
-/
syntax num ws (checkCMD "DT ") semicolonOrLinebreak : hbasic

/-- Recall Hypothesis

  Syntax: `<lnum> HYP <prop>`

  - `lnum` is the current line number
  - `prop` is a propositional statement

  This proof command searches for `prop` among the theorem hypotheses and previous lines.
  If `prop` is found then it assigns `prop` to the current line number.
-/
syntax num ws (checkCMD "HYP ") (checkARG term:max) semicolonOrLinebreak : hbasic

/-- Invoke Theorem

  Syntax: `<lnum> THM <name> <args>`

  - `lnum` is the current line number
  - `name` is the name of the theorem invoked
  - `args` is a space separated list of propositions

  This proof command searches a theorem `name` declared using the `thm` command and then assigns `args` to the propositional variables of the theorem.
  If the theorem has hypotheses, it searches for each one among previous lines.
  Then it assigns the theorem's main proposition to the current line number.
-/
syntax num ws (checkCMD "THM ") (checkTHM ident) (colGt term:max)* semicolonOrLinebreak : hbasic

/- TODO: document implementation -/
open Lean in macro_rules
| `(proof qed%$tk) => withRef tk `(by done)
| `(proof[$m] qed%$tk) =>
  let lm := mkLineId m.getNat
  withRef tk `(by first | exact $lm | done)
| `(proof$[[$m]]? $n:num MP%$tk $ref; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    let lref := mkLineId ref.getNat
    withRef n `(have $ln : (_ : Prop) := $lref (by first | assumption | fail "missing hypothesis"); proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num DT%$tk; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    withRef n `(fun $ln : (_ : Prop) => proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num HYP%$tk $h; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    withRef n `(have $ln : ($h : Prop) := (by assumption); proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num THM%$tk $name:ident $args:term*; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    let tn := mkThmId name.getId
    withRef n `(have $ln : (_ : Prop) := $tn $args*; proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"

/- Basic Theorems

The two deduction rules Modus Ponens (`MP`) and Deduction Theorem (`DT`) only characterize implication.
The basic axioms below are necessary to define the other logical connectives:

- True (⊤)
- False (⊥)
- Negation (¬·)
- Conjunction (·∧·)
- Disjunction (·∨·)
- Biconditional (·↔·)

The proofs involve Lean core theorems since they can't be proved using only the basic rules of this system.

In addition to these basic axioms, the basic implication axioms S, K, I are defined.
This is because the DT is not actually necessary in the presence of these axioms, so we make them available to users who wish to avoid DT.

Also, Pierce's Law is presented as the only axiom from classical logic.
It is sufficient to derive all classical theorems and it has the advantage of being formulated only using implication.
Users that wish to work in intuitionistic logic should avoid this axiom.
The Lean `#print axioms` command is useful to determine whether Pierce's Law is used, even indirectly, in a proof.
-/
section basic_theorems

/-- Axiom I: a → a -/
thm AXI a : ⊢ a → a :=
proof
10 DT
qed

/-- Axiom K: a → b → a -/
thm AXK a b : ⊢ a → b → a :=
proof
10 DT
20 DT
30 HYP a
qed

/-- Axiom S: (a → b → c) → (a → b) → a → c -/
thm AXS a b c : ⊢ (a → b → c) → (a → b) → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 20
50 MP 10
60 MP 50
qed

/-- Trivial: ⊤ -/
thm TRIV :
⊢ ⊤ := True.intro

/-- True Elimination: (⊤ → a) → a -/
thm THUS a :
⊢ (⊤ → a) → a :=
proof
10 DT
20 THM TRIV;
30 MP 10
qed

/-- Ex Falso Quodlibet: ⊥ → a -/
thm EXFALSO a :
⊢ ⊥ → a := False.elim

/-- Negation Introduction: (a → ⊥) → ¬ a -/
thm NOTI a :
⊢ (a → ⊥) → ¬ a := id

/-- Negation Elimination: ¬ a → a → ⊥ -/
thm NOTE a :
⊢ ¬ a → a → ⊥ := id

/-- Conjunction Introduction: a → b → a ∧ b -/
thm ANDI a b :
⊢ a → b → a ∧ b := And.intro

/-- Conjunction Elimination: (a → b → c) → a ∧ b → c -/
thm ANDE a b c :
⊢ (a → b → c) → a ∧ b → c := And.rec

/-- Conjunction Elimination (Left): a ∧ b → a -/
thm ANDL a b :
⊢ a ∧ b → a := -- And.left
proof
10 THM AXK a b
20 THM ANDE a b a
30 MP 20
qed

/-- Conjunction Elimination (Right): a ∧ b → b -/
thm ANDR a b :
⊢ a ∧ b → b := -- And.right
proof
10 THM AXK (b → b) a
20 THM AXI b
30 MP 10
40 THM ANDE a b b
50 MP 40
qed

/-- Disjunction Elimination: (a → c) → (b → c) → a ∨ b → c -/
thm ORE a b c :
⊢ (a → c) → (b → c) → a ∨ b → c := Or.rec

/-- Disjunction Introduction (Left): a → a ∨ b -/
thm ORL a b :
⊢ a → a ∨ b := Or.inl

/-- Disjunction Introduction (Right): b → a ∨ b -/
thm ORR a b :
⊢ b → a ∨ b := Or.inr

/-- Biconditional Introduction: (a → b) → (b → a) → (a ↔ b) -/
thm IFFI a b :
⊢ (a → b) → (b → a) → (a ↔ b) := Iff.intro

/-- Biconditional Elimination (Left): (a ↔ b) → a → b -/
thm IFFL a b :
⊢ (a ↔ b) → a → b := Iff.mp

/-- Biconditional Elimination (Right): (a ↔ b) → b → a -/
thm IFFR a b :
⊢ (a ↔ b) → b → a := Iff.mpr

/-- Pierce's Law: ((a → b) → a) → a -/
thm PIERCE a b :
⊢ ((a → b) → a) → a :=
fun h => match Classical.em a with
| .inl ha => ha
| .inr na => h fun ha => absurd ha na

end basic_theorems

/- Testing Zone -/
section test_theorems

thm IFTRANS a b c :
⊢ (a → b) → (b → c) → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 10
50 MP 20
qed

thm IFLCOMM a b c :
⊢ (a → b → c) → b → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 10
50 MP 40
qed

thm ANDIDEMR a :
⊢ a → a ∧ a :=
proof
10 DT
20 THM ANDI a a
30 MP 20
40 MP 30
qed

thm ANDIDEM a :
⊢ a ∧ a ↔ a :=
proof
10 THM ANDL a a
20 THM ANDIDEMR a
30 THM IFFI (a ∧ a) a
40 MP 30
50 MP 40
qed

thm ANDCOMM a b :
⊢ a ∧ b → b ∧ a :=
proof
10 THM ANDE a b (b ∧ a)
20 THM IFLCOMM b a (b ∧ a)
30 THM ANDI b a
40 MP 20
50 MP 10
qed

thm ANDASSOCL a b c :
⊢ a ∧ (b ∧ c) → (a ∧ b) ∧ c :=
proof
10 DT
20 THM ANDL a (b ∧ c)
30 MP 20
40 THM ANDR a (b ∧ c)
50 MP 40
60 THM ANDL b c
70 MP 60
80 THM ANDR b c
90 MP 80
100 THM ANDI a b
110 MP 100
120 MP 110
130 THM ANDI (a ∧ b) c
140 MP 130
150 MP 140
qed

thm ANDASSOCR a b c :
⊢ (a ∧ b) ∧ c → a ∧ (b ∧ c) :=
proof
10 DT
20 THM ANDR (a ∧ b) c
30 MP 20
40 THM ANDL (a ∧ b) c
50 MP 40
60 THM ANDR a b
70 MP 60
80 THM ANDL a b
90 MP 80
100 THM ANDI b c
110 MP 100
120 MP 110
130 THM ANDI a (b ∧ c)
140 MP 130
150 MP 140
qed

thm ANDASSOC a b c :
⊢ (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) :=
proof
10 THM ANDASSOCL a b c
20 THM ANDASSOCR a b c
30 THM IFFI ((a ∧ b) ∧ c) (a ∧ (b ∧ c))
40 MP 30
50 MP 40
qed

thm ANDTRUEL a :
⊢ ⊤ ∧ a ↔ a :=
proof
10 THM TRIV;
20 THM ANDR ⊤ a
30 THM ANDI ⊤ a
40 MP 30
50 THM IFFI (⊤ ∧ a) a
60 MP 50
70 MP 60
qed

thm ORIDEML a :
⊢ a ∨ a → a :=
proof
10 THM AXI a
20 THM ORE a a a
30 MP 20
40 MP 30
qed

thm ORIDEM :
⊢ a ∨ a ↔ a :=
proof
10 THM ORIDEML a
20 THM ORL a a
30 THM IFFI (a ∨ a) a
40 MP 30
50 MP 40
qed

thm ORCOMM a b :
⊢ a ∨ b → b ∨ a :=
proof
10 THM ORL b a
20 THM ORR b a
30 THM ORE a b (b ∨ a)
40 MP 30
50 MP 40
qed

thm ORASSOCL a b c :
⊢ a ∨ (b ∨ c) → (a ∨ b) ∨ c :=
proof
10 DT
20 THM ORE a (b ∨ c) ((a ∨ b) ∨ c)
30 THM ORL a b
40 THM ORL (a ∨ b) c
50 THM IFTRANS a (a ∨ b) ((a ∨ b) ∨ c)
60 MP 50
70 MP 60
80 MP 20
90 THM ORE b c ((a ∨ b) ∨ c)
100 THM ORR a b
110 THM ORL (a ∨ b) c
120 THM ORR (a ∨ b) c
130 THM IFTRANS b (a ∨ b) ((a ∨ b) ∨ c)
140 MP 130
150 MP 140
160 MP 90
170 MP 160
180 MP 80
190 MP 180
qed

thm ORASSOCR a b c :
⊢ (a ∨ b) ∨ c → a ∨ (b ∨ c) :=
proof
10 DT
20 THM ORE a b (a ∨ (b ∨ c))
30 THM ORL a (b ∨ c)
40 THM ORL b c
50 THM ORR a (b ∨ c)
60 THM IFTRANS b (b ∨ c) (a ∨ (b ∨ c))
70 MP 60
80 MP 70
90 MP 20
100 MP 90
110 THM ORR b c
120 THM IFTRANS c (b ∨ c) (a ∨ (b ∨ c))
130 MP 120
140 MP 130
150 THM ORE (a ∨ b) c (a ∨ (b ∨ c))
160 MP 150
170 MP 160
180 MP 170
qed

thm ORASSOC a b c :
⊢ (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) :=
proof
10 THM ORASSOCL a b c
20 THM ORASSOCR a b c
30 THM IFFI ((a ∨ b) ∨ c) (a ∨ (b ∨ c))
40 MP 30
50 MP 40
qed

thm ORRESL a b :
⊢ a ∨ b → ¬a → b :=
proof
10 DT
20 DT
30 THM ORE a b b
40 THM IFTRANS a ⊥ b
50 THM NOTE a
60 MP 50
70 MP 40
80 THM EXFALSO b
90 MP 70
100 MP 30
110 THM AXI b
120 MP 100
130 MP 120
qed

thm ORRESR a b :
⊢ a ∨ b → ¬b → a :=
proof
10 DT
20 DT
30 THM ORE a b a
40 THM AXI a
50 MP 30
60 THM IFTRANS b ⊥ a
70 THM NOTE b
80 MP 70
90 MP 60
100 THM EXFALSO a
110 MP 90
120 MP 50
130 MP 120
qed

thm ANDDISTRIBL a b c :
⊢ a ∧ (b ∨ c) → (a ∧ b) ∨ (a ∧ c) :=
proof
10 DT
20 THM ANDL a (b ∨ c)
30 MP 20
40 THM ANDR a (b ∨ c)
50 MP 40
60 THM ORE b c ((a ∧ b) ∨ (a ∧ c))
70 THM IFTRANS b (a ∧ b) ((a ∧ b) ∨ (a ∧ c))
80 THM ANDI a b
90 MP 80
100 MP 70
110 THM ORL (a ∧ b) (a ∧ c)
120 MP 100
130 THM IFTRANS c (a ∧ c) ((a ∧ b) ∨ (a ∧ c))
140 THM ANDI a c
150 MP 140
160 MP 130
170 THM ORR (a ∧ b) (a ∧ c)
180 MP 160
190 MP 60
200 MP 190
210 MP 200
qed

end test_theorems


import category_theory.category
import category_theory.limits.limits
import category_theory.limits.shapes

open category_theory
open category_theory.limits

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

local attribute [tidy] tactic.case_bash

@[derive decidable_eq] inductive walking_w : Type v
| left | middle | right | one | two

instance fintype_walking_w : fintype walking_w :=
{ elems := [walking_w.left, walking_w.middle, walking_w.right, walking_w.one, walking_w.two].to_finset,
  complete := λ x, by { cases x; simp } }

namespace walking_w

/-- The arrows in a pullback diagram. -/
inductive hom : walking_w → walking_w → Type v
| inl1 : hom left one
| inr1 : hom middle one
| inl2 : hom middle two
| inr2 : hom right two
| id : Π X : walking_w.{v}, hom X X

open hom

def hom.comp : Π (X Y Z : walking_w) (f : hom X Y) (g : hom Y Z), hom X Z
| _ _ _ (id _) h := h
| _ _ _ inl1    (id one) := inl1
| _ _ _ inr1    (id one) := inr1
| _ _ _ inl2    (id two) := inl2
| _ _ _ inr2    (id two) := inr2
.

instance category_struct : category_struct walking_w :=
{ hom  := hom,
  id   := hom.id,
  comp := hom.comp, }

instance (X Y : walking_w) : subsingleton (X ⟶ Y) := begin tidy end

-- We make this a @[simp] lemma later; if we do it now there's a mysterious
-- failure in `cospan`, below.
lemma hom_id (X : walking_w.{v}) : hom.id X = 𝟙 X := rfl

/-- The walking_cospan is the index diagram for a pullback. -/
instance : small_category.{v} walking_w.{v} := sparse_category

end walking_w

open walking_w walking_w.hom

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

/-- `cospan f g` is the functor from the walking cospan hitting `f` and `g`. -/
def w_cospan {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) : walking_w.{v} ⥤ C :=
{ obj := λ x, match x with
  | left := X
  | middle := Y
  | right := V
  | one := W
  | two := Z
  end,
  map := λ x y h, match x, y, h with
  | _, _, (id _) := 𝟙 _
  | _, _, inl1 := f1
  | _, _, inr1 := g1
  | _, _, inl2 := f2
  | _, _, inr2 := g2
  end }

@[simp] lemma w_cospan_left {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).obj walking_w.left = X := rfl

@[simp] lemma w_cospan_middle {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).obj walking_w.middle = Y := rfl

@[simp] lemma w_cospan_right {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).obj walking_w.right = V := rfl

@[simp] lemma w_cospan_one {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).obj walking_w.one = W := rfl

@[simp] lemma w_cospan_two {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).obj walking_w.two = Z := rfl

@[simp] lemma w_cospan_map_inl1 {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).map walking_w.hom.inl1 = f1 := rfl

@[simp] lemma w_cospan_map_inr1 {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).map walking_w.hom.inr1 = g1 := rfl

@[simp] lemma w_cospan_map_inl2 {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).map walking_w.hom.inl2 = f2 := rfl

@[simp] lemma w_cospan_map_inr2 {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) :
  (w_cospan f1 g1 f2 g2).map walking_w.hom.inr2 = g2 := rfl

@[simp] lemma w_cospan_map_id1 {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) (w : walking_w) :
  (w_cospan f1 g1 f2 g2).map (walking_w.hom.id w) = 𝟙 _ := rfl

variables {X Y V W Z : C}

attribute [simp] walking_w.hom_id

abbreviation w_pullback_cone (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) := cone (w_cospan f1 g1 f2 g2)

namespace w_pullback_cone
variables {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z}

abbreviation fst (t : w_pullback_cone f1 g1 f2 g2) : t.X ⟶ X := t.π.app left
abbreviation mid (t : w_pullback_cone f1 g1 f2 g2) : t.X ⟶ Y := t.π.app middle
abbreviation snd (t : w_pullback_cone f1 g1 f2 g2) : t.X ⟶ V := t.π.app right

def mk {P : C} (fst : P ⟶ X) (mid : P ⟶ Y) (snd : P ⟶ V) (eq1 : fst ≫ f1 = mid ≫ g1) (eq2 : mid ≫ f2 = snd ≫ g2) : w_pullback_cone f1 g1 f2 g2 :=
{ X := P,
  π :=
  { app := λ j, walking_w.cases_on j fst mid snd (fst ≫ f1) (mid ≫ f2),
    naturality' := λ j j' f, begin cases f; obviously end } }

end w_pullback_cone

abbreviation w_pullback {X Y V W Z : C} (f1 : X ⟶ W) (g1 : Y ⟶ W) (f2 : Y ⟶ Z) (g2 : V ⟶ Z) [has_limit (w_cospan f1 g1 f2 g2)] :=
limit (w_cospan f1 g1 f2 g2)

abbreviation w_pullback.fst {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] : w_pullback f1 g1 f2 g2 ⟶ X :=
limit.π (w_cospan f1 g1 f2 g2) walking_w.left
abbreviation w_pullback.mid {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] : w_pullback f1 g1 f2 g2 ⟶ Y :=
limit.π (w_cospan f1 g1 f2 g2) walking_w.middle
abbreviation w_pullback.snd {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] : w_pullback f1 g1 f2 g2 ⟶ V :=
limit.π (w_cospan f1 g1 f2 g2) walking_w.right

abbreviation w_pullback.lift {P X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)]
  (h : P ⟶ X) (j : P ⟶ Y) (k : P ⟶ V) (w1 : h ≫ f1 = j ≫ g1) (w2 : j ≫ f2 = k ≫ g2) : P ⟶ w_pullback f1 g1 f2 g2 :=
limit.lift _ (w_pullback_cone.mk h j k w1 w2)

lemma w_pullback.condition1 {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] :
  (w_pullback.fst : w_pullback f1 g1 f2 g2 ⟶ X) ≫ f1 = w_pullback.mid ≫ g1 :=
(limit.w (w_cospan f1 g1 f2 g2) walking_w.hom.inl1).trans
(limit.w (w_cospan f1 g1 f2 g2) walking_w.hom.inr1).symm

lemma w_pullback.condition2 {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] :
  (w_pullback.mid : w_pullback f1 g1 f2 g2 ⟶ Y) ≫ f2 = w_pullback.snd ≫ g2 :=
(limit.w (w_cospan f1 g1 f2 g2) walking_w.hom.inl2).trans
(limit.w (w_cospan f1 g1 f2 g2) walking_w.hom.inr2).symm

lemma w_pullback.condition2' {X Y V W Z : C} {f1 : X ⟶ W} {g1 : Y ⟶ W} {f2 : Y ⟶ Z} {g2 : V ⟶ Z} [has_limit (w_cospan f1 g1 f2 g2)] :
  (w_pullback.snd : w_pullback f1 g1 f2 g2 ⟶ V) ≫ g2 = w_pullback.mid ≫ f2 :=
by simp[w_pullback.condition2]


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

! This file was ported from Lean 3 source module control.traversable.basic
! leanprover-community/mathlib commit 1fc36cc9c8264e6e81253f88be7fb2cb6c92d76a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Defs
import Mathlib.Data.Option.Defs

/-!
# Traversable type class

Type classes for traversing collections. The concepts and laws are taken from
<http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Traversable.html>

Traversable collections are a generalization of functors. Whereas
functors (such as `List`) allow us to apply a function to every
element, it does not allow functions which external effects encoded in
a monad. Consider for instance a functor `invite : email → IO response`
that takes an email address, sends an email and waits for a
response. If we have a list `guests : List email`, using calling
`invite` using `map` gives us the following:
`map invite guests : List (IO response)`.  It is not what we need. We need something of
type `IO (List response)`. Instead of using `map`, we can use `traverse` to
send all the invites: `traverse invite guests : IO (List response)`.
`traverse` applies `invite` to every element of `guests` and combines
all the resulting effects. In the example, the effect is encoded in the
monad `IO` but any applicative functor is accepted by `traverse`.

For more on how to use traversable, consider the Haskell tutorial:
<https://en.wikibooks.org/wiki/Haskell/Traversable>

## Main definitions
  * `Traversable` type class - exposes the `traverse` function
  * `sequence` - based on `traverse`,
    turns a collection of effects into an effect returning a collection
  * `IsLawfulTraversable` - laws for a traversable functor
  * `ApplicativeTransformation` - the notion of a natural transformation for applicative functors

## Tags

traversable iterator functor applicative

## References

 * "Applicative Programming with Effects", by Conor McBride and Ross Paterson,
   Journal of Functional Programming 18:1 (2008) 1-13, online at
   <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>
 * "The Essence of the Iterator Pattern", by Jeremy Gibbons and Bruno Oliveira,
   in Mathematically-Structured Functional Programming, 2006, online at
   <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>
 * "An Investigation of the Laws of Traversals", by Mauro Jaskelioff and Ondrej Rypacek,
   in Mathematically-Structured Functional Programming, 2012,
   online at <http://arxiv.org/pdf/1202.2919>
-/

open Function hiding comp

universe u v w

section ApplicativeTransformation

variable (F : Type u → Type v) [Applicative F] [LawfulApplicative F]

variable (G : Type u → Type w) [Applicative G] [LawfulApplicative G]

/-- A transformation between applicative functors.  It is a natural
transformation such that `app` preserves the `Pure.pure` and
`Functor.map` (`<*>`) operations. See
`ApplicativeTransformation.preserves_map` for naturality. -/
structure ApplicativeTransformation : Type max (u + 1) v w where
  /-- The function on objects defined by an `ApplicativeTransformation`. -/
  app : ∀ α : Type u, F α → G α
  /-- An `ApplicativeTransformation` preserves `pure`. -/
  preserves_pure' : ∀ {α : Type u} (x : α), app _ (pure x) = pure x
  /-- An `ApplicativeTransformation` intertwines `seq`. -/
  preserves_seq' : ∀ {α β : Type u} (x : F (α → β)) (y : F α), app _ (x <*> y) = app _ x <*> app _ y
#align applicative_transformation ApplicativeTransformation

end ApplicativeTransformation

namespace ApplicativeTransformation

variable (F : Type u → Type v) [Applicative F] [LawfulApplicative F]

variable (G : Type u → Type w) [Applicative G] [LawfulApplicative G]

instance : CoeFun (ApplicativeTransformation F G) fun _ => ∀ {α}, F α → G α :=
  ⟨λ η => η.app _⟩

variable {F G}

@[simp]
theorem app_eq_coe (η : ApplicativeTransformation F G) : η.app = η :=
  rfl
#align applicative_transformation.app_eq_coe ApplicativeTransformation.app_eq_coe

@[simp]
theorem coe_mk (f : ∀ α : Type u, F α → G α) (pp ps) :
  (ApplicativeTransformation.mk f @pp @ps) = f :=
  rfl
#align applicative_transformation.coe_mk ApplicativeTransformation.coe_mk

protected theorem congr_fun (η η' : ApplicativeTransformation F G) (h : η = η') {α : Type u}
    (x : F α) : η x = η' x :=
  congrArg (fun η'' : ApplicativeTransformation F G => η'' x) h
#align applicative_transformation.congr_fun ApplicativeTransformation.congr_fun

protected theorem congr_arg (η : ApplicativeTransformation F G) {α : Type u} {x y : F α}
    (h : x = y) : η x = η y :=
  congrArg (fun z : F α => η z) h
#align applicative_transformation.congr_arg ApplicativeTransformation.congr_arg

theorem coe_inj ⦃η η' : ApplicativeTransformation F G⦄ (h : (η : ∀ α, F α → G α) = η') :
    η = η' := by
  cases η
  cases η'
  congr
#align applicative_transformation.coe_inj ApplicativeTransformation.coe_inj

@[ext]
theorem ext ⦃η η' : ApplicativeTransformation F G⦄ (h : ∀ (α : Type u) (x : F α), η x = η' x) :
    η = η' := by
  apply coe_inj
  ext1 α
  exact funext (h α)
#align applicative_transformation.ext ApplicativeTransformation.ext

theorem ext_iff {η η' : ApplicativeTransformation F G} :
    η = η' ↔ ∀ (α : Type u) (x : F α), η x = η' x :=
  ⟨fun h _ _ => h ▸ rfl, fun h => ext h⟩
#align applicative_transformation.ext_iff ApplicativeTransformation.ext_iff

section Preserves

variable (η : ApplicativeTransformation F G)

@[functor_norm]
theorem preserves_pure {α} : ∀ x : α, η (pure x) = pure x :=
  η.preserves_pure'
#align applicative_transformation.preserves_pure ApplicativeTransformation.preserves_pure

@[functor_norm]
theorem preserves_seq {α β : Type u} : ∀ (x : F (α → β)) (y : F α), η (x <*> y) = η x <*> η y :=
  η.preserves_seq'
#align applicative_transformation.preserves_seq ApplicativeTransformation.preserves_seq

@[functor_norm]
theorem preserves_map {α β} (x : α → β) (y : F α) : η (x <$> y) = x <$> η y := by
  rw [← pure_seq, η.preserves_seq, preserves_pure, pure_seq]

#align applicative_transformation.preserves_map ApplicativeTransformation.preserves_map

theorem preserves_map' {α β} (x : α → β) : @η _ ∘ Functor.map x = Functor.map x ∘ @η _ := by
  ext y
  exact preserves_map η x y
#align applicative_transformation.preserves_map' ApplicativeTransformation.preserves_map'

end Preserves

/-- The identity applicative transformation from an applicative functor to itself. -/
def idTransformation : ApplicativeTransformation F F where
  app α := id
  preserves_pure' := by simp
  preserves_seq' x y := by simp
#align applicative_transformation.id_transformation ApplicativeTransformation.idTransformation

instance : Inhabited (ApplicativeTransformation F F) :=
  ⟨idTransformation⟩

universe s t

variable {H : Type u → Type s} [Applicative H] [LawfulApplicative H]

/-- The composition of applicative transformations. -/
def comp (η' : ApplicativeTransformation G H) (η : ApplicativeTransformation F G) :
    ApplicativeTransformation F H where
  app α x := η' (η x)
  -- Porting note: something has gone wrong with `simp [functor_norm]`,
  -- which should suffice for the next two.
  preserves_pure' x := by simp only [preserves_pure]
  preserves_seq' x y := by simp only [preserves_seq]
#align applicative_transformation.comp ApplicativeTransformation.comp

@[simp]
theorem comp_apply (η' : ApplicativeTransformation G H) (η : ApplicativeTransformation F G)
    {α : Type u} (x : F α) : η'.comp η x = η' (η x) :=
  rfl
#align applicative_transformation.comp_apply ApplicativeTransformation.comp_apply

-- porting note: in mathlib3 we also had the assumption `[LawfulApplicative I]` because
-- this was assumed
theorem comp_assoc {I : Type u → Type t} [Applicative I]
    (η'' : ApplicativeTransformation H I) (η' : ApplicativeTransformation G H)
    (η : ApplicativeTransformation F G) : (η''.comp η').comp η = η''.comp (η'.comp η) :=
  rfl
#align applicative_transformation.comp_assoc ApplicativeTransformation.comp_assoc

@[simp]

@[simp]
theorem id_comp (η : ApplicativeTransformation F G) : idTransformation.comp η = η :=
  ext fun _ _ => rfl
#align applicative_transformation.id_comp ApplicativeTransformation.id_comp

end ApplicativeTransformation

open ApplicativeTransformation

/-- A traversable functor is a functor along with a way to commute
with all applicative functors (see `sequence`).  For example, if `t`
is the traversable functor `List` and `m` is the applicative functor
`IO`, then given a function `f : α → IO β`, the function `Functor.map f` is
`List α → List (IO β)`, but `traverse f` is `List α → IO (List β)`. -/
class Traversable (t : Type u → Type u) extends Functor t where
  /-- The function commuting a traversable functor `t` with an arbitrary applicative functor `m`. -/
  traverse : ∀ {m : Type u → Type u} [Applicative m] {α β}, (α → m β) → t α → m (t β)
#align traversable Traversable

open Functor

export Traversable (traverse)

section Functions

variable {t : Type u → Type u}

variable {m : Type u → Type v} [Applicative m]

variable {α β : Type u}

variable {f : Type u → Type u} [Applicative f]

/-- A traversable functor commutes with all applicative functors. -/
def sequence [Traversable t] : t (f α) → f (t α) :=
  traverse id
#align sequence sequence

end Functions

/-- A traversable functor is lawful if its `traverse` satisfies a
number of additional properties.  It must send `pure : α → Id α` to `pure`,
send the composition of applicative functors to the composition of the
`traverse` of each, send each function `f` to `λ x, f <$> x`, and
satisfy a naturality condition with respect to applicative
transformations. -/
class IsLawfulTraversable (t : Type u → Type u) [Traversable t] extends LawfulFunctor t :
    Type (u + 1) where
  /-- `traverse` plays well with `pure` of the identity monad-/
  id_traverse : ∀ {α} (x : t α), traverse (pure : α → Id α) x = x
  /-- `traverse` plays well with composition of applicative functors. -/
  comp_traverse :
    ∀ {F G} [Applicative F] [Applicative G] [LawfulApplicative F] [LawfulApplicative G] {α β γ}
      (f : β → F γ) (g : α → G β) (x : t α),
      traverse (Functor.Comp.mk ∘ map f ∘ g) x = Comp.mk (map (traverse f) (traverse g x))
  /-- An axiom for `traverse` involving `pure : β → Id β`. -/
  traverse_eq_map_id : ∀ {α β} (f : α → β) (x : t α),
    traverse ((pure : β → Id β) ∘ f) x = id.mk (f <$> x)
  /-- The naturality axiom explaining how lawful traversable functors should play with
  lawful applicative functors. -/
  naturality :
    ∀ {F G} [Applicative F] [Applicative G] [LawfulApplicative F] [LawfulApplicative G]
      (η : ApplicativeTransformation F G) {α β} (f : α → F β) (x : t α),
      η (traverse f x) = traverse (@η _ ∘ f) x
#align is_lawful_traversable IsLawfulTraversable

instance : Traversable Id :=
⟨id⟩

instance : IsLawfulTraversable Id := by refine' { .. } <;> intros <;> rfl

section

variable {F : Type u → Type v} [Applicative F]

instance : Traversable Option :=
  ⟨@Option.traverse⟩

instance : Traversable List :=
  ⟨@List.traverse⟩

end

namespace Sum

variable {σ : Type u}

variable {F : Type u → Type u}

variable [Applicative F]

-- porting note: this was marked as a dubious translation but the only issue seems to be
-- a universe issue; this may be a bug in mathlib3port. I've carefully checked the universes
-- in mathlib3 and mathlib4 and they seem to match up exactly. Discussion here
-- https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/why.20dubious.3F/

/- warning: sum.traverse -> Sum.traverse is a dubious translation:
lean 3 declaration is
  forall {σ : Type.{u}} {F : Type.{u} -> Type.{u}} [_inst_1 : Applicative.{u u} F]
    {α : Type.{u_1}} {β : Type.{u}}, (α -> (F β)) -> (Sum.{u u_1} σ α) ->
    (F (Sum.{u u} σ β))
but is expected to have type
  forall {σ : Type.{u}} {F : Type.{u} -> Type.{u}} [_inst_1 : Applicative.{u u} F]
    {α : Type.{_aux_param_0}} {β : Type.{u}}, (α -> (F β)) -> (Sum.{u _aux_param_0} σ α) ->
    (F (Sum.{u u} σ β))
Case conversion may be inaccurate. Consider using '#align sum.traverse Sum.traverseₓ'. -/

/-- Defines a `traverse` function on the second component of a sum type.
This is used to give a `traversable` instance for the functor `σ ⊕ -`. -/
protected def traverse {α β} (f : α → F β) : Sum σ α → F (Sum σ β)
  | Sum.inl x => pure (Sum.inl x)
  | Sum.inr x => Sum.inr <$> f x
#align sum.traverse Sum.traverse

end Sum

instance {σ : Type u} : Traversable.{u} (Sum σ) :=
  ⟨@Sum.traverse _⟩


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.model_category_axioms
import category_theory.limits.opposites
import category_theory.limits.shapes.comm_sq
import for_mathlib.category_theory.localization.predicate

noncomputable theory

open category_theory category_theory.limits

namespace algebraic_topology

variables (C : Type*) [category C]

class model_category extends category_with_fib_cof_weq C :=
(CM1axiom : has_finite_limits C ∧ has_finite_colimits C)
(CM2axiom : to_category_with_fib_cof_weq.CM2)
(CM3axiom : to_category_with_fib_cof_weq.CM3)
(CM4axiom : to_category_with_fib_cof_weq.CM4)
(CM5axiom : to_category_with_fib_cof_weq.CM5)

namespace model_category

variable {C}
variable [M : model_category C]
include M

def fib := M.fib
def cof := M.cof
def weq := M.weq
def triv_fib := M.to_category_with_fib_cof_weq.triv_fib
def triv_cof := M.to_category_with_fib_cof_weq.triv_cof

lemma CM1 : has_finite_limits C ∧ has_finite_colimits C := M.CM1axiom
lemma CM2 : (weq : morphism_property C).three_of_two := M.CM2axiom
lemma CM3 : M.to_category_with_fib_cof_weq.CM3 := M.CM3axiom
lemma CM3a : (weq : morphism_property C).is_stable_by_retract := CM3.weq
lemma CM3b : (fib : morphism_property C).is_stable_by_retract := CM3.fib
lemma CM3c : (cof : morphism_property C).is_stable_by_retract := CM3.cof
lemma CM4 : M.to_category_with_fib_cof_weq.CM4 := M.CM4axiom
lemma CM4a : (triv_cof : morphism_property C).has_lifting_property fib := CM4.1
lemma CM4b : (cof : morphism_property C).has_lifting_property triv_fib := CM4.2
lemma CM5 : M.to_category_with_fib_cof_weq.CM5 := M.CM5axiom
lemma CM5a : factorisation_axiom (triv_cof : morphism_property C) fib := CM5.1
lemma CM5b : factorisation_axiom (cof : morphism_property C) triv_fib := CM5.2

@[priority 100] instance : has_finite_limits C := CM1.1
@[priority 100] instance : has_finite_colimits C := CM1.2

instance : model_category Cᵒᵖ :=
{ to_category_with_fib_cof_weq := M.to_category_with_fib_cof_weq.op,
  CM1axiom := ⟨infer_instance, infer_instance⟩,
  CM2axiom := by simpa only [← M.to_category_with_fib_cof_weq.CM2_iff_op] using CM2axiom,
  CM3axiom := by simpa only [← M.to_category_with_fib_cof_weq.CM3_iff_op] using CM3axiom,
  CM4axiom := by simpa only [← M.to_category_with_fib_cof_weq.CM4_iff_op] using CM4axiom,
  CM5axiom := by simpa only [← M.to_category_with_fib_cof_weq.CM5_iff_op] using CM5axiom, }

variables {A B X Y Z : C} (i : A ⟶ B) {p : X ⟶ Y} {q : Y ⟶ Z} {f : X ⟶ Y}
  (hip : is_retract_hom i p)

class cofibration : Prop := (property : cof i)
class fibration : Prop := (property : fib i)
class weak_eq : Prop := (property : weq i)

variable {i}

@[priority 100] instance CM4a' [hi₁ : cofibration i] [hi₂ : weak_eq i] [hp : fibration p] :
  has_lifting_property i p := CM4a i ⟨hi₁.property, hi₂.property⟩ p hp.property
@[priority 100] instance CM4b' [hi : cofibration i] [hp₁ : fibration p] [hp₂ : weak_eq p] :
  has_lifting_property i p := CM4b i hi.property p ⟨hp₁.property, hp₂.property⟩

lemma cofibration_retract_stable [hp : cofibration p] : cofibration i :=
⟨CM3.cof i p hip hp.property⟩
lemma fibration_retract_stable [hp : fibration p] : fibration i :=
⟨CM3.fib i p hip hp.property⟩
lemma weq_retract_stable [hp : weak_eq p] : weak_eq i :=
⟨CM3.weq i p hip hp.property⟩

lemma cof_eq_llp_with_triv_fib : cof = (triv_fib : morphism_property C).llp_with :=
factorisation_axiom.eq_llp_with CM5b CM4b CM3.cof
lemma triv_fib_eq_rlp_with_cof : triv_fib = (cof : morphism_property C).rlp_with :=
factorisation_axiom.eq_rlp_with CM5b CM4b CM3.triv_fib
lemma triv_cof_eq_llp_with_fib : triv_cof = (fib : morphism_property C).llp_with :=
factorisation_axiom.eq_llp_with CM5a CM4a CM3.triv_cof
lemma fib_eq_rlp_with_triv_cof : fib = (triv_cof : morphism_property C).rlp_with :=
factorisation_axiom.eq_rlp_with CM5a CM4a CM3.fib

lemma cof_stable_under_composition : (cof : morphism_property C).stable_under_composition :=
by { rw cof_eq_llp_with_triv_fib, apply morphism_property.llp_with.stable_under_composition, }
lemma fib_stable_under_composition : (fib : morphism_property C).stable_under_composition :=
by { rw fib_eq_rlp_with_triv_cof, apply morphism_property.rlp_with.stable_under_composition, }

instance comp_weak_eq [hp : weak_eq p] [hq : weak_eq q] : weak_eq (p ≫ q) :=
⟨CM2.of_comp p q hp.property hq.property⟩
instance comp_cofibration [hp : cofibration p] [hq : cofibration q] : cofibration (p ≫ q) :=
⟨cof_stable_under_composition p q hp.property hq.property⟩
instance comp_fibration [hp : fibration p] [hq : fibration q] : fibration (p ≫ q) :=
⟨fib_stable_under_composition p q hp.property hq.property⟩

namespace weak_eq

variables (p q)

lemma of_comp_left (hp : weak_eq p) (hpq : weak_eq (p ≫ q)) : weak_eq q :=
⟨CM2.of_comp_left p q hp.property hpq.property⟩
lemma of_comp_left' [hp : weak_eq p] [hpq : weak_eq (p ≫ q)] : weak_eq q :=
of_comp_left p q hp hpq

lemma of_comp_right (hq : weak_eq q) (hpq : weak_eq (p ≫ q)) : weak_eq p :=
⟨CM2.of_comp_right p q hq.property hpq.property⟩
lemma of_comp_right' [hq : weak_eq q] [hpq : weak_eq (p ≫ q)] : weak_eq p :=
of_comp_right p q hq hpq

end weak_eq

lemma cof_contains_iso : morphism_property.isomorphisms C ⊆ cof :=
by { rw cof_eq_llp_with_triv_fib, apply morphism_property.llp_with.contains_iso, }
lemma fib_contains_iso : morphism_property.isomorphisms C ⊆ fib :=
by { rw fib_eq_rlp_with_triv_cof, apply morphism_property.rlp_with.contains_iso, }
lemma triv_cof_contains_iso : morphism_property.isomorphisms C ⊆ triv_cof :=
by { rw triv_cof_eq_llp_with_fib, apply morphism_property.llp_with.contains_iso, }
lemma triv_fib_contains_iso : morphism_property.isomorphisms C ⊆ triv_fib :=
by { rw triv_fib_eq_rlp_with_cof, apply morphism_property.rlp_with.contains_iso, }
lemma weq_contains_iso : morphism_property.isomorphisms C ⊆ weq :=
λ X Y f hf, (triv_cof_contains_iso f hf).2

@[priority 100] instance cofibration_of_is_iso [is_iso p] : cofibration p :=
⟨cof_contains_iso p (morphism_property.isomorphisms.infer_property _)⟩
@[priority 100] instance fibration_of_is_iso [is_iso p] : fibration p :=
⟨fib_contains_iso p (morphism_property.isomorphisms.infer_property _)⟩
@[priority 100] instance weak_eq_of_is_iso [is_iso p] : weak_eq p :=
⟨weq_contains_iso p (morphism_property.isomorphisms.infer_property _)⟩

instance CM5a_cofibration : cofibration (CM5a.i f) := ⟨(CM5a.i_property f).1⟩
instance CM5a_weak_eq : weak_eq (CM5a.i f) := ⟨(CM5a.i_property f).2⟩
instance CM5a_fibration : fibration (CM5a.p f) := ⟨CM5a.p_property f⟩

instance CM5b_cofibration : cofibration (CM5b.i f) := ⟨CM5b.i_property f⟩
instance CM5b_fibration : fibration (CM5b.p f) := ⟨(CM5b.p_property f).1⟩
instance CM5b_weak_eq : weak_eq (CM5b.p f) := ⟨(CM5b.p_property f).2⟩

lemma cof_is_stable_under_cobase_change : (cof : morphism_property C).stable_under_cobase_change :=
by { rw cof_eq_llp_with_triv_fib, apply morphism_property.llp_with.stable_under_cobase_change, }
lemma triv_cof_is_stable_under_cobase_change :
  (triv_cof : morphism_property C).stable_under_cobase_change :=
by { rw triv_cof_eq_llp_with_fib, apply morphism_property.llp_with.stable_under_cobase_change, }

lemma cof_is_stable_under_coproducts : (cof : morphism_property C).stable_under_coproducts :=
by { rw cof_eq_llp_with_triv_fib, apply morphism_property.llp_with.stable_under_coproducts, }
lemma triv_cof_is_stable_under_coproducts : (triv_cof : morphism_property C).stable_under_coproducts :=
by { rw triv_cof_eq_llp_with_fib, apply morphism_property.llp_with.stable_under_coproducts, }

lemma fib_is_stable_under_base_change :
  (fib : morphism_property C).stable_under_base_change :=
by { rw fib_eq_rlp_with_triv_cof, apply morphism_property.rlp_with.stable_under_base_change, }
lemma triv_fib_is_stable_under_base_change :
  (triv_fib : morphism_property C).stable_under_base_change :=
by { rw triv_fib_eq_rlp_with_cof, apply morphism_property.rlp_with.stable_under_base_change, }

lemma fib_is_stable_under_products : (fib : morphism_property C).stable_under_products :=
by { rw fib_eq_rlp_with_triv_cof, apply morphism_property.rlp_with.stable_under_products, }
lemma triv_fib_is_stable_under_products : (triv_fib : morphism_property C).stable_under_products :=
by { rw triv_fib_eq_rlp_with_cof, apply morphism_property.rlp_with.stable_under_products, }

lemma cof_respects_iso : (cof : morphism_property C).respects_iso :=
morphism_property.respects_iso.of_stable_under_composition_and_contains_iso
  cof_stable_under_composition cof_contains_iso
lemma fib_respects_iso : (fib : morphism_property C).respects_iso :=
morphism_property.respects_iso.of_stable_under_composition_and_contains_iso
  fib_stable_under_composition fib_contains_iso
lemma weq_respects_iso : (weq : morphism_property C).respects_iso :=
morphism_property.respects_iso.of_stable_under_composition_and_contains_iso
  CM2.of_comp weq_contains_iso

namespace cofibration

lemma op (hi : cofibration i) : fibration i.op := ⟨hi.property⟩
lemma unop {A B : Cᵒᵖ} {i : A ⟶ B} (hi : cofibration i) : fibration i.unop := ⟨hi.property⟩
lemma iff_cof : cofibration i ↔ cof i := ⟨λ h, h.property, λ h, ⟨h⟩⟩

lemma direct_image ⦃f : A ⟶ X⦄ ⦃i : A ⟶ B⦄ ⦃i' : X ⟶ Y⦄ ⦃g : B ⟶ Y⦄
  (h : is_pushout f i i' g) [hi : cofibration i] : cofibration i' :=
⟨cof_is_stable_under_cobase_change h hi.property⟩

lemma direct_image_is_weak_eq ⦃f : A ⟶ X⦄ ⦃i : A ⟶ B⦄ ⦃i' : X ⟶ Y⦄ ⦃g : B ⟶ Y⦄
  (h : is_pushout f i i' g) [hi₁ : cofibration i] [hi₂ : weak_eq i] : weak_eq i' :=
⟨(triv_cof_is_stable_under_cobase_change h ⟨hi₁.property, hi₂.property⟩).2⟩

instance {A X₁ X₂ : C} (f : A ⟶ X₁) (g : A ⟶ X₂) [hg : cofibration g] :
  cofibration (pushout.inl : X₁ ⟶ pushout f g) :=
⟨cof_is_stable_under_cobase_change.inl f g hg.property⟩

instance {A X₁ X₂ : C} (f : A ⟶ X₁) (g : A ⟶ X₂) [hf : cofibration f] :
  cofibration (pushout.inr : X₂ ⟶ pushout f g) :=
⟨cof_is_stable_under_cobase_change.inr f g hf.property⟩

instance {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) [h₁ : cofibration f₁] [h₂ : cofibration f₂] :
  cofibration (coprod.map f₁ f₂) :=
⟨cof_is_stable_under_coproducts.binary f₁ h₁.property f₂ h₂.property⟩

instance {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) [h₁ : cofibration f₁] [h₂ : cofibration f₂]
  [h₁' : weak_eq f₁] [h₂' : weak_eq f₂] :
  weak_eq (coprod.map f₁ f₂) :=
⟨(triv_cof_is_stable_under_coproducts.binary f₁ ⟨h₁.property, h₁'.property⟩
  f₂ ⟨h₂.property, h₂'.property⟩).2⟩

lemma respects_iso {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (e : arrow.mk f₁ ≅ arrow.mk f₂) :
  cofibration f₁ ↔ cofibration f₂ :=
by simpa only [iff_cof] using cof_respects_iso.arrow_mk_iso_iff e

end cofibration

namespace fibration

lemma op (hp : fibration p) : cofibration p.op := ⟨hp.property⟩
lemma unop {X Y : Cᵒᵖ} {p : X ⟶ Y} (hp : fibration p) : cofibration p.unop := ⟨hp.property⟩
lemma iff_fib : fibration i ↔ fib i := ⟨λ h, h.property, λ h, ⟨h⟩⟩

variable (p)
lemma iff_op : fibration p ↔ cofibration p.op := ⟨op, cofibration.unop⟩
lemma iff_unop {X Y : Cᵒᵖ} (p : X ⟶ Y) : fibration p ↔ cofibration p.unop := ⟨unop, cofibration.op⟩

lemma respects_iso {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (e : arrow.mk f₁ ≅ arrow.mk f₂) :
  fibration f₁ ↔ fibration f₂ :=
by simpa only [iff_fib] using fib_respects_iso.arrow_mk_iso_iff e

end fibration

namespace cofibration

variable (p)

lemma iff_op : cofibration p ↔ fibration p.op := ⟨op, fibration.unop⟩
lemma iff_unop {X Y : Cᵒᵖ} (p : X ⟶ Y) : cofibration p ↔ fibration p.unop := ⟨unop, fibration.op⟩

end cofibration

namespace weak_eq

lemma op (hp : weak_eq p) : weak_eq p.op := ⟨hp.property⟩
lemma unop {X Y : Cᵒᵖ} {p : X ⟶ Y} (hp : weak_eq p) : weak_eq p.unop := ⟨hp.property⟩
lemma iff_weq : weak_eq i ↔ weq i := ⟨λ h, h.property, λ h, ⟨h⟩⟩

instance {A X₁ X₂ : C} (f : A ⟶ X₁) (g : A ⟶ X₂) [hg₁ : cofibration g] [hg₂ : weak_eq g] :
  weak_eq (pushout.inl : X₁ ⟶ pushout f g) :=
⟨(triv_cof_is_stable_under_cobase_change.inl f g ⟨hg₁.property, hg₂.property⟩).2⟩

instance {A X₁ X₂ : C} (f : A ⟶ X₁) (g : A ⟶ X₂) [hf₁ : cofibration f] [hf₂ : weak_eq f] :
  weak_eq (pushout.inr : X₂ ⟶ pushout f g) :=
⟨(triv_cof_is_stable_under_cobase_change.inr f g ⟨hf₁.property, hf₂.property⟩).2⟩

lemma respects_iso {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (e : arrow.mk f₁ ≅ arrow.mk f₂) :
  weak_eq f₁ ↔ weak_eq f₂ :=
by simpa only [iff_weq] using weq_respects_iso.arrow_mk_iso_iff e

end weak_eq

variable (C)

@[derive category]
def Ho' := (weq : morphism_property C).localization

variable {C}

def L' : C ⥤ Ho' C := weq.Q

instance L'_is_localization : L'.is_localization (weq : morphism_property C) :=
by { dsimp [L'], apply_instance, }

variables {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq]

lemma is_iso_L_map' {X Y : C} (f : X ⟶ Y) (hf : weq f) : is_iso (L.map f) :=
localization.inverts L weq f hf

lemma is_iso_L_map {X Y : C} (f : X ⟶ Y) [weak_eq f] : is_iso (L.map f) :=
is_iso_L_map' L f weak_eq.property

end model_category

end algebraic_topology


import data.fintype tactic.find data.set.finite ring_theory.subring data.nat.choose tactic.find

open tactic expr lean interactive interactive.types
open set finset

meta def fold_test : expr → tactic (list (nat × string)) :=
λ e, do let l := e.fold [] (λ e n l, (n, e.to_string) :: l),
trace l, return l

meta def fold_test_type : expr → tactic (list (nat × string)) :=
λ e, do l ← e.fold (pure [])
  (λ e n l, (do t ← infer_type e, l ← l, return ((n, t.to_string) :: l)) <|> l),
  trace l, return l

meta def fold_test_target : tactic unit :=
target >>= fold_test >> skip

meta def fold_test_target_type : tactic unit :=
target >>= fold_test_type >> skip

/-- gets the type of any fintype in an expr -/
meta def get_fintype (e : expr) : tactic (list expr) :=
e.fold (pure []) $ λ e _ l, do l' ← l,
  (do t ← infer_type e,
  match t with
  | `(fintype _) := return (e::l')
  | _ := return l'
  end) <|> return l'

-- meta def is_fintype (e : expr) : tactic (list expr) :=
-- match e with
-- | (app n _) := if n.const_name = `fintype then return [e] else return []
-- | _         := return []
-- end

-- meta def is_fintype_type (e : expr) : tactic (list expr) :=
-- infer_type e >>= is_fintype

/-- checks is an expression is has type `fintype _` -/
meta def is_fintype (e : expr) : tactic bool :=
match e with
| (app n _) := if n.const_name = `fintype then return tt else return ff
| _         := return ff
end

/-- returns the type of an expr if it has type `fintype _` -/
meta def is_fintype_type (e : expr) : tactic expr :=
do f ← infer_type e,
  b ← is_fintype f,
  match b with
  | tt := return f
  | ff := failure
  end

-- meta def get_fintype' : expr → tactic (list expr)
-- | e := do l ← is_fintype_type e, match l with
--   | [] := match e with
--     | (mvar _ _ f)          := is_fintype f
--     | (local_const _ _ _ f) := is_fintype f
--     | (app f g)             := do lf ← get_fintype' f, lg ← get_fintype' g, return (lf ++ lg)
--     | _                     := return []
--     end
--   | _ := return l
-- end

-- meta def thing : tactic unit :=
-- do t ← target,
-- l ← get_fintype' t,
-- match l with
-- | [] := return ()
-- | (a :: l) := _match l >> pose `f none a >> reset_instance_cache >> skip
-- end
-- #print expr
-- lemma fintype_congr (α : Type*) [fintype α] (P : Π [fintype α], Prop) (h : P) (x : fintype α) : @P x :=
-- by convert h

-- meta def generalize_fintype : expr → tactic (list expr)
-- | `(@eq (%%u) (%%a) (%%b)) := match a with
--   | (mvar x y f)           := mcond (is_fintype f) (return [f]) failure
--   | (local_const _ _ _ f)  := mcond (is_fintype f) (return [f]) failure
--   | (app f g)              := do lf ← get_fintype f, lg ← get_fintype g, return (lf ++ lg)
--   | _                      := return []
--   end
-- | `((%%a) ↔ (%%b)) := match a with
--   | (mvar x y f)           := mcond (is_fintype f) (return [f]) failure
--   | (local_const _ _ _ f)  := mcond (is_fintype f) (return [f]) failure
--   | (app f g)              := do lf ← get_fintype f, lg ← get_fintype g, return (lf ++ lg)
--   | _                      := return []
--   end
-- | e := return []

-- #print expr.

-- meta def generalize_forall_aux (t : expr) (e : expr) (f : expr → expr) :
--   expr × (expr → expr) :=
-- cond (expr.alpha_eqv t e)
--   _
--   (e, f)

-- meta def generalize_forall (t : expr) : expr → (expr → expr) → tactic expr
-- | (const n l) f :=

-- #reduce tactic.skip
-- #reduce (return () : tactic unit)
-- example : false :=
-- let x : ℕ := 1 in
-- have hx : x = 1 := rfl,
-- begin
--   replace x := x,

-- end
#print cond._main
#print id_rhs
#find (tactic _ → option _)

meta def get_fintype' (e : expr) : tactic (list (expr × expr)) :=
e.fold (return []) $ λ e _ l, do l' ← l,
  (do t ← infer_type e,
  match t with
  | `(fintype _) := cond (has_var e) (return ((e, t) :: l')) (return l')
  | _ := return l'
  end) <|> return l'

meta def get_fintype_aux (e : expr) (t : expr) (l : tactic (list (expr × expr))) :
  tactic (list (expr × expr)) :=
  match t with
  | `(fintype _) := do l ← l, cond (has_var e) (return ((e, t) :: l)) (return l)
  | _ := l
  end

#eval (```((2 : ℕ) + 2) : expr ff).to_raw_fmt.to_string

#print expr.pi
meta def get_fintype₂ : expr → tactic (list (expr × expr))
| (const n l)           := do t ← infer_type (const n l), get_fintype_aux (const n l) t (pure [])
| (local_const n m i t) := get_fintype_aux (local_const n m i t) t (pure [])
| (app f x)             := do l₁ ← get_fintype₂ f, l₂ ← get_fintype₂ x, return (l₁ ++ l₂)
| (lam n i v e)         := do l₁ ← get_fintype₂ v, l₂ ← get_fintype₂ e, return (l₁ ++ l₂)
| (pi n i v e)          := do l₁ ← get_fintype₂ v, l₂ ← get_fintype₂ e, return (l₁ ++ l₂)
| _ := return []

#print simplify

#print monad
#print expr.replace
#reduce tactic
#print <|>
#print interaction_monad.result
#print tactic
#eval expr.get_nat_value

#print expr
#print tactic.simplify
meta def

meta def replace_fintype : Π (e : expr) (l : list (expr × expr)), tactic expr

example (s t : set ℕ) [fintype s] [fintype t] [decidable_pred t] (h : fintype.card ↥(s ∩ t) = 77) :
  fintype.card ↥(s ∪ t) = 9  :=
begin
  -- thing,
  -- fold_test_target_type,

end


import .homotopy

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cylinder

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

-- A map j : A → X is the inclusion of a strong deformation retract if
-- it admits a retraction r : X → A for which j ∘ r is homotopic to
-- the identity rel j.
structure sdr_inclusion {a x : C} (j : a ⟶ x) :=
(r : x ⟶ a)
(h : r ∘ j = 𝟙 a)
(H : j ∘ r ≃ 𝟙 x rel j)

def is_sdr_inclusion {a x : C} (j : a ⟶ x) : Prop := nonempty (sdr_inclusion j)

lemma pushout_of_sdr_inclusion {a x a' x' : C} {j : a ⟶ x} {f : a ⟶ a'} {f' : x ⟶ x'}
  {j' : a' ⟶ x'} (po : Is_pushout j f f' j')
  (po' : Is_pushout (I &> j) (I &> f) (I &> f') (I &> j')) :
  is_sdr_inclusion j → is_sdr_inclusion j' :=
assume ⟨⟨r, h, ⟨H, Hrel⟩⟩⟩, begin
  refine ⟨⟨po.induced (f ∘ r) (𝟙 a') (by rw [←assoc, h]; simp), by simp, _⟩⟩,
  -- Now need to give a homotopy from j' ∘ r' (r' = the above induced
  -- map) to 𝟙 x', rel j'. We define the homotopy using H on I +> x,
  -- and the constant homotopy at the identity on I +> a'.
  refine ⟨⟨po'.induced (f' ∘ H.H) (j' ∘ p @> a') _, _, _⟩, _⟩,
  -- The above maps agree on I +> a, so we can form the induced map:
  { unfold homotopy.is_rel at Hrel, rw [←assoc, Hrel, p_nat_assoc],
    have : f' ∘ (j ∘ r ∘ j ∘ p @> a) = (f' ∘ j) ∘ (r ∘ j) ∘ p @> a, by simp,
    rw [this, po.commutes, h], dsimp, simp },
  -- The homotopy defined in this way starts at j' ∘ r' : x' → x':
  { apply po.uniqueness; rw i_nat_assoc; conv { to_rhs, rw ←assoc }; simp;
      rw ←assoc,
    { erw [H.Hi₀, assoc, po.commutes] },
    { rw [pi_components], simp } },
  -- ... and ends at 𝟙 x':
  { apply po.uniqueness; rw i_nat_assoc; simp; rw [←assoc],
    { erw H.Hi₁; simp }, { rw [pi_components], simp } },
  -- ... and is rel j:
  { unfold homotopy.is_rel,
    simp, congr, rw [←assoc], dsimp, simp }
end

end homotopy_theory.cylinder


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.additive_functor
import category_theory.abelian.basic
import category_theory.limits.preserves.shapes.kernels
import category_theory.adjunction.limits

/-!
# Transferring "abelian-ness" across a functor

If `C` is an additive category, `D` is an abelian category,
we have `F : C ⥤ D` `G : D ⥤ C` (both preserving zero morphisms),
`G` is left exact (that is, preserves finite limits),
and further we have `adj : G ⊣ F` and `i : F ⋙ G ≅ 𝟭 C`,
then `C` is also abelian.

See https://stacks.math.columbia.edu/tag/03A3

## Notes
The hypotheses, following the statement from the Stacks project,
may appear suprising: we don't ask that the counit of the adjunction is an isomorphism,
but just that we have some potentially unrelated isomorphism `i : F ⋙ G ≅ 𝟭 C`.

However Lemma A1.1.1 from [Elephant] shows that in this situation the counit itself
must be an isomorphism, and thus that `C` is a reflective subcategory of `D`.

Someone may like to formalize that lemma, and restate this theorem in terms of `reflective`.
(That lemma has a nice string diagrammatic proof that holds in any bicategory.)
-/

noncomputable theory

namespace category_theory
open category_theory.limits

universes v u₁ u₂

namespace abelian_of_adjunction

variables {C : Type u₁} [category.{v} C] [preadditive C]
variables {D : Type u₂} [category.{v} D] [abelian D]
variables (F : C ⥤ D)
variables (G : D ⥤ C) [functor.preserves_zero_morphisms G]
variables (i : F ⋙ G ≅ 𝟭 C) (adj : G ⊣ F)

include i

/-- No point making this an instance, as it requires `i`. -/
lemma has_kernels [preserves_finite_limits G] : has_kernels C :=
{ has_limit := λ X Y f, begin
    have := nat_iso.naturality_1 i f,
    simp at this,
    rw ←this,
    haveI : has_kernel (G.map (F.map f) ≫ i.hom.app _) := limits.has_kernel_comp_mono _ _,
    apply limits.has_kernel_iso_comp,
  end }

include adj

/-- No point making this an instance, as it requires `i` and `adj`. -/
lemma has_cokernels : has_cokernels C :=
{ has_colimit := λ X Y f, begin
    haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
    have := nat_iso.naturality_1 i f,
    simp at this,
    rw ←this,
    haveI : has_cokernel (G.map (F.map f) ≫ i.hom.app _) := limits.has_cokernel_comp_iso _ _,
    apply limits.has_cokernel_epi_comp,
  end }

variables [limits.has_cokernels C]

/-- Auxiliary construction for `coimage_iso_image` -/
def cokernel_iso {X Y : C} (f : X ⟶ Y) : G.obj (cokernel (F.map f)) ≅ cokernel f :=
begin
  -- We have to write an explicit `preserves_colimits` type here,
  -- as `left_adjoint_preserves_colimits` has universe variables.
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc G.obj (cokernel (F.map f))
      ≅ cokernel (G.map (F.map f)) : (as_iso (cokernel_comparison _ G)).symm
  ... ≅ cokernel (_ ≫ f ≫ _)       : cokernel_iso_of_eq (nat_iso.naturality_2 i f).symm
  ... ≅ cokernel (f ≫ _)           : cokernel_epi_comp _ _
  ... ≅ cokernel f                 : cokernel_comp_is_iso _ _
end

variables [limits.has_kernels C] [preserves_finite_limits G]

/-- Auxiliary construction for `coimage_iso_image` -/
def coimage_iso_image_aux {X Y : C} (f : X ⟶ Y) :
  kernel (G.map (cokernel.π (F.map f))) ≅ kernel (cokernel.π f) :=
begin
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc kernel (G.map (cokernel.π (F.map f)))
      ≅ kernel (cokernel.π (G.map (F.map f)) ≫ cokernel_comparison (F.map f) G)
          : kernel_iso_of_eq (π_comp_cokernel_comparison _ _).symm
  ... ≅ kernel (cokernel.π (G.map (F.map f))) : kernel_comp_mono _ _
  ... ≅ kernel (cokernel.π (_ ≫ f ≫ _) ≫ (cokernel_iso_of_eq _).hom)
          : kernel_iso_of_eq (π_comp_cokernel_iso_of_eq_hom (nat_iso.naturality_2 i f)).symm
  ... ≅ kernel (cokernel.π (_ ≫ f ≫ _))       : kernel_comp_mono _ _
  ... ≅ kernel (cokernel.π (f ≫ i.inv.app Y) ≫ (cokernel_epi_comp (i.hom.app X) _).inv)
          : kernel_iso_of_eq (by simp only [cokernel.π_desc, cokernel_epi_comp_inv])
  ... ≅ kernel (cokernel.π (f ≫ _))           : kernel_comp_mono _ _
  ... ≅ kernel (inv (i.inv.app Y) ≫ cokernel.π f ≫ (cokernel_comp_is_iso f (i.inv.app Y)).inv)
          : kernel_iso_of_eq (by simp only [cokernel.π_desc, cokernel_comp_is_iso_inv,
              iso.hom_inv_id_app_assoc, nat_iso.inv_inv_app])
  ... ≅ kernel (cokernel.π f ≫ _)             : kernel_is_iso_comp _ _
  ... ≅ kernel (cokernel.π f)                 : kernel_comp_mono _ _
end

variables [functor.preserves_zero_morphisms F]

/--
Auxiliary definition: the abelian coimage and abelian image agree.
We still need to check that this agrees with the canonical morphism.
-/
def coimage_iso_image {X Y : C} (f : X ⟶ Y) : abelian.coimage f ≅ abelian.image f :=
begin
  haveI : preserves_limits F := adj.right_adjoint_preserves_limits,
  haveI : preserves_colimits G := adj.left_adjoint_preserves_colimits,
  calc abelian.coimage f
      ≅ cokernel (kernel.ι f)                 : iso.refl _
  ... ≅ G.obj (cokernel (F.map (kernel.ι f))) : (cokernel_iso _ _ i adj _).symm
  ... ≅ G.obj (cokernel (kernel_comparison f F ≫ (kernel.ι (F.map f))))
                                              : G.map_iso (cokernel_iso_of_eq (by simp))
  ... ≅ G.obj (cokernel (kernel.ι (F.map f))) : G.map_iso (cokernel_epi_comp _ _)
  ... ≅ G.obj (abelian.coimage (F.map f))     : iso.refl _
  ... ≅ G.obj (abelian.image (F.map f))       : G.map_iso (abelian.coimage_iso_image _)
  ... ≅ G.obj (kernel (cokernel.π (F.map f))) : iso.refl _
  ... ≅ kernel (G.map (cokernel.π (F.map f))) : preserves_kernel.iso _ _
  ... ≅ kernel (cokernel.π f)                 : coimage_iso_image_aux F G i adj f
  ... ≅ abelian.image f                       : iso.refl _,
end

local attribute [simp] cokernel_iso coimage_iso_image coimage_iso_image_aux

-- The account of this proof in the Stacks project omits this calculation.
-- Happily it's little effort: our `[ext]` and `[simp]` lemmas only need a little guidance.
lemma coimage_iso_image_hom {X Y : C} (f : X ⟶ Y) :
  (coimage_iso_image F G i adj f).hom = abelian.coimage_image_comparison f :=
by { ext, simpa [-functor.map_comp, ←G.map_comp_assoc] using nat_iso.naturality_1 i f, }

end abelian_of_adjunction

open abelian_of_adjunction

/--
If `C` is an additive category, `D` is an abelian category,
we have `F : C ⥤ D` `G : D ⥤ C` (both preserving zero morphisms),
`G` is left exact (that is, preserves finite limits),
and further we have `adj : G ⊣ F` and `i : F ⋙ G ≅ 𝟭 C`,
then `C` is also abelian.

See https://stacks.math.columbia.edu/tag/03A3
-/
def abelian_of_adjunction
  {C : Type u₁} [category.{v} C] [preadditive C] [has_finite_products C]
  {D : Type u₂} [category.{v} D] [abelian D]
  (F : C ⥤ D) [functor.preserves_zero_morphisms F]
  (G : D ⥤ C) [functor.preserves_zero_morphisms G] [preserves_finite_limits G]
  (i : F ⋙ G ≅ 𝟭 C) (adj : G ⊣ F) : abelian C :=
begin
  haveI := has_kernels F G i, haveI := has_cokernels F G i adj,
  haveI : ∀ {X Y : C} (f : X ⟶ Y), is_iso (abelian.coimage_image_comparison f),
  { intros X Y f, rw ←coimage_iso_image_hom F G i adj f, apply_instance, },
  apply abelian.of_coimage_image_comparison_is_iso,
end

end category_theory


import for_mathlib.category_theory.morphism_property_misc
import category_theory.lifting_properties.basic
import for_mathlib.category_theory.lifting_properties.pullbacks
import for_mathlib.category_theory.lifting_properties.products
import for_mathlib.category_theory.lifting_properties.over

open category_theory.limits

namespace category_theory

variables {C : Type*} [category C]

namespace morphism_property

variables (F G : morphism_property C)

def has_lifting_property : Prop :=
∀ ⦃A B X Y : C⦄ (i : A ⟶ B) (hi : F i) (p : X ⟶ Y) (hp : G p), has_lifting_property i p

namespace has_lifting_property

variables {F G}

lemma property (h : has_lifting_property F G)
{A B X Y : C} {i : A ⟶ B} (hi : F i) {p : X ⟶ Y} (hp : G p) :
  category_theory.has_lifting_property i p := h i hi p hp

lemma op (h : has_lifting_property F G) :
  has_lifting_property G.op F.op :=
λ A B X Y i hi p hp, (h p.unop hp i.unop hi).op

lemma unop {F G : morphism_property Cᵒᵖ} (h : has_lifting_property F G) :
  has_lifting_property G.unop F.unop :=
λ A B X Y i hi p hp, (h p.op hp i.op hi).unop

variables (F G)
lemma iff_op : has_lifting_property F G ↔ has_lifting_property G.op F.op := ⟨op, unop⟩
lemma iff_unop (F' G' : morphism_property Cᵒᵖ) :
  has_lifting_property F' G' ↔ has_lifting_property G'.unop F'.unop := ⟨unop, op⟩

variables {F G}
lemma under (h : has_lifting_property F G) (M : C) :
  has_lifting_property (F.inverse_image (under.forget M)) (G.inverse_image (under.forget M)) :=
λ A B X Y i hi p hp, by { haveI := h _ hi _ hp, apply_instance, }

end has_lifting_property

@[simp]
def llp_with : morphism_property C :=
λ A B i, ∀ ⦃X Y : C⦄ (p : X ⟶ Y) (hp : G p), category_theory.has_lifting_property i p

@[simp]
def rlp_with : morphism_property C :=
λ X Y p, ∀ ⦃A B : C⦄ (i : A ⟶ B) (hi : F i), category_theory.has_lifting_property i p

lemma llp_with_op :
  F.op.llp_with = F.rlp_with.op :=
begin
  ext A B i,
  split,
  { intros h X Y p hp,
    rw category_theory.has_lifting_property.iff_op,
    exact h p.op hp, },
  { intros h X Y p hp,
    rw category_theory.has_lifting_property.iff_unop,
    exact h p.unop hp, },
end

lemma rlp_with_op :
  G.op.rlp_with = G.llp_with.op :=
begin
  ext A B i,
  split,
  { intros h X Y p hp,
    rw category_theory.has_lifting_property.iff_op,
    exact h p.op hp, },
  { intros h X Y p hp,
    rw category_theory.has_lifting_property.iff_unop,
    exact h p.unop hp, },
end

lemma llp_with_unop (G : morphism_property Cᵒᵖ) :
  G.unop.llp_with = G.rlp_with.unop :=
begin
  have h := rlp_with_op G.unop,
  rw G.op_unop at h,
  rw [h, unop_op],
end

lemma rlp_with_unop (F : morphism_property Cᵒᵖ) :
  F.unop.rlp_with = F.llp_with.unop :=
begin
  have h := llp_with_op F.unop,
  rw F.op_unop at h,
  rw [h, unop_op],
end

namespace llp_with

lemma contains_iso : isomorphisms C ⊆ G.llp_with :=
λ A B i hi X Y p hp, by { haveI : is_iso i := hi, apply_instance, }

lemma stable_under_composition : G.llp_with.stable_under_composition :=
λ A₁ A₂ A₃ i j hi hj X Y p hp, by { haveI := hi p hp, haveI := hj p hp, apply_instance, }

lemma respects_iso : G.llp_with.respects_iso :=
respects_iso.of_stable_under_composition_and_contains_iso
    (llp_with.stable_under_composition G) (llp_with.contains_iso G)

lemma stable_under_cobase_change : G.llp_with.stable_under_cobase_change :=
λ A A' B B' f g f' g' h hf X Y p hp, h.has_lifting_property_imp p (hf p hp)

lemma stable_under_coproducts : G.llp_with.stable_under_coproducts :=
⟨llp_with.respects_iso G,
  λ J A B hA hB i hi X Y p hp, by { haveI := λ j, hi j p hp, apply_instance, }⟩

end llp_with

namespace rlp_with

lemma contains_iso : isomorphisms C ⊆ F.rlp_with :=
λ X Y p hp A B i hi, by { haveI : is_iso p := hp, apply_instance, }

lemma stable_under_composition : F.rlp_with.stable_under_composition :=
λ X Y Z p q hp hq A B i hi, by { haveI := hp i hi, haveI := hq i hi, apply_instance, }

lemma respects_iso : F.rlp_with.respects_iso :=
respects_iso.of_stable_under_composition_and_contains_iso
    (rlp_with.stable_under_composition F) (rlp_with.contains_iso F)

lemma stable_under_base_change : F.rlp_with.stable_under_base_change :=
λ X' Y Y' X f g f' g' h hg A B i hi, h.has_lifting_property_imp i (hg i hi)

lemma stable_under_products : F.rlp_with.stable_under_products :=
⟨rlp_with.respects_iso F,
λ J X Y hX hY p hp A B i hi, by { haveI := λ j, hp j i hi, apply_instance, }⟩

end rlp_with

namespace stable_under_cobase_change

lemma coprod_inl {P : morphism_property C}
  (h : P.stable_under_cobase_change) (A B : C) [has_binary_coproduct A B]
  [has_initial C] (hB : P (initial.to B)) :
  P (coprod.inl : A ⟶ A ⨿ B) :=
h (is_pushout.of_has_binary_coproduct' A B) hB

lemma coprod_inr {P : morphism_property C}
  (h : P.stable_under_cobase_change) (A B : C) [has_binary_coproduct A B]
  [has_initial C] (hA : P (initial.to A)) :
  P (coprod.inr : B ⟶ A ⨿ B) :=
h (is_pushout.of_has_binary_coproduct' A B).flip hA

end stable_under_cobase_change

namespace stable_under_base_change

lemma prod_fst {P : morphism_property C}
  (h : P.stable_under_base_change) (X Y : C) [has_binary_product X Y]
  [has_terminal C] (hY : P (terminal.from Y)) :
  P (limits.prod.fst : X ⨯ Y ⟶ X) :=
h (is_pullback.of_has_binary_product' X Y).flip hY

lemma prod_snd {P : morphism_property C}
  (h : P.stable_under_base_change) (X Y : C) [has_binary_product X Y]
  [has_terminal C] (hX : P (terminal.from X)) :
  P (limits.prod.snd : X ⨯ Y ⟶ Y) :=
h (is_pullback.of_has_binary_product' X Y) hX

end stable_under_base_change

end morphism_property

end category_theory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.const
import category_theory.discrete_category
import category_theory.yoneda
import category_theory.reflects_isomorphisms

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄
open category_theory

variables {J : Type u₁} [category.{v₁} J]
variables {K : Type u₂} [category.{v₂} K]
variables {C : Type u₃} [category.{v₃} C]
variables {D : Type u₄} [category.{v₄} D]

open category_theory
open category_theory.category
open category_theory.functor
open opposite

namespace category_theory

namespace functor
variables {J C} (F : J ⥤ C)

/--
`F.cones` is the functor assigning to an object `X` the type of
natural transformations from the constant functor with value `X` to `F`.
An object representing this functor is a limit of `F`.
-/
@[simps]
def cones : Cᵒᵖ ⥤ Type (max u₁ v₃) := (const J).op ⋙ yoneda.obj F

/--
`F.cocones` is the functor assigning to an object `X` the type of
natural transformations from `F` to the constant functor with value `X`.
An object corepresenting this functor is a colimit of `F`.
-/
@[simps]
def cocones : C ⥤ Type (max u₁ v₃) := const J ⋙ coyoneda.obj (op F)

end functor

section
variables (J C)

/--
Functorially associated to each functor `J ⥤ C`, we have the `C`-presheaf consisting of
cones with a given cone point.
-/
@[simps] def cones : (J ⥤ C) ⥤ (Cᵒᵖ ⥤ Type (max u₁ v₃)) :=
{ obj := functor.cones,
  map := λ F G f, whisker_left (const J).op (yoneda.map f) }

/--
Contravariantly associated to each functor `J ⥤ C`, we have the `C`-copresheaf consisting of
cocones with a given cocone point.
-/
@[simps] def cocones : (J ⥤ C)ᵒᵖ ⥤ (C ⥤ Type (max u₁ v₃)) :=
{ obj := λ F, functor.cocones (unop F),
  map := λ F G f, whisker_left (const J) (coyoneda.map f) }

end

namespace limits

/--
A `c : cone F` is:
* an object `c.X` and
* a natural transformation `c.π : c.X ⟶ F` from the constant `c.X` functor to `F`.

`cone F` is equivalent, via `cone.equiv` below, to `Σ X, F.cones.obj X`.
-/
structure cone (F : J ⥤ C) :=
(X : C)
(π : (const J).obj X ⟶ F)

instance inhabited_cone (F : discrete punit ⥤ C) : inhabited (cone F) :=
⟨{ X := F.obj punit.star,
   π := { app := λ ⟨⟩, 𝟙 _ } }⟩

@[simp, reassoc] lemma cone.w {F : J ⥤ C} (c : cone F) {j j' : J} (f : j ⟶ j') :
  c.π.app j ≫ F.map f = c.π.app j' :=
by { rw ← c.π.naturality f, apply id_comp }

/--
A `c : cocone F` is
* an object `c.X` and
* a natural transformation `c.ι : F ⟶ c.X` from `F` to the constant `c.X` functor.

`cocone F` is equivalent, via `cone.equiv` below, to `Σ X, F.cocones.obj X`.
-/
structure cocone (F : J ⥤ C) :=
(X : C)
(ι : F ⟶ (const J).obj X)

instance inhabited_cocone (F : discrete punit ⥤ C) : inhabited (cocone F) :=
⟨{ X := F.obj punit.star,
   ι := { app := λ ⟨⟩, 𝟙 _ } }⟩

@[simp, reassoc] lemma cocone.w {F : J ⥤ C} (c : cocone F) {j j' : J} (f : j ⟶ j') :
  F.map f ≫ c.ι.app j' = c.ι.app j :=
by { rw c.ι.naturality f, apply comp_id }

variables {F : J ⥤ C}

namespace cone

/-- The isomorphism between a cone on `F` and an element of the functor `F.cones`. -/
@[simps]
def equiv (F : J ⥤ C) : cone F ≅ Σ X, F.cones.obj X :=
{ hom := λ c, ⟨op c.X, c.π⟩,
  inv := λ c, { X := c.1.unop, π := c.2 },
  hom_inv_id' := by { ext1, cases x, refl },
  inv_hom_id' := by { ext1, cases x, refl } }

/-- A map to the vertex of a cone naturally induces a cone by composition. -/
@[simps] def extensions (c : cone F) :
  yoneda.obj c.X ⋙ ulift_functor.{u₁} ⟶ F.cones :=
{ app := λ X f, (const J).map f.down ≫ c.π }

/-- A map to the vertex of a cone induces a cone by composition. -/
@[simps] def extend (c : cone F) {X : C} (f : X ⟶ c.X) : cone F :=
{ X := X,
  π := c.extensions.app (op X) ⟨f⟩ }

/-- Whisker a cone by precomposition of a functor. -/
@[simps] def whisker (E : K ⥤ J) (c : cone F) : cone (E ⋙ F) :=
{ X := c.X,
  π := whisker_left E c.π }

end cone

namespace cocone

/-- The isomorphism between a cocone on `F` and an element of the functor `F.cocones`. -/
def equiv (F : J ⥤ C) : cocone F ≅ Σ X, F.cocones.obj X :=
{ hom := λ c, ⟨c.X, c.ι⟩,
  inv := λ c, { X := c.1, ι := c.2 },
  hom_inv_id' := by { ext1, cases x, refl },
  inv_hom_id' := by { ext1, cases x, refl } }

/-- A map from the vertex of a cocone naturally induces a cocone by composition. -/
@[simps] def extensions (c : cocone F) : coyoneda.obj (op c.X) ⋙ ulift_functor.{u₁} ⟶ F.cocones :=
{ app := λ X f, c.ι ≫ (const J).map f.down }

/-- A map from the vertex of a cocone induces a cocone by composition. -/
@[simps] def extend (c : cocone F) {X : C} (f : c.X ⟶ X) : cocone F :=
{ X := X,
  ι := c.extensions.app X ⟨f⟩ }

/--
Whisker a cocone by precomposition of a functor. See `whiskering` for a functorial
version.
-/
@[simps] def whisker (E : K ⥤ J) (c : cocone F) : cocone (E ⋙ F) :=
{ X := c.X,
  ι := whisker_left E c.ι }

end cocone

/-- A cone morphism between two cones for the same diagram is a morphism of the cone points which
commutes with the cone legs. -/
@[ext] structure cone_morphism (A B : cone F) :=
(hom : A.X ⟶ B.X)
(w'  : ∀ j : J, hom ≫ B.π.app j = A.π.app j . obviously)

restate_axiom cone_morphism.w'
attribute [simp, reassoc] cone_morphism.w

instance inhabited_cone_morphism (A : cone F) : inhabited (cone_morphism A A) :=
⟨{ hom := 𝟙 _ }⟩

/-- The category of cones on a given diagram. -/
@[simps] instance cone.category : category (cone F) :=
{ hom  := λ A B, cone_morphism A B,
  comp := λ X Y Z f g, { hom := f.hom ≫ g.hom },
  id   := λ B, { hom := 𝟙 B.X } }

namespace cones
/-- To give an isomorphism between cones, it suffices to give an
  isomorphism between their vertices which commutes with the cone
  maps. -/
@[ext, simps] def ext {c c' : cone F}
  (φ : c.X ≅ c'.X) (w : ∀ j, c.π.app j = φ.hom ≫ c'.π.app j) : c ≅ c' :=
{ hom := { hom := φ.hom },
  inv := { hom := φ.inv, w' := λ j, φ.inv_comp_eq.mpr (w j) } }

/--
Given a cone morphism whose object part is an isomorphism, produce an
isomorphism of cones.
-/
lemma cone_iso_of_hom_iso {K : J ⥤ C} {c d : cone K} (f : c ⟶ d) [i : is_iso f.hom] :
  is_iso f :=
⟨⟨{ hom := inv f.hom,
    w' := λ j, (as_iso f.hom).inv_comp_eq.2 (f.w j).symm }, by tidy⟩⟩

/--
Functorially postcompose a cone for `F` by a natural transformation `F ⟶ G` to give a cone for `G`.
-/
@[simps] def postcompose {G : J ⥤ C} (α : F ⟶ G) : cone F ⥤ cone G :=
{ obj := λ c, { X := c.X, π := c.π ≫ α },
  map := λ c₁ c₂ f, { hom := f.hom } }

/-- Postcomposing a cone by the composite natural transformation `α ≫ β` is the same as
postcomposing by `α` and then by `β`. -/
@[simps]
def postcompose_comp {G H : J ⥤ C} (α : F ⟶ G) (β : G ⟶ H) :
  postcompose (α ≫ β) ≅ postcompose α ⋙ postcompose β :=
nat_iso.of_components (λ s, cones.ext (iso.refl _) (by tidy)) (by tidy)

/-- Postcomposing by the identity does not change the cone up to isomorphism. -/
@[simps]
def postcompose_id : postcompose (𝟙 F) ≅ 𝟭 (cone F) :=
nat_iso.of_components (λ s, cones.ext (iso.refl _) (by tidy)) (by tidy)

/--
If `F` and `G` are naturally isomorphic functors, then they have equivalent categories of
cones.
-/
@[simps]
def postcompose_equivalence {G : J ⥤ C} (α : F ≅ G) : cone F ≌ cone G :=
{ functor := postcompose α.hom,
  inverse := postcompose α.inv,
  unit_iso := nat_iso.of_components (λ s, cones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ s, cones.ext (iso.refl _) (by tidy)) (by tidy) }

/--
Whiskering on the left by `E : K ⥤ J` gives a functor from `cone F` to `cone (E ⋙ F)`.
-/
@[simps]
def whiskering (E : K ⥤ J) : cone F ⥤ cone (E ⋙ F) :=
{ obj := λ c, c.whisker E,
  map := λ c c' f, { hom := f.hom } }

/--
Whiskering by an equivalence gives an equivalence between categories of cones.
-/
@[simps]
def whiskering_equivalence (e : K ≌ J) :
  cone F ≌ cone (e.functor ⋙ F) :=
{ functor := whiskering e.functor,
  inverse := whiskering e.inverse ⋙ postcompose (e.inv_fun_id_assoc F).hom,
  unit_iso := nat_iso.of_components (λ s, cones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ s, cones.ext (iso.refl _)
  (begin
    intro k,
    dsimp, -- See library note [dsimp, simp]
    simpa [e.counit_app_functor] using s.w (e.unit_inv.app k),
  end)) (by tidy), }

/--
The categories of cones over `F` and `G` are equivalent if `F` and `G` are naturally isomorphic
(possibly after changing the indexing category by an equivalence).
-/
@[simps functor inverse unit_iso counit_iso]
def equivalence_of_reindexing {G : K ⥤ C}
  (e : K ≌ J) (α : e.functor ⋙ F ≅ G) : cone F ≌ cone G :=
(whiskering_equivalence e).trans (postcompose_equivalence α)

section
variable (F)

/-- Forget the cone structure and obtain just the cone point. -/
@[simps]
def forget : cone F ⥤ C :=
{ obj := λ t, t.X, map := λ s t f, f.hom }

variables (G : C ⥤ D)

/-- A functor `G : C ⥤ D` sends cones over `F` to cones over `F ⋙ G` functorially. -/
@[simps] def functoriality : cone F ⥤ cone (F ⋙ G) :=
{ obj := λ A,
  { X := G.obj A.X,
    π := { app := λ j, G.map (A.π.app j), naturality' := by intros; erw ←G.map_comp; tidy } },
  map := λ X Y f,
  { hom := G.map f.hom,
    w' := λ j, by simp [-cone_morphism.w, ←f.w j] } }

instance functoriality_full [full G] [faithful G] : full (functoriality F G) :=
{ preimage := λ X Y t,
  { hom := G.preimage t.hom,
    w' := λ j, G.map_injective (by simpa using t.w j) } }

instance functoriality_faithful [faithful G] : faithful (cones.functoriality F G) :=
{ map_injective' := λ X Y f g e, by { ext1, injection e, apply G.map_injective h_1 } }

/--
If `e : C ≌ D` is an equivalence of categories, then `functoriality F e.functor` induces an
equivalence between cones over `F` and cones over `F ⋙ e.functor`.
-/
@[simps]
def functoriality_equivalence (e : C ≌ D) : cone F ≌ cone (F ⋙ e.functor) :=
let f : (F ⋙ e.functor) ⋙ e.inverse ≅ F :=
  functor.associator _ _ _ ≪≫ iso_whisker_left _ (e.unit_iso).symm ≪≫ functor.right_unitor _ in
{ functor := functoriality F e.functor,
  inverse := (functoriality (F ⋙ e.functor) e.inverse) ⋙
    (postcompose_equivalence f).functor,
  unit_iso := nat_iso.of_components (λ c, cones.ext (e.unit_iso.app _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cones.ext (e.counit_iso.app _) (by tidy)) (by tidy), }

/--
If `F` reflects isomorphisms, then `cones.functoriality F` reflects isomorphisms
as well.
-/
instance reflects_cone_isomorphism (F : C ⥤ D) [reflects_isomorphisms F] (K : J ⥤ C) :
  reflects_isomorphisms (cones.functoriality K F) :=
begin
  constructor,
  introsI,
  haveI : is_iso (F.map f.hom) :=
    (cones.forget (K ⋙ F)).map_is_iso ((cones.functoriality K F).map f),
  haveI := reflects_isomorphisms.reflects F f.hom,
  apply cone_iso_of_hom_iso
end

end

end cones

/-- A cocone morphism between two cocones for the same diagram is a morphism of the cocone points
which commutes with the cocone legs. -/
@[ext] structure cocone_morphism (A B : cocone F) :=
(hom : A.X ⟶ B.X)
(w'  : ∀ j : J, A.ι.app j ≫ hom = B.ι.app j . obviously)

instance inhabited_cocone_morphism (A : cocone F) : inhabited (cocone_morphism A A) :=
⟨{ hom := 𝟙 _ }⟩

restate_axiom cocone_morphism.w'
attribute [simp, reassoc] cocone_morphism.w

@[simps] instance cocone.category : category (cocone F) :=
{ hom  := λ A B, cocone_morphism A B,
  comp := λ _ _ _ f g,
  { hom := f.hom ≫ g.hom },
  id   := λ B, { hom := 𝟙 B.X } }

namespace cocones
/-- To give an isomorphism between cocones, it suffices to give an
  isomorphism between their vertices which commutes with the cocone
  maps. -/
@[ext, simps] def ext {c c' : cocone F}
  (φ : c.X ≅ c'.X) (w : ∀ j, c.ι.app j ≫ φ.hom = c'.ι.app j) : c ≅ c' :=
{ hom := { hom := φ.hom },
  inv := { hom := φ.inv, w' := λ j, φ.comp_inv_eq.mpr (w j).symm } }

/--
Given a cocone morphism whose object part is an isomorphism, produce an
isomorphism of cocones.
-/
lemma cocone_iso_of_hom_iso {K : J ⥤ C} {c d : cocone K} (f : c ⟶ d) [i : is_iso f.hom] :
  is_iso f :=
⟨⟨{ hom := inv f.hom,
    w' := λ j, (as_iso f.hom).comp_inv_eq.2 (f.w j).symm }, by tidy⟩⟩

/-- Functorially precompose a cocone for `F` by a natural transformation `G ⟶ F` to give a cocone
for `G`. -/
@[simps] def precompose {G : J ⥤ C} (α : G ⟶ F) : cocone F ⥤ cocone G :=
{ obj := λ c, { X := c.X, ι := α ≫ c.ι },
  map := λ c₁ c₂ f, { hom := f.hom } }

/-- Precomposing a cocone by the composite natural transformation `α ≫ β` is the same as
precomposing by `β` and then by `α`. -/
def precompose_comp {G H : J ⥤ C} (α : F ⟶ G) (β : G ⟶ H) :
  precompose (α ≫ β) ≅ precompose β ⋙ precompose α :=
nat_iso.of_components (λ s, cocones.ext (iso.refl _) (by tidy)) (by tidy)

/-- Precomposing by the identity does not change the cocone up to isomorphism. -/
def precompose_id : precompose (𝟙 F) ≅ 𝟭 (cocone F) :=
nat_iso.of_components (λ s, cocones.ext (iso.refl _) (by tidy)) (by tidy)

/--
If `F` and `G` are naturally isomorphic functors, then they have equivalent categories of
cocones.
-/
@[simps]
def precompose_equivalence {G : J ⥤ C} (α : G ≅ F) : cocone F ≌ cocone G :=
{ functor := precompose α.hom,
  inverse := precompose α.inv,
  unit_iso := nat_iso.of_components (λ s, cocones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ s, cocones.ext (iso.refl _) (by tidy)) (by tidy) }

/--
Whiskering on the left by `E : K ⥤ J` gives a functor from `cocone F` to `cocone (E ⋙ F)`.
-/
@[simps]
def whiskering (E : K ⥤ J) : cocone F ⥤ cocone (E ⋙ F) :=
{ obj := λ c, c.whisker E,
  map := λ c c' f, { hom := f.hom, } }

/--
Whiskering by an equivalence gives an equivalence between categories of cones.
-/
@[simps]
def whiskering_equivalence (e : K ≌ J) :
  cocone F ≌ cocone (e.functor ⋙ F) :=
{ functor := whiskering e.functor,
  inverse := whiskering e.inverse ⋙
    precompose ((functor.left_unitor F).inv ≫ (whisker_right (e.counit_iso).inv F) ≫
      (functor.associator _ _ _).inv),
  unit_iso := nat_iso.of_components (λ s, cocones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ s, cocones.ext (iso.refl _)
  (begin
    intro k,
    dsimp,
    simpa [e.counit_inv_app_functor k] using s.w (e.unit.app k),
  end)) (by tidy), }

/--
The categories of cocones over `F` and `G` are equivalent if `F` and `G` are naturally isomorphic
(possibly after changing the indexing category by an equivalence).
-/
@[simps functor_obj]
def equivalence_of_reindexing {G : K ⥤ C}
  (e : K ≌ J) (α : e.functor ⋙ F ≅ G) : cocone F ≌ cocone G :=
(whiskering_equivalence e).trans (precompose_equivalence α.symm)

section
variable (F)

/-- Forget the cocone structure and obtain just the cocone point. -/
@[simps]
def forget : cocone F ⥤ C :=
{ obj := λ t, t.X, map := λ s t f, f.hom }

variables (G : C ⥤ D)

/-- A functor `G : C ⥤ D` sends cocones over `F` to cocones over `F ⋙ G` functorially. -/
@[simps] def functoriality : cocone F ⥤ cocone (F ⋙ G) :=
{ obj := λ A,
  { X := G.obj A.X,
    ι := { app := λ j, G.map (A.ι.app j), naturality' := by intros; erw ←G.map_comp; tidy } },
  map := λ _ _ f,
  { hom := G.map f.hom,
    w'  := by intros; rw [←functor.map_comp, cocone_morphism.w] } }

instance functoriality_full [full G] [faithful G] : full (functoriality F G) :=
{ preimage := λ X Y t,
  { hom := G.preimage t.hom,
    w' := λ j, G.map_injective (by simpa using t.w j) } }

instance functoriality_faithful [faithful G] : faithful (functoriality F G) :=
{ map_injective' := λ X Y f g e, by { ext1, injection e, apply G.map_injective h_1 } }

/--
If `e : C ≌ D` is an equivalence of categories, then `functoriality F e.functor` induces an
equivalence between cocones over `F` and cocones over `F ⋙ e.functor`.
-/
@[simps]
def functoriality_equivalence (e : C ≌ D) : cocone F ≌ cocone (F ⋙ e.functor) :=
let f : (F ⋙ e.functor) ⋙ e.inverse ≅ F :=
  functor.associator _ _ _ ≪≫ iso_whisker_left _ (e.unit_iso).symm ≪≫ functor.right_unitor _ in
{ functor := functoriality F e.functor,
  inverse := (functoriality (F ⋙ e.functor) e.inverse) ⋙
    (precompose_equivalence f.symm).functor,
  unit_iso := nat_iso.of_components (λ c, cocones.ext (e.unit_iso.app _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cocones.ext (e.counit_iso.app _)
  begin
    -- Unfortunately this doesn't work by `tidy`.
    -- In this configuration `simp` reaches a dead-end and needs help.
    intros j,
    dsimp,
    simp only [←equivalence.counit_inv_app_functor, iso.inv_hom_id_app, map_comp,
      equivalence.fun_inv_map, assoc, id_comp, iso.inv_hom_id_app_assoc],
    dsimp, simp, -- See note [dsimp, simp].
  end)
  (λ c c' f, by { ext, dsimp, simp, dsimp, simp, }), }

/--
If `F` reflects isomorphisms, then `cocones.functoriality F` reflects isomorphisms
as well.
-/
instance reflects_cocone_isomorphism (F : C ⥤ D) [reflects_isomorphisms F] (K : J ⥤ C) :
  reflects_isomorphisms (cocones.functoriality K F) :=
begin
  constructor,
  introsI,
  haveI : is_iso (F.map f.hom) :=
    (cocones.forget (K ⋙ F)).map_is_iso ((cocones.functoriality K F).map f),
  haveI := reflects_isomorphisms.reflects F f.hom,
  apply cocone_iso_of_hom_iso
end

end
end cocones

end limits

namespace functor

variables {F : J ⥤ C} {G : J ⥤ C} (H : C ⥤ D)

open category_theory.limits

/-- The image of a cone in C under a functor G : C ⥤ D is a cone in D. -/
@[simps]
def map_cone   (c : cone F)   : cone (F ⋙ H)   := (cones.functoriality F H).obj c
/-- The image of a cocone in C under a functor G : C ⥤ D is a cocone in D. -/
@[simps]
def map_cocone (c : cocone F) : cocone (F ⋙ H) := (cocones.functoriality F H).obj c

/-- Given a cone morphism `c ⟶ c'`, construct a cone morphism on the mapped cones functorially.  -/
def map_cone_morphism   {c c' : cone F}   (f : c ⟶ c')   :
  H.map_cone c ⟶ H.map_cone c' := (cones.functoriality F H).map f

/-- Given a cocone morphism `c ⟶ c'`, construct a cocone morphism on the mapped cocones
functorially. -/
def map_cocone_morphism {c c' : cocone F} (f : c ⟶ c') :
  H.map_cocone c ⟶ H.map_cocone c' := (cocones.functoriality F H).map f

/-- If `H` is an equivalence, we invert `H.map_cone` and get a cone for `F` from a cone
for `F ⋙ H`.-/
def map_cone_inv [is_equivalence H]
  (c : cone (F ⋙ H)) : cone F :=
(limits.cones.functoriality_equivalence F (as_equivalence H)).inverse.obj c

/-- `map_cone` is the left inverse to `map_cone_inv`. -/
def map_cone_map_cone_inv {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : cone (F ⋙ H)) :
  map_cone H (map_cone_inv H c) ≅ c :=
(limits.cones.functoriality_equivalence F (as_equivalence H)).counit_iso.app c

/-- `map_cone` is the right inverse to `map_cone_inv`. -/
def map_cone_inv_map_cone {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : cone F) :
  map_cone_inv H (map_cone H c) ≅ c :=
(limits.cones.functoriality_equivalence F (as_equivalence H)).unit_iso.symm.app c
/-- If `H` is an equivalence, we invert `H.map_cone` and get a cone for `F` from a cone
for `F ⋙ H`.-/

def map_cocone_inv [is_equivalence H]
  (c : cocone (F ⋙ H)) : cocone F :=
(limits.cocones.functoriality_equivalence F (as_equivalence H)).inverse.obj c

/-- `map_cocone` is the left inverse to `map_cocone_inv`. -/
def map_cocone_map_cocone_inv {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : cocone (F ⋙ H)) :
  map_cocone H (map_cocone_inv H c) ≅ c :=
(limits.cocones.functoriality_equivalence F (as_equivalence H)).counit_iso.app c

/-- `map_cocone` is the right inverse to `map_cocone_inv`. -/
def map_cocone_inv_map_cocone {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : cocone F) :
  map_cocone_inv H (map_cocone H c) ≅ c :=
(limits.cocones.functoriality_equivalence F (as_equivalence H)).unit_iso.symm.app c

/-- `functoriality F _ ⋙ postcompose (whisker_left F _)` simplifies to `functoriality F _`. -/
@[simps]
def functoriality_comp_postcompose {H H' : C ⥤ D} (α : H ≅ H') :
  cones.functoriality F H ⋙ cones.postcompose (whisker_left F α.hom) ≅ cones.functoriality F H' :=
nat_iso.of_components (λ c, cones.ext (α.app _) (by tidy)) (by tidy)

/--
For `F : J ⥤ C`, given a cone `c : cone F`, and a natural isomorphism `α : H ≅ H'` for functors
`H H' : C ⥤ D`, the postcomposition of the cone `H.map_cone` using the isomorphism `α` is
isomorphic to the cone `H'.map_cone`.
-/
@[simps]
def postcompose_whisker_left_map_cone {H H' : C ⥤ D} (α : H ≅ H') (c : cone F) :
  (cones.postcompose (whisker_left F α.hom : _)).obj (H.map_cone c) ≅ H'.map_cone c :=
(functoriality_comp_postcompose α).app c

/--
`map_cone` commutes with `postcompose`. In particular, for `F : J ⥤ C`, given a cone `c : cone F`, a
natural transformation `α : F ⟶ G` and a functor `H : C ⥤ D`, we have two obvious ways of producing
a cone over `G ⋙ H`, and they are both isomorphic.
-/
@[simps]
def map_cone_postcompose {α : F ⟶ G} {c} :
  H.map_cone ((cones.postcompose α).obj c) ≅
  (cones.postcompose (whisker_right α H : _)).obj (H.map_cone c) :=
cones.ext (iso.refl _) (by tidy)

/--
`map_cone` commutes with `postcompose_equivalence`
-/
@[simps]
def map_cone_postcompose_equivalence_functor {α : F ≅ G} {c} :
  H.map_cone ((cones.postcompose_equivalence α).functor.obj c) ≅
    (cones.postcompose_equivalence (iso_whisker_right α H : _)).functor.obj (H.map_cone c) :=
cones.ext (iso.refl _) (by tidy)

/-- `functoriality F _ ⋙ precompose (whisker_left F _)` simplifies to `functoriality F _`. -/
@[simps]
def functoriality_comp_precompose {H H' : C ⥤ D} (α : H ≅ H') :
   cocones.functoriality F H ⋙ cocones.precompose (whisker_left F α.inv)
 ≅ cocones.functoriality F H' :=
nat_iso.of_components (λ c, cocones.ext (α.app _) (by tidy)) (by tidy)

/--
For `F : J ⥤ C`, given a cocone `c : cocone F`, and a natural isomorphism `α : H ≅ H'` for functors
`H H' : C ⥤ D`, the precomposition of the cocone `H.map_cocone` using the isomorphism `α` is
isomorphic to the cocone `H'.map_cocone`.
-/
@[simps]
def precompose_whisker_left_map_cocone {H H' : C ⥤ D} (α : H ≅ H') (c : cocone F) :
  (cocones.precompose (whisker_left F α.inv : _)).obj (H.map_cocone c) ≅ H'.map_cocone c :=
(functoriality_comp_precompose α).app c

/--
`map_cocone` commutes with `precompose`. In particular, for `F : J ⥤ C`, given a cocone
`c : cocone F`, a natural transformation `α : F ⟶ G` and a functor `H : C ⥤ D`, we have two obvious
ways of producing a cocone over `G ⋙ H`, and they are both isomorphic.
-/
@[simps]
def map_cocone_precompose {α : F ⟶ G} {c} :
  H.map_cocone ((cocones.precompose α).obj c) ≅
  (cocones.precompose (whisker_right α H : _)).obj (H.map_cocone c) :=
cocones.ext (iso.refl _) (by tidy)

/--
`map_cocone` commutes with `precompose_equivalence`
-/
@[simps]
def map_cocone_precompose_equivalence_functor {α : F ≅ G} {c} :
  H.map_cocone ((cocones.precompose_equivalence α).functor.obj c) ≅
    (cocones.precompose_equivalence (iso_whisker_right α H : _)).functor.obj (H.map_cocone c) :=
cocones.ext (iso.refl _) (by tidy)

/--
`map_cone` commutes with `whisker`
-/
@[simps]
def map_cone_whisker {E : K ⥤ J} {c : cone F} :
  H.map_cone (c.whisker E) ≅ (H.map_cone c).whisker E :=
cones.ext (iso.refl _) (by tidy)

/--
`map_cocone` commutes with `whisker`
-/
@[simps]
def map_cocone_whisker {E : K ⥤ J} {c : cocone F} :
  H.map_cocone (c.whisker E) ≅ (H.map_cocone c).whisker E :=
cocones.ext (iso.refl _) (by tidy)

end functor

end category_theory

namespace category_theory.limits

section
variables {F : J ⥤ C}

/-- Change a `cocone F` into a `cone F.op`. -/
@[simps] def cocone.op (c : cocone F) : cone F.op :=
{ X := op c.X,
  π :=
  { app := λ j, (c.ι.app (unop j)).op,
    naturality' := λ j j' f, quiver.hom.unop_inj (by tidy) } }

/-- Change a `cone F` into a `cocone F.op`. -/
@[simps] def cone.op (c : cone F) : cocone F.op :=
{ X := op c.X,
  ι :=
  { app := λ j, (c.π.app (unop j)).op,
    naturality' := λ j j' f, quiver.hom.unop_inj (by tidy) } }

/-- Change a `cocone F.op` into a `cone F`. -/
@[simps] def cocone.unop (c : cocone F.op) : cone F :=
{ X := unop c.X,
  π :=
  { app := λ j, (c.ι.app (op j)).unop,
    naturality' := λ j j' f, quiver.hom.op_inj (c.ι.naturality f.op).symm } }

/-- Change a `cone F.op` into a `cocone F`. -/
@[simps] def cone.unop (c : cone F.op) : cocone F :=
{ X := unop c.X,
  ι :=
  { app := λ j, (c.π.app (op j)).unop,
    naturality' := λ j j' f, quiver.hom.op_inj (c.π.naturality f.op).symm } }

variables (F)

/--
The category of cocones on `F`
is equivalent to the opposite category of
the category of cones on the opposite of `F`.
-/
@[simps]
def cocone_equivalence_op_cone_op : cocone F ≌ (cone F.op)ᵒᵖ :=
{ functor :=
  { obj := λ c, op (cocone.op c),
    map := λ X Y f, quiver.hom.op
    { hom := f.hom.op,
      w' := λ j, by { apply quiver.hom.unop_inj, dsimp, simp, }, } },
  inverse :=
  { obj := λ c, cone.unop (unop c),
    map := λ X Y f,
    { hom := f.unop.hom.unop,
      w' := λ j, by { apply quiver.hom.op_inj, dsimp, simp, }, } },
  unit_iso := nat_iso.of_components (λ c, cocones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c,
    by { induction c using opposite.rec,
         dsimp, apply iso.op, exact cones.ext (iso.refl _) (by tidy), })
    begin
      intros,
      have hX : X = op (unop X) := rfl,
      revert hX,
      generalize : unop X = X',
      rintro rfl,
      have hY : Y = op (unop Y) := rfl,
      revert hY,
      generalize : unop Y = Y',
      rintro rfl,
      apply quiver.hom.unop_inj,
      apply cone_morphism.ext,
      dsimp, simp,
    end,
  functor_unit_iso_comp' := λ c, begin apply quiver.hom.unop_inj, ext, dsimp, simp, end }

end

section
variables {F : J ⥤ Cᵒᵖ}

/-- Change a cocone on `F.left_op : Jᵒᵖ ⥤ C` to a cocone on `F : J ⥤ Cᵒᵖ`. -/
-- Here and below we only automatically generate the `@[simp]` lemma for the `X` field,
-- as we can write a simpler `rfl` lemma for the components of the natural transformation by hand.
@[simps {rhs_md := semireducible, simp_rhs := tt}]
def cone_of_cocone_left_op (c : cocone F.left_op) : cone F :=
{ X := op c.X,
  π := nat_trans.remove_left_op (c.ι ≫ (const.op_obj_unop (op c.X)).hom) }

/-- Change a cone on `F : J ⥤ Cᵒᵖ` to a cocone on `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps {rhs_md := semireducible, simp_rhs := tt}]
def cocone_left_op_of_cone (c : cone F) : cocone (F.left_op) :=
{ X := unop c.X,
  ι := nat_trans.left_op c.π }

/-- Change a cone on `F.left_op : Jᵒᵖ ⥤ C` to a cocone on `F : J ⥤ Cᵒᵖ`. -/
/- When trying use `@[simps]` to generate the `ι_app` field of this definition, `@[simps]` tries to
  reduce the RHS using `expr.dsimp` and `expr.simp`, but for some reason the expression is not
  being simplified properly. -/
@[simps X]
def cocone_of_cone_left_op (c : cone F.left_op) : cocone F :=
{ X := op c.X,
  ι := nat_trans.remove_left_op ((const.op_obj_unop (op c.X)).hom ≫ c.π) }

@[simp] lemma cocone_of_cone_left_op_ι_app (c : cone F.left_op) (j) :
  (cocone_of_cone_left_op c).ι.app j = (c.π.app (op j)).op :=
by { dsimp [cocone_of_cone_left_op], simp }

/-- Change a cocone on `F : J ⥤ Cᵒᵖ` to a cone on `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps {rhs_md := semireducible, simp_rhs := tt}]
def cone_left_op_of_cocone (c : cocone F) : cone (F.left_op) :=
{ X := unop c.X,
  π := nat_trans.left_op c.ι }

end

end category_theory.limits

namespace category_theory.functor

open category_theory.limits

variables {F : J ⥤ C}

section
variables (G : C ⥤ D)

/-- The opposite cocone of the image of a cone is the image of the opposite cocone. -/
@[simps {rhs_md := semireducible}]
def map_cone_op (t : cone F) : (G.map_cone t).op ≅ (G.op.map_cocone t.op) :=
cocones.ext (iso.refl _) (by tidy)

/-- The opposite cone of the image of a cocone is the image of the opposite cone. -/
@[simps {rhs_md := semireducible}]
def map_cocone_op {t : cocone F} : (G.map_cocone t).op ≅ (G.op.map_cone t.op) :=
cones.ext (iso.refl _) (by tidy)

end

end category_theory.functor