/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.shift

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, zero morphisms and zero objects, and the shift functor
on differential objects.
-/

open category_theory.limits

universes v u

namespace category_theory

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

variables [has_zero_morphisms C] [has_shift C]

/--
A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
@[nolint has_inhabited_instance]
structure differential_object :=
(X : C)
(d : X ⟶ X⟦1⟧)
(d_squared' : d ≫ d⟦1⟧' = 0 . obviously)

restate_axiom differential_object.d_squared'
attribute [simp] differential_object.d_squared

variables {C}

namespace differential_object

/--
A morphism of differential objects is a morphism commuting with the differentials.
-/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : differential_object C) :=
(f : X.X ⟶ Y.X)
(comm' : X.d ≫ f⟦1⟧' = f ≫ Y.d . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

namespace hom

/-- The identity morphism of a differential object. -/
@[simps]
def id (X : differential_object C) : hom X X :=
{ f := 𝟙 X.X }

/-- The composition of morphisms of differential objects. -/
@[simps]
def comp {X Y Z : differential_object C} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ f := f.f ≫ g.f, }

end hom

instance category_of_differential_objects : category (differential_object C) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z f g, hom.comp f g, }

@[simp]

@[simp]
lemma comp_f {X Y Z : differential_object C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).f = f.f ≫ g.f :=
rfl

variables (C)

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget : (differential_object C) ⥤ C :=
{ obj := λ X, X.X,
  map := λ X Y f, f.f, }

instance forget_faithful : faithful (forget C) :=
{ }

instance has_zero_morphisms : has_zero_morphisms (differential_object C) :=
{ has_zero := λ X Y,
  ⟨{ f := 0, }⟩}

variables {C}

@[simp]
lemma zero_f (P Q : differential_object C) : (0 : P ⟶ Q).f = 0 := rfl

/--
An isomorphism of differential objects gives an isomorphism of the underlying objects.
-/
@[simps] def iso_app {X Y : differential_object C} (f : X ≅ Y) : X.X ≅ Y.X :=
⟨f.hom.f, f.inv.f, by { dsimp, rw [← comp_f, iso.hom_inv_id, id_f] },
  by { dsimp, rw [← comp_f, iso.inv_hom_id, id_f] }⟩

@[simp] lemma iso_app_refl (X : differential_object C) : iso_app (iso.refl X) = iso.refl X.X := rfl
@[simp] lemma iso_app_symm {X Y : differential_object C} (f : X ≅ Y) :
  iso_app f.symm = (iso_app f).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : differential_object C} (f : X ≅ Y) (g : Y ≅ Z) :
  iso_app (f ≪≫ g) = iso_app f ≪≫ iso_app g := rfl

end differential_object

namespace functor

universes v' u'
variables (D : Type u') [category.{v'} D]
variables [has_zero_morphisms D] [has_shift D]

/--
A functor `F : C ⥤ D` which commutes with shift functors on `C` and `D` and preserves zero morphisms
can be lifted to a functor `differential_object C ⥤ differential_object D`.
-/
@[simps]
def map_differential_object (F : C ⥤ D) (η : (shift C).functor.comp F ⟶ F.comp (shift D).functor)
  (hF : ∀ c c', F.map (0 : c ⟶ c') = 0) :
  differential_object C ⥤ differential_object D :=
{ obj := λ X, { X := F.obj X.X,
    d := F.map X.d ≫ η.app X.X,
    d_squared' := begin
      dsimp, rw [functor.map_comp, ← functor.comp_map F (shift D).functor],
      slice_lhs 2 3 { rw [← η.naturality X.d] },
      rw [functor.comp_map],
      slice_lhs 1 2 { rw [← F.map_comp, X.d_squared, hF] },
      rw [zero_comp, zero_comp],
    end },
  map := λ X Y f, { f := F.map f.f,
    comm' := begin
      dsimp,
      slice_lhs 2 3 { rw [← functor.comp_map F (shift D).functor, ← η.naturality f.f] },
      slice_lhs 1 2 { rw [functor.comp_map, ← F.map_comp, f.comm, F.map_comp] },
      rw [category.assoc]
    end },
  map_id' := by { intros, ext, simp },
  map_comp' := by { intros, ext, simp }, }

end functor

end category_theory

namespace category_theory

namespace differential_object

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

variables [has_zero_object C] [has_zero_morphisms C] [has_shift C]

open_locale zero_object

instance has_zero_object : has_zero_object (differential_object C) :=
{ zero :=
  { X := (0 : C),
    d := 0, },
  unique_to := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩,
  unique_from := λ X, ⟨⟨{ f := 0 }⟩, λ f, (by ext)⟩, }

end differential_object

namespace differential_object

variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_zero_morphisms C] [has_shift C]

instance concrete_category_of_differential_objects :
  concrete_category (differential_object C) :=
{ forget := forget C ⋙ category_theory.forget C }

instance : has_forget₂ (differential_object C) C :=
{ forget₂ := forget C }

end differential_object

/-! The category of differential objects itself has a shift functor. -/
namespace differential_object

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

