import for_mathlib.imker

noncomputable theory

open category_theory category_theory.limits

namespace cochain_complex

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
variables (C : cochain_complex 𝓐 ℤ)

open_locale zero_object

--This should be the canonical truncation functor `τ_{≤n}` for cochain complexes.
--It is the functor (3) in the second set of truncation functors on this page:
--https://stacks.math.columbia.edu/tag/0118

/-- The "canonical truncation" of a cochain complex (Cⁱ) at an integer `n`,
defined as ... ⟶ Cⁿ⁻² ⟶ Cⁿ⁻¹ ⟶ ker(d : Cⁿ ⟶ Cⁿ⁺¹) ⟶ 0 ⟶ 0 ⟶ ..., with the kernel
in degree `n`. -/
def truncation (C : cochain_complex 𝓐 ℤ) (n : ℤ) : cochain_complex 𝓐 ℤ :=
{ X := λ i, if i < n
    then C.X i
    else if i = n
      then kernel (C.d n (n+1))
      else 0,
  d := λ i j, if hi : i + 1 = j -- (complex_shape.up ℤ).rel i j
    then if hj : j < n
      then eq_to_hom (by rw if_pos (lt_trans (show i < j, by linarith) hj)) ≫ C.d i j ≫ eq_to_hom (by rw if_pos hj)
      else if hj_eq : j = n
        then eq_to_hom (by rw if_pos (show i < n, by linarith)) ≫
          eq_to_hom (by rw (show i = n - 1, by linarith)) ≫
          (kernel.lift (C.d n (n+1)) (C.d (n-1) n) (C.d_comp_d (n-1) n (n+1)) : C.X (n-1) ⟶ kernel (C.d n (n+1))) ≫
          eq_to_hom (by rw [if_neg hj, if_pos hj_eq])
        else 0
    else 0,
  shape' := λ i j, begin
    rintro h : ¬ (i + 1) = j,
    rw dif_neg h,
  end,
  d_comp_d' := λ i j k, begin
    rintro (rfl : i + 1 = j) (rfl : i + 1 + 1 = k),
    rw dif_pos rfl,
    by_cases hin : i + 1 < n,
    { rw dif_pos hin,
      rw dif_pos rfl,
      by_cases hin' : i + 1 + 1 < n,
      { rw dif_pos hin',
        simp only [category.assoc, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp,
          homological_complex.d_comp_d_assoc, zero_comp, comp_zero], },
      { rw dif_neg hin',
        have hn : n = i + 1 + 1, linarith,
        subst hn,
        rw dif_pos rfl,
        simp only [eq_to_hom_trans_assoc, category.assoc, preadditive.is_iso.comp_left_eq_zero],
        rw [← category.assoc, ← category.assoc, comp_mono_zero_iff],
        ext,
        simp, } },
    { rw dif_neg hin,
      by_cases hn : i + 1 = n,
      { rw [dif_pos hn, dif_pos rfl, dif_neg (show ¬ i + 1 + 1 < n, by linarith),
          dif_neg (show ¬ i + 1 + 1 = n, by linarith), comp_zero], },
      { rw [dif_neg hn, zero_comp], } },
  end }

namespace truncation

@[reducible] def X_iso_of_lt {i n : ℤ} (h : i < n) : (C.truncation n).X i ≅ C.X i :=
eq_to_iso (by simp [truncation, if_pos h] )

-- don't know whether to go for kernel of d_n or of d_i!
@[reducible] def X_iso_of_eq {i n : ℤ} (h : i = n) : (C.truncation n).X i ≅ kernel (C.d n (n+1)) :=
eq_to_iso (by subst h; simp [truncation, if_neg (show ¬ i < i, by linarith)] )

@[reducible] def X_iso_of_eq' {i n : ℤ} (h : i = n) : (C.truncation n).X i ≅ kernel (C.d i (i+1)) :=
eq_to_iso (by subst h; simp [truncation, if_neg (show ¬ i < i, by linarith)] )

lemma is_zero_X_of_lt {i n : ℤ} (h : n < i) : is_zero ((C.truncation n).X i) :=
begin
  simp [truncation, if_neg (show ¬ i < n, by linarith), if_neg (show ¬ i = n, by linarith),
    is_zero_zero],
end

lemma bounded_by (n : ℤ) :
  ((homotopy_category.quotient _ _).obj (C.truncation n)).bounded_by (n+1) :=
begin
  intros i hi,
  dsimp only [homotopy_category.quotient_obj_as, truncation],
  rw [if_neg, if_neg],
  { apply is_zero_zero, },
  { linarith },
  { linarith }
end

instance is_bounded_above (n : ℤ) :
  ((homotopy_category.quotient _ _).obj (C.truncation n)).is_bounded_above :=
⟨⟨n+1, bounded_by C n⟩⟩