/-- The shift functor on `differential_object C`. -/
@[simps]
def shift_functor : differential_object C ⥤ differential_object C :=
{ obj := λ X,
  { X := X.X⟦1⟧,
    d := X.d⟦1⟧',
    d_squared' := begin
      dsimp,
      rw [←functor.map_comp, X.d_squared, is_equivalence_preserves_zero_morphisms],
    end },
  map := λ X Y f,
  { f := f.f⟦1⟧',
    comm' := begin dsimp, rw [←functor.map_comp, f.comm, ←functor.map_comp], end, }, }

/-- The inverse shift functor on `differential C`, at the level of objects. -/
@[simps]
def shift_inverse_obj : differential_object C → differential_object C :=
λ X,
{ X := X.X⟦-1⟧,
  d := X.d⟦-1⟧' ≫ (shift C).unit_inv.app X.X ≫ (shift C).counit_inv.app X.X,
  d_squared' := begin
    dsimp,
    rw functor.map_comp,
    slice_lhs 3 4 { erw ←(shift C).counit_inv.naturality, },
    slice_lhs 2 3 { erw ←(shift C).unit_inv.naturality, },
    slice_lhs 1 2 { erw [←functor.map_comp, X.d_squared], },
    simp,
  end, }

/-- The inverse shift functor on `differential C`. -/
@[simps]
def shift_inverse : differential_object C ⥤ differential_object C :=
{ obj := shift_inverse_obj C,
  map := λ X Y f,
  { f := f.f⟦-1⟧',
    comm' := begin
      dsimp,
      slice_lhs 3 4 { erw ←(shift C).counit_inv.naturality, },
      slice_lhs 2 3 { erw ←(shift C).unit_inv.naturality, },
      slice_lhs 1 2 { erw [←functor.map_comp, f.comm, functor.map_comp], },
      rw [category.assoc, category.assoc],
    end, }, }.

/-- The unit for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit : 𝟭 (differential_object C) ⟶ shift_functor C ⋙ shift_inverse C :=
{ app := λ X,
  { f := (shift C).unit.app X.X,
    comm' := begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).unit.naturality, },
      simp only [category.comp_id, functor.id_map, iso.hom_inv_id_app,
        category.assoc, equivalence.counit_inv_app_functor],
    end, }, }

/-- The inverse of the unit for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit_inv : shift_functor C ⋙ shift_inverse C ⟶ 𝟭 (differential_object C) :=
{ app := λ X,
  { f := (shift C).unit_inv.app X.X,
    comm' := begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).unit_inv.naturality, },
      rw [equivalence.counit_inv_app_functor],
      slice_lhs 3 4 { rw ←functor.map_comp, },
      simp only [iso.hom_inv_id_app, functor.comp_map, iso.hom_inv_id_app_assoc,
        nat_iso.cancel_nat_iso_inv_left, equivalence.inv_fun_map, category.assoc],
      dsimp,
      rw category_theory.functor.map_id,
    end, }, }.

/-- The unit isomorphism for the shift functor on `differential_object C`. -/
@[simps]
def shift_unit_iso : 𝟭 (differential_object C) ≅ shift_functor C ⋙ shift_inverse C :=
{ hom := shift_unit C,
  inv := shift_unit_inv C, }.

/-- The counit for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit : shift_inverse C ⋙ shift_functor C ⟶ 𝟭 (differential_object C) :=
{ app := λ X,
  { f := (shift C).counit.app X.X,
    comm' :=
    begin
      dsimp,
      slice_rhs 1 2 { erw ←(shift C).counit.naturality, },
      rw [(shift C).functor.map_comp, (shift C).functor.map_comp],
      slice_lhs 3 4 { erw [←functor.map_comp, iso.inv_hom_id_app, functor.map_id], },
      erw equivalence.counit_app_functor,
      rw category.comp_id,
      refl,
    end, }, }

/-- The inverse of the counit for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit_inv : 𝟭 (differential_object C) ⟶ shift_inverse C ⋙ shift_functor C :=
{ app := λ X,
  { f := (shift C).counit_inv.app X.X,
    comm' :=
    begin
      dsimp,
      rw [(shift C).functor.map_comp, (shift C).functor.map_comp],
      slice_rhs 1 2 { erw ←(shift C).counit_inv.naturality, },
      rw ←equivalence.counit_app_functor,
      slice_rhs 2 3 { rw iso.inv_hom_id_app, },
      rw category.id_comp,
      refl,
    end, }, }

/-- The counit isomorphism for the shift functor on `differential_object C`. -/
@[simps]
def shift_counit_iso : shift_inverse C ⋙ shift_functor C ≅ 𝟭 (differential_object C) :=
{ hom := shift_counit C,
  inv := shift_counit_inv C, }

/--
The category of differential objects in `C` itself has a shift functor.
-/
instance : has_shift (differential_object C) :=
{ shift :=
  { functor := shift_functor C,
    inverse := shift_inverse C,
    unit_iso := shift_unit_iso C,
    counit_iso := shift_counit_iso C, } }

end differential_object

end category_theory


import morphisms.basic
import algebraic_geometry.pullback_carrier

/-!
# Surjective morphisms

A morphism of schemes `f : X ⟶ Y` is surjective if the underlying map is.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/- A morphism of schemes `f : X ⟶ Y` is surjective if the underlying map is. -/
@[mk_iff]
class surjective (f : X ⟶ Y) : Prop :=
(out [] : function.surjective f.1.base)

instance surjective_of_is_iso [is_iso f] : surjective f :=
⟨(Top.homeo_of_iso $ as_iso f.1.base).surjective⟩

lemma surjective_stable_under_composition :
  morphism_property.stable_under_composition @surjective :=
λ X Y Z f g hf hg, ⟨hg.out.comp hf.out⟩

lemma surjective_respects_iso :
  morphism_property.respects_iso @surjective :=
surjective_stable_under_composition.respects_iso (λ X Y f, infer_instance)

lemma surjective_stable_under_base_change :
  morphism_property.stable_under_base_change @surjective :=
morphism_property.stable_under_base_change.mk surjective_respects_iso
begin
  intros X Y S f g H,
  rw surjective_iff at H ⊢,
  rw [← set.range_iff_surjective, pullback.range_fst, set.range_iff_surjective.mpr H],
  refl
end

lemma surjective_is_local_at_target :
  property_is_local_at_target @surjective :=
begin
  refine ⟨surjective_respects_iso, _, _⟩,
  { intros X Y f U H,
    rw surjective_iff at H ⊢,
    rw morphism_restrict_val_base,
    exact set.restrict_preimage_surjective _ H },
  { intros X Y f 𝒰 H,
    rw surjective_iff,
    have : (⋃ i, (𝒰.map i).opens_range.1) = set.univ,
    { rw [← opens.coe_top, ← 𝒰.supr_opens_range, opens.coe_supr], refl },
    refine (set.surjective_iff_surjective_of_Union_eq_univ this).mpr (λ i, _),
    rw [← morphism_restrict_val_base, ← surjective_iff,
      surjective_respects_iso.arrow_mk_iso_iff
      (morphism_restrict_opens_range _ _)],
    exact H _ }
end

end algebraic_geometry


/-
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.tauto

/-!
# Strongly Connected Components

This file defines tactics to construct proofs of equivalences between a set of mutually equivalent
propositions. The tactics use implications transitively to find sets of equivalent propositions.

## Implementation notes

The tactics use a strongly connected components algorithm on a graph where propositions are
vertices and edges are proofs that the source implies the target. The strongly connected components
are therefore sets of propositions that are pairwise equivalent to each other.

The resulting strongly connected components are encoded in a disjoint set data structure to
facilitate the construction of equivalence proofs between two arbitrary members of an equivalence
class.

## Possible generalizations

Instead of reasoning about implications and equivalence, we could generalize the machinery to
reason about arbitrary partial orders.

## References

 * Tarjan, R. E. (1972), "Depth-first search and linear graph algorithms",
   SIAM Journal on Computing, 1 (2): 146–160, doi:10.1137/0201010
 * Dijkstra, Edsger (1976), A Discipline of Programming, NJ: Prentice Hall, Ch. 25.
 * <https://en.wikipedia.org/wiki/Disjoint-set_data_structure>

## Tags

graphs, tactic, strongly connected components, disjoint sets
-/

namespace tactic

/--
`closure` implements a disjoint set data structure using path compression
optimization. For the sake of the scc algorithm, it also stores the preorder
numbering of the equivalence graph of the local assumptions.

The `expr_map` encodes a directed forest by storing for every non-root
node, a reference to its parent and a proof of equivalence between
that node's expression and its parent's expression. Given that data
structure, checking that two nodes belong to the same tree is easy and
fast by repeatedly following the parent references until a root is reached.
If both nodes have the same root, they belong to the same tree, i.e. their
expressions are equivalent. The proof of equivalence can be formed by
composing the proofs along the edges of the paths to the root.

More concretely, if we ignore preorder numbering, the set
`{ {e₀,e₁,e₂,e₃}, {e₄,e₅} }` is represented as:

```
e₀ → ⊥      -- no parent, i.e. e₀ is a root
e₁ → e₀, p₁ -- with p₁ : e₁ ↔ e₀
e₂ → e₁, p₂ -- with p₂ : e₂ ↔ e₁
e₃ → e₀, p₃ -- with p₃ : e₃ ↔ e₀
e₄ → ⊥      -- no parent, i.e. e₄ is a root
e₅ → e₄, p₅ -- with p₅ : e₅ ↔ e₄
```

We can check that `e₂` and `e₃` are equivalent by seeking the root of
the tree of each. The parent of `e₂` is `e₁`, the parent of `e₁` is
`e₀` and `e₀` does not have a parent, and thus, this is the root of its tree.
The parent of `e₃` is `e₀` and it's also the root, the same as for `e₂` and
they are therefore equivalent. We can build a proof of that equivalence by using
transitivity on `p₂`, `p₁` and `p₃.symm` in that order.

Similarly, we can discover that `e₂` and `e₅` aren't equivalent.

A description of the path compression optimization can be found at:
<https://en.wikipedia.org/wiki/Disjoint-set_data_structure#Path_compression>

-/
meta def closure := ref (expr_map (ℕ ⊕ (expr × expr)))

namespace closure

/-- `with_new_closure f` creates an empty `closure` `c`, executes `f` on `c`, and then deletes `c`,
returning the output of `f`. -/
meta def with_new_closure {α} : (closure → tactic α) → tactic α :=
using_new_ref (expr_map.mk _)

/-- `to_tactic_format cl` pretty-prints the `closure` `cl` as a list. Assuming `cl` was built by
`dfs_at`, each element corresponds to a node `pᵢ : expr` and is one of the folllowing:
- if `pᵢ` is a root: `"pᵢ ⇐ i"`, where `i` is the preorder number of `pᵢ`,
- otherwise: `"(pᵢ, pⱼ) : P"`, where `P` is `pᵢ ↔ pⱼ`.
Useful for debugging. -/
meta def to_tactic_format (cl : closure) : tactic format :=
do m ← read_ref cl,
   let l := m.to_list,
   fmt ← l.mmap $ λ ⟨x,y⟩, match y with
                           | sum.inl y := pformat!"{x} ⇐ {y}"
                           | sum.inr ⟨y,p⟩ := pformat!"({x}, {y}) : {infer_type p}"
                           end,
   pure $ to_fmt fmt

meta instance : has_to_tactic_format closure := ⟨ to_tactic_format ⟩

/-- `(n,r,p) ← root cl e` returns `r` the root of the tree that `e` is a part of (which might be
itself) along with `p` a proof of `e ↔ r` and `n`, the preorder numbering of the root. -/
meta def root (cl : closure) : expr → tactic (ℕ × expr × expr) | e :=
do m ← read_ref cl,
   match m.find e with
   | none :=
     do p ← mk_app ``iff.refl [e],
        pure (0,e,p)
   | (some (sum.inl n)) :=
     do p ← mk_app ``iff.refl [e],
        pure (n,e,p)
   | (some (sum.inr (e₀,p₀))) :=
     do (n,e₁,p₁) ← root e₀,
        p ← mk_app ``iff.trans [p₀,p₁],
        modify_ref cl $ λ m, m.insert e (sum.inr (e₁,p)),
        pure (n,e₁,p)
   end

/-- (Implementation of `merge`.) -/
meta def merge_intl (cl : closure) (p e₀ p₀ e₁ p₁ : expr) : tactic unit :=
do p₂ ← mk_app ``iff.symm [p₀],
   p ← mk_app ``iff.trans [p₂,p],
   p ← mk_app ``iff.trans [p,p₁],
   modify_ref cl $ λ m, m.insert e₀ $ sum.inr (e₁,p)

/-- `merge cl p`, with `p` a proof of `e₀ ↔ e₁` for some `e₀` and `e₁`,
merges the trees of `e₀` and `e₁` and keeps the root with the smallest preorder
number as the root. This ensures that, in the depth-first traversal of the graph,
when encountering an edge going into a vertex whose equivalence class includes
a vertex that originated the current search, that vertex will be the root of
the corresponding tree. -/
meta def merge (cl : closure) (p : expr) : tactic unit :=
do `(%%e₀ ↔ %%e₁) ← infer_type p >>= instantiate_mvars,
   (n₂,e₂,p₂) ← root cl e₀,
   (n₃,e₃,p₃) ← root cl e₁,
   if e₂ ≠ e₃ then do
     if n₂ < n₃ then do p ← mk_app ``iff.symm [p],
                        cl.merge_intl p e₃ p₃ e₂ p₂
                else cl.merge_intl p e₂ p₂ e₃ p₃
   else pure ()

/-- Sequentially assign numbers to the nodes of the graph as they are being visited. -/
meta def assign_preorder (cl : closure) (e : expr) : tactic unit :=
modify_ref cl $ λ m, m.insert e (sum.inl m.size)

/-- `prove_eqv cl e₀ e₁` constructs a proof of equivalence of `e₀` and `e₁` if
they are equivalent. -/
meta def prove_eqv (cl : closure) (e₀ e₁ : expr) : tactic expr :=
do (_,r,p₀) ← root cl e₀,
   (_,r',p₁) ← root cl e₁,
   guard (r = r') <|> fail!"{e₀} and {e₁} are not equivalent",
   p₁ ← mk_app ``iff.symm [p₁],
   mk_app ``iff.trans [p₀,p₁]

/-- `prove_impl cl e₀ e₁` constructs a proof of `e₀ -> e₁` if they are equivalent. -/
meta def prove_impl (cl : closure) (e₀ e₁ : expr) : tactic expr :=
cl.prove_eqv e₀ e₁ >>= iff_mp

/-- `is_eqv cl e₀ e₁` checks whether `e₀` and `e₁` are equivalent without building a proof. -/
meta def is_eqv (cl : closure) (e₀ e₁ : expr) : tactic bool :=
do (_,r,p₀) ← root cl e₀,
   (_,r',p₁) ← root cl e₁,
   return $ r = r'

end closure

/-- mutable graphs between local propositions that imply each other with the proof of implication -/
@[reducible]
meta def impl_graph := ref (expr_map (list $ expr × expr))

/-- `with_impl_graph f` creates an empty `impl_graph` `g`, executes `f` on `g`, and then deletes
`g`, returning the output of `f`. -/
meta def with_impl_graph {α} : (impl_graph → tactic α) → tactic α :=
using_new_ref (expr_map.mk (list $ expr × expr))

namespace impl_graph

/-- `add_edge g p`, with `p` a proof of `v₀ → v₁` or `v₀ ↔ v₁`, adds an edge to the implication
graph `g`. -/
meta def add_edge (g : impl_graph) : expr → tactic unit | p :=
do t ← infer_type p,
   match t with
   | `(%%v₀ → %%v₁) :=
     do is_prop v₀ >>= guardb,
        is_prop v₁ >>= guardb,
        m ← read_ref g,
        let xs := (m.find v₀).get_or_else [],
        let xs' := (m.find v₁).get_or_else [],
        modify_ref g $ λ m, (m.insert v₀ ((v₁,p) :: xs)).insert v₁ xs'
   | `(%%v₀ ↔ %%v₁) :=
     do p₀ ← mk_mapp ``iff.mp [none,none,p],
        p₁ ← mk_mapp ``iff.mpr [none,none,p],
        add_edge p₀, add_edge p₁
   | _ := failed
   end

section scc
open list
parameter g : expr_map (list $ expr × expr)
parameter visit : ref $ expr_map bool
parameter cl : closure

/-- `merge_path path e`, where `path` and `e` forms a cycle with proofs of implication between
consecutive vertices. The proofs are compiled into proofs of equivalences and added to the closure
structure. `e` and the first vertex of `path` do not have to be the same but they have to be
in the same equivalence class. -/
meta def merge_path (path : list (expr × expr)) (e : expr) : tactic unit :=
do p₁ ← cl.prove_impl e path.head.fst,
   p₂ ← mk_mapp ``id [e],
   let path := (e,p₁) :: path,

   (_,ls) ← path.mmap_accuml (λ p p',
     prod.mk <$> mk_mapp ``implies.trans [none,p'.1,none,p,p'.2] <*> pure p) p₂,
   (_,rs) ← path.mmap_accumr (λ p p',
     prod.mk <$> mk_mapp ``implies.trans [none,none,none,p.2,p'] <*> pure p') p₂,
   ps ← mzip_with (λ p₀ p₁, mk_app ``iff.intro [p₀,p₁]) ls.tail rs.init,
   ps.mmap' cl.merge

/-- (implementation of `collapse`) -/
meta def collapse' : list (expr × expr) → list (expr × expr) → expr → tactic unit
| acc [] v := merge_path acc v
| acc ((x,pr) :: xs) v :=
  do b ← cl.is_eqv x v,
     let acc' := (x,pr)::acc,
     if b
       then merge_path acc' v
       else collapse' acc' xs v

/-- `collapse path v`, where `v` is a vertex that originated the current search
(or a vertex in the same equivalence class as the one that originated the current search).
It or its equivalent should be found in `path`. Since the vertices following `v` in the path
form a cycle with `v`, they can all be added to an equivalence class. -/
meta def collapse : list (expr × expr) → expr → tactic unit :=
collapse' []

/--
Strongly connected component algorithm inspired by Tarjan's and
Dijkstra's scc algorithm. Whereas they return strongly connected
components by enumerating them, this algorithm returns a disjoint set
data structure using path compression. This is a compact
representation that allows us, after the fact, to construct a proof of
equivalence between any two members of an equivalence class.

 * Tarjan, R. E. (1972), "Depth-first search and linear graph algorithms",
   SIAM Journal on Computing, 1 (2): 146–160, doi:10.1137/0201010
 * Dijkstra, Edsger (1976), A Discipline of Programming, NJ: Prentice Hall, Ch. 25.
-/
meta def dfs_at :
  list (expr × expr) → expr → tactic unit
| vs v :=
do m ← read_ref visit,
   (_,v',_) ← cl.root v,
   match m.find v' with
   | (some tt) :=
        pure ()
   | (some ff) :=
        collapse vs v
   | none :=
     do cl.assign_preorder v,
        modify_ref visit $ λ m, m.insert v ff,
        ns ← g.find v,
        ns.mmap' $ λ ⟨w,e⟩, dfs_at ((v,e) :: vs) w,
        modify_ref visit $ λ m, m.insert v tt,
        pure ()
   end

end scc

/-- Use the local assumptions to create a set of equivalence classes. -/
meta def mk_scc (cl : closure) : tactic (expr_map (list (expr × expr))) :=
with_impl_graph $ λ g,
using_new_ref (expr_map.mk bool) $ λ visit,
do ls ← local_context,
   ls.mmap' $ λ l, try (g.add_edge l),
   m ← read_ref g,
   m.to_list.mmap $ λ ⟨v,_⟩, impl_graph.dfs_at m visit cl [] v,
   pure m

end impl_graph

meta def prove_eqv_target (cl : closure) : tactic unit :=
do `(%%p ↔ %%q) ← target >>= whnf,
   cl.prove_eqv p q >>= exact

/--
`scc` uses the available equivalences and implications to prove
a goal of the form `p ↔ q`.

```lean
example (p q r : Prop) (hpq : p → q) (hqr : q ↔ r) (hrp : r → p) : p ↔ r :=
by scc
```
-/
meta def interactive.scc : tactic unit :=
closure.with_new_closure $ λ cl,
do impl_graph.mk_scc cl,
   `(%%p ↔ %%q) ← target,
   cl.prove_eqv p q >>= exact

/-- Collect all the available equivalences and implications and
add assumptions for every equivalence that can be proven using the
strongly connected components technique. Mostly useful for testing. -/
meta def interactive.scc' : tactic unit :=
closure.with_new_closure $ λ cl,
do m ← impl_graph.mk_scc cl,
   let ls := m.to_list.map prod.fst,
   let ls' := prod.mk <$> ls <*> ls,
   ls'.mmap' $ λ x,
     do { h ← get_unused_name `h,
          try $ closure.prove_eqv cl x.1 x.2 >>= note h none }

/--
`scc` uses the available equivalences and implications to prove
a goal of the form `p ↔ q`.

```lean
example (p q r : Prop) (hpq : p → q) (hqr : q ↔ r) (hrp : r → p) : p ↔ r :=
by scc
```

The variant `scc'` populates the local context with all equivalences that `scc` is able to prove.
This is mostly useful for testing purposes.
-/
add_tactic_doc
{ name := "scc",
  category := doc_category.tactic,
  decl_names := [``interactive.scc, ``interactive.scc'],
  tags := ["logic"] }

end tactic


import Mathlib.Tactic.ApplyWith

example (f : ∀ x : Nat, x = x → α) : α := by
  apply (config := {}) f
  apply rfl
  apply 1

example (f : ∀ x : Nat, x = x → α) : α := by
  apply (config := { newGoals := .nonDependentOnly }) f
  apply @rfl _ 1

example (f : ∀ x : Nat, x = x → α) : α := by
  apply (config := { newGoals := .all }) f
  apply 1
  apply rfl


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.preserves.basic

/-!
# Creating (co)limits

We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.
-/

open category_theory category_theory.limits

noncomputable theory

namespace category_theory

universes w' w v₁ v₂ v₃ u₁ u₂ u₃

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

section creates
variables {D : Type u₂} [category.{v₂} D]

variables {J : Type w} [category.{w'} J] {K : J ⥤ C}

/--
Define the lift of a cone: For a cone `c` for `K ⋙ F`, give a cone for `K`
which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of limits:
every limit cone has a lift.

Note this definition is really only useful when `c` is a limit already.
-/
structure liftable_cone (K : J ⥤ C) (F : C ⥤ D) (c : cone (K ⋙ F)) :=
(lifted_cone : cone K)
(valid_lift : F.map_cone lifted_cone ≅ c)

/--
Define the lift of a cocone: For a cocone `c` for `K ⋙ F`, give a cocone for
`K` which is a lift of `c`, i.e. the image of it under `F` is (iso) to `c`.

We will then use this as part of the definition of creation of colimits:
every limit cocone has a lift.

Note this definition is really only useful when `c` is a colimit already.
-/
structure liftable_cocone (K : J ⥤ C) (F : C ⥤ D) (c : cocone (K ⋙ F)) :=
(lifted_cocone : cocone K)
(valid_lift : F.map_cocone lifted_cocone ≅ c)

/--
Definition 3.3.1 of [Riehl].
We say that `F` creates limits of `K` if, given any limit cone `c` for `K ⋙ F`
(i.e. below) we can lift it to a cone "above", and further that `F` reflects
limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_limit (K : J ⥤ C) (F : C ⥤ D) extends reflects_limit K F :=
(lifts : Π c, is_limit c → liftable_cone K F c)

/--
`F` creates limits of shape `J` if `F` creates the limit of any diagram
`K : J ⥤ C`.
-/
class creates_limits_of_shape (J : Type w) [category.{w'} J] (F : C ⥤ D) :=
(creates_limit : Π {K : J ⥤ C}, creates_limit K F . tactic.apply_instance)

/-- `F` creates limits if it creates limits of shape `J` for any `J`. -/
@[nolint check_univs] -- This should be used with explicit universe variables.
class creates_limits_of_size (F : C ⥤ D) :=
(creates_limits_of_shape : Π {J : Type w} [category.{w'} J],
  creates_limits_of_shape J F . tactic.apply_instance)

/-- `F` creates small limits if it creates limits of shape `J` for any small `J`. -/
abbreviation creates_limits (F : C ⥤ D) := creates_limits_of_size.{v₂ v₂} F

/--
Dual of definition 3.3.1 of [Riehl].
We say that `F` creates colimits of `K` if, given any limit cocone `c` for
`K ⋙ F` (i.e. below) we can lift it to a cocone "above", and further that `F`
reflects limits for `K`.

If `F` reflects isomorphisms, it suffices to show only that the lifted cocone is
a limit - see `creates_limit_of_reflects_iso`.
-/
class creates_colimit (K : J ⥤ C) (F : C ⥤ D) extends reflects_colimit K F :=
(lifts : Π c, is_colimit c → liftable_cocone K F c)

/--
`F` creates colimits of shape `J` if `F` creates the colimit of any diagram
`K : J ⥤ C`.
-/
class creates_colimits_of_shape (J : Type w) [category.{w'} J] (F : C ⥤ D) :=
(creates_colimit : Π {K : J ⥤ C}, creates_colimit K F . tactic.apply_instance)

/-- `F` creates colimits if it creates colimits of shape `J` for any small `J`. -/
@[nolint check_univs] -- This should be used with explicit universe variables.
class creates_colimits_of_size (F : C ⥤ D) :=
(creates_colimits_of_shape : Π {J : Type w} [category.{w'} J],
  creates_colimits_of_shape J F . tactic.apply_instance)

/-- `F` creates small colimits if it creates colimits of shape `J` for any small `J`. -/
abbreviation creates_colimits (F : C ⥤ D) := creates_colimits_of_size.{v₂ v₂} F

attribute [instance, priority 100] -- see Note [lower instance priority]
  creates_limits_of_shape.creates_limit creates_limits_of_size.creates_limits_of_shape
  creates_colimits_of_shape.creates_colimit creates_colimits_of_size.creates_colimits_of_shape

/- Interface to the `creates_limit` class. -/

/-- `lift_limit t` is the cone for `K` given by lifting the limit `t` for `K ⋙ F`. -/
def lift_limit {K : J ⥤ C} {F : C ⥤ D} [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  cone K :=
(creates_limit.lifts c t).lifted_cone

/-- The lifted cone has an image isomorphic to the original cone. -/
def lifted_limit_maps_to_original {K : J ⥤ C} {F : C ⥤ D}
  [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  F.map_cone (lift_limit t) ≅ c :=
(creates_limit.lifts c t).valid_lift

/-- The lifted cone is a limit. -/
def lifted_limit_is_limit {K : J ⥤ C} {F : C ⥤ D}
  [creates_limit K F] {c : cone (K ⋙ F)} (t : is_limit c) :
  is_limit (lift_limit t) :=
reflects_limit.reflects (is_limit.of_iso_limit t (lifted_limit_maps_to_original t).symm)

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
lemma has_limit_of_created (K : J ⥤ C) (F : C ⥤ D)
  [has_limit (K ⋙ F)] [creates_limit K F] : has_limit K :=
has_limit.mk { cone := lift_limit (limit.is_limit (K ⋙ F)),
  is_limit := lifted_limit_is_limit _ }

/--
If `F` creates limits of shape `J`, and `D` has limits of shape `J`, then
`C` has limits of shape `J`.
-/
lemma has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (F : C ⥤ D)
  [has_limits_of_shape J D] [creates_limits_of_shape J F] : has_limits_of_shape J C :=
⟨λ G, has_limit_of_created G F⟩

/-- If `F` creates limits, and `D` has all limits, then `C` has all limits. -/
lemma has_limits_of_has_limits_creates_limits (F : C ⥤ D) [has_limits_of_size.{w w'} D]
  [creates_limits_of_size.{w w'} F] : has_limits_of_size.{w w'} C :=
⟨λ J I, by exactI has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape F⟩

/- Interface to the `creates_colimit` class. -/

/-- `lift_colimit t` is the cocone for `K` given by lifting the colimit `t` for `K ⋙ F`. -/
def lift_colimit {K : J ⥤ C} {F : C ⥤ D} [creates_colimit K F] {c : cocone (K ⋙ F)}
  (t : is_colimit c) :
  cocone K :=
(creates_colimit.lifts c t).lifted_cocone

/-- The lifted cocone has an image isomorphic to the original cocone. -/
def lifted_colimit_maps_to_original {K : J ⥤ C} {F : C ⥤ D}
  [creates_colimit K F] {c : cocone (K ⋙ F)} (t : is_colimit c) :
  F.map_cocone (lift_colimit t) ≅ c :=
(creates_colimit.lifts c t).valid_lift

/-- The lifted cocone is a colimit. -/
def lifted_colimit_is_colimit {K : J ⥤ C} {F : C ⥤ D}
  [creates_colimit K F] {c : cocone (K ⋙ F)} (t : is_colimit c) :
  is_colimit (lift_colimit t) :=
reflects_colimit.reflects (is_colimit.of_iso_colimit t (lifted_colimit_maps_to_original t).symm)

/-- If `F` creates the limit of `K` and `K ⋙ F` has a limit, then `K` has a limit. -/
lemma has_colimit_of_created (K : J ⥤ C) (F : C ⥤ D)
  [has_colimit (K ⋙ F)] [creates_colimit K F] : has_colimit K :=
has_colimit.mk { cocone := lift_colimit (colimit.is_colimit (K ⋙ F)),
  is_colimit := lifted_colimit_is_colimit _ }

/--
If `F` creates colimits of shape `J`, and `D` has colimits of shape `J`, then
`C` has colimits of shape `J`.
-/
lemma has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape (F : C ⥤ D)
  [has_colimits_of_shape J D] [creates_colimits_of_shape J F] : has_colimits_of_shape J C :=
⟨λ G, has_colimit_of_created G F⟩

/-- If `F` creates colimits, and `D` has all colimits, then `C` has all colimits. -/
lemma has_colimits_of_has_colimits_creates_colimits (F : C ⥤ D) [has_colimits_of_size.{w w'} D]
  [creates_colimits_of_size.{w w'} F] : has_colimits_of_size.{w w'} C :=
⟨λ J I, by exactI has_colimits_of_shape_of_has_colimits_of_shape_creates_colimits_of_shape F⟩

@[priority 10] instance reflects_limits_of_shape_of_creates_limits_of_shape (F : C ⥤ D)
  [creates_limits_of_shape J F] : reflects_limits_of_shape J F := {}
@[priority 10] instance reflects_limits_of_creates_limits (F : C ⥤ D)
  [creates_limits_of_size.{w w'} F] : reflects_limits_of_size.{w w'} F := {}
@[priority 10] instance reflects_colimits_of_shape_of_creates_colimits_of_shape (F : C ⥤ D)
  [creates_colimits_of_shape J F] : reflects_colimits_of_shape J F := {}
@[priority 10] instance reflects_colimits_of_creates_colimits (F : C ⥤ D)
  [creates_colimits_of_size.{w w'} F] : reflects_colimits_of_size.{w w'} F := {}

/--
A helper to show a functor creates limits. In particular, if we can show
that for any limit cone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates limits.
Usually, `F` creating limits says that _any_ lift of `c` is a limit, but
here we only need to show that our particular lift of `c` is a limit.
-/
structure lifts_to_limit (K : J ⥤ C) (F : C ⥤ D) (c : cone (K ⋙ F)) (t : is_limit c)
  extends liftable_cone K F c :=
(makes_limit : is_limit lifted_cone)

/--
A helper to show a functor creates colimits. In particular, if we can show
that for any limit cocone `c` for `K ⋙ F`, there is a lift of it which is
a limit and `F` reflects isomorphisms, then `F` creates colimits.
Usually, `F` creating colimits says that _any_ lift of `c` is a colimit, but
here we only need to show that our particular lift of `c` is a colimit.
-/
structure lifts_to_colimit (K : J ⥤ C) (F : C ⥤ D) (c : cocone (K ⋙ F)) (t : is_colimit c)
  extends liftable_cocone K F c :=
(makes_colimit : is_colimit lifted_cocone)

/--
If `F` reflects isomorphisms and we can lift any limit cone to a limit cone,
then `F` creates limits.
In particular here we don't need to assume that F reflects limits.
-/
def creates_limit_of_reflects_iso {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
  (h : Π c t, lifts_to_limit K F c t) :
  creates_limit K F :=
{ lifts := λ c t, (h c t).to_liftable_cone,
  to_reflects_limit :=
  { reflects := λ (d : cone K) (hd : is_limit (F.map_cone d)),
    begin
      let d' : cone K := (h (F.map_cone d) hd).to_liftable_cone.lifted_cone,
      let i : F.map_cone d' ≅ F.map_cone d := (h (F.map_cone d) hd).to_liftable_cone.valid_lift,
      let hd' : is_limit d' := (h (F.map_cone d) hd).makes_limit,
      let f : d ⟶ d' := hd'.lift_cone_morphism d,
      have : (cones.functoriality K F).map f = i.inv := (hd.of_iso_limit i.symm).uniq_cone_morphism,
      haveI : is_iso ((cones.functoriality K F).map f) := (by { rw this, apply_instance }),
      haveI : is_iso f := is_iso_of_reflects_iso f (cones.functoriality K F),
      exact is_limit.of_iso_limit hd' (as_iso f).symm,
    end } }

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to exhibit a lift of the chosen limit cone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_lift {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_limit (K ⋙ F)]
  (c : cone K) (i : F.map_cone c ≅ limit.cone (K ⋙ F)) : creates_limit K F :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone := c,
  valid_lift := i.trans (is_limit.unique_up_to_iso (limit.is_limit _) t),
  makes_limit := is_limit.of_faithful F (is_limit.of_iso_limit (limit.is_limit _) i.symm)
    (λ s, F.preimage _) (λ s, F.image_preimage _) })

/--
When `F` is fully faithful, and `has_limit (K ⋙ F)`, to show that `F` creates the limit for `K`
it suffices to show that the chosen limit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cone maps,
-- so the constructed limits may not be ideal, definitionally.
def creates_limit_of_fully_faithful_of_iso {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_limit (K ⋙ F)]
  (X : C) (i : F.obj X ≅ limit (K ⋙ F)) : creates_limit K F :=
creates_limit_of_fully_faithful_of_lift
({ X := X,
  π :=
  { app := λ j, F.preimage (i.hom ≫ limit.π (K ⋙ F) j),
    naturality' := λ Y Z f, F.map_injective (by { dsimp, simp, erw limit.w (K ⋙ F), }) }} : cone K)
(by { fapply cones.ext, exact i, tidy, })

/-- `F` preserves the limit of `K` if it creates the limit and `K ⋙ F` has the limit. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limit_of_creates_limit_and_has_limit (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] [has_limit (K ⋙ F)] :
  preserves_limit K F :=
{ preserves := λ c t, is_limit.of_iso_limit (limit.is_limit _)
    ((lifted_limit_maps_to_original (limit.is_limit _)).symm ≪≫
      ((cones.functoriality K F).map_iso
        ((lifted_limit_is_limit (limit.is_limit _)).unique_up_to_iso t))) }

/-- `F` preserves the limit of shape `J` if it creates these limits and `D` has them. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape (F : C ⥤ D)
  [creates_limits_of_shape J F] [has_limits_of_shape J D] :
  preserves_limits_of_shape J F := {}

/-- `F` preserves limits if it creates limits and `D` has limits. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_limits_of_creates_limits_and_has_limits (F : C ⥤ D)
  [creates_limits_of_size.{w w'} F]
  [has_limits_of_size.{w w'} D] :
  preserves_limits_of_size.{w w'} F := {}

/--
If `F` reflects isomorphisms and we can lift any colimit cocone to a colimit cocone,
then `F` creates colimits.
In particular here we don't need to assume that F reflects colimits.
-/
def creates_colimit_of_reflects_iso {K : J ⥤ C} {F : C ⥤ D} [reflects_isomorphisms F]
  (h : Π c t, lifts_to_colimit K F c t) :
  creates_colimit K F :=
{ lifts := λ c t, (h c t).to_liftable_cocone,
  to_reflects_colimit :=
  { reflects := λ (d : cocone K) (hd : is_colimit (F.map_cocone d)),
    begin
      let d' : cocone K := (h (F.map_cocone d) hd).to_liftable_cocone.lifted_cocone,
      let i : F.map_cocone d' ≅ F.map_cocone d :=
        (h (F.map_cocone d) hd).to_liftable_cocone.valid_lift,
      let hd' : is_colimit d' := (h (F.map_cocone d) hd).makes_colimit,
      let f : d' ⟶ d := hd'.desc_cocone_morphism d,
      have : (cocones.functoriality K F).map f = i.hom :=
        (hd.of_iso_colimit i.symm).uniq_cocone_morphism,
      haveI : is_iso ((cocones.functoriality K F).map f) := (by { rw this, apply_instance }),
      haveI := is_iso_of_reflects_iso f (cocones.functoriality K F),
      exact is_colimit.of_iso_colimit hd' (as_iso f),
    end } }

/--
When `F` is fully faithful, and `has_colimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to exhibit a lift of the chosen colimit cocone for `K ⋙ F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_lift {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_colimit (K ⋙ F)]
  (c : cocone K) (i : F.map_cocone c ≅ colimit.cocone (K ⋙ F)) : creates_colimit K F :=
creates_colimit_of_reflects_iso (λ c' t,
{ lifted_cocone := c,
  valid_lift := i.trans (is_colimit.unique_up_to_iso (colimit.is_colimit _) t),
  makes_colimit := is_colimit.of_faithful F
    (is_colimit.of_iso_colimit (colimit.is_colimit _) i.symm)
    (λ s, F.preimage _) (λ s, F.image_preimage _) })

/--
When `F` is fully faithful, and `has_colimit (K ⋙ F)`, to show that `F` creates the colimit for `K`
it suffices to show that the chosen colimit point is in the essential image of `F`.
-/
-- Notice however that even if the isomorphism is `iso.refl _`,
-- this construction will insert additional identity morphisms in the cocone maps,
-- so the constructed colimits may not be ideal, definitionally.
def creates_colimit_of_fully_faithful_of_iso {K : J ⥤ C} {F : C ⥤ D}
  [full F] [faithful F] [has_colimit (K ⋙ F)]
  (X : C) (i : F.obj X ≅ colimit (K ⋙ F)) : creates_colimit K F :=
creates_colimit_of_fully_faithful_of_lift
({ X := X,
  ι :=
  { app := λ j, F.preimage (colimit.ι (K ⋙ F) j ≫ i.inv : _),
    naturality' := λ Y Z f, F.map_injective
      (by { erw category.comp_id, simp only [functor.map_comp, functor.image_preimage],
        erw colimit.w_assoc (K ⋙ F) }) }} : cocone K)
(by { fapply cocones.ext, exact i, tidy, })

/-- `F` preserves the colimit of `K` if it creates the colimit and `K ⋙ F` has the colimit. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimit_of_creates_colimit_and_has_colimit (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] [has_colimit (K ⋙ F)] :
  preserves_colimit K F :=
{ preserves := λ c t, is_colimit.of_iso_colimit (colimit.is_colimit _)
    ((lifted_colimit_maps_to_original (colimit.is_colimit _)).symm ≪≫
      ((cocones.functoriality K F).map_iso
        ((lifted_colimit_is_colimit (colimit.is_colimit _)).unique_up_to_iso t))) }

/-- `F` preserves the colimit of shape `J` if it creates these colimits and `D` has them. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimit_of_shape_of_creates_colimits_of_shape_and_has_colimits_of_shape
  (F : C ⥤ D) [creates_colimits_of_shape J F] [has_colimits_of_shape J D] :
  preserves_colimits_of_shape J F := {}

/-- `F` preserves limits if it creates limits and `D` has limits. -/
@[priority 100] -- see Note [lower instance priority]
instance preserves_colimits_of_creates_colimits_and_has_colimits (F : C ⥤ D)
  [creates_colimits_of_size.{w w'} F] [has_colimits_of_size.{w w'} D] :
  preserves_colimits_of_size.{w w'} F := {}

/-- Transfer creation of limits along a natural isomorphism in the diagram. -/
def creates_limit_of_iso_diagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂)
  [creates_limit K₁ F] : creates_limit K₂ F :=
{ lifts := λ c t,
  let t' := (is_limit.postcompose_inv_equiv (iso_whisker_right h F : _) c).symm t in
  { lifted_cone := (cones.postcompose h.hom).obj (lift_limit t'),
    valid_lift :=
        F.map_cone_postcompose ≪≫
        (cones.postcompose (iso_whisker_right h F).hom).map_iso
            (lifted_limit_maps_to_original t') ≪≫
        cones.ext (iso.refl _) (λ j, by { dsimp, rw [category.assoc, ←F.map_comp], simp }) }
  ..reflects_limit_of_iso_diagram F h }

/-- If `F` creates the limit of `K` and `F ≅ G`, then `G` creates the limit of `K`. -/
def creates_limit_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limit K F] :
  creates_limit K G :=
{ lifts := λ c t,
  { lifted_cone :=
      lift_limit ((is_limit.postcompose_inv_equiv (iso_whisker_left K h : _) c).symm t),
    valid_lift :=
    begin
      refine (is_limit.map_cone_equiv h _).unique_up_to_iso t,
      apply is_limit.of_iso_limit _ ((lifted_limit_maps_to_original _).symm),
      apply (is_limit.postcompose_inv_equiv _ _).symm t,
    end },
  to_reflects_limit := reflects_limit_of_nat_iso _ h }

/-- If `F` creates limits of shape `J` and `F ≅ G`, then `G` creates limits of shape `J`. -/
def creates_limits_of_shape_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limits_of_shape J F] :
  creates_limits_of_shape J G :=
{ creates_limit := λ K, creates_limit_of_nat_iso h }

/-- If `F` creates limits and `F ≅ G`, then `G` creates limits. -/
def creates_limits_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_limits_of_size.{w w'} F] :
  creates_limits_of_size.{w w'} G :=
{ creates_limits_of_shape := λ J 𝒥₁, by exactI creates_limits_of_shape_of_nat_iso h }

/-- Transfer creation of colimits along a natural isomorphism in the diagram. -/
def creates_colimit_of_iso_diagram {K₁ K₂ : J ⥤ C} (F : C ⥤ D) (h : K₁ ≅ K₂)
  [creates_colimit K₁ F] : creates_colimit K₂ F :=
{ lifts := λ c t,
  let t' := (is_colimit.precompose_hom_equiv (iso_whisker_right h F : _) c).symm t in
  { lifted_cocone := (cocones.precompose h.inv).obj (lift_colimit t'),
    valid_lift :=
        F.map_cocone_precompose ≪≫
        (cocones.precompose (iso_whisker_right h F).inv).map_iso
            (lifted_colimit_maps_to_original t') ≪≫
        cocones.ext (iso.refl _) (λ j, by { dsimp, rw ←F.map_comp_assoc, simp }) },
  ..reflects_colimit_of_iso_diagram F h }

/-- If `F` creates the colimit of `K` and `F ≅ G`, then `G` creates the colimit of `K`. -/
def creates_colimit_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_colimit K F] :
  creates_colimit K G :=
{ lifts := λ c t,
  { lifted_cocone :=
      lift_colimit ((is_colimit.precompose_hom_equiv (iso_whisker_left K h : _) c).symm t),
    valid_lift :=
    begin
      refine (is_colimit.map_cocone_equiv h _).unique_up_to_iso t,
      apply is_colimit.of_iso_colimit _ ((lifted_colimit_maps_to_original _).symm),
      apply (is_colimit.precompose_hom_equiv _ _).symm t,
    end },
  to_reflects_colimit := reflects_colimit_of_nat_iso _ h }

/-- If `F` creates colimits of shape `J` and `F ≅ G`, then `G` creates colimits of shape `J`. -/
def creates_colimits_of_shape_of_nat_iso {F G : C ⥤ D} (h : F ≅ G)
  [creates_colimits_of_shape J F] : creates_colimits_of_shape J G :=
{ creates_colimit := λ K, creates_colimit_of_nat_iso h }

/-- If `F` creates colimits and `F ≅ G`, then `G` creates colimits. -/
def creates_colimits_of_nat_iso {F G : C ⥤ D} (h : F ≅ G) [creates_colimits_of_size.{w w'} F] :
  creates_colimits_of_size.{w w'} G :=
{ creates_colimits_of_shape := λ J 𝒥₁, by exactI creates_colimits_of_shape_of_nat_iso h }

-- For the inhabited linter later.
/-- If F creates the limit of K, any cone lifts to a limit. -/
def lifts_to_limit_of_creates (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] (c : cone (K ⋙ F)) (t : is_limit c) :
  lifts_to_limit K F c t :=
{ lifted_cone := lift_limit t,
  valid_lift := lifted_limit_maps_to_original t,
  makes_limit := lifted_limit_is_limit t }

-- For the inhabited linter later.
/-- If F creates the colimit of K, any cocone lifts to a colimit. -/
def lifts_to_colimit_of_creates (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] (c : cocone (K ⋙ F)) (t : is_colimit c) :
  lifts_to_colimit K F c t :=
{ lifted_cocone := lift_colimit t,
  valid_lift := lifted_colimit_maps_to_original t,
  makes_colimit := lifted_colimit_is_colimit t }

/-- Any cone lifts through the identity functor. -/
def id_lifts_cone (c : cone (K ⋙ 𝟭 C)) : liftable_cone K (𝟭 C) c :=
{ lifted_cone :=
  { X := c.X,
    π := c.π ≫ K.right_unitor.hom },
  valid_lift := cones.ext (iso.refl _) (by tidy) }

/-- The identity functor creates all limits. -/
instance id_creates_limits : creates_limits_of_size.{w w'} (𝟭 C) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ F, { lifts := λ c t, id_lifts_cone c } } }

/-- Any cocone lifts through the identity functor. -/
def id_lifts_cocone (c : cocone (K ⋙ 𝟭 C)) : liftable_cocone K (𝟭 C) c :=
{ lifted_cocone :=
  { X := c.X,
    ι := K.right_unitor.inv ≫ c.ι },
  valid_lift := cocones.ext (iso.refl _) (by tidy) }

/-- The identity functor creates all colimits. -/
instance id_creates_colimits : creates_colimits_of_size.{w w'} (𝟭 C) :=
{ creates_colimits_of_shape := λ J 𝒥, by exactI
  { creates_colimit := λ F, { lifts := λ c t, id_lifts_cocone c } } }

/-- Satisfy the inhabited linter -/
instance inhabited_liftable_cone (c : cone (K ⋙ 𝟭 C)) :
  inhabited (liftable_cone K (𝟭 C) c) :=
⟨id_lifts_cone c⟩
instance inhabited_liftable_cocone (c : cocone (K ⋙ 𝟭 C)) :
  inhabited (liftable_cocone K (𝟭 C) c) :=
⟨id_lifts_cocone c⟩

/-- Satisfy the inhabited linter -/
instance inhabited_lifts_to_limit (K : J ⥤ C) (F : C ⥤ D)
  [creates_limit K F] (c : cone (K ⋙ F)) (t : is_limit c) :
  inhabited (lifts_to_limit _ _ _ t) :=
⟨lifts_to_limit_of_creates K F c t⟩
instance inhabited_lifts_to_colimit (K : J ⥤ C) (F : C ⥤ D)
  [creates_colimit K F] (c : cocone (K ⋙ F)) (t : is_colimit c) :
  inhabited (lifts_to_colimit _ _ _ t) :=
⟨lifts_to_colimit_of_creates K F c t⟩

section comp

variables {E : Type u₃} [ℰ : category.{v₃} E]
variables (F : C ⥤ D) (G : D ⥤ E)

instance comp_creates_limit [creates_limit K F] [creates_limit (K ⋙ F) G] :
  creates_limit K (F ⋙ G) :=
{ lifts := λ c t,
  { lifted_cone := lift_limit (lifted_limit_is_limit t),
    valid_lift := (cones.functoriality (K ⋙ F) G).map_iso
      (lifted_limit_maps_to_original (lifted_limit_is_limit t)) ≪≫
      (lifted_limit_maps_to_original t) } }

instance comp_creates_limits_of_shape [creates_limits_of_shape J F] [creates_limits_of_shape J G] :
  creates_limits_of_shape J (F ⋙ G) :=
{ creates_limit := infer_instance }

instance comp_creates_limits [creates_limits_of_size.{w w'} F] [creates_limits_of_size.{w w'} G] :
  creates_limits_of_size.{w w'} (F ⋙ G) :=
{ creates_limits_of_shape := infer_instance }

instance comp_creates_colimit [creates_colimit K F] [creates_colimit (K ⋙ F) G] :
  creates_colimit K (F ⋙ G) :=
{ lifts := λ c t,
  { lifted_cocone := lift_colimit (lifted_colimit_is_colimit t),
    valid_lift := (cocones.functoriality (K ⋙ F) G).map_iso
      (lifted_colimit_maps_to_original (lifted_colimit_is_colimit t)) ≪≫
      (lifted_colimit_maps_to_original t) } }

instance comp_creates_colimits_of_shape
  [creates_colimits_of_shape J F] [creates_colimits_of_shape J G] :
  creates_colimits_of_shape J (F ⋙ G) :=
{ creates_colimit := infer_instance }

instance comp_creates_colimits [creates_colimits_of_size.{w w'} F]
  [creates_colimits_of_size.{w w'} G] : creates_colimits_of_size.{w w'} (F ⋙ G) :=
{ creates_colimits_of_shape := infer_instance }

end comp

end creates

end category_theory


import polycodable

open ptree (pencodable)

variables {α β γ δ ε : Type*} [pencodable α] [pencodable β] [pencodable γ]
 [pencodable δ] [pencodable ε]

open ptree.pencodable (encode decode)

class has_psize (α : Type*) [pencodable α] :=
(psize : α → ℕ)
(p_lower : ∃ p : polynomial ℕ, ∀ x, (encode x).sizeof ≤ p.eval (psize x))
(p_upper : ∃ p : polynomial ℕ, ∀ x, psize x ≤ p.eval (encode x).sizeof)

def default_has_psize (α : Type*) [pencodable α] : has_psize α :=
{ psize := λ x, (encode x).sizeof,
  p_lower := ⟨polynomial.monomial 1 1, λ x, le_of_eq (by simp)⟩,
  p_upper := ⟨polynomial.monomial 1 1, λ x, le_of_eq (by simp)⟩ }

-- def mk_has_psize_of_fintype (α : Type*) [fintype α] [pencodable α] (psize : α → ℕ) : has_psize α :=
-- begin
--   refine_struct { psize := psize }, sorry,
--   -- suffices : ∀ (f g : α → ℕ), ∃ p : polynomial ℕ,
-- end

open has_psize (psize)

section psize
variables [has_psize α] [has_psize β]

noncomputable def psize_lower (α : Type*) [pencodable α] [has_psize α] : polynomial ℕ :=
  (infer_instance : has_psize α).p_lower.some
lemma psize_lower_spec (x : α) : (encode x).sizeof ≤ (psize_lower α).eval (psize x) :=
    (infer_instance : has_psize α).p_lower.some_spec x
noncomputable def psize_upper (α : Type*) [pencodable α] [has_psize α] : polynomial ℕ :=
  (infer_instance : has_psize α).p_upper.some
lemma psize_upper_spec (x : α) : psize x ≤ (psize_upper α).eval (encode x).sizeof :=
    (infer_instance : has_psize α).p_upper.some_spec x

instance : has_psize ptree := default_has_psize _
instance : has_psize (α × β) :=
{ psize := λ x, psize x.1 + psize x.2,
  p_lower := ⟨1 + (psize_lower α + psize_lower β), λ ⟨x₁, x₂⟩,
  begin
    simp [encode, add_assoc],
    mono; refine (psize_lower_spec _).trans _; mono; simp,
  end⟩,
  p_upper := ⟨psize_upper α + psize_upper β, λ ⟨x₁, x₂⟩,
  begin
    simp,
    mono; refine (psize_upper_spec _).trans _; mono; simp [encode]; linarith only,
  end⟩ }
-- instance {α : Type*} [pencodable α] : has_psize (list α) :=

end psize

@[simp] lemma encode_sizeof_ptree (x : ptree) : (encode x).sizeof = x.sizeof := rfl
lemma one_le_encode_sizeof (x : α) :
  1 ≤ (encode x).sizeof :=
by { cases (encode x); simp, linarith only, }

@[simp] lemma encode_sizeof_pair (a : α) (b : β) : (encode (a, b)).sizeof = (encode a).sizeof + (encode b).sizeof + 1 :=
by { simp [encode], ac_refl, }

@[simp] lemma encode_sizeof_unit (x : unit) : (encode x).sizeof = 1 :=
by simp [encode]

@[simp] lemma polysize_fun.encode_tt_sizeof : (encode tt).sizeof = 1 :=
by simp [encode]

@[simp] lemma polysize_fun.encode_ff_sizeof : (encode ff).sizeof = 3 :=
by simp [encode]

@[simp] lemma encode_sizeof_nil : (encode ([] : list γ)).sizeof = 1 :=
by simp [encode]
@[simp] lemma encode_sizeof_cons (a : γ) (b : list γ) :
  (encode (a :: b)).sizeof = 1 + (encode a).sizeof + (encode b).sizeof :=
by simp [encode]

lemma encode_sizeof_le_of_mem {l : list γ} {x : γ} (hx : x ∈ l) :
  (encode x).sizeof ≤ (encode l).sizeof :=
begin
  induction l with hd tl ih, { simp at hx, contradiction, },
  rcases ((list.mem_cons_iff _ _ _).mp hx) with rfl|h; simp,
  { linarith only, },
  linarith only [ih h],
end

@[simp] lemma encode_sizeof_append (a b : list γ) :
  ((encode (a ++ b)).sizeof : ℤ) = ((encode a).sizeof : ℤ) + (encode b).sizeof - 1 :=
by { induction a with hd tl ih, { simp, }, simp [ih], ring, }

lemma encode_sizeof_le_of_sublist {a b : list γ} (h : a <+ b) :
  (encode a).sizeof ≤ (encode b).sizeof :=
begin
  induction h, { simp, },
  case list.sublist.cons : l₁ l₂ s₁ H ih { refine ih.trans _, simp, },
  case list.sublist.cons2 : l₁ l₂ s₁ H ih { simpa, },
end

lemma encode_sizeof_le_of_infix {a b : list γ} (h : a <:+: b) :
  (encode a).sizeof ≤ (encode b).sizeof :=
encode_sizeof_le_of_sublist h.sublist

lemma encode_list_sizeof (l : list γ) :
  (encode l).sizeof = (l.map (λ x, (encode x).sizeof)).sum + l.length + 1 :=
by { induction l with hd tl ih, { simp, }, simp [ih], ac_refl, }

@[simp] lemma encode_sizeof_reverse (l : list γ) :
  (encode l.reverse).sizeof = (encode l).sizeof :=
by { simp [encode_list_sizeof, list.sum_reverse], }

lemma len_le_encode_sizeof' (a : list γ) :
  a.length + 1 ≤ (encode a).sizeof :=
by { induction a with hd tl ih, { simp, }, simp, linarith, }

lemma len_le_encode_sizeof (a : list γ) :
  a.length ≤ (encode a).sizeof :=
by { refine trans _ (len_le_encode_sizeof' a), simp, }

def polysize_fun (f : α → β) : Prop :=
∃ p : polynomial ℕ, ∀ (x : α), (encode (f x)).sizeof ≤ p.eval (encode x).sizeof

lemma polysize_of_polytime_fun {f : α → β} (hf : polytime_fun f) :
  polysize_fun f :=
begin
  rcases hf with ⟨c, ⟨p, hp⟩, sc⟩, use p,
  intro x, specialize sc x, rw part.eq_some_iff at sc,
  rcases hp (encode x) with ⟨t, ht, t_le⟩,
  exact (eval_sizeof_le_time sc ht).trans t_le,
end

lemma polysize_fun.comp {g : β → γ} {f : α → β} (hg : polysize_fun g) (hf : polysize_fun f) :
  polysize_fun (g ∘ f) :=
begin
  rcases hf with ⟨pf, hpf⟩, rcases hg with ⟨pg, hpg⟩,
  use pg.comp pf, intro x, simp,
  refine (hpg _).trans (monotone_polynomial_nat _ _),
  apply hpf,
end

def polysize_fun₂ (f : α → β → γ) : Prop := polysize_fun (function.uncurry f)
lemma polysize₂_of_polytime₂ {f : α → β → γ} (hf : polytime_fun₂ f) : polysize_fun₂ f :=
polysize_of_polytime_fun hf

lemma polysize_fun.pair {f : α → β} {g : α → γ} (hf : polysize_fun f) (hg : polysize_fun g) :
  polysize_fun (λ s, (f s, g s)) :=
by { cases hf with pf hpf, cases hg with pg hpg, use pf + pg + 1, intro x, simpa using add_le_add (hpf _) (hpg _), }

lemma polysize_fun.comp₂ {f : α → β → γ} {g : δ → α} {h : δ → β} (hf : polysize_fun₂ f) (hg : polysize_fun g) (hh : polysize_fun h) :
  polysize_fun (λ s, f (g s) (h s)) :=
polysize_fun.comp hf (polysize_fun.pair hg hh)

def polysize_fun₃ (f : α → β → γ → δ) : Prop :=
polysize_fun (λ a : α × β × γ, f a.1 a.2.1 a.2.2)
lemma polysize₃_of_polytime₃ {f : α → β → γ → δ} (hf : polytime_fun₃ f) : polysize_fun₃ f :=
polysize_of_polytime_fun hf
lemma polysize_fun.comp₃ {f : α → β → γ → δ} {g : ε → α} {h : ε → β} {i : ε → γ}
  (hf : polysize_fun₃ f) (hg : polysize_fun g) (hh : polysize_fun h) (hi : polysize_fun i) :
  polysize_fun (λ s, f (g s) (h s) (i s)) :=
polysize_fun.comp hf (polysize_fun.pair hg (polysize_fun.pair hh hi))

variables {σ : α → Type*} [∀ x, pencodable (σ x)]
def polysize_fun_safe (f : Π x, (σ x) → γ) : Prop :=
∃ p : polynomial ℕ, ∀ (x : α) (y : σ x), (encode (f x y)).sizeof ≤ (encode y).sizeof + p.eval (encode x).sizeof

lemma polysize_fun_safe_of_polysize {f : α → γ} :
  polysize_fun f → polysize_fun_safe (λ x (_ : σ x), f x)
| ⟨p, hp⟩ := by { refine ⟨p, λ _ _, (hp _).trans _⟩, simp, }

@[simp] lemma polysize_fun_safe_iff_polysize {f : α → γ} :
  polysize_fun_safe (λ x (_ : β), f x) ↔ polysize_fun f :=
begin
  split, swap, { exact polysize_fun_safe_of_polysize, },
  inhabit β,
  rintro ⟨p, hp⟩, dsimp only at hp,
  use p + (encode (default : β)).sizeof, intro x,
  simpa [add_comm] using hp x default,
end

def polysize_fun_uniform (f : Π x, (σ x) → γ) : Prop :=
∃ p : polynomial ℕ, ∀ (x : α) (y : σ x), (encode (f x y)).sizeof ≤ p.eval (encode x).sizeof

@[simp] lemma polysize_fun_uniform_iff_polysize {f : α → γ} :
  polysize_fun_uniform (λ x (_ : σ x), f x) ↔ polysize_fun f :=
begin
  split,
  { rintro ⟨p, hp⟩, use p, intro x, inhabit (σ x),
    simpa using hp x default, },
  { rintro ⟨p, hp⟩, exact ⟨p, λ _ _, (hp _).trans rfl.le⟩ },
end

lemma polysize_fun_uniform.to_safe {f : Π x, σ x → γ} : polysize_fun_uniform f → polysize_fun_safe f
| ⟨p, hp⟩ := ⟨p, λ x y, (hp x y).trans (by simp)⟩

lemma polysize_uniform_of_fin_range [fintype γ] (f : Π x, σ x → γ) :
  polysize_fun_uniform f :=
begin
  haveI : nonempty γ := ⟨decode ptree.nil⟩,
  let B := ((finset.image (λ x : γ, (encode x).sizeof) finset.univ).max' _ : ℕ),
  { use B, intros x _, simp, apply finset.le_max', simp, },
  simpa using finset.univ_nonempty,
end

lemma polysize_fun_of_fin_range [fintype β] (f : α → β) : polysize_fun f :=
by simpa using (show polysize_fun_uniform (λ x (y : unit), f x), from polysize_uniform_of_fin_range _)

lemma polysize_fun_uniform.pair {f : Π x, (σ x) → β} {g : Π x, (σ x) → γ} :
  polysize_fun_uniform f → polysize_fun_uniform g → polysize_fun_uniform (λ x y, (f x y, g x y))
| ⟨pf, hpf⟩ ⟨pg, hpg⟩ :=
begin
  use pf + pg + 1,
  intros x y,
  simp, mono,
end

variables {ι : Type*} {ζ : ι → Type*} [pencodable ι] [∀ x, pencodable (ζ x)]
lemma polysize_fun_safe.comp
  {f : α → β → γ} {g : Π x, ζ x → α} {h : Π x, ζ x → β} :
  polysize_fun_safe f → polysize_fun_uniform g → polysize_fun_safe h →
  polysize_fun_safe (λ x y, f (g x y) (h x y))
| ⟨pf, hf⟩ ⟨pg, hg⟩ ⟨ph, hh⟩ :=
begin
  use ph + (pf.comp pg),
  intros x y,
  refine (hf _ _).trans _,
  simp [← add_assoc], mono*,
end

lemma polysize_fun_safe.comp'
  {f : β → γ} {g : Π x, ζ x → β} (hf : polysize_fun_safe (λ (_ : unit), f)) (hg : polysize_fun_safe g) : polysize_fun_safe (λ x y, f (g x y)) :=
by { apply hf.comp, { exact polysize_uniform_of_fin_range default, }, exact hg, }

lemma polysize_fun_uniform.comp {f : α → β → γ} {g : Π x, ζ x → α} {h : Π x, ζ x → β} :
  polysize_fun_uniform f → polysize_fun_uniform g → polysize_fun_uniform (λ x y, f (g x y) (h x y))
| ⟨pf, hf⟩ ⟨pg, hg⟩ :=
begin
  use pf.comp pg, intros x y, simp,
  refine (hf _ _).trans _, mono,
end

lemma polysize_fun_uniform.comp' {f : β → γ} {g : Π x, ζ x → β} :
  polysize_fun_safe (λ (_ : unit), f) → polysize_fun_uniform g → polysize_fun_uniform (λ x y, f (g x y))
| ⟨pf, hf⟩ ⟨pg, hg⟩ :=
begin
  use pg + (pf.eval 1), intros x y, simp at hf hg ⊢,
  refine (hf () (g x y)).trans _, simpa using hg _ _,
end

lemma polysize_fun_safe.pair_left {f : Π x, σ x → γ} {g : Π x, σ x → β}
  (hf : polysize_fun_uniform f) (hg : polysize_fun_safe g) :
  polysize_fun_safe (λ x y, (f x y, g x y)) :=
begin
  rcases hf with ⟨pf, hf⟩, rcases hg with ⟨pg, hg⟩,
  use pg + pf + 1, intros x y, simp [← add_assoc],
  conv_lhs { rw add_comm, }, mono,
end

lemma polysize_fun_safe.pair_right {f : Π x, σ x → γ} {g : Π x, σ x → β}
  (hf : polysize_fun_safe f) (hg : polysize_fun_uniform g) :
  polysize_fun_safe (λ x y, (f x y, g x y)) :=
begin
  rcases hf with ⟨pf, hf⟩, rcases hg with ⟨pg, hg⟩,
  use pf + pg + 1, intros x y, simp [← add_assoc], mono,
end

lemma polysize_fun_safe.tail (α : Type*) [pencodable α] : polysize_fun_safe (λ (_ : α), @list.tail β) :=
⟨0, λ _ y, by simpa using encode_sizeof_le_of_sublist (y.tail_sublist)⟩

lemma polysize_fun_safe.fst (α : Type*) [pencodable α] : polysize_fun_safe (λ (_ : α), @prod.fst β γ) :=
⟨0, λ _ ⟨y₁, y₂⟩, by simp [add_assoc]⟩

lemma polysize_fun_safe.snd (α : Type*) [pencodable α] : polysize_fun_safe (λ (_ : α), @prod.snd β γ) :=
⟨0, λ _ ⟨y₁, y₂⟩, by { simp, linarith only, }⟩

lemma polysize_fun.id : polysize_fun (@id α) :=
⟨polynomial.monomial 1 1, λ x, by simp⟩

lemma polysize_fun_safe.id : polysize_fun_safe (λ (_ : α) (x : β), x) :=
⟨0, λ _ x, by simp⟩

lemma polysize_fun_safe.ite {f g : Π x, σ x → γ} {P : Π x, σ x → Prop} [∀ (x : α) (y : σ x), decidable (P x y)]
  (hf : polysize_fun_safe f) (hg : polysize_fun_safe g) : polysize_fun_safe (λ x y, if P x y then f x y else g x y) :=
begin
  rcases hf with ⟨pf, hf⟩, rcases hg with ⟨pg, hg⟩, use pf + pg,
  intros x y, dsimp only, split_ifs,
  { refine (hf _ _).trans _, simp, }, { refine (hg _ _).trans _, simp, },
end

lemma _root_.bool.cond_eq_ite (x y : α) (b : bool) : cond b x y = if b then x else y := by cases b; refl

lemma polysize_fun_safe.cond {f g : Π x, σ x → γ} {P : Π x, σ x → bool}
  (hf : polysize_fun_safe f) (hg : polysize_fun_safe g) : polysize_fun_safe (λ x y, cond (P x y) (f x y) (g x y)) :=
by { simp_rw bool.cond_eq_ite, exact polysize_fun_safe.ite hf hg, }

lemma polysize_fun_safe.cons : polysize_fun_safe (@list.cons α) :=
by { use polynomial.monomial 1 1 + 1, intros x y, simp [add_comm], }

lemma polysize_fun_safe.append : polysize_fun_safe (λ (a b : list α), a ++ b) :=
by { use polynomial.monomial 1 1 + 1, intros x y, zify, simp, linarith only,  }

def set_encodable (S : set α) [decidable_pred (∈ S)] {d : α} (hd : d ∈ S) : ptree.pencodable S :=
ptree.pencodable.mk'
(coe : S → α)
(λ x, if h : x ∈ S then ⟨x, h⟩ else ⟨d, hd⟩)
(λ x, by simp)


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.set.basic
import tactic.monotonicity.basic

/-!
# Typeclass for types with a set-like extensionality property

The `has_mem` typeclass is used to let terms of a type have elements.
Many instances of `has_mem` have a set-like extensionality property:
things are equal iff they have the same elements.  The `set_like`
typeclass provides a unified interface to define a `has_mem` that is
extensional in this way.

The main use of `set_like` is for algebraic subobjects (such as
`submonoid` and `submodule`), whose non-proof data consists only of a
carrier set.  In such a situation, the projection to the carrier set
is injective.

In general, a type `A` is `set_like` with elements of type `B` if it
has an injective map to `set B`.  This module provides standard
boilerplate for every `set_like`: a `coe_sort`, a `coe` to set, a
`partial_order`, and various extensionality and simp lemmas.

A typical subobject should be declared as:
```
structure my_subobject (X : Type*) [object_typeclass X] :=
(carrier : set X)
(op_mem' : ∀ {x : X}, x ∈ carrier → sorry ∈ carrier)

namespace my_subobject

variables {X : Type*} [object_typeclass X] {x : X}

instance : set_like (my_subobject X) X :=
⟨my_subobject.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp] lemma mem_carrier {p : my_subobject X} : x ∈ p.carrier ↔ x ∈ (p : set X) := iff.rfl

@[ext] theorem ext {p q : my_subobject X} (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := set_like.ext h

/-- Copy of a `my_subobject` with a new `carrier` equal to the old one. Useful to fix definitional
equalities. See Note [range copy pattern]. -/
protected def copy (p : my_subobject X) (s : set X) (hs : s = ↑p) : my_subobject X :=
{ carrier := s,
  op_mem' := hs.symm ▸ p.op_mem' }

@[simp] lemma coe_copy (p : my_subobject X) (s : set X) (hs : s = ↑p) :
  (p.copy s hs : set X) = s := rfl

lemma copy_eq (p : my_subobject X) (s : set X) (hs : s = ↑p) : p.copy s hs = p :=
set_like.coe_injective hs

end my_subobject
```

An alternative to `set_like` could have been an extensional `has_mem` typeclass:
```
class has_ext_mem (α : out_param $ Type u) (β : Type v) extends has_mem α β :=
(ext_iff : ∀ {s t : β}, s = t ↔ ∀ (x : α), x ∈ s ↔ x ∈ t)
```
While this is equivalent, `set_like` conveniently uses a carrier set projection directly.

## Tags

subobjects
-/

/-- A class to indicate that there is a canonical injection between `A` and `set B`.

This has the effect of giving terms of `A` elements of type `B` (through a `has_mem`
instance) and a compatible coercion to `Type*` as a subtype.

Note: if `set_like.coe` is a projection, implementers should create a simp lemma such as
```
@[simp] lemma mem_carrier {p : my_subobject X} : x ∈ p.carrier ↔ x ∈ (p : set X) := iff.rfl
```
to normalize terms.
-/
@[protect_proj]
class set_like (A : Type*) (B : out_param $ Type*) :=
(coe : A → set B)
(coe_injective' : function.injective coe)

namespace set_like

variables {A : Type*} {B : Type*} [i : set_like A B]

include i

instance : has_coe_t A (set B) := ⟨set_like.coe⟩

@[priority 100]
instance : has_mem B A := ⟨λ x p, x ∈ (p : set B)⟩

-- `dangerous_instance` does not know that `B` is used only as an `out_param`
@[nolint dangerous_instance, priority 100]
instance : has_coe_to_sort A Type* := ⟨λ p, {x : B // x ∈ p}⟩

variables (p q : A)

@[simp, norm_cast] theorem coe_sort_coe : ((p : set B) : Type*) = p := rfl

variables {p q}

protected theorem «exists» {q : p → Prop} :
  (∃ x, q x) ↔ (∃ x ∈ p, q ⟨x, ‹_›⟩) := set_coe.exists

protected theorem «forall» {q : p → Prop} :
  (∀ x, q x) ↔ (∀ x ∈ p, q ⟨x, ‹_›⟩) := set_coe.forall

theorem coe_injective : function.injective (coe : A → set B) :=
λ x y h, set_like.coe_injective' h

@[simp, norm_cast] theorem coe_set_eq : (p : set B) = q ↔ p = q := coe_injective.eq_iff

theorem ext' (h : (p : set B) = q) : p = q := coe_injective h

theorem ext'_iff : p = q ↔ (p : set B) = q := coe_set_eq.symm

/-- Note: implementers of `set_like` must copy this lemma in order to tag it with `@[ext]`. -/
theorem ext (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := coe_injective $ set.ext h

theorem ext_iff : p = q ↔ (∀ x, x ∈ p ↔ x ∈ q) := coe_injective.eq_iff.symm.trans set.ext_iff

@[simp] theorem mem_coe {x : B} : x ∈ (p : set B) ↔ x ∈ p := iff.rfl

@[simp, norm_cast] lemma coe_eq_coe {x y : p} : (x : B) = y ↔ x = y := subtype.ext_iff_val.symm

@[simp, norm_cast] lemma coe_mk (x : B) (hx : x ∈ p) : ((⟨x, hx⟩ : p) : B) = x := rfl
@[simp] lemma coe_mem (x : p) : (x : B) ∈ p := x.2

@[simp] protected lemma eta (x : p) (hx : (x : B) ∈ p) : (⟨x, hx⟩ : p) = x := subtype.eta x hx

-- `dangerous_instance` does not know that `B` is used only as an `out_param`
@[nolint dangerous_instance, priority 100]
instance : partial_order A :=
{ le := λ H K, ∀ ⦃x⦄, x ∈ H → x ∈ K,
  .. partial_order.lift (coe : A → set B) coe_injective }

lemma le_def {S T : A} : S ≤ T ↔ ∀ ⦃x : B⦄, x ∈ S → x ∈ T := iff.rfl

@[simp, norm_cast]
lemma coe_subset_coe {S T : A} : (S : set B) ⊆ T ↔ S ≤ T := iff.rfl

@[mono] lemma coe_mono : monotone (coe : A → set B) := λ a b, coe_subset_coe.mpr

@[simp, norm_cast]
lemma coe_ssubset_coe {S T : A} : (S : set B) ⊂ T ↔ S < T := iff.rfl

@[mono] lemma coe_strict_mono : strict_mono (coe : A → set B) := λ a b, coe_ssubset_coe.mpr

lemma not_le_iff_exists : ¬(p ≤ q) ↔ ∃ x ∈ p, x ∉ q := set.not_subset

lemma exists_of_lt : p < q → ∃ x ∈ q, x ∉ p := set.exists_of_ssubset

lemma lt_iff_le_and_exists : p < q ↔ p ≤ q ∧ ∃ x ∈ q, x ∉ p :=
by rw [lt_iff_le_not_le, not_le_iff_exists]

end set_like


import topology.local_homeomorph

variables {α β : Type*} [topological_space α] [topological_space β] (e : local_homeomorph α β)

namespace local_homeomorph

lemma is_open_symm_image_iff_of_subset_target {s : set β} (hs : s ⊆ e.target) :
  is_open (e.symm '' s) ↔ is_open s :=
begin
  refine ⟨λ h, _, λ h, e.symm.image_open_of_open h hs⟩,
  have hs' : e.symm '' s ⊆ e.source,
  { rw e.symm_image_eq_source_inter_preimage hs, apply set.inter_subset_left, },
  rw ← e.to_local_equiv.image_symm_image_of_subset_target hs,
  exact e.image_open_of_open h hs',
end

lemma is_open_image_iff_of_subset_source {s : set α} (hs : s ⊆ e.source) :
  is_open s ↔ is_open (e '' s) :=
by rw [← e.symm.is_open_symm_image_iff_of_subset_target (hs : s ⊆ e.symm.target), e.symm_symm]

end local_homeomorph


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem algebra_3rootspoly_amdtamctambeqnasqmbpctapcbtdpasqmbpctapcbta
  (b c d a : ℂ) :
  (a-d) * (a-c) * (a-b) = -(((a^2 - (b+c) * a) + c * b) * d) + (a^2 - (b+c) * a + c * b) * a :=
begin
  ring,
end


import tactic
import data.rel
import data.vector
import data.nat.basic
import ruby.defs

open rel vector nat

variables {α β γ δ ε φ ψ : Type}

/- Basic lemmas -/

--@[simp]
lemma rel_seq_assoc (r : rel α β) (s : rel β γ) (t : rel γ δ) :
  r ;; (s ;; t) = (r ;; s) ;; t := (comp_assoc r s t).symm

@[simp]
lemma seq_par_dist (r : rel α β) (s : rel β γ) (t : rel δ ε) (u : rel ε φ) :
  [r ;; s, t ;; u] = [r, t] ;; [s, u] :=
begin
  ext ⟨a,d⟩ ⟨c,f⟩,
  split,
  { rintro ⟨⟨b,rab,sbc⟩,⟨e,tde,uef⟩⟩,
    exact ⟨⟨b,e⟩,⟨⟨rab,tde⟩,⟨sbc,uef⟩⟩⟩, },
  { rintro ⟨⟨b,e⟩,⟨⟨rab,tde⟩,⟨sbc,uef⟩⟩⟩,
    exact ⟨⟨b,⟨rab,sbc⟩⟩,⟨e,⟨tde,uef⟩⟩⟩, }
end

@[simp]
lemma conv_seq (r : rel α β) (s : rel β γ) : (r ;; s)† = s† ;; r† := inv_comp r s

@[simp]
lemma conv_par (r : rel α β) (s : rel γ δ) : [r,s]† = [r†,s†] :=
begin
  ext ⟨b,d⟩ ⟨a,c⟩,
  split,
  { rintro ⟨rab,scd⟩,
    exact ⟨(inv_def r a b).mpr rab,(inv_def s c d).mpr scd⟩, },
  { rintro ⟨h1,h2⟩,
    simp at *,
    exact ⟨h1,h2⟩, }
end

@[simp]
lemma conv_conv (r : rel α β) : r†† = r := inv_inv r

@[simp]
lemma conv_id : (@idd α)† = @idd α := inv_id

@[simp]
lemma seq_id_left (r : rel α β) : idd ;; r = r := comp_left_id r

@[simp]
lemma seq_id_right (r : rel α β) : r ;; idd = r := comp_right_id r

@[simp]
lemma par_id : [idd, idd] = @idd (α × β) :=
begin
  ext ⟨a,b⟩ ⟨x,y⟩,
  split,
  rintro ⟨hax,hby⟩,
  simp * at *,
  intro h,
  exact ⟨congr_arg prod.fst h,congr_arg prod.snd h⟩,
end

lemma from_conv {r s : rel α β} : r† = s† ↔ r=s :=
begin
  split,
  { intro h,
    ext x y,
    unfold inv flip at h,
    have w := congr_fun (congr_fun h y) x, dsimp at w,
    simpa using w, },
  { intro h,
    rw h, }
end


/-
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.cochain_complex.cm5a
import for_mathlib.algebra.homology.double
import for_mathlib.algebra.homology.k_projective
import category_theory.filtered
import for_mathlib.algebra.homology.homology_sequence

noncomputable theory

open category_theory category_theory.category algebraic_topology
  category_theory.limits

variables {C : Type*} [category C]

namespace category_theory

namespace functor

section

variables {J : Type*} [category J] (F : J ⥤ C) [is_filtered J]

open is_filtered

def is_eventually_constant_from (i : J) : Prop :=
∀ (j : J) (f : i ⟶ j), is_iso (F.map f)

lemma is_eventually_constant_from.of_map {i i' : J} (g : i ⟶ i')
  (hi : F.is_eventually_constant_from i) :
  F.is_eventually_constant_from i' :=
λ j f, begin
  haveI : is_iso (F.map (g ≫ f)) := hi _ _,
  haveI : is_iso (F.map g) := hi _ _,
  exact is_iso.of_is_iso_fac_left (F.map_comp g f).symm,
end

class is_eventually_constant : Prop :=
(condition [] : ∃ (i : J), F.is_eventually_constant_from i)

namespace is_eventually_constant

variable [is_eventually_constant F]

def index : J :=
  (is_eventually_constant.condition F).some

instance {j : J} (f : index F ⟶ j) :
  is_iso (F.map f) := (is_eventually_constant.condition F).some_spec j f

lemma map_from_index_eq {j : J} (f₁ f₂ : index F ⟶ j) :
  F.map f₁ = F.map f₂ :=
begin
  haveI : is_iso (F.map (coeq_hom f₁ f₂)) := begin
    have eq := F.map_comp f₁ (coeq_hom f₁ f₂),
    exact is_iso.of_is_iso_fac_left eq.symm,
  end,
  simp only [← cancel_mono (F.map (coeq_hom f₁ f₂)), ← F.map_comp],
  exact F.congr_map (coeq_condition f₁ f₂),
end

lemma map_is_iso {j₁ j₂ : J} (g : j₁ ⟶ j₂) (f₁ : index F ⟶ j₁) :
  is_iso (F.map g) :=
is_iso.of_is_iso_fac_left (F.map_comp f₁ g).symm

lemma map_eq {j j' : J} (f₁ f₂ : j ⟶ j') (g : index F ⟶ j') :
  F.map f₁ = F.map f₂ :=
begin
  haveI : is_iso (F.map (coeq_hom f₁ f₂)) := map_is_iso F _ g,
  simp only [← cancel_mono (F.map (coeq_hom f₁ f₂)), ← F.map_comp, coeq_condition],
end

@[simps]
def cocone : cocone F :=
{ X := F.obj (index F),
  ι :=
  { app := λ j, F.map (left_to_max j (index F)) ≫
        category_theory.inv (F.map (right_to_max j (index F))),
    naturality' := λ j j' g, begin
      let k := (is_filtered.max j (index F)),
      let k' := (is_filtered.max j' (index F)),
      let m := is_filtered.max k k',
      have eq := map_from_index_eq F (right_to_max _ _ ≫ (left_to_max _ _ : _ ⟶ m))
        (right_to_max _ _ ≫ (right_to_max _ _ : _ ⟶ m)),
      simp only [F.map_comp] at eq,
      haveI : is_iso (F.map (right_to_max k k')) := map_is_iso F _ (right_to_max _ _),
      erw [const_obj_map, comp_id, ← cancel_mono (F.map (right_to_max _ _ : _ ⟶ k')),
        assoc, assoc, is_iso.inv_hom_id, comp_id, ← cancel_mono (F.map (right_to_max k k')),
        assoc, assoc, assoc, ← eq, is_iso.inv_hom_id_assoc, ← F.map_comp, ← F.map_comp,
        ← F.map_comp],
      exact map_eq F _ _ (right_to_max _ _ ≫ right_to_max _ _),
    end }, }

lemma cocone_ι_app_eq {j : J} (g : index F ⟶ j) :
  (cocone F).ι.app j = category_theory.inv (F.map g) :=
begin
  dsimp,
  let h := coeq_hom (g ≫ left_to_max _ (index F)) (right_to_max _ _),
  haveI : is_iso (F.map h) := map_is_iso F _ (right_to_max _ _),
  simpa only [← cancel_epi (F.map g), is_iso.hom_inv_id, assoc, is_iso.hom_inv_id_assoc,
    ← cancel_mono (F.map (right_to_max j (index F))), is_iso.inv_hom_id, comp_id,
    ← cancel_mono (F.map h), F.map_comp]
    using F.congr_map (coeq_condition (g ≫ left_to_max _ (index F)) (right_to_max _ _)),
end

@[simp]
lemma cocone_ι_app_index :
  (cocone F).ι.app (index F) = 𝟙 _ :=
begin
  simp only [cocone_ι_app_eq F (𝟙 (index F)), F.map_id],
  dsimp,
  simp only [is_iso.inv_id],
end

def cocone_is_colimit : is_colimit (cocone F) :=
{ desc := λ s, s.ι.app (index F),
  fac' := λ s j, begin
    dsimp,
    have eq := s.ι.naturality (right_to_max j (index F)),
    dsimp at eq,
    rw comp_id at eq,
    rw [← eq, assoc, is_iso.inv_hom_id_assoc, cocone.w],
  end,
  uniq' := λ s m hm, by simpa only [cocone_ι_app_index, id_comp] using hm (index F), }

@[priority 100]
instance : has_colimit F :=
⟨⟨⟨_, cocone_is_colimit F⟩⟩⟩

lemma is_iso_cocone_ι_app' (j : J) (g : index F ⟶ j) : is_iso (colimit.ι F j) :=
begin
  haveI : is_iso ((cocone F).ι.app j),
  { rw cocone_ι_app_eq F g,
    apply_instance, },
  exact is_iso.of_is_iso_fac_right
    (limits.colimit.comp_cocone_point_unique_up_to_iso_inv (cocone_is_colimit F) j),
end

lemma is_iso_colimit_ι_app (i : J) (hi : F.is_eventually_constant_from i) :
  is_iso (colimit.ι F i) :=
begin
  haveI : is_iso (F.map (left_to_max i (index F))) := hi _ _,
  haveI : is_iso (colimit.ι F (is_filtered.max i (index F))) :=
    is_iso_cocone_ι_app' _ _ (right_to_max _ _),
  rw ← colimit.w F (left_to_max i (index F)),
  apply_instance,
end

end is_eventually_constant

end

variables {X : ℕ → C} (φ : Π n, X n ⟶ X (n+1))

namespace mk_of_sequence

lemma congr_φ (n n' : ℕ) (h : n = n') :
  φ n = eq_to_hom (by rw h) ≫ φ n' ≫ eq_to_hom (by rw h) :=
by { subst h, simp only [eq_to_hom_refl, comp_id, id_comp], }

def f_aux (n : ℕ) : Π (k : ℕ), X n ⟶ X (n+k)
|0 := eq_to_hom (by rw add_zero)
|(k+1) := f_aux k ≫ φ (n+k) ≫ eq_to_hom (by rw add_assoc)

lemma congr_f_aux (n k k' : ℕ) (h : k = k') :
  f_aux φ n k = f_aux φ n k' ≫ eq_to_hom (by rw h) :=
by { subst h, simp only [eq_to_hom_refl, comp_id], }

lemma congr_f_aux' (n n' k k' : ℕ) (hn : n = n') (hk : k = k') :
  f_aux φ n k = eq_to_hom (by rw hn) ≫ f_aux φ n' k' ≫ eq_to_hom (by rw [hn, hk]) :=
by { substs hn hk, simp only [eq_to_hom_refl, comp_id, id_comp], }

def f (n n' : ℕ) (h : n ≤ n') : X n ⟶ X n' :=
f_aux φ n (n'-n) ≫ eq_to_hom (by { congr', linarith, })

lemma congr_f (n₁ n₂ n₂' : ℕ) (h : n₁ ≤ n₂) (h₂ : n₂ = n₂') :
  f φ n₁ n₂ h = f φ n₁ n₂' (h.trans (by rw h₂)) ≫ eq_to_hom (by rw h₂) :=
by { subst h₂, rw [eq_to_hom_refl, comp_id], }

lemma f_eq_f_aux_comp_eq_to_hom (n n' r : ℕ) (h : n' = n+r) :
  f φ n n' (nat.le.intro h.symm)= f_aux φ n r ≫ eq_to_hom (by rw h) :=
begin
  have hr : r = n'-n := by simp only [h, add_tsub_cancel_left],
  subst hr,
  refl,
end

@[simp]
lemma f_eq_id (n : ℕ) : f φ n n (by refl) = 𝟙 _ :=
begin
  rw f_eq_f_aux_comp_eq_to_hom φ n n 0 (add_zero n).symm,
  dsimp [f_aux],
  rw comp_id,
end

lemma f_comp_next (n₁ n₂ n₃ : ℕ) (h : n₁ ≤ n₂) (hn₃ : n₃ = n₂+1) :
  f φ n₁ n₃ (h.trans (by simpa only [hn₃] using nat.le_succ n₂)) =
    f φ n₁ n₂ h ≫ φ n₂ ≫ eq_to_hom (by rw hn₃) :=
begin
  rw le_iff_exists_add at h,
  obtain ⟨r, rfl⟩ := h,
  rw [f_eq_f_aux_comp_eq_to_hom φ n₁ (n₁+r) r rfl,
    f_eq_f_aux_comp_eq_to_hom φ n₁ n₃ (r+1) (by linarith)],
  unfold f_aux,
  simpa only [eq_to_hom_refl, comp_id, assoc],
end

lemma f_next (n₁ n₂ : ℕ) (h : n₂ = n₁+1) :
  f φ n₁ n₂ (by simpa only [h] using nat.le_succ n₁) = φ n₁ ≫ eq_to_hom (by rw h) :=
by simp only [f_comp_next φ n₁ n₁ n₂ (by refl) h, f_eq_id, id_comp]

lemma f_comp (n₁ n₂ n₃ : ℕ) (h₁₂ : n₁ ≤ n₂) (h₂₃ : n₂ ≤ n₃) :
  f φ n₁ n₂ h₁₂ ≫ f φ n₂ n₃ h₂₃ = f φ n₁ n₃ (h₁₂.trans h₂₃) :=
begin
  rw le_iff_exists_add at h₂₃,
  obtain ⟨r, rfl⟩ := h₂₃,
  induction r with r hr,
  { simp only [congr_f φ n₂ (n₂ + 0) n₂ (by linarith) (add_zero n₂),
      congr_f φ n₁ (n₂ + 0) n₂ (by linarith) (add_zero n₂),
      f_eq_id, eq_to_hom_refl, comp_id], },
  { simp only [f_comp_next φ n₂ (n₂+r) (n₂+r.succ) (by linarith) rfl,
      f_comp_next φ n₁ (n₂+r) (n₂+r.succ) (by linarith) rfl,
      reassoc_of (hr (by linarith))], },
end

lemma is_iso_f (n₁ n₂ : ℕ) (h₁₂ : n₁ ≤ n₂)
  (H : ∀ (p : ℕ) (hp : n₁ ≤ p) (hp' : p < n₂), is_iso (φ p)) :
  is_iso (f φ n₁ n₂ h₁₂) :=
begin
  rw le_iff_exists_add at h₁₂,
  unfreezingI { obtain ⟨r, rfl⟩ := h₁₂, },
  unfreezingI { induction r with r hr, },
  { simp only [congr_f φ n₁ (n₁+0) n₁ (by linarith) (by linarith),
      f_eq_id, eq_to_hom_refl, comp_id],
    apply_instance, },
  { rw congr_f φ n₁ (n₁+r.succ) (n₁+r+1) (by linarith)
      (by { rw nat.succ_eq_add_one, linarith, }),
    rw ← f_comp φ n₁ (n₁+r) (n₁+r+1) (by linarith) (by linarith),
    haveI := H (n₁+r) (by linarith) (by { rw nat.succ_eq_add_one, linarith, }),
    haveI : is_iso (f φ (n₁+r) (n₁+r+1) (by linarith)),
    { rw f_next φ _ _ rfl, apply_instance, },
    haveI := hr (by linarith) (λ p hp hp', H p hp (by { rw nat.succ_eq_add_one, linarith, })),
    apply_instance, },
end

variable (ψ : Π (n₀ n₁ : ℕ) (h : n₁ = n₀+1), X n₀ ⟶ X n₁)

@[simp]
def restriction (n : ℕ) : X n ⟶ X (n+1) := ψ n (n+1) rfl

lemma f_of_restriction (n₀ n₁ : ℕ) (h : n₁ = n₀ + 1) :
  f (restriction ψ) n₀ n₁ (by simpa only [h] using nat.le_succ n₀) = ψ n₀ n₁ h :=
begin
  subst h,
  simp only [restriction, f_next _ n₀ (n₀+1) rfl, eq_to_hom_refl, comp_id],
end

end mk_of_sequence

@[simps]
def mk_of_sequence : ℕ ⥤ C :=
{ obj := X,
  map := λ n₁ n₂ g, mk_of_sequence.f φ n₁ n₂ (le_of_hom g),
  map_id' := mk_of_sequence.f_eq_id _,
  map_comp' := λ n₁ n₂ n₃ g g', (mk_of_sequence.f_comp φ n₁ n₂ n₃ _ _).symm, }

end functor

variables {X Z : C} (f : X ⟶ Z)

structure hom_factorisation :=
(Y : C)
(i : X ⟶ Y)
(p : Y ⟶ Z)
(fac' : i ≫ p = f . obviously)

namespace hom_factorisation

restate_axiom fac'
attribute [simp, reassoc] fac

variables {f} (F₁ F₂ F₃ : hom_factorisation f)

@[ext]
structure hom :=
(τ : F₁.Y ⟶ F₂.Y)
(commi' : F₁.i ≫ τ = F₂.i . obviously)
(commp' : τ ≫ F₂.p = F₁.p . obviously)

namespace hom

restate_axiom commi'
restate_axiom commp'
attribute [simp, reassoc] commi commp

end hom

instance : category (hom_factorisation f) :=
{ hom := hom,
  id := λ F, { τ := 𝟙 _, },
  comp := λ F₁ F₂ F₃ φ φ', { τ := φ.τ ≫ φ'.τ, }, }

variable (f)

def eval : hom_factorisation f ⥤ C :=
{ obj := λ F, F.Y,
  map := λ F₁ F₂ φ, φ.τ, }

variable {f}

@[simp] lemma id_τ (F : hom_factorisation f) : hom.τ (𝟙 F) = 𝟙 _ := rfl
@[simp, reassoc] lemma comp_τ {F₁ F₂ F₃ : hom_factorisation f} (φ : F₁ ⟶ F₂) (φ' : F₂ ⟶ F₃) :
  (φ ≫ φ').τ = φ.τ ≫ φ'.τ := rfl

lemma eq_to_hom_τ {F₁ F₂ : hom_factorisation f} (eq : F₁ = F₂) :
  hom.τ (eq_to_hom eq) = eq_to_hom (by rw eq) := by { subst eq, refl, }

lemma is_iso_τ {F₁ F₂ : hom_factorisation f} (φ : F₁ ⟶ F₂) [is_iso φ] :
  is_iso φ.τ :=
begin
  change is_iso ((eval f).map φ),
  apply_instance,
end

end hom_factorisation

end category_theory

open category_theory

variables [abelian C] [enough_projectives C]

namespace cochain_complex

namespace minus

namespace projective_model_structure

/-namespace CM5b

variables {X Z : minus C} {f : X ⟶ Z}

instance (n : ℤ) [is_iso f] : is_iso (f.f n) :=
begin
  change is_iso ((homological_complex.eval _ _ n).map ((induced_functor _).map f)),
  apply_instance,
end

structure is_cof_fib_factorisation (F : hom_factorisation f) : Prop :=
(hi : arrow_classes.cof F.i)
(hp : arrow_classes.fib F.p)

variable (f)

@[derive category]
def cof_fib_factorisation := full_subcategory (@is_cof_fib_factorisation _ _ _ _ _ _ f)

@[simps]
def cof_fib_factorisation.forget : cof_fib_factorisation f ⥤ hom_factorisation f :=
full_subcategory_inclusion _

@[simps]
def cof_fib_factorisation.eval (n : ℤ) : cof_fib_factorisation f ⥤ C :=
cof_fib_factorisation.forget f ⋙ hom_factorisation.eval f ⋙
  bounded_above_cochain_complex.ι ⋙ (homological_complex.eval C (complex_shape.up ℤ) n)

variable {f}

def cof_fib_factorisation.quasi_iso_ge (F : cof_fib_factorisation f) (n : ℤ) : Prop :=
  ∀ (i : ℤ) (hi : n ≤ i), is_iso (homology_map F.1.p i)

variable (f)

@[derive category]
def cof_fib_factorisation_quasi_iso_ge (n : ℤ) :=
  full_subcategory (λ (F : cof_fib_factorisation f), F.quasi_iso_ge n)

variable {f}

def cof_fib_factorisation.is_iso_ge (F : cof_fib_factorisation f) (n : ℤ) : Prop :=
  ∀ (i : ℤ) (hi : n ≤ i), is_iso (F.1.i.f i)

namespace induction

variables (f) (hf : arrow_classes.fib f)

include hf

lemma step₁ (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (hf' : ∀ (q : ℤ) (hq : n₁ ≤ q), is_iso (homology_map f q)) :
  ∃ (F : cof_fib_factorisation f) (hF₁ : F.is_iso_ge n₁) (hF₂ : F.quasi_iso_ge n₁),
    epi (homology_map (F.1.p) n₀) :=
begin
  let Y : bounded_above_cochain_complex C :=
    ⟨homological_complex.biprod X.1
      ((homological_complex.single C (complex_shape.up ℤ) n₀).obj
        (projective.over (Z.1.cycles n₀))),
    cochain_complex.is_bounded_above.of_biprod _ _ X.2
      (cochain_complex.is_bounded_above.of_is_strictly_le _ n₀)⟩,
  let i : X ⟶ Y := homological_complex.biprod.inl,
  let p : Y ⟶ Z := homological_complex.biprod.desc f
    (cochain_complex.desc_single _ _ ((homological_complex.single_obj_X_self _ _ _ _).hom ≫
    projective.π _ ≫ Z.1.cycles_i n₀) (n₀+1) rfl
      (by simp only [assoc, homological_complex.cycles_i_d, comp_zero])),
  refine
  ⟨⟨{ Y := Y,
    i := i,
    p := p,
    fac' := homological_complex.biprod.inl_desc _ _, },
    { hi := _, hp := _ }⟩, _, _, _⟩,
  { intro n,
    refine ⟨_, _, biprod.snd, ⟨⟨biprod.fst, biprod.inr,
      ⟨biprod.inl_fst, biprod.inr_snd, biprod.inl_snd, biprod.inr_fst, biprod.total⟩⟩⟩⟩,
    by_cases n = n₀,
    { subst h,
      exact projective.of_iso (homological_complex.single_obj_X_self C _ _ _).symm
        infer_instance, },
    { dsimp [homological_complex.single],
      rw if_neg h,
      apply_instance, }, },
  { intro n,
    change epi (p.f n),
    haveI : epi (biprod.inl ≫ p.f n),
    { dsimp [p],
      rw biprod.inl_desc,
      exact hf n, },
    exact epi_of_epi biprod.inl (p.f n), },
  { intros n hn,
    refine ⟨⟨biprod.fst, biprod.inl_fst, eq.symm _⟩⟩,
    dsimp,
    rw [← biprod.total, add_right_eq_self],
    convert comp_zero,
    apply is_zero.eq_of_src,
    rw if_neg,
    { apply is_zero_zero, },
    { linarith, }, },
  { sorry, },
  { sorry, },
end

lemma step₂ (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (hf' : ∀ (q : ℤ) (hq : n₁ ≤ q), is_iso (homology_map f q))
  (hf'' : epi (homology_map f n₀)) :
  ∃ (F : cof_fib_factorisation f) (hF₁ : F.is_iso_ge n₀),
    F.quasi_iso_ge n₀ := sorry

lemma step₁₂ (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (hf' : ∀ (q : ℤ) (hq : n₁ ≤ q), is_iso (homology_map f q)) :
  ∃ (F : cof_fib_factorisation f) (hF : F.is_iso_ge n₁),
    F.quasi_iso_ge n₀ :=
begin
  obtain ⟨F₁, hF₁, hF₂, hp⟩ := step₁ f hf n₀ n₁ hn₁ hf',
  obtain ⟨F₂, hF₂, hF₂'⟩ := step₂ F₁.1.p F₁.2.hp n₀ n₁ hn₁ hF₂ hp,
  let F : cof_fib_factorisation f :=
  ⟨{ Y := F₂.1.Y,
    i := F₁.1.i ≫ F₂.1.i,
    p := F₂.1.p, },
  { hi := cof_stable_under_composition _ _ F₁.2.hi F₂.2.hi,
    hp := F₂.2.hp, }⟩,
  refine ⟨F, _, hF₂'⟩,
  { intros i hi,
    dsimp [F],
    haveI := hF₁ i hi,
    haveI : is_iso (F₂.obj.i.f i) := hF₂ i (by linarith),
    erw homological_complex.comp_f,
    apply_instance, },
end

lemma step' (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (F : cof_fib_factorisation_quasi_iso_ge f n₁) :
  ∃ (F' : cof_fib_factorisation_quasi_iso_ge f n₀) (φ : F.obj.obj ⟶ F'.obj.obj),
    ∀ (i : ℤ) (hi : n₁ ≤ i), is_iso ((hom_factorisation.hom.τ φ).f i) :=
begin
  obtain ⟨G, hG, hG'⟩ := step₁₂ F.1.1.p F.1.2.hp n₀ n₁ hn₁ F.2,
  let F' : cof_fib_factorisation f :=
  ⟨{ Y := G.1.Y,
    i :=  F.1.1.i ≫ G.1.i,
    p := G.1.p, },
  { hi := cof_stable_under_composition _ _ F.1.2.hi G.2.hi,
    hp := G.2.hp, }⟩,
  exact ⟨⟨F', hG'⟩, { τ := G.1.i, }, hG⟩,
end

variables {n₀ : ℤ} (F₀ : cof_fib_factorisation_quasi_iso_ge f n₀)

def step (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (F₁ : cof_fib_factorisation_quasi_iso_ge f n₁) :
  cof_fib_factorisation_quasi_iso_ge f n₀ :=
(step' f hf n₀ n₁ hn₁ F₁).some

def step_map (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (F₁ : cof_fib_factorisation_quasi_iso_ge f n₁) :
  F₁.obj.obj ⟶ (step f hf n₀ n₁ hn₁ F₁).obj.obj :=
(step' f hf n₀ n₁ hn₁ F₁).some_spec.some

lemma is_iso_step_map_τ_f (n₀ n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (F₁ : cof_fib_factorisation_quasi_iso_ge f n₁) (i : ℤ) (hi : n₁ ≤ i) :
  is_iso ((hom_factorisation.hom.τ (step_map f hf n₀ n₁ hn₁ F₁)).f i) :=
(step' f hf n₀ n₁ hn₁ F₁).some_spec.some_spec i hi

noncomputable def sequence : Π (k : ℕ), cof_fib_factorisation_quasi_iso_ge f (n₀-k)
| 0 := ⟨F₀.1, λ i hi, F₀.2 i (by simpa using hi)⟩
| (k+1) := step f hf _ _ (by { simp only [nat.cast_add, algebra_map.coe_one],linarith, })
    (sequence k)

def sequence_next_step_iso (k₀ k₁ : ℕ) (h : k₁ = k₀ + 1) :
  (step f hf (n₀ - ↑k₁) (n₀ - ↑k₀) (by { subst h, simp only [nat.cast_add,
    algebra_map.coe_one, sub_add_eq_sub_sub, sub_add_cancel], })
    (sequence f hf F₀ k₀)).obj ≅
  (sequence f hf F₀ k₁).obj :=
eq_to_iso (by { subst h, unfold sequence, })

instance (k₀ k₁ : ℕ) (h : k₁ = k₀ + 1) :
  is_iso ((sequence_next_step_iso f hf F₀ k₀ k₁ h).hom.τ) :=
is_iso.of_iso ((cof_fib_factorisation.forget f ⋙
  hom_factorisation.eval f).map_iso (sequence_next_step_iso f hf F₀ k₀ k₁ h))

lemma congr_sequence_obj (k k' : ℕ) (h : k = k') :
  (sequence f hf F₀ k).obj = (sequence f hf F₀ k').obj :=
by subst h

def sequence_map_next (k₀ k₁ : ℕ) (h : k₁ = k₀ + 1) :
  (sequence f hf F₀ k₀).obj ⟶ (sequence f hf F₀ k₁).obj :=
step_map f hf (n₀-k₁) (n₀-k₀) (by linarith) _ ≫
  (sequence_next_step_iso f hf F₀ k₀ k₁ h).hom

lemma is_iso_sequence_map_next_τ_f (k₀ k₁ : ℕ )(h : k₁ = k₀ + 1) (n : ℤ) (hn : n₀ - k₀ ≤ n) :
  is_iso ((sequence_map_next f hf F₀ k₀ k₁ h).τ.f n) :=
begin
  unfold sequence_map_next,
  haveI := is_iso_step_map_τ_f f hf (n₀-k₁) _ (by linarith) (sequence f hf F₀ k₀) n hn,
  erw [homological_complex.comp_f],
  apply_instance,
end

def inductive_system : ℕ ⥤ cof_fib_factorisation f :=
functor.mk_of_sequence (functor.mk_of_sequence.restriction (sequence_map_next f hf F₀))

def inductive_system' : ℕ ⥤ cochain_complex C ℤ :=
inductive_system f hf F₀ ⋙ cof_fib_factorisation.forget f ⋙ hom_factorisation.eval f ⋙
  bounded_above_cochain_complex.ι

lemma is_iso_inductive_system'_comp_eval_map_next (k₀ k₁ : ℕ ) (h : k₁ = k₀ + 1) (n : ℤ)
  (hn : n₀ - k₀ ≤ n) :
  is_iso ((inductive_system' f hf F₀ ⋙ homological_complex.eval C (complex_shape.up ℤ) n).map
    (hom_of_le (nat.le.intro h.symm))) :=
begin
  dsimp [inductive_system', inductive_system, hom_factorisation.eval, ι],
  rw [functor.mk_of_sequence.f_next _ k₀ k₁ h],
  simp only [functor.mk_of_sequence.restriction, functor.map_comp, eq_to_hom_map,
    hom_factorisation.comp_τ, hom_factorisation.eq_to_hom_τ],
  erw [homological_complex.comp_f, hom_factorisation.eq_to_hom_τ,
    homological_complex.eq_to_hom_f],
  { haveI := is_iso_sequence_map_next_τ_f f hf F₀ k₀ _ rfl n hn,
    apply_instance, },
  all_goals { rw congr_sequence_obj, linarith, },
end

lemma is_iso_inductive_system'_comp_eval_map (k₀ k₁ : ℕ) (h : k₀ ≤ k₁) (n : ℤ)
  (hn : n₀ - k₀ ≤ n) :
  is_iso ((inductive_system' f hf F₀ ⋙ homological_complex.eval C (complex_shape.up ℤ) n).map
    (hom_of_le h)) :=
begin
  rw le_iff_exists_add at h,
  obtain ⟨r, rfl⟩ := h,
  induction r with r hr,
  { haveI : is_iso (hom_of_le h) :=
      ⟨⟨hom_of_le (by refl), subsingleton.elim _ _ , subsingleton.elim _ _⟩⟩,
    apply_instance, },
  { have h₁ : k₀ ≤ k₀ + r := by linarith,
    have h₂ : k₀ + r ≤ k₀ + r.succ := by { rw nat.succ_eq_add_one, linarith, },
    have eq : _ = hom_of_le h := hom_of_le_comp h₁ h₂,
    simp only [← eq, functor.map_comp],
    exact @is_iso.comp_is_iso _ _ _ _ _ _ _ (hr h₁)
      (is_iso_inductive_system'_comp_eval_map_next f hf F₀ (k₀+r) (k₀+r.succ)
          (by { rw nat.succ_eq_add_one, linarith, }) _
          (by { simp only [nat.cast_add, tsub_le_iff_right], linarith, })), },
end

lemma inductive_system'_comp_eval_is_eventually_constant_from (n : ℤ) :
  ((inductive_system' f hf F₀) ⋙
    homological_complex.eval _ _ n).is_eventually_constant_from (n₀-n).truncate :=
λ p hp, is_iso_inductive_system'_comp_eval_map _ _ _ _ _ (le_of_hom hp) _
  (by linarith [int.self_le_coe_truncate (n₀-n)])

instance inductive_system'_comp_eval_is_eventually_constant (n : ℤ) :
  ((inductive_system' f hf F₀) ⋙
    homological_complex.eval _ _ n).is_eventually_constant :=
⟨⟨_, inductive_system'_comp_eval_is_eventually_constant_from f hf F₀ n⟩⟩

lemma is_iso_colimit_ι_inductive_system'_f (k : ℕ) (n : ℤ) (hn : n₀-k ≤ n) :
  is_iso ((colimit.ι (inductive_system' f hf F₀) k).f n) :=
begin
  have ineq : (n₀-n).truncate ≤ k,
  { by_cases n ≤ n₀,
    { simp only [← int.coe_nat_le_coe_nat_iff, int.coe_truncate (n₀-n) (by linarith)],
      linarith, },
    { simpa only [int.truncate_eq_zero (n₀-n) (by linarith)] using zero_le', }, },
  haveI := functor.is_eventually_constant.is_iso_colimit_ι_app
    ((inductive_system' f hf F₀) ⋙ homological_complex.eval _ _ n) k
    (functor.is_eventually_constant_from.of_map _
      (hom_of_le ineq) (inductive_system'_comp_eval_is_eventually_constant_from f hf F₀ n)),
  exact is_iso.of_is_iso_fac_right ((ι_preserves_colimits_iso_hom (homological_complex.eval _ _ n)
      (inductive_system' f hf F₀) k)),
end

@[simps]
def factorisation_Y : bounded_above_cochain_complex C :=
⟨colimit (inductive_system' f hf F₀),
begin
  obtain ⟨ny, hny⟩ := F₀.obj.obj.Y.2,
  have h₂ := le_max_right ny n₀,
  refine ⟨max ny n₀, λ i hi, _⟩,
  haveI := is_iso_colimit_ι_inductive_system'_f f hf F₀ 0 i
    (by simpa only [algebra_map.coe_zero, tsub_zero]
      using (lt_of_le_of_lt (le_max_right _ _) hi).le),
  exact limits.is_zero.of_iso (hny _ (lt_of_le_of_lt (le_max_left _ _) hi))
    (as_iso ((limits.colimit.ι (inductive_system' f hf F₀) 0).f i)).symm,
end⟩

@[simps]
def factorisation_i : X ⟶ factorisation_Y f hf F₀ :=
F₀.obj.obj.i ≫ colimit.ι (inductive_system' f hf F₀) 0

@[simp]
def factorisation_p : factorisation_Y f hf F₀ ⟶ Z :=
colimit.desc (inductive_system' f hf F₀) (cocone.mk Z.obj
{ app := λ n, ((inductive_system f hf F₀).obj n).obj.p,
  naturality' := λ n n' φ, begin
    dsimp,
    rw comp_id,
    exact ((inductive_system f hf F₀).map φ).commp,
  end, })

@[simps]
def factorisation : cof_fib_factorisation f :=
⟨{ Y := factorisation_Y f hf F₀,
  i := factorisation_i f hf F₀,
  p := factorisation_p f hf F₀,
  fac' := begin
    dsimp only [factorisation_i, factorisation_p],
    simp only [assoc],
    erw colimit.ι_desc,
    dsimp only,
    exact ((inductive_system f hf F₀).obj 0).1.fac,
  end, },
  { hi := λ n, begin
      let k := (n₀-n).truncate,
      dsimp [ι],
      haveI := is_iso_colimit_ι_inductive_system'_f f hf F₀ k n
        (by linarith [int.self_le_coe_truncate (n₀-n)]),
      have eq : F₀.obj.obj.i.f n ≫ (limits.colimit.ι (inductive_system' f hf F₀) 0).f n =
        ((inductive_system f hf F₀).obj k).obj.i.f n ≫
        (limits.colimit.ι (inductive_system' f hf F₀) k).f n,
      { simpa only [← homological_complex.comp_f,
          ← colimit.w (inductive_system' f hf F₀) (hom_of_le (zero_le' : 0 ≤ k)), ← assoc,
          ← ((inductive_system f hf F₀).map (hom_of_le (zero_le' : 0 ≤ k))).commi],},
      rw eq,
      exact preadditive.mono_with_projective_coker.is_stable_by_composition
        _ _ _ (((inductive_system f hf F₀).obj k).2.hi n)
          (preadditive.mono_with_projective_coker.of_is_iso _),
    end,
    hp := λ n, begin
      dsimp [ι],
      let k := (n₀-n).truncate,
      haveI := is_iso_colimit_ι_inductive_system'_f f hf F₀ k n
        (by linarith [int.self_le_coe_truncate (n₀-n)]),
      rw [← epi_comp_left_iff_epi ((limits.colimit.ι (inductive_system' f hf F₀) k).f n),
        ← homological_complex.comp_f, colimit.ι_desc],
      exact ((inductive_system f hf F₀).obj k).2.hp n,
    end, }⟩

lemma quasi_iso_factorisation_p (n : ℤ) :
  quasi_iso (ι.map (factorisation f hf F₀).1.p) :=
⟨λ n, begin
  let k := (n₀+1-n).truncate,
  have hk := int.self_le_coe_truncate (n₀+1-n),
  have eq : homology_map (colimit.ι (inductive_system' f hf F₀) k) n ≫
    homology_map (factorisation f hf F₀).obj.p n =
      homology_map ((inductive_system f hf F₀).obj k).obj.p n,
  { rw ← homology_map_comp,
    congr' 1,
    apply colimit.ι_desc _ _, },
  haveI : is_iso (homology_map ((inductive_system f hf F₀).obj k).obj.p n) :=
    (sequence f hf F₀ k).2 n (by linarith),
  haveI : is_iso (homology_map (limits.colimit.ι (inductive_system' f hf F₀) k) n),
  { let φ := (homological_complex.short_complex_functor C _ n).map
      ((limits.colimit.ι (inductive_system' f hf F₀) k)),
    change is_iso ((short_complex.homology_functor C).map φ),
    haveI : is_iso φ.τ₁,
    { apply is_iso_colimit_ι_inductive_system'_f,
      rw cochain_complex.prev,
      linarith, },
    haveI : is_iso φ.τ₂,
    { apply is_iso_colimit_ι_inductive_system'_f,
      linarith, },
    haveI : is_iso φ.τ₃,
    { apply is_iso_colimit_ι_inductive_system'_f,
      rw cochain_complex.next,
      linarith, },
    haveI := short_complex.is_iso_of_isos φ,
    apply_instance, },
  exact is_iso.of_is_iso_fac_left eq,
end⟩

end induction

lemma for_fibration {X Z : bounded_above_cochain_complex C} (f : X ⟶ Z)
  (hf : arrow_classes.fib f) :
  ∃ (Y : bounded_above_cochain_complex C) (i : X ⟶ Y)
    (hi : arrow_classes.cof i) (p : Y ⟶ Z)
    (hp : arrow_classes.triv_fib p), f = i ≫ p :=
begin
  obtain ⟨nx, hnx⟩ := X.2,
  obtain ⟨ny, hny⟩ := Z.2,
  haveI : X.obj.is_strictly_le nx := ⟨hnx⟩,
  haveI : Z.obj.is_strictly_le ny := ⟨hny⟩,
  let n₀ := max (nx+1) (ny+1),
  have hnx' : nx + 1 ≤ n₀ := le_max_left _ _,
  have hny' : ny + 1 ≤ n₀ := le_max_right _ _,
  let F₀ : cof_fib_factorisation_quasi_iso_ge f n₀ :=
  ⟨⟨{ Y := X,
    i := 𝟙 _,
    p := f, },
  { hi := λ n, preadditive.mono_with_projective_coker.id_mem _,
    hp := hf, }⟩,
    λ i hi, ⟨⟨0,
      limits.is_zero.eq_of_src (cochain_complex.is_le.is_zero _ nx _ (by linarith)) _ _,
      limits.is_zero.eq_of_src (cochain_complex.is_le.is_zero _ ny _ (by linarith)) _ _⟩⟩⟩,
  let F := induction.factorisation f hf F₀,
  exact ⟨_, _, F.2.hi, _,
    ⟨F.2.hp,
      ⟨λ n, by { haveI := induction.quasi_iso_factorisation_p f hf F₀ n, apply_instance, }⟩⟩,
    F.1.fac.symm⟩,
end

end CM5b-/

lemma CM5b' {X Z : minus C} (f : X ⟶ Z) (n : ℤ) [X.obj.is_strictly_le n]
  [Z.obj.is_strictly_le n] : ∃ (Y : minus C)
  (hY : Y.obj.is_strictly_le n) (i : X ⟶ Y) (p : Y ⟶ Z)
  (hi : (arrow_classes C).cof i) (hp : (arrow_classes C).triv_fib p), i ≫ p = f := sorry
  --obtain ⟨X', j, hj, q, hq, rfl⟩ := projective_model_structure.CM5a f,
  --obtain ⟨Y, i, hi, p, hp, rfl⟩ := CM5b.for_fibration q hq,
  --exact ⟨Y, j ≫ i, cof_stable_under_composition j i hj.1 hi, p, hp, by rw assoc⟩,

lemma CM5b : (arrow_classes C).CM5b :=
λ X Z f, begin
  obtain ⟨nX, hX⟩ := X.property,
  obtain ⟨nZ, hZ⟩ := Z.property,
  haveI := hX,
  haveI := hZ,
  let n := max nX nZ,
  haveI : X.obj.is_strictly_le n := is_strictly_le_of_le _ _ _ (le_max_left _ _),
  haveI : Z.obj.is_strictly_le n := is_strictly_le_of_le _ _ _ (le_max_right _ _),
  obtain ⟨Y, hY, i, p, hi, hp, fac⟩ := CM5b' f n,
  exact ⟨Y, i, hi, p, hp, fac⟩,
end

lemma CM5 : (arrow_classes C).CM5 :=
  ⟨CM5a, CM5b⟩

end projective_model_structure

end minus

end cochain_complex