def ι (n : ℤ) : C.truncation n ⟶ C :=
{ f := λ i, if hin : i < n
    then (X_iso_of_lt C hin).hom
    else if hi : i = n
      then (X_iso_of_eq C hi).hom ≫ kernel.ι _ ≫ eq_to_hom (by rw hi)
      else 0,
  comm' := λ i j, begin
    rintro (rfl : i + 1 = j),
    dsimp only [truncation],
    simp only [eq_self_iff_true, eq_to_hom_trans_assoc, dif_pos],
    by_cases hiltn : i < n,
    { rw dif_pos hiltn,
      by_cases hi1ltn : i + 1 < n,
      { rw [dif_pos hi1ltn, dif_pos hi1ltn],
        simp,
        refl, },
      { have hn : i + 1 = n, linarith,
        subst hn,
        rw [dif_neg hi1ltn, dif_neg hi1ltn],
        rw [dif_pos rfl, dif_pos rfl ],
        simp only [eq_to_iso.hom, eq_to_hom_refl, category.comp_id, category.assoc,
          eq_to_hom_trans_assoc, category.id_comp, kernel.lift_ι],
        congr'; linarith, } },
    { rw dif_neg hiltn,
      by_cases hin : i = n,
      { subst hin,
        simp, },
      { rw dif_neg hin,
        rw dif_neg (show ¬ i + 1 < n, by linarith),
        rw dif_neg (show ¬ i + 1 = n, by linarith),
        simp, } },
  end }

def ι_inv (n : ℤ) (hn : is_zero (C.X (n + 1))) : C ⟶ C.truncation n :=
{ f := λ i, if hin : i < n
    then (X_iso_of_lt C hin).inv
    else if hi : i = n
      then (eq_to_hom (by rw hi) : C.X i ⟶ C.X n) ≫
        kernel.lift (C.d n (n+1)) (𝟙 (C.X n)) (hn.eq_zero_of_tgt _) ≫
        (X_iso_of_eq C hi).inv
      else 0,
  comm' := λ i j, begin
    rintro (rfl : i + 1 = j),
    dsimp only [truncation],
    simp only [eq_self_iff_true, eq_to_iso.inv, eq_to_hom_trans_assoc, dif_pos],
    by_cases hiltn : i < n,
    { rw dif_pos hiltn,
      by_cases hi1ltn : i + 1 < n,
      { simp [dif_pos hi1ltn], },
      { have hi1n : i + 1 = n, linarith,
        subst hi1n,
        simp only [eq_self_iff_true, add_left_inj, lt_self_iff_false, not_false_iff, dif_pos,
          dif_neg, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp, ← category.assoc],
        congr' 1,
        ext,
        simp, } },
    { rw dif_neg hiltn,
      by_cases hin : i = n,
      { simp [hin], },
      { rw [dif_neg hin, zero_comp],
        rw dif_neg (show ¬ i + 1 < n, by linarith),
        rw [dif_neg (show ¬ i + 1 = n, by linarith), comp_zero], }, },
  end }

lemma ι_iso (n : ℤ) (hC : ((homotopy_category.quotient _ _).obj C).bounded_by (n+1)) :
  is_iso (truncation.ι C n) :=
{ out := ⟨ι_inv C n (hC (n+1) (by refl)),
  by {
    ext i,
    simp only [homological_complex.comp_f, homological_complex.id_f, ι, ι_inv, eq_to_iso.hom,
      eq_to_iso.inv],
    by_cases hiltn : i < n,
    { simp [dif_pos hiltn], },
    { rw [dif_neg hiltn, dif_neg hiltn],
      by_cases hin : i = n,
      { subst hin,
        simp only [eq_self_iff_true, eq_to_hom_refl, dif_pos, category.id_comp, category.assoc],
        rw ← category.assoc (kernel.ι (C.d i (i + 1))),
        suffices : kernel.ι (C.d i (i + 1)) ≫ kernel.lift (C.d i (i + 1)) (𝟙 (C.X i)) _ = 𝟙 _,
        { simp [this] },
        { ext,
          simp },
        { apply is_zero.eq_zero_of_tgt,
          simpa using hC (i + 1) (by refl), } },
      { apply is_zero.eq_of_tgt,
        apply is_zero_X_of_lt,
        push_neg at hiltn,
        obtain (h1 | h2) := lt_or_eq_of_le hiltn,
        { exact h1 },
        { exact (hin h2.symm).elim, } } } },
  begin
    ext i,
    simp only [ι, ι_inv, eq_to_iso.inv, eq_to_iso.hom, homological_complex.comp_f,
      homological_complex.id_f],
        by_cases hiltn : i < n,
    { simp [dif_pos hiltn], },
    { rw [dif_neg hiltn, dif_neg hiltn],
      by_cases hin : i = n,
      { subst hin,
        simp only [eq_to_hom_refl, category.id_comp, dif_pos, category.comp_id, category.assoc,
          eq_to_hom_trans_assoc, kernel.lift_ι], },
      { apply is_zero.eq_of_tgt,
        simpa using hC i _,
        push_neg at hiltn,
        obtain (h1 | h2) := lt_or_eq_of_le hiltn,
        { exact int.add_one_le_iff.mpr h1, },
        { exact (hin h2.symm).elim, } } }
  end⟩ }

/-- The obvious "inclusion" from the m'th truncation to the n'th, if m<=n. -/
def map_of_le (m n : ℤ) (h : m ≤ n) : C.truncation m ⟶ C.truncation n :=
{ f := λ i, if him : i < m
    then (X_iso_of_lt C him).hom ≫
      (X_iso_of_lt C (lt_of_lt_of_le him h)).inv -- id
    else if him' : i = m -- domain is ker(d)
      then if hin : i < n
        then (X_iso_of_eq C him').hom ≫ kernel.ι _ ≫
          (eq_to_hom (by rw him') : C.X m ⟶ C.X i) ≫ (X_iso_of_lt C hin).inv -- kernel.ι
        else (X_iso_of_eq' C him').hom ≫ (X_iso_of_eq' C (by linarith : i = n)).inv -- identity
      else 0,
  comm' := λ i j, begin
    rintro (rfl : _ = _),
    delta truncation,
    dsimp only [zero_add, neg_zero, add_zero, zero_lt_one, neg_neg, neg_eq_zero, homological_complex.d_comp_d, dif_neg, dif_pos,
  category.assoc, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp, homological_complex.d_comp_d_assoc,
  zero_comp, comp_zero, preadditive.is_iso.comp_left_eq_zero, comp_mono_zero_iff,
  homological_complex.d_comp_eq_to_hom, add_tsub_cancel_right, complex_shape.up_rel, add_left_inj, eq_self_iff_true,
  equalizer_as_kernel, kernel.lift_ι, mul_one],
    simp only [eq_self_iff_true, eq_to_iso.hom, eq_to_iso.inv, eq_to_hom_trans, eq_to_hom_trans_assoc, dif_pos],
    by_cases him : i < m,
    { rw dif_pos him,
      by_cases hi1n : i + 1 < n,
      { rw dif_pos hi1n,
        by_cases hi1m : i + 1 < m,
        { simp [dif_pos hi1m], },
        { have hm : i + 1 = m, linarith,
          subst hm,
          rw [dif_neg hi1m, dif_pos rfl, dif_neg hi1m, dif_pos rfl, dif_pos hi1n],
          simp only [eq_to_hom_trans_assoc, category.assoc, eq_to_hom_refl, category.id_comp, kernel.lift_ι_assoc],
          congr';
          ring,
        }
      },
      { rw dif_neg hi1n,
        have hn : i + 1 = n, linarith,
        subst hn,
        have hm : m = i + 1, linarith,
        subst hm,
        simp, } },
    { rw dif_neg him,
      by_cases hm : i = m,
      { subst hm,
        rw [dif_pos rfl, dif_neg (show ¬ (i + 1) < i, by linarith),
          dif_neg (show ¬ i + 1 = i, by linarith), zero_comp],
        obtain (hn | rfl) := lt_or_eq_of_le h,
        { rw dif_pos hn,
          by_cases hi1n : i + 1 < n,
          { rw dif_pos hi1n,
            simp, },
          { rw dif_neg hi1n,
            have hn2 : i + 1 = n, linarith,
            subst hn2,
            simp,
            have hi : eq_to_hom _ ≫ kernel.lift (C.d (i + 1) (i + 1 + 1)) (C.d (i + 1 - 1) (i + 1)) _ = kernel.lift (C.d (i + 1) (i + 1 + 1)) (C.d i (i + 1)) _,
            { ext, simp, },
            rw [← category.assoc (eq_to_hom _), hi],
            swap, apply C.d_comp_d,
            rw ← category.assoc,
            convert zero_comp,
            ext, simp, } },
        { rw [dif_neg him, dif_neg (show ¬ i + 1 < i, by linarith),
            dif_neg (show i + 1 ≠ i, by linarith), comp_zero], }
      },
      { rw [dif_neg hm, zero_comp, dif_neg (show ¬ i + 1 < m, by linarith),
          dif_neg (show i + 1 ≠ m, by linarith), zero_comp],
      } }
  end }
.

def ι_succ (n : ℤ) : C.truncation n ⟶ C.truncation (n+1) :=
truncation.map_of_le _ _ _ $ by simp only [le_add_iff_nonneg_right, zero_le_one]

lemma ι_succ_f_self {n : ℤ} :
  (ι_succ C n).f n = (X_iso_of_eq C (rfl : n = n)).hom ≫
    kernel.ι (C.d n (n + 1)) ≫ (X_iso_of_lt C (by simp)).inv :=
by simp [ι_succ, map_of_le]

--move
lemma _root_.homological_complex.d_from_eq_d_comp_X_next_iso_inv {ι V : Type*} [category V]
  [has_zero_morphisms V] {c : complex_shape ι} (C : homological_complex V c)
    {i j : ι} (r : c.rel i j) :
  C.d_from i = C.d i j ≫ (C.X_next_iso r).inv :=
by simp [C.d_from_eq r]

--- move
@[simp, reassoc] lemma _root_.category_theory.limits.eq_to_hom_comp_image.ι {C : Type*} [category C] {X Y : C} {f f' : X ⟶ Y}
  [has_image f] [has_image f'] [has_equalizers C] (h : f = f') :
(eq_to_hom (by simp_rw h)) ≫ image.ι f' = image.ι f :=
begin
  unfreezingI {subst h},
  simp,
end

--- move
@[simp, reassoc] lemma _root_.category_theory.limits.eq_to_hom_comp_kernel.ι {C : Type*}
  [category C] [abelian C] {X Y : C} {f f' : X ⟶ Y} (h : f = f') :
(eq_to_hom (by simp_rw h)) ≫ kernel.ι f' = kernel.ι f :=
begin
  unfreezingI {subst h},
  simp,
end

-- move
attribute [reassoc] homological_complex.d_comp_eq_to_hom

-- move
lemma _root_.category_theory.limits.factor_thru_image_of_eq {A B : 𝓐} {f f' : A ⟶ B} (h : f = f') :
factor_thru_image f ≫ (eq_to_hom (by rw h)) = factor_thru_image f' :=
begin
  subst h,
  simp,
end

-- lemma _root_.category_theory.limits.factor_thru_image_comp {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) :
--   factor_thru_image (f ≫ g) ≫ image.pre_comp f g = f ≫ factor_thru_image g :=
-- begin
--   exact image.factor_thru_image_pre_comp f g
-- end

lemma _root_.category_theory.limits.factor_thru_image_iso_comp {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C)
  [is_iso f] : factor_thru_image (f ≫ g) = f ≫ factor_thru_image g ≫ inv (image.pre_comp f g):=
by simp [← image.factor_thru_image_pre_comp_assoc]

-- move
@[ext] lemma image.ι.hom_ext {A B X : 𝓐} (f : A ⟶ B) (s t : X ⟶ image f)
  (h : s ≫ image.ι f = t ≫ image.ι f) : s = t :=
by rwa cancel_mono at h

-- move
@[reassoc] lemma comp_factor_thru_image_eq_zero {A B C : 𝓐} {f : A ⟶ B} {g : B ⟶ C}
  (w : f ≫ g = 0) : f ≫ factor_thru_image g = 0 :=
begin
  ext,
  simp [w],
end

@[simp, reassoc] lemma kernel_ι_comp_factor_thru_image {A B : 𝓐} {f : A ⟶ B} :
kernel.ι f ≫ factor_thru_image f = 0 :=
comp_factor_thru_image_eq_zero (kernel.condition f)

def to_imker (n : ℤ) : C.truncation n ⟶ imker C n :=
{ f := λ i, if hi : i = n - 1
           then (X_iso_of_lt C (show i < n, by linarith)).hom ≫ eq_to_hom (by rw hi) ≫
           factor_thru_image (C.d (n-1) n) ≫
           (eq_to_hom (by { rw ← C.X_prev_iso_comp_d_to, show (n - 1) + 1 = n, ring, })) ≫
             image.pre_comp (C.X_prev_iso (show (n - 1) + 1 = n, by ring)).inv (C.d_to n) ≫
             (imker.X_iso_image_of_eq C hi).inv -- C(n-1) ⟶ Im(d^{n-1})
           else if hn : i = n
             then (X_iso_of_eq C hn).hom ≫
             kernel.lift (C.d n (n+1) ≫ (C.X_next_iso (show n + 1 = n + 1, from rfl)).inv) (kernel.ι _) (by {rw [← category.assoc, kernel.condition, zero_comp]}) ≫
             eq_to_hom begin simp_rw ← C.d_from_eq_d_comp_X_next_iso_inv, end ≫
             (imker.kernel_iso_X_of_eq C hn).hom
             else 0,
  comm' := λ i j, begin
    rintro (rfl : _ = _),
    by_cases hi : i = n - 1,
    { rw dif_pos hi,
      subst hi,
      delta imker truncation, dsimp only,
      rw [dif_pos rfl, dif_pos (show n - 1 + 1 = n, by ring), dif_pos rfl,
        dif_neg (show ¬ n - 1 + 1 < n, by linarith), dif_pos (show n - 1 + 1 = n, by ring),
        dif_neg (show n - 1 + 1 ≠ n - 1, by linarith), dif_pos (show n - 1 + 1 = n, by ring)],
      simp only [← category.assoc],
      congr' 1,
      ext,
      delta image_to_kernel',
      simp only [homological_complex.X_prev_iso_comp_d_to, category.assoc, eq_to_iso.hom, eq_to_hom_refl, category.comp_id,
  imker.X_iso_image_of_eq_inv, eq_to_hom_trans, kernel.lift_ι, image.pre_comp_ι,
  category_theory.limits.eq_to_hom_comp_image.ι, image.fac, category_theory.limits.eq_to_hom_comp_kernel.ι],
      refl, },
    { rw dif_neg hi,
      by_cases hn : i = n,
      { subst hn,
        simp only [dif_neg (show i + 1 ≠ i - 1, by linarith), imker.d_def, add_right_eq_self, one_ne_zero, not_false_iff, dif_neg, dite_eq_ite, if_t_t, comp_zero], },
      { rw dif_neg hn,
        by_cases hin : i + 1 = n - 1,
        { rw dif_pos hin,
          have hi : i = n - 2, linarith, subst hi,
          delta truncation, dsimp only,
          simp only [dif_pos (show (n - 2) + 1 < n, by linarith),
            C.d_comp_eq_to_hom_assoc (show (n - 2) + 1 = n - 1, by ring),
            comp_factor_thru_image_eq_zero_assoc, homological_complex.d_comp_d, eq_to_iso.hom, zero_comp, eq_to_hom_trans_assoc,
  dif_pos, category.assoc, complex_shape.up_rel, comp_zero], },
        { rw dif_neg hin,
          rw dif_neg (show i + 1 ≠ n, by {intro h, apply hi, linarith}),
          rw [zero_comp, comp_zero], } } }
  end }
.

example {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] :
is_iso (image.pre_comp f g) := infer_instance

example {𝒞 : Type} [category 𝒞] {A B C D E P Q R : 𝒞} (f : A ⟶ B) (g : B ⟶ C) (h : C ⟶ D) (i : D ⟶ E)
(φ : A ⟶ P) (ψ : P ⟶ Q) (ρ : Q ⟶ R) (σ : R ⟶ D) (commutes : f ≫ g ≫ h = φ ≫ ψ ≫ ρ ≫ σ) :
f ≫ g ≫ h ≫ i = φ ≫ ψ ≫ ρ ≫ σ ≫ i :=
by simp [reassoc_of commutes]

--def kernel_comp_is_iso {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] :
--  kernel (f ≫ g) ≅ kernel f :=
--{ hom := kernel.lift _ (kernel.ι _) (begin rw [← cancel_mono g, category.assoc], simp, end),
--  inv := kernel.lift _ (kernel.ι _) (by simp), }

-- image f ⟶ image e ≫ f

def image_comp_is_iso_left {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso f] : image (f ≫ g) ≅ image g :=
{ hom := image.lift ({I := image g, m := image.ι g, e := f ≫ factor_thru_image g } : mono_factorisation (f ≫ g)),
  inv := image.lift ({I := image (f ≫ g), m := image.ι (f ≫ g), e := (inv f) ≫ factor_thru_image (f ≫ g) } : mono_factorisation g),
  hom_inv_id' := by {dsimp at *, ext1, simp at *},
  inv_hom_id' := by {dsimp at *, ext1, simp at *} }

@[simp] lemma image_comp_is_iso_left_comp_ι {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso f] :
  (image_comp_is_iso_left f g).hom ≫ image.ι g = image.ι (f ≫ g) :=
begin
  simp [image_comp_is_iso_left],
end

@[simp] lemma image_comp_is_iso_left_comp_ι' {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso f] :
  (image_comp_is_iso_left f g).inv ≫ image.ι (f ≫ g) = image.ι g :=
begin
  simp [image_comp_is_iso_left],
end

lemma image.lift_image_ι {A A' B : 𝓐} (f : A ⟶ B) (f' : A' ⟶ B) (e : A' ⟶ A) [is_iso e] (w : f' = e ≫ f) :
image.lift ({ I := image f', m := image.ι f', e := factor_thru_image f ≫
(image_comp_is_iso_left e f).inv ≫ (image_iso_of_eq w.symm).hom,
fac' := by { subst w, simp [image_comp_is_iso_left, image_iso_of_eq] },
} : mono_factorisation f) ≫ image.ι f' = image.ι f :=
begin
  simp,
end

lemma to_imker_f_succ {n : ℤ} : (to_imker C (n + 1)).f n = (X_iso_of_lt C (by simp)).hom ≫
factor_thru_image (C.d n (n+1)) ≫ (imker.X_iso_image' C n).inv :=
begin
  delta to_imker,
  dsimp only,
  rw dif_pos (show n = n + 1 - 1, by ring),
--  delta imker.X_iso_image',
  simp only [imker.X_iso_image, eq_to_iso.hom, imker.X_iso_image_of_eq_inv, eq_to_hom_trans_assoc, iso.trans_inv, imker.X_iso_image_inv,
  category.assoc, eq_to_iso.inv, eq_to_hom_trans],
  simp only [imker.X_iso_image'_inv],
  --    top is `image (homological_complex.d_to C (n + 1)) ⟶ (C.imker (n + 1)).X n`
  -- bottom is `image (homological_complex.d_to C (n + 1)) ⟶ (C.imker (n + 1)).X n`
  simp only [← category.assoc],
  congr' 1,
  ext,
  simp only [homological_complex.X_prev_iso_comp_d_to, category.assoc, image.pre_comp_ι,
  category_theory.limits.eq_to_hom_comp_image.ι, image.fac],
  have foo : (image.is_iso_comp (C.d n (n + 1))).inv ≫
  (image_iso_of_eq (C.d_to_eq rfl)).inv ≫ image.ι (homological_complex.d_to C (n + 1)) = (image.ι (C.d n (n+1)) : image (C.d n (n + 1)) ⟶ C.X (n + 1)),
  { ext, simp,
    -- is this the right move? Surely?
    convert image.fac (C.d n (n+1)),
    /-
    𝓐 : Type u_1,
    _inst_1 : category 𝓐,
    _inst_2 : abelian 𝓐,
    C : cochain_complex 𝓐 ℤ,
    n : ℤ
    ⊢ (image.is_iso_comp (C.d n (n + 1))).inv ≫
          (image_iso_of_eq _).inv ≫ image.ι (homological_complex.d_to C (n + 1)) =
        image.ι (C.d n (n + 1))
    -/

    rw ← category.assoc,
    convert image.lift_image_ι _ _ _ (C.d_to_eq rfl), swap, apply_instance,
    simp [image.is_iso_comp, image_iso_of_eq],
    rw ← is_iso.eq_comp_inv,
    ext,
    simp,
    /-
    𝓐 : Type u_1,
    _inst_1 : category 𝓐,
    _inst_2 : abelian 𝓐,
    C : cochain_complex 𝓐 ℤ,
    n : ℤ
    ⊢ C.d n (n + 1) =
        factor_thru_image (C.d n (n + 1)) ≫
          (image_comp_is_iso_left (homological_complex.X_prev_iso C rfl).hom (C.d n (n + 1))).inv ≫
            (image_iso_of_eq _).hom ≫
              eq_to_hom _ ≫ image.ι ((homological_complex.X_prev_iso C rfl).hom ≫ C.d n (n + 1))
    -/
    convert (image.fac (C.d n (n+1))).symm,
    /-
    𝓐 : Type u_1,
    _inst_1 : category 𝓐,
    _inst_2 : abelian 𝓐,
    C : cochain_complex 𝓐 ℤ,
    n : ℤ
    ⊢ (image_comp_is_iso_left (homological_complex.X_prev_iso C rfl).hom (C.d n (n + 1))).inv ≫
          (image_iso_of_eq _).hom ≫
            eq_to_hom _ ≫ image.ι ((homological_complex.X_prev_iso C rfl).hom ≫ C.d n (n + 1)) =
        image.ι (C.d n (n + 1))
    -/
    convert image_comp_is_iso_left_comp_ι' _ _,
    delta image_iso_of_eq,
    simp, },
  rw foo,
  simp,
  have := C.eq_to_hom_comp_d (rfl : n + 1 = n + 1) (show n + 1 - 1 + 1 = n + 1, by ring),
  rw ← this,
  simp only [← category.assoc],
  congr' 1, clear this foo,
  simp,
end

-- move!
lemma lt_of_not_lt_of_ne {a b : ℤ} (h1 : ¬ a < b) (h2 : ¬ a = b) : b < a :=
begin
  rcases lt_trichotomy a b with (h3 | rfl | h3),
  { contradiction },
  { exact h2.elim rfl },
  { exact h3 }
end

-- move!
instance kernel.lift_iso_of_comp_mono {A B C : 𝓐} (f : A ⟶ B) (e : B ⟶ C) [mono e] :
  is_iso (kernel.lift (f ≫ e) (kernel.ι f) (by rw [kernel.condition_assoc, zero_comp]) : kernel f ⟶ kernel (f ≫ e)) :=
⟨⟨kernel.lift _ (kernel.ι (f ≫ e))  (by { rw ← cancel_mono e, simp }), by {ext, simp}, by {ext, simp}⟩⟩

lemma kernel.ι_comp_iso {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso g] : kernel.ι (f ≫ g) =
inv (kernel.lift (f ≫ g) (kernel.ι f) (by simp) : kernel f ⟶ kernel (f ≫ g)) ≫ kernel.ι f :=
begin
  rw [is_iso.eq_inv_comp, kernel.lift_ι],
end

/-- Factors kernel.ι (iso ≫ g) as iso ≫ kernel.ι g ≫ iso. -/
lemma kernel.ι_iso_comp {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] : kernel.ι (f ≫ g) =
  (kernel.lift g (kernel.ι (f ≫ g) ≫ f) (by simp) : kernel (f ≫ g) ⟶ kernel g) ≫ kernel.ι g ≫ (inv f) :=
by rw [← category.assoc, kernel.lift_ι, category.assoc, is_iso.hom_inv_id, category.comp_id]

instance cokernel.desc_iso_of_iso {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] :
  is_iso (cokernel.desc (f ≫ g) (cokernel.π g) (by simp) : cokernel (f ≫ g) ⟶ cokernel g) :=
⟨⟨cokernel.desc _ (cokernel.π (f ≫ g)) (by { rw [← cancel_epi f, ← category.assoc], simp }),
  by {ext, simp}, by {ext, simp}⟩⟩

instance cokernel.desc_iso_of_iso' {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso g] :
  is_iso (cokernel.desc _ (g ≫ cokernel.π _) (by rw [← category.assoc, cokernel.condition]) :
  cokernel f ⟶ cokernel (f ≫ g)) :=
⟨⟨cokernel.desc _ ((inv g) ≫ cokernel.π f) (by simp), (by {ext, simp}), (by {ext, simp})⟩⟩

lemma cokernel.π_iso_comp {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] : cokernel.π (f ≫ g) =
cokernel.π g ≫ inv (cokernel.desc _ (cokernel.π g) (by simp) : cokernel (f ≫ g) ⟶ cokernel g) :=
begin
  rw [is_iso.eq_comp_inv, cokernel.π_desc],
end

/-- Factors cokernel.π (f ≫ iso) as iso ≫ cokernel.π f ≫ iso. -/
lemma cokernel.π_comp_iso {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso g] : cokernel.π (f ≫ g) =
inv g ≫ cokernel.π f ≫ (cokernel.desc _ (g ≫ cokernel.π (f ≫ g)) (by rw [← category.assoc, cokernel.condition])) :=
by rw [cokernel.π_desc, is_iso.inv_hom_id_assoc]

instance {i n : ℤ} : epi ((to_imker C i).f n) :=
begin
  delta to_imker, dsimp only,
  split_ifs with hn hi,
  { subst hn,
    simp only [epi_comp_is_iso_iff_epi, epi_is_iso_comp_iff_epi,
      factor_thru_image.category_theory.epi], },
  { subst hi,
    simp,
    apply_instance, },
  { apply epi_of_target_iso_zero,
    exact is_zero.iso_zero (imker.X_is_zero_of_ne C hn hi), }
end

lemma map_of_le_mono {m n : ℤ} (h : m ≤ n) (i : ℤ) : mono ((map_of_le C m n h).f i) :=
begin
  delta map_of_le, dsimp only,
  split_ifs with hnotlt hnoteq; try {apply_instance},
  apply mono_of_source_iso_zero,
  exact is_zero.iso_zero (is_zero_X_of_lt C (lt_of_not_lt_of_ne hnotlt hnoteq)),
end

instance ι_succ_mono {i n : ℤ} : mono ((ι_succ C i).f n) :=
begin
  delta ι_succ,
  apply map_of_le_mono,
end

-- has_homology version of exact
lemma _root_.abelian.exact_iff_has_homology_zero {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) :
  exact f g ↔ ∃ w : f ≫ g = 0, nonempty (has_homology f g 0) :=
begin
  rw preadditive.exact_iff_homology_zero,
  apply exists_congr,
  intro w,
  split,
  { rintro ⟨h⟩,
    exact ⟨(homology.has f g w).of_iso h⟩ },
  { rintro ⟨h⟩,
    exact ⟨(homology.has f g w).iso h⟩, },
end

lemma ι_succ.comp_to_imker_zero {i n : ℤ} : (ι_succ C i).f n ≫ (to_imker C (i + 1)).f n = 0 :=
begin
  delta ι_succ map_of_le to_imker,
  dsimp only,
  by_cases h : n < i,
  { rw [dif_pos h, dif_neg (show n ≠ i + 1 - 1, by linarith), dif_neg (show n ≠ i + 1, by linarith),
      comp_zero], },
  { rw dif_neg h,
    by_cases hn : n = i,
    { rw dif_pos hn,
      subst hn,
      rw [dif_pos (show n < n + 1, by linarith), dif_pos (show n = n + 1 - 1, by ring),
        ← image.factor_thru_image_pre_comp_assoc, ← category_theory.limits.factor_thru_image_of_eq
          ((C.eq_to_hom_comp_d rfl (show n + 1 - 1 + 1 = n + 1, by ring)).symm)],
      simp,
    },
    { rw [dif_neg hn, zero_comp], } },
end

lemma comp_zero_cancel_left {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (h : g = 0) : f ≫ g = 0 :=
by rw [h, comp_zero]

lemma comp_zero_cancel_right {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (h : f = 0) : f ≫ g = 0 :=
by rw [h, zero_comp]

lemma kernel.ι_factor_thru_image {A B : 𝓐} (f : A ⟶ B) : kernel.ι (factor_thru_image f) =
kernel.lift (factor_thru_image f ≫ image.ι f) (kernel.ι (factor_thru_image f))
  (by rw [kernel.condition_assoc, zero_comp]) ≫ eq_to_hom (by simp) ≫ kernel.ι f :=
by simp only [image.fac, category_theory.limits.eq_to_hom_comp_kernel.ι, kernel.lift_ι]

lemma kernel.ι_factor_thru_image_comp_cokernel_π {A B : 𝓐} (f : A ⟶ B) :
  kernel.ι (factor_thru_image f) ≫ cokernel.π (kernel.ι f) = 0 :=
begin
  rw [kernel.ι_factor_thru_image, category.assoc, category.assoc, cokernel.condition],
  simp only [comp_zero],
end

lemma kernel.ι_iso_is_zero {A B : 𝓐} (f : A ⟶ B) [is_iso f] : kernel.ι f = 0 :=
is_zero.eq_zero_of_src (is_zero_kernel_of_mono f) _

lemma cokernel.π_iso_is_zero {A B : 𝓐} (f : A ⟶ B) [is_iso f] : cokernel.π f = 0 :=
is_zero.eq_zero_of_tgt (is_zero_cokernel_of_epi f) _

lemma ι_succ_to_imker_π_ι {i n : ℤ} : kernel.ι ((to_imker C (i + 1)).f n) ≫
  cokernel.π ((ι_succ C i).f n) = 0 :=
begin
  delta to_imker ι_succ map_of_le,
  dsimp only,
  by_cases hn : n = i,
  { subst hn, -- I seem to have to do all the work myself here :-(
    rw [dif_pos (show n = n + 1 - 1, by ring), dif_neg (show ¬ n < n, by linarith),
      dif_pos (rfl : n = n), dif_pos (show n < n + 1, by linarith)],
    rw [kernel.ι_iso_comp, category.assoc],
    apply comp_zero_cancel_left,
    rw [kernel.ι_iso_comp, category.assoc, category.assoc],
    apply comp_zero_cancel_left,
    rw [kernel.ι_comp_iso, category.assoc, category.assoc],
    apply comp_zero_cancel_left,
    rw [cokernel.π_iso_comp, ← category.assoc _ _ (inv _), ← category.assoc _ _ (inv _), ← category.assoc _ _ (inv _)],
    apply comp_zero_cancel_right,
    rw [cokernel.π_comp_iso, ← category.assoc _ _ (cokernel.desc _ _ _), ← category.assoc _ _ (cokernel.desc _ _ _), ← category.assoc _ _ (cokernel.desc _ _ _), ← category.assoc _ _ (cokernel.desc _ _ _)],
    apply comp_zero_cancel_right,
    rw ← category_theory.limits.eq_to_hom_comp_kernel.ι (category_theory.limits.factor_thru_image_of_eq
          ((C.eq_to_hom_comp_d (show n + 1 - 1 + 1 = n + 1, by ring) rfl))).symm,
    rw [kernel.ι_comp_iso, category.assoc, category.assoc],
    apply comp_zero_cancel_left,
    apply comp_zero_cancel_left,
    have foo := category_theory.limits.factor_thru_image_iso_comp
      (eq_to_hom (by rw (show n + 1 - 1 = n, by ring)) : C.X (n + 1 - 1) ⟶ C.X n) (C.d n (n + 1)),
    rw category_theory.limits.factor_thru_image_iso_comp
      (eq_to_hom (by rw (show n + 1 - 1 = n, by ring)) : C.X (n + 1 - 1) ⟶ C.X n) (C.d n (n + 1)),
    rw [kernel.ι_iso_comp, category.assoc],
    apply comp_zero_cancel_left,
    simp only [kernel.ι_comp_iso, kernel.ι_factor_thru_image_comp_cokernel_π, inv_eq_to_hom,
      category.assoc, eq_to_iso.hom, eq_to_hom_refl, eq_to_iso.inv, category.id_comp,
      eq_to_hom_trans_assoc, comp_zero], },
  { rw [dif_neg (show n ≠ i + 1 - 1, by {intro h, apply hn, linarith})],
    by_cases hn1 : n = i + 1,
    { rw dif_pos hn1,
      apply comp_zero_cancel_right, -- kernel of iso is 0
      apply kernel.ι_iso_is_zero, },
    { rw dif_neg hn1,
      by_cases hni : n < i,
      { rw dif_pos hni,
        apply comp_zero_cancel_left, -- cokernel of iso is 0
        apply cokernel.π_iso_is_zero, },
      { rw [dif_neg hni, dif_neg hn], -- middle term is 0
        apply comp_zero_cancel_right,
        apply is_zero.eq_zero_of_tgt,
        apply is_zero_X_of_lt,
        rw not_lt at hni,
        obtain (hlt | rfl) := lt_or_eq_of_le hni,
        { rw int.lt_iff_add_one_le at hlt,
          obtain (hlt' | rfl) := lt_or_eq_of_le hlt,
          { exact hlt' },
          { exact hn1.elim rfl, }, },
        { exact hn.elim rfl, } } } }
end
.

-- image.factor_thru_image_pre_comp

--example {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] : is_iso (image.pre_comp f g) :=
--infer_instance

def kernel_factor_thru_image_iso {A B : 𝓐} (f : A ⟶ B) : kernel (factor_thru_image f) ≅ kernel f :=
(kernel_comp_mono (factor_thru_image f) (image.ι f)).symm.trans (kernel_iso_of_eq (by simp))

-- lemma factor_thru_image_comp {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) :
-- factor_thru_image (f ≫ g) ≫ (image.pre_comp f g) = f ≫ factor_thru_image g :=
-- begin
--   exact image.factor_thru_image_pre_comp f g,
-- end

lemma epi_kernel_lift_zero_iff_epi {A B C : 𝓐} (f : A ⟶ B) :
  epi (kernel.lift (0 : B ⟶ C) f comp_zero) ↔ epi f :=
begin
  conv_rhs {rw ← kernel.lift_ι (0 : B ⟶ C) f comp_zero},
  rw epi_is_iso_comp_iff_epi,
end

def kernel_comp_is_iso {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] :
  kernel (f ≫ g) ≅ kernel f :=
{ hom := kernel.lift _ (kernel.ι _) (begin rw [← cancel_mono g, category.assoc], simp, end),
  inv := kernel.lift _ (kernel.ι _) (by simp), }

def kernel_iso_assoc {A B C D : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (h : C ⟶ D) :
  kernel (f ≫ g ≫ h) ≅ kernel ((f ≫ g) ≫ h) := kernel_iso_of_eq (by rw category.assoc)

@[simp] lemma mono_comp_iso_iff_mono {V : Type*} [category V] {A B C : V} (e : A ≅ B) (f : B ⟶ C) :
  mono (e.hom ≫ f) ↔ mono f :=
begin
  split,
  { introI h,
    have := mono_comp e.inv (e.hom ≫ f),
    simpa using this, },
  { apply mono_comp, },
end

@[simp] lemma mono_comp_is_iso_iff_mono {V : Type*} [category V] {A B C : V} (e : A ⟶ B) [is_iso e]
  (f : B ⟶ C) : mono (e ≫ f) ↔ mono f :=
mono_comp_iso_iff_mono (as_iso e) _

lemma ι_succ_to_imker_ex_π_aux₁ {i n : ℤ} (h : n = i) :
  epi (kernel.lift ((to_imker C (i + 1)).f n)
  ((ι_succ C i).f n) (ι_succ.comp_to_imker_zero C)) :=
begin
  delta to_imker ι_succ map_of_le, dsimp only,
  have hn : n = n+1-1, by ring,
  subst h,
  -- `simp_rw dif_pos (show n = n + 1 - 1, by ring)` fails so we hack our way around it.
  suffices : epi (kernel.lift ((X_iso_of_lt C _).hom ≫ eq_to_hom _ ≫
    factor_thru_image (C.d (n + 1 - 1) (n + 1)) ≫
    eq_to_hom _ ≫
    image.pre_comp (homological_complex.X_prev_iso C _).inv (homological_complex.d_to C (n + 1)) ≫
    (imker.X_iso_image_of_eq C (show n = n + 1 - 1, by ring)).inv) _ _),
  -- 14 goals but bear with me
  convert this, -- 11 goals
  rw dif_pos hn, -- 4 goals
  rw dif_pos hn, -- 3 goals
  swap, apply_instance, -- 2 goals
  swap,
  { convert ι_succ.comp_to_imker_zero C,
    delta to_imker, dsimp only, rw dif_pos hn, },-- rw finally works!,
  -- back to 1 goal
  simp only [zero_lt_one, dif_pos, dif_neg, eq_to_hom_refl, category.id_comp, eq_self_iff_true,
    not_false_iff, eq_to_iso.hom, eq_to_hom_trans, lt_add_iff_pos_right, lt_self_iff_false,
    eq_to_iso.inv],
  -- goal is epi (mess : ker(d)->)
  rw ← epi_iso_comp_iff_epi _ (kernel_is_iso_comp _ _),
  -- now knock them off the other end
  rw ← epi_iso_comp_iff_epi _ (kernel_iso_assoc _ _ _),
  rw ← epi_iso_comp_iff_epi _ (kernel_comp_is_iso _ _),
  -- simp now goes down the wrong track
  /- The goal is now to prove that some monstrous map

  (C.truncation n).X n ⟶ kernel (eq_to_hom _ ≫ factor_thru_image (C.d (n + 1 - 1) (n + 1)))

  is an epimorphism. This map is essentially the identity map
  from ker C.d n (n+1) to itself, modulo the usual cannonical
  isomorphisms. My plan is to pre and post compose with some more
  canonical isomorphisms to actually get a map from an object
  to itself and then claim that it is epi because it's the identity
  and then hopefully `ext, simp` will do it.
  -/

  rw ← epi_comp_iso_iff_epi (X_iso_of_eq C rfl).symm,
  have foo : eq_to_hom _ ≫ C.d (n + 1 - 1) (n + 1) = C.d n (n + 1) := C.eq_to_hom_comp_d
    (show n + 1 = n + 1, by refl) (show (n + 1 - 1) + 1 = n + 1, by ring),
  rw ← epi_iso_comp_iff_epi _ (kernel_iso_of_eq (image.factor_thru_image_pre_comp _ _).symm),
  swap, apply_instance, swap, apply_instance,
  rw ← epi_iso_comp_iff_epi _ (kernel_comp_is_iso _ _),
  rw ← epi_iso_comp_iff_epi _ (kernel_factor_thru_image_iso _),
  rw ← epi_iso_comp_iff_epi _ (kernel_iso_of_eq foo),
  let t := _, change epi t,
  suffices : t = 𝟙 _,
  { rw this, apply_instance },

  apply equalizer.hom_ext,
  dsimp only [t, kernel_comp_is_iso, kernel_iso_assoc, kernel_factor_thru_image_iso,
    iso.trans_hom, iso.symm_hom],

  simp only [category.id_comp, category.assoc, kernel_iso_of_eq_hom_comp_ι,
    kernel_iso_of_eq_hom_comp_ι_assoc, kernel_comp_mono_inv,
    kernel.lift_ι, kernel_is_iso_comp_hom, kernel.lift_ι_assoc],
  simp only [eq_to_iso.inv, eq_to_iso.hom, eq_to_hom_trans, eq_to_hom_refl,
    category.comp_id, eq_to_hom_trans_assoc, category.id_comp],
end

lemma ι_succ_to_imker_ex_π {i n : ℤ} : epi (kernel.lift ((to_imker C (i + 1)).f n)
  ((ι_succ C i).f n) (ι_succ.comp_to_imker_zero C)) :=
begin
  by_cases h : n = i,
  { apply ι_succ_to_imker_ex_π_aux₁, exact h },
  delta to_imker ι_succ map_of_le, dsimp only,
  by_cases hn : n = i + 1,
  { apply epi_of_target_iso_zero,
    apply is_zero.iso_zero,
    apply @is_zero_kernel_of_mono _ _ _ _ _ _ _,
    subst hn,
    rw [dif_neg (show i + 1 ≠ i + 1 - 1, by linarith), dif_pos rfl],
    apply mono_comp, },
  { suffices : epi (kernel.lift (0 : (C.truncation (i + 1)).X n ⟶ (C.imker (i + 1)).X n) _ _),
    { convert this,
      rw dif_neg (show n ≠ i + 1 - 1, by ring_nf; exact h),
      rw dif_neg hn,
      rw dif_neg (show n ≠ i + 1 - 1, by ring_nf; exact h),
      rw dif_neg hn, },
    swap,
    { convert ι_succ.comp_to_imker_zero C,
      delta to_imker, dsimp only,
      rw dif_neg (show n ≠ i + 1 - 1, by ring_nf; exact h),
      rw dif_neg hn, },
    rw epi_kernel_lift_zero_iff_epi,
    by_cases hi : n < i,
    { rw dif_pos hi,
      apply_instance, },
    { rw dif_neg hi,
      rw dif_neg h,
      apply epi_of_target_iso_zero,
      apply is_zero.iso_zero,
      apply is_zero_X_of_lt,
      -- we've been here before
      rw not_lt at hi,
      obtain (hlt | rfl) := lt_or_eq_of_le hi,
      { rw int.lt_iff_add_one_le at hlt,
        obtain (hlt' | rfl) := lt_or_eq_of_le hlt,
        { exact hlt' },
        { exact hn.elim rfl, }, },
      { exact h.elim rfl, }, } },
end
.

lemma mono_of_epi_of_comp_mono {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [epi f] [mono (f ≫ g)] :
  mono g :=
begin
  haveI : mono f := mono_of_mono f g,
  haveI : is_iso f := is_iso_of_mono_of_epi _,
  exact (mono_comp_is_iso_iff_mono f g).mp infer_instance,
end

lemma mono_coker_desc_congr {A B C : 𝓐} {f f' : A ⟶ B} (h : f = f') (g : B ⟶ C) (w : f ≫ g = 0) :
  mono (cokernel.desc f g w) ↔ mono (cokernel.desc f' g (h ▸ w)) :=
by subst h

lemma cokernel.desc_comp_iso_left {A B C D : 𝓐} {e : A ⟶ B} [is_iso e] (f : B ⟶ C) (g : C ⟶ D) (w : f ≫ g = 0):
(cokernel.desc (e ≫ f) g (by simp [w])) = cokernel.desc _ (cokernel.π f) (by simp) ≫ cokernel.desc f g w :=
begin
  ext,
  simp,
end

lemma cokernel.desc_comp_snd_right {A B C D : 𝓐} {e : A ⟶ B} (f : B ⟶ C) (g : C ⟶ D) (w : e ≫ f = 0):
(cokernel.desc e (f ≫ g) (by rw [← category.assoc, w, zero_comp])) = cokernel.desc e f w ≫ g :=
begin
  ext,
  simp,
end

lemma yet_another_cokernel_lemma {A B C D : 𝓐} {e : A ⟶ B} (f : B ⟶ C) (g : C ⟶ D) (w : e ≫ f ≫ g = 0):
(cokernel.desc _ (f ≫ cokernel.π _) (by rw [← category.assoc, cokernel.condition])) ≫ (cokernel.desc (e ≫ f) g (by simp [w])) = cokernel.desc e (f ≫ g) w :=
begin
  ext,
  simp,
end

lemma meh {A B C D : 𝓐} {f : A ⟶ B} (e : C ≅ B) (g : B ⟶ D) (w : f ≫ g = 0) :
  mono (cokernel.desc (f ≫ e.inv) (e.hom ≫ g) (by simp [w])) ↔ mono (cokernel.desc f g w) :=
begin
  rw ← yet_another_cokernel_lemma,
  convert mono_comp_is_iso_iff_mono _ _, simp, simp,
--  rw ← yet_another_cokernel_lemma,
--  apply @is_iso.comp_is_iso _ _ _ _ _ _ _ infer_instance infer_instance,
  clear w g,
  apply cokernel.desc_iso_of_iso',
end

lemma first_isomorphism_theorem {A B : 𝓐} (f : A ⟶ B) :
is_iso (cokernel.desc (kernel.ι f) (factor_thru_image f) (by simp only [kernel_ι_comp_factor_thru_image])) :=
begin
  convert (infer_instance : is_iso (abelian.coimage_iso_image' f).hom),
  simp [← cancel_mono (image.ι f), ← cancel_epi (cokernel.π (kernel.ι f))]
end

/-
instance cokernel.desc_iso_of_iso {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) [is_iso f] :
  is_iso (cokernel.desc (f ≫ g) (cokernel.π g) (by simp) : cokernel (f ≫ g) ⟶ cokernel g) :=
  -/
lemma ι_succ_to_imker_ι_ex_aux {n : ℤ} : mono (cokernel.desc ((ι_succ C n).f n) ((to_imker C (n + 1)).f n) (ι_succ.comp_to_imker_zero C)) :=
begin
  rw mono_coker_desc_congr (ι_succ_f_self C),
  /-
  𝓐 : Type u_1,
  _inst_1 : category 𝓐,
  _inst_2 : abelian 𝓐,
  C : cochain_complex 𝓐 ℤ,
  n : ℤ
  ⊢ mono
      (cokernel.desc ((X_iso_of_eq C rfl).hom ≫ kernel.ι (C.d n (n + 1)) ≫ (X_iso_of_lt C _).inv)
         ((to_imker C (n + 1)).f n)
         _)
  -/
  simp_rw [to_imker_f_succ C],
  rw cokernel.desc_comp_iso_left, swap, simp [_root_.category_theory.limits.factor_thru_image_iso_comp],
  apply @mono_comp _ _ _ _ _ _ _ _ _, apply_instance,
  rw meh, swap, simp,
  simp,
  /-
  𝓐 : Type u_1,
  _inst_1 : category 𝓐,
  _inst_2 : abelian 𝓐,
  C : cochain_complex 𝓐 ℤ,
  n : ℤ
  ⊢ mono
      (cokernel.desc (kernel.ι (C.d n (n + 1)) ≫ (X_iso_of_lt C _).inv)
         ((X_iso_of_lt C _).hom ≫ factor_thru_image (C.d n (n + 1)) ≫ (imker.X_iso_image' C n).inv)
         _)
  -/

  rw cokernel.desc_comp_snd_right, swap, simp,
  apply @mono_comp _ _ _ _ _ _ _ _ _, swap, apply_instance,
  apply @is_iso.mono_of_iso _ _ _ _ _ _,
  apply first_isomorphism_theorem,
end

lemma ι_succ_to_imker_ι_ex {i n : ℤ} : mono (cokernel.desc ((ι_succ C i).f n)
  ((to_imker C (i + 1)).f n) (ι_succ.comp_to_imker_zero C)) :=
begin
  by_cases h : n = i,
  { subst h,
--    delta ι_succ map_of_le, dsimp,
    apply ι_succ_to_imker_ι_ex_aux, },
  { by_cases hni : n < i,
    { apply mono_of_source_iso_zero,
      apply is_zero.iso_zero,
      apply @is_zero_cokernel_of_epi _ _ _ _ _ _ _,
      dunfold ι_succ,
      dunfold ι_succ map_of_le, dsimp only,
      simp [dif_pos hni],
      apply_instance, },
    { by_cases hni1 : n = i + 1, -- or aomwrhibf
      { subst hni1,
        suffices : mono ((to_imker C (i + 1)).f (i + 1)),
        { rw ← cokernel.π_desc ((ι_succ C i).f (i + 1)) ((to_imker C (i + 1)).f (i + 1)) (ι_succ.comp_to_imker_zero C) at this,
          exact @mono_of_epi_of_comp_mono _ _ _ _ _ _ _ _ _ this, },
        delta to_imker,
        dsimp only,
        rw dif_neg (show i + 1 ≠ i + 1 - 1, by linarith),
        rw dif_pos rfl,
        simp,
        apply_instance,
      },
      { apply mono_of_source_iso_zero,
        apply is_zero.iso_zero,
        apply @is_zero_cokernel_of_epi _ _ _ _ _ _ _,
        apply epi_of_target_iso_zero,
        apply is_zero.iso_zero,
        apply is_zero_X_of_lt,
        apply lt_of_not_lt_of_ne _ hni1,
        push_neg at hni ⊢,
        obtain (hni | rfl) := lt_or_eq_of_le hni,
        { linarith },
        { exact h.elim rfl } } } }
end

def ι_succ_to_imker_has_homology_zero {i n : ℤ} :
  has_homology ((ι_succ C i).f n) ((to_imker C (i + 1)).f n) 0 :=
{ w := ι_succ.comp_to_imker_zero C,
  π := 0,
  ι := 0,
  π_ι := by simp [ι_succ_to_imker_π_ι],
  ex_π := by {rw ← epi_iff_exact_zero_right, apply ι_succ_to_imker_ex_π},
  ι_ex := by {rw ← mono_iff_exact_zero_left, apply ι_succ_to_imker_ι_ex },
  epi_π := epi_of_target_iso_zero _ (iso.refl _),
  mono_ι := mono_of_source_iso_zero _ (iso.refl _) }

lemma short_exact_ι_succ_to_imker (i : ℤ) (n : ℤ) :
  short_exact ((ι_succ C i).f n) ((to_imker C (i+1)).f n) :=
{ mono := infer_instance,
  epi := infer_instance,
  exact := begin
    rw abelian.exact_iff_has_homology_zero,
    exact ⟨ι_succ.comp_to_imker_zero C, ⟨ι_succ_to_imker_has_homology_zero C⟩⟩,
end }

end truncation

end cochain_complex


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin

! This file was ported from Lean 3 source module category_theory.adjunction.limits
! leanprover-community/mathlib commit 9e7c80f638149bfb3504ba8ff48dfdbfc949fb1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Adjunction.Basic
import Mathlib.CategoryTheory.Limits.Creates

/-!
# Adjunctions and limits

A left adjoint preserves colimits (`CategoryTheory.Adjunction.leftAdjointPreservesColimits`),
and a right adjoint preserves limits (`CategoryTheory.Adjunction.rightAdjointPreservesLimits`).

Equivalences create and reflect (co)limits.
(`CategoryTheory.Adjunction.isEquivalenceCreatesLimits`,
`CategoryTheory.Adjunction.isEquivalenceCreatesColimits`,
`CategoryTheory.Adjunction.isEquivalenceReflectsLimits`,
`CategoryTheory.Adjunction.isEquivalenceReflectsColimits`,)

In `CategoryTheory.Adjunction.coconesIso` we show that
when `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/

open Opposite

namespace CategoryTheory.Adjunction

open CategoryTheory

open CategoryTheory.Functor

open CategoryTheory.Limits

universe v u v₁ v₂ v₀ u₁ u₂

section ArbitraryUniverse

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

variable {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)

section PreservationColimits

variable {J : Type u} [Category.{v} J] (K : J ⥤ C)

/-- The right adjoint of `Cocones.functoriality K F : Cocone K ⥤ Cocone (K ⋙ F)`.

Auxiliary definition for `functorialityIsLeftAdjoint`.
-/
def functorialityRightAdjoint : Cocone (K ⋙ F) ⥤ Cocone K :=
  Cocones.functoriality _ G ⋙
    Cocones.precompose (K.rightUnitor.inv ≫ whiskerLeft K adj.unit ≫ (associator _ _ _).inv)
#align category_theory.adjunction.functoriality_right_adjoint CategoryTheory.Adjunction.functorialityRightAdjoint

-- porting note: used dsimp in order to unfold the definition when necessary
-- attribute [local reducible] functorialityRightAdjoint

/-- The unit for the adjunction for `Cocones.functoriality K F : Cocone K ⥤ Cocone (K ⋙ F)`.

Auxiliary definition for `functorialityIsLeftAdjoint`.
-/
@[simps]
def functorialityUnit :
  𝟭 (Cocone K) ⟶ Cocones.functoriality _ F ⋙ functorialityRightAdjoint adj K where
    app c :=
      { Hom := adj.unit.app c.pt
        w := fun j => by
          dsimp [functorialityRightAdjoint]
          simp }
    naturality := fun X Y f => by
      dsimp [functorialityRightAdjoint]
      aesop_cat
#align category_theory.adjunction.functoriality_unit CategoryTheory.Adjunction.functorialityUnit

/-- The counit for the adjunction for `Cocones.functoriality K F : Cocone K ⥤ Cocone (K ⋙ F)`.

Auxiliary definition for `functorialityIsLeftAdjoint`.
-/
@[simps]
def functorialityCounit :
  functorialityRightAdjoint adj K ⋙ Cocones.functoriality _ F ⟶ 𝟭 (Cocone (K ⋙ F)) where
    app c :=
      { Hom := adj.counit.app c.pt
        w := fun j => by
          dsimp [functorialityRightAdjoint]
          aesop_cat }
    naturality := fun X Y f => by
      dsimp [functorialityRightAdjoint]
      aesop_cat
#align category_theory.adjunction.functoriality_counit CategoryTheory.Adjunction.functorialityCounit

/-- The functor `Cocones.functoriality K F : Cocone K ⥤ Cocone (K ⋙ F)` is a left adjoint. -/
def functorialityIsLeftAdjoint : IsLeftAdjoint (Cocones.functoriality K F)
    where
  right := functorialityRightAdjoint adj K
  adj :=
    mkOfUnitCounit
      { unit := functorialityUnit adj K
        counit := functorialityCounit adj K
        right_triangle := by
          dsimp [functorialityRightAdjoint]
          aesop_cat
        left_triangle := by
          dsimp [functorialityRightAdjoint]
          aesop_cat }
#align category_theory.adjunction.functoriality_is_left_adjoint CategoryTheory.Adjunction.functorialityIsLeftAdjoint

/-- A left adjoint preserves colimits.

See <https://stacks.math.columbia.edu/tag/0038>.
-/
def leftAdjointPreservesColimits : PreservesColimitsOfSize.{v, u} F
    where preservesColimitsOfShape :=
    { preservesColimit :=
        { preserves := fun hc =>
            IsColimit.isoUniqueCoconeMorphism.inv fun _ =>
              @Equiv.unique _ _ (IsColimit.isoUniqueCoconeMorphism.hom hc _)
                ((adj.functorialityIsLeftAdjoint _).adj.homEquiv _ _) } }
#align category_theory.adjunction.left_adjoint_preserves_colimits CategoryTheory.Adjunction.leftAdjointPreservesColimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalencePreservesColimits (E : C ⥤ D) [IsEquivalence E] :
    PreservesColimitsOfSize.{v, u} E :=
  leftAdjointPreservesColimits E.adjunction
#align category_theory.adjunction.is_equivalence_preserves_colimits CategoryTheory.Adjunction.isEquivalencePreservesColimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalenceReflectsColimits (E : D ⥤ C) [IsEquivalence E] :
    ReflectsColimitsOfSize.{v, u} E
    where reflectsColimitsOfShape :=
    { reflectsColimit :=
        { reflects := fun t =>
          (isColimitOfPreserves E.inv t).mapCoconeEquiv E.asEquivalence.unitIso.symm } }
#align category_theory.adjunction.is_equivalence_reflects_colimits CategoryTheory.Adjunction.isEquivalenceReflectsColimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalenceCreatesColimits (H : D ⥤ C) [IsEquivalence H] :
    CreatesColimitsOfSize.{v, u} H where
  CreatesColimitsOfShape :=
    { CreatesColimit :=
        { lifts := fun c _ =>
            { liftedCocone := mapCoconeInv H c
              validLift := mapCoconeMapCoconeInv H c } } }
#align category_theory.adjunction.is_equivalence_creates_colimits CategoryTheory.Adjunction.isEquivalenceCreatesColimits

-- verify the preserve_colimits instance works as expected:
example (E : C ⥤ D) [IsEquivalence E] (c : Cocone K) (h : IsColimit c) :
    IsColimit (E.mapCocone c) :=
  PreservesColimit.preserves h

theorem hasColimit_comp_equivalence (E : C ⥤ D) [IsEquivalence E] [HasColimit K] :
    HasColimit (K ⋙ E) :=
  HasColimit.mk
    { cocone := E.mapCocone (colimit.cocone K)
      isColimit := PreservesColimit.preserves (colimit.isColimit K) }
#align category_theory.adjunction.has_colimit_comp_equivalence CategoryTheory.Adjunction.hasColimit_comp_equivalence

theorem hasColimit_of_comp_equivalence (E : C ⥤ D) [IsEquivalence E] [HasColimit (K ⋙ E)] :
    HasColimit K :=
  @hasColimitOfIso _ _ _ _ (K ⋙ E ⋙ E.inv) K
    (@hasColimit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) E.inv _ _)
    ((Functor.rightUnitor _).symm ≪≫ isoWhiskerLeft K E.asEquivalence.unitIso)
#align category_theory.adjunction.has_colimit_of_comp_equivalence CategoryTheory.Adjunction.hasColimit_of_comp_equivalence

/-- Transport a `HasColimitsOfShape` instance across an equivalence. -/
theorem hasColimitsOfShape_of_equivalence (E : C ⥤ D) [IsEquivalence E] [HasColimitsOfShape J D] :
    HasColimitsOfShape J C :=
  ⟨fun F => hasColimit_of_comp_equivalence F E⟩
#align category_theory.adjunction.has_colimits_of_shape_of_equivalence CategoryTheory.Adjunction.hasColimitsOfShape_of_equivalence

/-- Transport a `HasColimitsOfSize` instance across an equivalence. -/
theorem has_colimits_of_equivalence (E : C ⥤ D) [IsEquivalence E] [HasColimitsOfSize.{v, u} D] :
    HasColimitsOfSize.{v, u} C :=
  ⟨fun _ _ => hasColimitsOfShape_of_equivalence E⟩
#align category_theory.adjunction.has_colimits_of_equivalence CategoryTheory.Adjunction.has_colimits_of_equivalence

end PreservationColimits

section PreservationLimits

variable {J : Type u} [Category.{v} J] (K : J ⥤ D)

/-- The left adjoint of `Cones.functoriality K G : Cone K ⥤ Cone (K ⋙ G)`.

Auxiliary definition for `functorialityIsRightAdjoint`.
-/
def functorialityLeftAdjoint : Cone (K ⋙ G) ⥤ Cone K :=
  Cones.functoriality _ F ⋙
    Cones.postcompose ((associator _ _ _).hom ≫ whiskerLeft K adj.counit ≫ K.rightUnitor.hom)
#align category_theory.adjunction.functoriality_left_adjoint CategoryTheory.Adjunction.functorialityLeftAdjoint

-- porting note: used dsimp in order to unfold the definition when necessary
-- attribute [local reducible] functoriality_left_adjoint

/-- The unit for the adjunction for `Cones.functoriality K G : Cone K ⥤ Cone (K ⋙ G)`.

Auxiliary definition for `functorialityIsRightAdjoint`.
-/
@[simps]
def functorialityUnit' :
  𝟭 (Cone (K ⋙ G)) ⟶ functorialityLeftAdjoint adj K ⋙ Cones.functoriality _ G where
    app c :=
      { Hom := adj.unit.app c.pt
        w := fun j => by
          dsimp [functorialityLeftAdjoint]
          simp }
    naturality := fun X Y f => by
      dsimp [functorialityLeftAdjoint]
      aesop_cat
#align category_theory.adjunction.functoriality_unit' CategoryTheory.Adjunction.functorialityUnit'

/-- The counit for the adjunction for `Cones.functoriality K G : Cone K ⥤ Cone (K ⋙ G)`.

Auxiliary definition for `functorialityIsRightAdjoint`.
-/
@[simps]
def functorialityCounit' :
  Cones.functoriality _ G ⋙ functorialityLeftAdjoint adj K ⟶ 𝟭 (Cone K) where
    app c :=
      { Hom := adj.counit.app c.pt
        w := fun j => by
          dsimp [functorialityLeftAdjoint]
          aesop_cat }
    naturality := fun X Y f => by
      dsimp [functorialityLeftAdjoint]
      aesop_cat
#align category_theory.adjunction.functoriality_counit' CategoryTheory.Adjunction.functorialityCounit'

/-- The functor `Cones.functoriality K G : Cone K ⥤ Cone (K ⋙ G)` is a right adjoint. -/
def functorialityIsRightAdjoint : IsRightAdjoint (Cones.functoriality K G)
    where
  left := functorialityLeftAdjoint adj K
  adj :=
    mkOfUnitCounit
      { unit := functorialityUnit' adj K
        counit := functorialityCounit' adj K
        right_triangle := by
          dsimp [functorialityLeftAdjoint]
          aesop_cat
        left_triangle := by
          dsimp [functorialityLeftAdjoint]
          aesop_cat }
#align category_theory.adjunction.functoriality_is_right_adjoint CategoryTheory.Adjunction.functorialityIsRightAdjoint

/-- A right adjoint preserves limits.

See <https://stacks.math.columbia.edu/tag/0038>.
-/
def rightAdjointPreservesLimits : PreservesLimitsOfSize.{v, u} G
    where preservesLimitsOfShape :=
    { preservesLimit :=
        { preserves := fun hc =>
            IsLimit.isoUniqueConeMorphism.inv fun _ =>
              @Equiv.unique _ _ (IsLimit.isoUniqueConeMorphism.hom hc _)
                ((adj.functorialityIsRightAdjoint _).adj.homEquiv _ _).symm } }
#align category_theory.adjunction.right_adjoint_preserves_limits CategoryTheory.Adjunction.rightAdjointPreservesLimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalencePreservesLimits (E : D ⥤ C) [IsEquivalence E] :
    PreservesLimitsOfSize.{v, u} E :=
  rightAdjointPreservesLimits E.inv.adjunction
#align category_theory.adjunction.is_equivalence_preserves_limits CategoryTheory.Adjunction.isEquivalencePreservesLimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalenceReflectsLimits (E : D ⥤ C) [IsEquivalence E] :
    ReflectsLimitsOfSize.{v, u} E
    where reflectsLimitsOfShape :=
    { reflectsLimit :=
        { reflects := fun t =>
            (isLimitOfPreserves E.inv t).mapConeEquiv E.asEquivalence.unitIso.symm } }
#align category_theory.adjunction.is_equivalence_reflects_limits CategoryTheory.Adjunction.isEquivalenceReflectsLimits

-- see Note [lower instance priority]
instance (priority := 100) isEquivalenceCreatesLimits (H : D ⥤ C) [IsEquivalence H] :
    CreatesLimitsOfSize.{v, u} H where
  CreatesLimitsOfShape :=
    { CreatesLimit :=
        { lifts := fun c _ =>
            { liftedCone := mapConeInv H c
              validLift := mapConeMapConeInv H c } } }
#align category_theory.adjunction.is_equivalence_creates_limits CategoryTheory.Adjunction.isEquivalenceCreatesLimits

-- verify the preserve_limits instance works as expected:
example (E : D ⥤ C) [IsEquivalence E] (c : Cone K) (h : IsLimit c) : IsLimit (E.mapCone c) :=
  PreservesLimit.preserves h

theorem hasLimit_comp_equivalence (E : D ⥤ C) [IsEquivalence E] [HasLimit K] : HasLimit (K ⋙ E) :=
  HasLimit.mk
    { cone := E.mapCone (limit.cone K)
      isLimit := PreservesLimit.preserves (limit.isLimit K) }
#align category_theory.adjunction.has_limit_comp_equivalence CategoryTheory.Adjunction.hasLimit_comp_equivalence

theorem hasLimit_of_comp_equivalence (E : D ⥤ C) [IsEquivalence E] [HasLimit (K ⋙ E)] :
    HasLimit K :=
  @hasLimitOfIso _ _ _ _ (K ⋙ E ⋙ E.inv) K
    (@hasLimit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) E.inv _ _)
    (isoWhiskerLeft K E.asEquivalence.unitIso.symm ≪≫ Functor.rightUnitor _)
#align category_theory.adjunction.has_limit_of_comp_equivalence CategoryTheory.Adjunction.hasLimit_of_comp_equivalence

/-- Transport a `HasLimitsOfShape` instance across an equivalence. -/
theorem hasLimitsOfShape_of_equivalence (E : D ⥤ C) [IsEquivalence E] [HasLimitsOfShape J C] :
    HasLimitsOfShape J D :=
  ⟨fun F => hasLimit_of_comp_equivalence F E⟩
#align category_theory.adjunction.has_limits_of_shape_of_equivalence CategoryTheory.Adjunction.hasLimitsOfShape_of_equivalence

/-- Transport a `HasLimitsOfSize` instance across an equivalence. -/
theorem has_limits_of_equivalence (E : D ⥤ C) [IsEquivalence E] [HasLimitsOfSize.{v, u} C] :
    HasLimitsOfSize.{v, u} D :=
  ⟨fun _ _ => hasLimitsOfShape_of_equivalence E⟩
#align category_theory.adjunction.has_limits_of_equivalence CategoryTheory.Adjunction.has_limits_of_equivalence

end PreservationLimits

/-- auxiliary construction for `coconesIso` -/
@[simp]
def coconesIsoComponentHom {J : Type u} [Category.{v} J] {K : J ⥤ C} (Y : D)
    (t : ((cocones J D).obj (op (K ⋙ F))).obj Y) : (G ⋙ (cocones J C).obj (op K)).obj Y
    where
  app j := (adj.homEquiv (K.obj j) Y) (t.app j)
  naturality j j' f := by
    erw [← adj.homEquiv_naturality_left, t.naturality]
    dsimp
    simp
#align category_theory.adjunction.cocones_iso_component_hom CategoryTheory.Adjunction.coconesIsoComponentHom

/-- auxiliary construction for `coconesIso` -/
@[simp]
def coconesIsoComponentInv {J : Type u} [Category.{v} J] {K : J ⥤ C} (Y : D)
    (t : (G ⋙ (cocones J C).obj (op K)).obj Y) : ((cocones J D).obj (op (K ⋙ F))).obj Y
    where
  app j := (adj.homEquiv (K.obj j) Y).symm (t.app j)
  naturality j j' f :=
    by
    erw [← adj.homEquiv_naturality_left_symm, ← adj.homEquiv_naturality_right_symm, t.naturality]
    dsimp; simp
#align category_theory.adjunction.cocones_iso_component_inv CategoryTheory.Adjunction.coconesIsoComponentInv

/-- auxiliary construction for `conesIso` -/
@[simp]
def conesIsoComponentHom {J : Type u} [Category.{v} J] {K : J ⥤ D} (X : Cᵒᵖ)
    (t : (Functor.op F ⋙ (cones J D).obj K).obj X) : ((cones J C).obj (K ⋙ G)).obj X
    where
  app j := (adj.homEquiv (unop X) (K.obj j)) (t.app j)
  naturality j j' f :=
    by
    erw [← adj.homEquiv_naturality_right, ← t.naturality, Category.id_comp, Category.id_comp]
    rfl
#align category_theory.adjunction.cones_iso_component_hom CategoryTheory.Adjunction.conesIsoComponentHom

/-- auxiliary construction for `conesIso` -/
@[simp]
def conesIsoComponentInv {J : Type u} [Category.{v} J] {K : J ⥤ D} (X : Cᵒᵖ)
    (t : ((cones J C).obj (K ⋙ G)).obj X) : (Functor.op F ⋙ (cones J D).obj K).obj X
    where
  app j := (adj.homEquiv (unop X) (K.obj j)).symm (t.app j)
  naturality j j' f := by
    erw [← adj.homEquiv_naturality_right_symm, ← t.naturality, Category.id_comp, Category.id_comp]
#align category_theory.adjunction.cones_iso_component_inv CategoryTheory.Adjunction.conesIsoComponentInv

end ArbitraryUniverse

variable {C : Type u₁} [Category.{v₀} C] {D : Type u₂} [Category.{v₀} D] {F : C ⥤ D} {G : D ⥤ C}
  (adj : F ⊣ G)

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
/-- When `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/
def coconesIso {J : Type u} [Category.{v} J] {K : J ⥤ C} :
    (cocones J D).obj (op (K ⋙ F)) ≅ G ⋙ (cocones J C).obj (op K) :=
  NatIso.ofComponents
    (fun Y =>
      { hom := coconesIsoComponentHom adj Y
        inv := coconesIsoComponentInv adj Y
        hom_inv_id := by
          funext
          aesop_cat
        inv_hom_id := by
          funext
          simp
          rfl })
    (fun f => by
      funext
      aesop_cat)
#align category_theory.adjunction.cocones_iso CategoryTheory.Adjunction.coconesIso

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
/-- When `F ⊣ G`,
the functor associating to each `X` the cones over `K` with cone point `F.op.obj X`
is naturally isomorphic to
the functor associating to each `X` the cones over `K ⋙ G` with cone point `X`.
-/
def conesIso {J : Type u} [Category.{v} J] {K : J ⥤ D} :
    F.op ⋙ (cones J D).obj K ≅ (cones J C).obj (K ⋙ G) :=
  NatIso.ofComponents
    (fun X =>
      { hom := conesIsoComponentHom adj X
        inv := conesIsoComponentInv adj X
        hom_inv_id := by
          funext
          aesop_cat
        inv_hom_id := by
          funext
          simp
          rfl })
    (fun f => by
      funext
      aesop_cat)
#align category_theory.adjunction.cones_iso CategoryTheory.Adjunction.conesIso

end CategoryTheory.Adjunction


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta

! This file was ported from Lean 3 source module order.partition.finpartition
! leanprover-community/mathlib commit d6fad0e5bf2d6f48da9175d25c3dc5706b3834ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Order.Atoms.Finite
import Mathlib.Order.SupIndep

/-!
# Finite partitions

In this file, we define finite partitions. A finpartition of `a : α` is a finite set of pairwise
disjoint parts `parts : Finset α` which does not contain `⊥` and whose supremum is `a`.

Finpartitions of a finset are at the heart of Szemerédi's regularity lemma. They are also studied
purely order theoretically in Sperner theory.

## Constructions

We provide many ways to build finpartitions:
* `Finpartition.ofErase`: Builds a finpartition by erasing `⊥` for you.
* `Finpartition.ofSubset`: Builds a finpartition from a subset of the parts of a previous
  finpartition.
* `Finpartition.empty`: The empty finpartition of `⊥`.
* `Finpartition.indiscrete`: The indiscrete, aka trivial, aka pure, finpartition made of a single
  part.
* `Finpartition.discrete`: The discrete finpartition of `s : Finset α` made of singletons.
* `Finpartition.bind`: Puts together the finpartitions of the parts of a finpartition into a new
  finpartition.
* `Finpartition.atomise`: Makes a finpartition of `s : Finset α` by breaking `s` along all finsets
  in `F : Finset (Finset α)`. Two elements of `s` belong to the same part iff they belong to the
  same elements of `F`.

`Finpartition.indiscrete` and `Finpartition.bind` together form the monadic structure of
`Finpartition`.

## Implementation notes

Forbidding `⊥` as a part follows mathematical tradition and is a pragmatic choice concerning
operations on `Finpartition`. Not caring about `⊥` being a part or not breaks extensionality (it's
not because the parts of `P` and the parts of `Q` have the same elements that `P = Q`). Enforcing
`⊥` to be a part makes `Finpartition.bind` uglier and doesn't rid us of the need of
`Finpartition.ofErase`.

## TODO

Link `Finpartition` and `Setoid.isPartition`.

The order is the wrong way around to make `Finpartition a` a graded order. Is it bad to depart from
the literature and turn the order around?
-/

open BigOperators Finset Function

variable {α : Type _}

/-- A finite partition of `a : α` is a pairwise disjoint finite set of elements whose supremum is
`a`. We forbid `⊥` as a part. -/
@[ext]
structure Finpartition [Lattice α] [OrderBot α] (a : α) where
  -- porting note: Docstrings added
  /-- The elements of the finite partition of `a` -/
  parts : Finset α
  /-- The partition is supremum-independent -/
  supIndep : parts.SupIndep id
  /-- The supremum of the partition is `a` -/
  supParts : parts.sup id = a
  /-- No element of the partition is bottom-/
  not_bot_mem : ⊥ ∉ parts
  deriving DecidableEq
#align finpartition Finpartition
#align finpartition.parts Finpartition.parts
#align finpartition.sup_indep Finpartition.supIndep
#align finpartition.sup_parts Finpartition.supParts
#align finpartition.not_bot_mem Finpartition.not_bot_mem

-- Porting note: attribute [protected] doesn't work
-- attribute [protected] Finpartition.supIndep

namespace Finpartition

section Lattice

variable [Lattice α] [OrderBot α]

/-- A `Finpartition` constructor which does not insist on `⊥` not being a part. -/
@[simps]
def ofErase [DecidableEq α] {a : α} (parts : Finset α) (sup_indep : parts.SupIndep id)
    (sup_parts : parts.sup id = a) : Finpartition a
    where
  parts := parts.erase ⊥
  supIndep := sup_indep.subset (erase_subset _ _)
  supParts := (sup_erase_bot _).trans sup_parts
  not_bot_mem := not_mem_erase _ _
#align finpartition.of_erase Finpartition.ofErase

/-- A `Finpartition` constructor from a bigger existing finpartition. -/
@[simps]
def ofSubset {a b : α} (P : Finpartition a) {parts : Finset α} (subset : parts ⊆ P.parts)
    (sup_parts : parts.sup id = b) : Finpartition b :=
  { parts :=parts
    supIndep := P.supIndep.subset subset
    supParts := sup_parts
    not_bot_mem := fun h ↦ P.not_bot_mem (subset h) }
#align finpartition.of_subset Finpartition.ofSubset

/-- Changes the type of a finpartition to an equal one. -/
@[simps]
def copy {a b : α} (P : Finpartition a) (h : a = b) : Finpartition b
    where
  parts := P.parts
  supIndep := P.supIndep
  supParts := h ▸ P.supParts
  not_bot_mem := P.not_bot_mem
#align finpartition.copy Finpartition.copy

variable (α)

/-- The empty finpartition. -/
@[simps]
protected def empty : Finpartition (⊥ : α)
    where
  parts := ∅
  supIndep := supIndep_empty _
  supParts := Finset.sup_empty
  not_bot_mem := not_mem_empty ⊥
#align finpartition.empty Finpartition.empty

instance : Inhabited (Finpartition (⊥ : α)) :=
  ⟨Finpartition.empty α⟩

@[simp]
theorem default_eq_empty : (default : Finpartition (⊥ : α)) = Finpartition.empty α :=
  rfl
#align finpartition.default_eq_empty Finpartition.default_eq_empty

variable {α} {a : α}

/-- The finpartition in one part, aka indiscrete finpartition. -/
@[simps]
def indiscrete (ha : a ≠ ⊥) : Finpartition a
    where
  parts := {a}
  supIndep := supIndep_singleton _ _
  supParts := Finset.sup_singleton
  not_bot_mem h := ha (mem_singleton.1 h).symm
#align finpartition.indiscrete Finpartition.indiscrete

variable (P : Finpartition a)

protected theorem le {b : α} (hb : b ∈ P.parts) : b ≤ a :=
  (le_sup hb).trans P.supParts.le
#align finpartition.le Finpartition.le

theorem ne_bot {b : α} (hb : b ∈ P.parts) : b ≠ ⊥ := by
  intro h
  refine' P.not_bot_mem (_)
  rw [h] at hb
  exact hb
#align finpartition.ne_bot Finpartition.ne_bot

protected theorem disjoint : (P.parts : Set α).PairwiseDisjoint id :=
  P.supIndep.pairwiseDisjoint
#align finpartition.disjoint Finpartition.disjoint

variable {P}

theorem parts_eq_empty_iff : P.parts = ∅ ↔ a = ⊥ := by
  simp_rw [← P.supParts]
  refine' ⟨fun h ↦ _, fun h ↦ eq_empty_iff_forall_not_mem.2 fun b hb ↦ P.not_bot_mem _⟩
  · rw [h]
    exact Finset.sup_empty
  · rwa [← le_bot_iff.1 ((le_sup hb).trans h.le)]
#align finpartition.parts_eq_empty_iff Finpartition.parts_eq_empty_iff

theorem parts_nonempty_iff : P.parts.Nonempty ↔ a ≠ ⊥ := by
  rw [nonempty_iff_ne_empty, not_iff_not, parts_eq_empty_iff]
#align finpartition.parts_nonempty_iff Finpartition.parts_nonempty_iff

theorem parts_nonempty (P : Finpartition a) (ha : a ≠ ⊥) : P.parts.Nonempty :=
  parts_nonempty_iff.2 ha
#align finpartition.parts_nonempty Finpartition.parts_nonempty

instance : Unique (Finpartition (⊥ : α)) :=
  { (inferInstance : Inhabited (Finpartition (⊥ : α))) with
    uniq := fun P ↦ by
      ext a
      exact iff_of_false (fun h ↦ P.ne_bot h <| le_bot_iff.1 <| P.le h) (not_mem_empty a) }

-- See note [reducible non instances]
/-- There's a unique partition of an atom. -/
@[reducible]
def IsAtom.uniqueFinpartition (ha : IsAtom a) : Unique (Finpartition a)
    where
  default := indiscrete ha.1
  uniq P := by
    have h : ∀ b ∈ P.parts, b = a := fun _ hb ↦
      (ha.le_iff.mp <| P.le hb).resolve_left (P.ne_bot hb)
    ext b
    refine' Iff.trans ⟨h b, _⟩ mem_singleton.symm
    rintro rfl
    obtain ⟨c, hc⟩ := P.parts_nonempty ha.1
    simp_rw [← h c hc]
    exact hc
#align is_atom.unique_finpartition Finpartition.IsAtom.uniqueFinpartition

instance [Fintype α] [DecidableEq α] (a : α) : Fintype (Finpartition a) :=
  @Fintype.ofSurjective { p : Finset α // p.SupIndep id ∧ p.sup id = a ∧ ⊥ ∉ p } (Finpartition a) _
    (Subtype.fintype _) (fun i ↦ ⟨i.1, i.2.1, i.2.2.1, i.2.2.2⟩) fun ⟨_, y, z, w⟩ ↦
    ⟨⟨_, y, z, w⟩, rfl⟩

/-! ### Refinement order -/

section Order

/-- We say that `P ≤ Q` if `P` refines `Q`: each part of `P` is less than some part of `Q`. -/
instance : LE (Finpartition a) :=
  ⟨fun P Q ↦ ∀ ⦃b⦄, b ∈ P.parts → ∃ c ∈ Q.parts, b ≤ c⟩

instance : PartialOrder (Finpartition a) :=
  { (inferInstance : LE (Finpartition a)) with
    le_refl := fun P b hb ↦ ⟨b, hb, le_rfl⟩
    le_trans := fun P Q R hPQ hQR b hb ↦ by
      obtain ⟨c, hc, hbc⟩ := hPQ hb
      obtain ⟨d, hd, hcd⟩ := hQR hc
      exact ⟨d, hd, hbc.trans hcd⟩
    le_antisymm := fun P Q hPQ hQP ↦ by
      ext b
      refine' ⟨fun hb ↦ _, fun hb ↦ _⟩
      · obtain ⟨c, hc, hbc⟩ := hPQ hb
        obtain ⟨d, hd, hcd⟩ := hQP hc
        rwa [hbc.antisymm]
        rwa [P.disjoint.eq_of_le hb hd (P.ne_bot hb) (hbc.trans hcd)]
      · obtain ⟨c, hc, hbc⟩ := hQP hb
        obtain ⟨d, hd, hcd⟩ := hPQ hc
        rwa [hbc.antisymm]
        rwa [Q.disjoint.eq_of_le hb hd (Q.ne_bot hb) (hbc.trans hcd)] }

instance [Decidable (a = ⊥)] : OrderTop (Finpartition a)
    where
  top := if ha : a = ⊥ then (Finpartition.empty α).copy ha.symm else indiscrete ha
  le_top P := by
    split_ifs with h
    · intro x hx
      simpa [h, P.ne_bot hx] using P.le hx
    · exact fun b hb ↦ ⟨a, mem_singleton_self _, P.le hb⟩

theorem parts_top_subset (a : α) [Decidable (a = ⊥)] : (⊤ : Finpartition a).parts ⊆ {a} := by
  intro b hb
  have hb : b ∈ Finpartition.parts (dite _ _ _) := hb
  split_ifs at hb
  · simp only [copy_parts, empty_parts, not_mem_empty] at hb
  · exact hb
#align finpartition.parts_top_subset Finpartition.parts_top_subset

theorem parts_top_subsingleton (a : α) [Decidable (a = ⊥)] :
    ((⊤ : Finpartition a).parts : Set α).Subsingleton :=
  Set.subsingleton_of_subset_singleton fun _ hb ↦ mem_singleton.1 <| parts_top_subset _ hb
#align finpartition.parts_top_subsingleton Finpartition.parts_top_subsingleton

end Order

end Lattice

section DistribLattice

variable [DistribLattice α] [OrderBot α]

section Inf

variable [DecidableEq α] {a b c : α}

instance : Inf (Finpartition a) :=
  ⟨fun P Q ↦
    ofErase ((P.parts ×ᶠ Q.parts).image fun bc ↦ bc.1 ⊓ bc.2)
      (by
        rw [supIndep_iff_disjoint_erase]
        simp only [mem_image, and_imp, exists_prop, forall_exists_index, id.def, Prod.exists,
          mem_product, Finset.disjoint_sup_right, mem_erase, Ne.def]
        rintro _ x₁ y₁ hx₁ hy₁ rfl _ h x₂ y₂ hx₂ hy₂ rfl
        rcases eq_or_ne x₁ x₂ with (rfl | xdiff)
        · refine' Disjoint.mono inf_le_right inf_le_right (Q.disjoint hy₁ hy₂ _)
          intro t
          simp [t] at h
        exact Disjoint.mono inf_le_left inf_le_left (P.disjoint hx₁ hx₂ xdiff))
      (by
        rw [sup_image, comp.left_id, sup_product_left]
        trans P.parts.sup id ⊓ Q.parts.sup id
        · simp_rw [Finset.sup_inf_distrib_right, Finset.sup_inf_distrib_left]
          rfl
        · rw [P.supParts, Q.supParts, inf_idem])⟩

@[simp]

instance : SemilatticeInf (Finpartition a) :=
  { (inferInstance : PartialOrder (Finpartition a)),
    (inferInstance : Inf (Finpartition a)) with
    inf_le_left := fun P Q b hb ↦ by
      obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb)
      rw [mem_product] at hc
      exact ⟨c.1, hc.1, inf_le_left⟩
    inf_le_right := fun P Q b hb ↦ by
      obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb)
      rw [mem_product] at hc
      exact ⟨c.2, hc.2, inf_le_right⟩
    le_inf := fun P Q R hPQ hPR b hb ↦ by
      obtain ⟨c, hc, hbc⟩ := hPQ hb
      obtain ⟨d, hd, hbd⟩ := hPR hb
      have h := _root_.le_inf hbc hbd
      refine'
        ⟨c ⊓ d,
          mem_erase_of_ne_of_mem (ne_bot_of_le_ne_bot (P.ne_bot hb) h)
            (mem_image.2 ⟨(c, d), mem_product.2 ⟨hc, hd⟩, rfl⟩),
          h⟩ }

end Inf

theorem exists_le_of_le {a b : α} {P Q : Finpartition a} (h : P ≤ Q) (hb : b ∈ Q.parts) :
    ∃ c ∈ P.parts, c ≤ b := by
  by_contra H
  refine' Q.ne_bot hb (disjoint_self.1 <| Disjoint.mono_right (Q.le hb) _)
  rw [← P.supParts, Finset.disjoint_sup_right]
  rintro c hc
  obtain ⟨d, hd, hcd⟩ := h hc
  refine' (Q.disjoint hb hd _).mono_right hcd
  rintro rfl
  simp only [not_exists, not_and] at H
  exact H _ hc hcd
#align finpartition.exists_le_of_le Finpartition.exists_le_of_le

theorem card_mono {a : α} {P Q : Finpartition a} (h : P ≤ Q) : Q.parts.card ≤ P.parts.card := by
  classical
    have : ∀ b ∈ Q.parts, ∃ c ∈ P.parts, c ≤ b := fun b ↦ exists_le_of_le h
    choose f hP hf using this
    rw [← card_attach]
    refine' card_le_card_of_inj_on (fun b ↦ f _ b.2) (fun b _ ↦ hP _ b.2) fun b _ c _ h ↦ _
    exact
      Subtype.coe_injective
        (Q.disjoint.elim b.2 c.2 fun H ↦
          P.ne_bot (hP _ b.2) <| disjoint_self.1 <| H.mono (hf _ b.2) <| h.le.trans <| hf _ c.2)
#align finpartition.card_mono Finpartition.card_mono

variable [DecidableEq α] {a b c : α}

section Bind

variable {P : Finpartition a} {Q : ∀ i ∈ P.parts, Finpartition i}

/-- Given a finpartition `P` of `a` and finpartitions of each part of `P`, this yields the
finpartition of `a` obtained by juxtaposing all the subpartitions. -/
@[simps]
def bind (P : Finpartition a) (Q : ∀ i ∈ P.parts, Finpartition i) : Finpartition a
    where
  parts := P.parts.attach.bunionᵢ fun i ↦ (Q i.1 i.2).parts
  supIndep := by
    rw [supIndep_iff_pairwiseDisjoint]
    rintro a ha b hb h
    rw [Finset.mem_coe, Finset.mem_bunionᵢ] at ha hb
    obtain ⟨⟨A, hA⟩, -, ha⟩ := ha
    obtain ⟨⟨B, hB⟩, -, hb⟩ := hb
    obtain rfl | hAB := eq_or_ne A B
    · exact (Q A hA).disjoint ha hb h
    · exact (P.disjoint hA hB hAB).mono ((Q A hA).le ha) ((Q B hB).le hb)
  supParts := by
    simp_rw [sup_bunionᵢ]
    trans (sup P.parts id)
    · rw [eq_comm, ← Finset.sup_attach]
      exact sup_congr rfl fun b _hb ↦ (Q b.1 b.2).supParts.symm
    · exact P.supParts
  not_bot_mem h := by
    rw [Finset.mem_bunionᵢ] at h
    obtain ⟨⟨A, hA⟩, -, h⟩ := h
    exact (Q A hA).not_bot_mem h
#align finpartition.bind Finpartition.bind

theorem mem_bind : b ∈ (P.bind Q).parts ↔ ∃ A hA, b ∈ (Q A hA).parts := by
  rw [bind, mem_bunionᵢ]
  constructor
  · rintro ⟨⟨A, hA⟩, -, h⟩
    exact ⟨A, hA, h⟩
  · rintro ⟨A, hA, h⟩
    exact ⟨⟨A, hA⟩, mem_attach _ ⟨A, hA⟩, h⟩
#align finpartition.mem_bind Finpartition.mem_bind

theorem card_bind (Q : ∀ i ∈ P.parts, Finpartition i) :
    (P.bind Q).parts.card = ∑ A in P.parts.attach, (Q _ A.2).parts.card := by
  apply card_bunionᵢ
  rintro ⟨b, hb⟩ - ⟨c, hc⟩ - hbc
  rw [Finset.disjoint_left]
  rintro d hdb hdc
  rw [Ne.def, Subtype.mk_eq_mk] at hbc
  exact
    (Q b hb).ne_bot hdb
      (eq_bot_iff.2 <|
        (le_inf ((Q b hb).le hdb) <| (Q c hc).le hdc).trans <| (P.disjoint hb hc hbc).le_bot)
#align finpartition.card_bind Finpartition.card_bind

end Bind

/-- Adds `b` to a finpartition of `a` to make a finpartition of `a ⊔ b`. -/
@[simps]
def extend (P : Finpartition a) (hb : b ≠ ⊥) (hab : Disjoint a b) (hc : a ⊔ b = c) : Finpartition c
    where
  parts := insert b P.parts
  supIndep := by
    rw [supIndep_iff_pairwiseDisjoint, coe_insert]
    exact P.disjoint.insert fun d hd _ ↦ hab.symm.mono_right <| P.le hd
  supParts := by rwa [sup_insert, P.supParts, id, _root_.sup_comm]
  not_bot_mem h := (mem_insert.1 h).elim hb.symm P.not_bot_mem
#align finpartition.extend Finpartition.extend

theorem card_extend (P : Finpartition a) (b c : α) {hb : b ≠ ⊥} {hab : Disjoint a b}
    {hc : a ⊔ b = c} : (P.extend hb hab hc).parts.card = P.parts.card + 1 :=
  card_insert_of_not_mem fun h ↦ hb <| hab.symm.eq_bot_of_le <| P.le h
#align finpartition.card_extend Finpartition.card_extend

end DistribLattice

section GeneralizedBooleanAlgebra

variable [GeneralizedBooleanAlgebra α] [DecidableEq α] {a b c : α} (P : Finpartition a)

/-- Restricts a finpartition to avoid a given element. -/
@[simps!]
def avoid (b : α) : Finpartition (a \ b) :=
  ofErase
    (P.parts.image (· \ b))
    (P.disjoint.image_finset_of_le fun a ↦ sdiff_le).supIndep
    (by rw [sup_image, comp.left_id, Finset.sup_sdiff_right, ← id_def, P.supParts])
#align finpartition.avoid Finpartition.avoid

@[simp]
theorem mem_avoid : c ∈ (P.avoid b).parts ↔ ∃ d ∈ P.parts, ¬d ≤ b ∧ d \ b = c := by
  simp only [avoid, ofErase, mem_erase, Ne.def, mem_image, exists_prop, ← exists_and_left,
    @and_left_comm (c ≠ ⊥)]
  refine' exists_congr fun d ↦ and_congr_right' <| and_congr_left _
  rintro rfl
  rw [sdiff_eq_bot_iff]
#align finpartition.mem_avoid Finpartition.mem_avoid

end GeneralizedBooleanAlgebra

end Finpartition

/-! ### Finite partitions of finsets -/

namespace Finpartition

variable [DecidableEq α] {s t : Finset α} (P : Finpartition s)

theorem nonempty_of_mem_parts {a : Finset α} (ha : a ∈ P.parts) : a.Nonempty :=
  nonempty_iff_ne_empty.2 <| P.ne_bot ha
#align finpartition.nonempty_of_mem_parts Finpartition.nonempty_of_mem_parts

theorem exists_mem {a : α} (ha : a ∈ s) : ∃ t ∈ P.parts, a ∈ t := by
  simp_rw [← P.supParts] at ha
  exact mem_sup.1 ha
#align finpartition.exists_mem Finpartition.exists_mem

theorem bunionᵢ_parts : P.parts.bunionᵢ id = s :=
  (sup_eq_bunionᵢ _ _).symm.trans P.supParts
#align finpartition.bUnion_parts Finpartition.bunionᵢ_parts

theorem sum_card_parts : (∑ i in P.parts, i.card) = s.card := by
  convert congr_arg Finset.card P.bunionᵢ_parts
  rw [card_bunionᵢ P.supIndep.pairwiseDisjoint]
  rfl
#align finpartition.sum_card_parts Finpartition.sum_card_parts

/-- `⊥` is the partition in singletons, aka discrete partition. -/
instance (s : Finset α) : Bot (Finpartition s) :=
  ⟨{  parts := s.map ⟨singleton, singleton_injective⟩
      supIndep :=
        Set.PairwiseDisjoint.supIndep
          (by
            rw [Finset.coe_map]
            exact Finset.pairwiseDisjoint_range_singleton.subset (Set.image_subset_range _ _))
      supParts := by rw [sup_map, comp.left_id, Embedding.coeFn_mk, Finset.sup_singleton']
      not_bot_mem := by simp }⟩

@[simp]
theorem parts_bot (s : Finset α) :
    (⊥ : Finpartition s).parts = s.map ⟨singleton, singleton_injective⟩ :=
  rfl
#align finpartition.parts_bot Finpartition.parts_bot

theorem card_bot (s : Finset α) : (⊥ : Finpartition s).parts.card = s.card :=
  Finset.card_map _
#align finpartition.card_bot Finpartition.card_bot

theorem mem_bot_iff : t ∈ (⊥ : Finpartition s).parts ↔ ∃ a ∈ s, {a} = t :=
  mem_map
#align finpartition.mem_bot_iff Finpartition.mem_bot_iff

instance (s : Finset α) : OrderBot (Finpartition s) :=
  { (inferInstance : Bot (Finpartition s)) with
    bot_le := fun P t ht ↦ by
      rw [mem_bot_iff] at ht
      obtain ⟨a, ha, rfl⟩ := ht
      obtain ⟨t, ht, hat⟩ := P.exists_mem ha
      exact ⟨t, ht, singleton_subset_iff.2 hat⟩ }

theorem card_parts_le_card (P : Finpartition s) : P.parts.card ≤ s.card := by
  rw [← card_bot s]
  exact card_mono bot_le
#align finpartition.card_parts_le_card Finpartition.card_parts_le_card

section Atomise

/-- Cuts `s` along the finsets in `F`: Two elements of `s` will be in the same part if they are
in the same finsets of `F`. -/
def atomise (s : Finset α) (F : Finset (Finset α)) : Finpartition s :=
  ofErase (F.powerset.image fun Q ↦ s.filter fun i ↦ ∀ t ∈ F, t ∈ Q ↔ i ∈ t)
    (Set.PairwiseDisjoint.supIndep fun x hx y hy h ↦
      disjoint_left.mpr fun z hz1 hz2 ↦
        h (by
            rw [mem_coe, mem_image] at hx hy
            obtain ⟨Q, hQ, rfl⟩ := hx
            obtain ⟨R, hR, rfl⟩ := hy
            suffices h' : Q = R
            · subst h'
              exact of_eq_true (eq_self (
                filter (fun i ↦ ∀ (t : Finset α), t ∈ F → (t ∈ Q ↔ i ∈ t)) s))
            rw [id, mem_filter] at hz1 hz2
            rw [mem_powerset] at hQ hR
            ext i
            refine' ⟨fun hi ↦ _, fun hi ↦ _⟩
            · rwa [hz2.2 _ (hQ hi), ← hz1.2 _ (hQ hi)]
            · rwa [hz1.2 _ (hR hi), ← hz2.2 _ (hR hi)]))
    (by
      refine' (Finset.sup_le fun t ht ↦ _).antisymm fun a ha ↦ _
      · rw [mem_image] at ht
        obtain ⟨A, _, rfl⟩ := ht
        exact s.filter_subset _
      · rw [mem_sup]
        refine'
          ⟨s.filter fun i ↦ ∀ t, t ∈ F → ((t ∈ F.filter fun u ↦ a ∈ u) ↔ i ∈ t),
            mem_image_of_mem _ (mem_powerset.2 <| filter_subset _ _),
            mem_filter.2 ⟨ha, fun t ht ↦ _⟩⟩
        rw [mem_filter]
        exact and_iff_right ht)
#align finpartition.atomise Finpartition.atomise

variable {F : Finset (Finset α)}

-- porting note:
/- ./././Mathport/Syntax/Translate/Basic.lean:632:2: warning: expanding binder collection
   (Q «expr ⊆ » F) -/
theorem mem_atomise :
    t ∈ (atomise s F).parts ↔
      t.Nonempty ∧ ∃ (Q : _)(_ : Q ⊆ F), (s.filter fun i ↦ ∀ u ∈ F, u ∈ Q ↔ i ∈ u) = t := by
  simp only [atomise, ofErase, bot_eq_empty, mem_erase, mem_image, nonempty_iff_ne_empty,
    mem_singleton, and_comm, mem_powerset, exists_prop]
#align finpartition.mem_atomise Finpartition.mem_atomise

theorem atomise_empty (hs : s.Nonempty) : (atomise s ∅).parts = {s} := by
  simp only [atomise, powerset_empty, image_singleton, not_mem_empty, IsEmpty.forall_iff,
    imp_true_iff, filter_True]
  exact erase_eq_of_not_mem (not_mem_singleton.2 hs.ne_empty.symm)
#align finpartition.atomise_empty Finpartition.atomise_empty

theorem card_atomise_le : (atomise s F).parts.card ≤ 2 ^ F.card :=
  (card_le_of_subset <| erase_subset _ _).trans <| Finset.card_image_le.trans (card_powerset _).le
#align finpartition.card_atomise_le Finpartition.card_atomise_le

theorem bunionᵢ_filter_atomise (ht : t ∈ F) (hts : t ⊆ s) :
    ((atomise s F).parts.filter fun u ↦ u ⊆ t ∧ u.Nonempty).bunionᵢ id = t := by
  ext a
  refine' mem_bunionᵢ.trans ⟨fun ⟨u, hu, ha⟩ ↦ (mem_filter.1 hu).2.1 ha, fun ha ↦ _⟩
  obtain ⟨u, hu, hau⟩ := (atomise s F).exists_mem (hts ha)
  refine' ⟨u, mem_filter.2 ⟨hu, fun b hb ↦ _, _, hau⟩, hau⟩
  obtain ⟨Q, _hQ, rfl⟩ := (mem_atomise.1 hu).2
  rw [mem_filter] at hau hb
  rwa [← hb.2 _ ht, hau.2 _ ht]
#align finpartition.bUnion_filter_atomise Finpartition.bunionᵢ_filter_atomise

theorem card_filter_atomise_le_two_pow (ht : t ∈ F) :
    ((atomise s F).parts.filter fun u ↦ u ⊆ t ∧ u.Nonempty).card ≤ 2 ^ (F.card - 1) := by
  suffices h :
    ((atomise s F).parts.filter fun u ↦ u ⊆ t ∧ u.Nonempty) ⊆
      (F.erase t).powerset.image fun P ↦ s.filter fun i ↦ ∀ x ∈ F, x ∈ insert t P ↔ i ∈ x
  · refine' (card_le_of_subset h).trans (card_image_le.trans _)
    rw [card_powerset, card_erase_of_mem ht]
  rw [subset_iff]
  simp_rw [mem_image, mem_powerset, mem_filter, and_imp, Finset.Nonempty, exists_imp, mem_atomise,
    and_imp, Finset.Nonempty, exists_imp]
  rintro P' i hi P PQ rfl hy₂ j _hj
  refine' ⟨P.erase t, erase_subset_erase _ PQ, _⟩
  simp only [insert_erase (((mem_filter.1 hi).2 _ ht).2 <| hy₂ hi)]
#align finpartition.card_filter_atomise_le_two_pow Finpartition.card_filter_atomise_le_two_pow

end Atomise

end Finpartition


variable (A B : Prop) -- "variables" cannot be used in Lean 4?

-- example : A ∧ ¬ B → ¬ B ∧ A :=
--   have h : (A ∧ ¬ B)
--   show ¬ B ∧ A from and.intro (and.right h) (and.left h)

-- show <prop> from <term>
-- suffices <var>:<prop>

#check fun (hp : A) (hq : B) => And.intro hp hq

-- Prop combinators
#check False
#print False
#check True
#print True
#check And
#print And
#check Or
#check Not
#print Not
-- No "Implies": "→" is a primitive combinator

-- Term combinators
#check @And.intro
#check @And.left
#check @And.right

#check @Or.intro_left
#check @Or.intro_right
#check @Or.inl -- shorthand for "intro_left _"
#check @Or.inr -- shorthand for "intro_right _"


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.pi
import data.prod
import data.subtype
import logic.unique
import logic.function.basic

/-!
# Nontrivial types

A type is *nontrivial* if it contains at least two elements. This is useful in particular for rings
(where it is equivalent to the fact that zero is different from one) and for vector spaces
(where it is equivalent to the fact that the dimension is positive).

We introduce a typeclass `nontrivial` formalizing this property.
-/

variables {α : Type*} {β : Type*}

open_locale classical

/-- Predicate typeclass for expressing that a type is not reduced to a single element. In rings,
this is equivalent to `0 ≠ 1`. In vector spaces, this is equivalent to positive dimension. -/
class nontrivial (α : Type*) : Prop :=
(exists_pair_ne : ∃ (x y : α), x ≠ y)

lemma nontrivial_iff : nontrivial α ↔ ∃ (x y : α), x ≠ y :=
⟨λ h, h.exists_pair_ne, λ h, ⟨h⟩⟩

lemma exists_pair_ne (α : Type*) [nontrivial α] : ∃ (x y : α), x ≠ y :=
nontrivial.exists_pair_ne

lemma exists_ne [nontrivial α] (x : α) : ∃ y, y ≠ x :=
begin
  rcases exists_pair_ne α with ⟨y, y', h⟩,
  by_cases hx : x = y,
  { rw ← hx at h,
    exact ⟨y', h.symm⟩ },
  { exact ⟨y, ne.symm hx⟩ }
end

-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
lemma nontrivial_of_ne (x y : α) (h : x ≠ y) : nontrivial α :=
⟨⟨x, y, h⟩⟩

-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
lemma nontrivial_of_lt [preorder α] (x y : α) (h : x < y) : nontrivial α :=
⟨⟨x, y, ne_of_lt h⟩⟩

lemma nontrivial_iff_exists_ne (x : α) : nontrivial α ↔ ∃ y, y ≠ x :=
⟨λ h, @exists_ne α h x, λ ⟨y, hy⟩, nontrivial_of_ne _ _ hy⟩

lemma subtype.nontrivial_iff_exists_ne (p : α → Prop) (x : subtype p) :
  nontrivial (subtype p) ↔ ∃ (y : α) (hy : p y), y ≠ x :=
by simp only [nontrivial_iff_exists_ne x, subtype.exists, ne.def, subtype.ext_iff, subtype.coe_mk]

@[priority 100] -- see Note [lower instance priority]
instance nontrivial.to_nonempty [nontrivial α] : nonempty α :=
let ⟨x, _⟩ := exists_pair_ne α in ⟨x⟩

/-- An inhabited type is either nontrivial, or has a unique element. -/
noncomputable def nontrivial_psum_unique (α : Type*) [inhabited α] :
  psum (nontrivial α) (unique α) :=
if h : nontrivial α then psum.inl h else psum.inr
{ default := default α,
  uniq := λ (x : α),
  begin
    change x = default α,
    contrapose! h,
    use [x, default α]
  end }

lemma subsingleton_iff : subsingleton α ↔ ∀ (x y : α), x = y :=
⟨by { introsI h, exact subsingleton.elim }, λ h, ⟨h⟩⟩

lemma not_nontrivial_iff_subsingleton : ¬(nontrivial α) ↔ subsingleton α :=
by { rw [nontrivial_iff, subsingleton_iff], push_neg, refl }

lemma not_subsingleton (α) [h : nontrivial α] : ¬subsingleton α :=
let ⟨⟨x, y, hxy⟩⟩ := h in λ ⟨h'⟩, hxy $ h' x y

/-- A type is either a subsingleton or nontrivial. -/
lemma subsingleton_or_nontrivial (α : Type*) : subsingleton α ∨ nontrivial α :=
by { rw [← not_nontrivial_iff_subsingleton, or_comm], exact classical.em _ }

lemma false_of_nontrivial_of_subsingleton (α : Type*) [nontrivial α] [subsingleton α] : false :=
let ⟨x, y, h⟩ := exists_pair_ne α in h $ subsingleton.elim x y

instance option.nontrivial [nonempty α] : nontrivial (option α) :=
by { inhabit α, use [none, some (default α)] }

/-- Pushforward a `nontrivial` instance along an injective function. -/
protected lemma function.injective.nontrivial [nontrivial α]
  {f : α → β} (hf : function.injective f) : nontrivial β :=
let ⟨x, y, h⟩ := exists_pair_ne α in ⟨⟨f x, f y, hf.ne h⟩⟩

/-- Pullback a `nontrivial` instance along a surjective function. -/
protected lemma function.surjective.nontrivial [nontrivial β]
  {f : α → β} (hf : function.surjective f) : nontrivial α :=
begin
  rcases exists_pair_ne β with ⟨x, y, h⟩,
  rcases hf x with ⟨x', hx'⟩,
  rcases hf y with ⟨y', hy'⟩,
  have : x' ≠ y', by { contrapose! h, rw [← hx', ← hy', h] },
  exact ⟨⟨x', y', this⟩⟩
end

/-- An injective function from a nontrivial type has an argument at
which it does not take a given value. -/
protected lemma function.injective.exists_ne [nontrivial α] {f : α → β}
  (hf : function.injective f) (y : β) : ∃ x, f x ≠ y :=
begin
  rcases exists_pair_ne α with ⟨x₁, x₂, hx⟩,
  by_cases h : f x₂ = y,
  { exact ⟨x₁, (hf.ne_iff' h).2 hx⟩ },
  { exact ⟨x₂, h⟩ }
end

instance nontrivial_prod_right [nonempty α] [nontrivial β] : nontrivial (α × β) :=
prod.snd_surjective.nontrivial

instance nontrivial_prod_left [nontrivial α] [nonempty β] : nontrivial (α × β) :=
prod.fst_surjective.nontrivial

namespace pi

variables {I : Type*} {f : I → Type*}

/-- A pi type is nontrivial if it's nonempty everywhere and nontrivial somewhere. -/
lemma nontrivial_at (i' : I) [inst : Π i, nonempty (f i)] [nontrivial (f i')] :
  nontrivial (Π i : I, f i) :=
by classical; exact
(function.update_injective (λ i, classical.choice (inst i)) i').nontrivial

/--
As a convenience, provide an instance automatically if `(f (default I))` is nontrivial.

If a different index has the non-trivial type, then use `haveI := nontrivial_at that_index`.
-/
instance nontrivial [inhabited I] [inst : Π i, nonempty (f i)] [nontrivial (f (default I))] :
  nontrivial (Π i : I, f i) :=
nontrivial_at (default I)

end pi

instance function.nontrivial [h : nonempty α] [nontrivial β] : nontrivial (α → β) :=
h.elim $ λ a, pi.nontrivial_at a

mk_simp_attribute nontriviality "Simp lemmas for `nontriviality` tactic"

protected lemma subsingleton.le [preorder α] [subsingleton α] (x y : α) : x ≤ y :=
le_of_eq (subsingleton.elim x y)

attribute [nontriviality] eq_iff_true_of_subsingleton subsingleton.le

namespace tactic

/--
Tries to generate a `nontrivial α` instance by performing case analysis on
`subsingleton_or_nontrivial α`,
attempting to discharge the subsingleton branch using lemmas with `@[nontriviality]` attribute,
including `subsingleton.le` and `eq_iff_true_of_subsingleton`.
-/
meta def nontriviality_by_elim (α : expr) (lems : interactive.parse simp_arg_list) : tactic unit :=
do
  alternative ← to_expr ``(subsingleton_or_nontrivial %%α),
  n ← get_unused_name "_inst",
  tactic.cases alternative [n, n],
  (solve1 $ do
    reset_instance_cache,
    apply_instance <|>
      interactive.simp none none ff lems [`nontriviality] (interactive.loc.ns [none])) <|>
      fail format!"Could not prove goal assuming `subsingleton {α}`",
  reset_instance_cache

/--
Tries to generate a `nontrivial α` instance using `nontrivial_of_ne` or `nontrivial_of_lt`
and local hypotheses.
-/
meta def nontriviality_by_assumption (α : expr) : tactic unit :=
do
  n ← get_unused_name "_inst",
  to_expr ``(nontrivial %%α) >>= assert n,
  apply_instance <|> `[solve_by_elim [nontrivial_of_ne, nontrivial_of_lt]],
  reset_instance_cache

end tactic

namespace tactic.interactive

open tactic

setup_tactic_parser

/--
Attempts to generate a `nontrivial α` hypothesis.

The tactic first looks for an instance using `apply_instance`.

If the goal is an (in)equality, the type `α` is inferred from the goal.
Otherwise, the type needs to be specified in the tactic invocation, as `nontriviality α`.

The `nontriviality` tactic will first look for strict inequalities amongst the hypotheses,
and use these to derive the `nontrivial` instance directly.

Otherwise, it will perform a case split on `subsingleton α ∨ nontrivial α`, and attempt to discharge
the `subsingleton` goal using `simp [lemmas] with nontriviality`, where `[lemmas]` is a list of
additional `simp` lemmas that can be passed to `nontriviality` using the syntax
`nontriviality α using [lemmas]`.

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : 0 < a :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  assumption,
end
```

```
example {R : Type} [comm_ring R] {r s : R} : r * s = s * r :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  apply mul_comm,
end
```

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : (2 : ℕ) ∣ 4 :=
begin
  nontriviality R, -- there is now a `nontrivial R` hypothesis available.
  dec_trivial
end
```

```
def myeq {α : Type} (a b : α) : Prop := a = b

example {α : Type} (a b : α) (h : a = b) : myeq a b :=
begin
  success_if_fail { nontriviality α }, -- Fails
  nontriviality α using [myeq], -- There is now a `nontrivial α` hypothesis available
  assumption
end
```
-/
meta def nontriviality (t : parse texpr?)
  (lems : parse (tk "using" *> simp_arg_list <|> pure [])) :
  tactic unit :=
do
  α ← match t with
  | some α := to_expr α
  | none :=
    (do t ← mk_mvar, e ← to_expr ``(@eq %%t _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@has_le.le %%t _ _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@ne %%t _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@has_lt.lt %%t _ _ _), target >>= unify e, return t) <|>
    fail "The goal is not an (in)equality, so you'll need to specify the desired `nontrivial α`
      instance by invoking `nontriviality α`."
  end,
  nontriviality_by_assumption α <|> nontriviality_by_elim α lems

add_tactic_doc
{ name                     := "nontriviality",
  category                 := doc_category.tactic,
  decl_names               := [`tactic.interactive.nontriviality],
  tags                     := ["logic", "type class"] }

end tactic.interactive

namespace bool

instance : nontrivial bool := ⟨⟨tt,ff, tt_eq_ff_eq_false⟩⟩

end bool