import for_mathlib.algebra.homology.trunc_ge

noncomputable theory

open category_theory category_theory.limits category_theory.category
open_locale zero_object

variables {C : Type*} [category C] [abelian C]

namespace category_theory.short_complex

lemma quasi_iso.of_kernel_fork {C : Type*} [category C] [has_zero_morphisms C]
  {S₁ S₂ : short_complex C} (φ : S₁ ⟶ S₂) [S₁.has_homology] [S₂.has_homology]
  [epi φ.τ₁] (hg₁ : S₁.g = 0) (hτ₂ : is_limit (kernel_fork.of_ι φ.τ₂
    (show φ.τ₂ ≫ S₂.g = 0, by rw [φ.comm₂₃, hg₁, zero_comp]))) :
  short_complex.quasi_iso φ :=
begin
  have w : φ.τ₂ ≫ S₂.g = 0 := by rw [φ.comm₂₃, hg₁, zero_comp],
  have h₂ := S₂.some_left_homology_data,
  let e : h₂.K ≅ S₁.X₂ := is_limit.cone_point_unique_up_to_iso h₂.hi hτ₂,
  have he : e.hom ≫ φ.τ₂ = h₂.i :=
    is_limit.cone_point_unique_up_to_iso_hom_comp h₂.hi hτ₂ walking_parallel_pair.zero,
  have wi : e.hom ≫ S₁.g = 0 := by rw [hg₁, comp_zero],
  let hi : is_limit (kernel_fork.of_ι e.hom wi) := kernel_fork.is_limit.of_ι _ _
    (λ A x hx, x ≫ e.inv)
    (λ A x hx, by rw [assoc, e.inv_hom_id, comp_id])
    (λ A x hx b hb, by rw [← hb, assoc, e.hom_inv_id, comp_id]),
  have comm : S₁.f ≫ e.inv = φ.τ₁ ≫ h₂.f',
  { rw [← cancel_mono h₂.i, assoc, assoc, h₂.f'_i, ← he, e.inv_hom_id_assoc, φ.comm₁₂], },
  have wπ : (S₁.f ≫ e.inv) ≫ h₂.π = 0,
  { rw [comm, assoc, h₂.f'_π, comp_zero], },
  have hπ : is_colimit (cokernel_cofork.of_π h₂.π wπ) := cokernel_cofork.is_colimit.of_π _ _
    (λ A x hx, h₂.hπ.desc (cokernel_cofork.of_π _
      (show h₂.f' ≫ x = 0, by rw [← cancel_epi φ.τ₁, ← reassoc_of comm, ← assoc, hx, comp_zero])))
    (λ A x hx, cofork.is_colimit.π_desc h₂.hπ)
    (λ A x hx b hb, by { erw [← cancel_epi h₂.π, hb, cofork.is_colimit.π_desc h₂.hπ], refl, }),
  let h₁ : S₁.left_homology_data :=
  { K := h₂.K,
    H := h₂.H,
    i := e.hom,
    wi := wi,
    hi := hi,
    π := h₂.π,
    wπ := wπ,
    hπ := hπ, },
  let hφ : left_homology_map_data φ h₁ h₂ :=
  { φK := 𝟙 _,
    φH := 𝟙 _,
    commi' := by rw [id_comp, he], },
  rw hφ.quasi_iso_iff,
  dsimp,
  apply_instance,
end

end category_theory.short_complex

namespace cochain_complex

variables (K L : cochain_complex C ℤ)

def trunc_le.X (n : ℤ) (i : ℤ) : C :=
if n < i
  then 0
  else if i = n
    then (homological_complex.short_complex_functor C (complex_shape.up ℤ) i ⋙
      short_complex.cycles_functor C).obj K
    else K.X i

lemma trunc_le.is_zero_X (n : ℤ) (i : ℤ) (hn : n < i) :
  is_zero (trunc_le.X K n i) :=
begin
  dsimp [trunc_le.X],
  simpa only [if_pos hn] using is_zero_zero C,
end

def trunc_le.X_iso_X (n : ℤ) (i : ℤ) (hn : i < n) :
  trunc_le.X K n i ≅ K.X i :=
eq_to_iso begin
  dsimp [trunc_le.X],
  rw [if_neg (show ¬n<i, by linarith), if_neg (show i ≠ n, by linarith)],
end

def trunc_le.X_iso_cycles (n : ℤ) (i : ℤ) (hn : i = n) :
  trunc_le.X K n i ≅ (K.sc' i).cycles :=
eq_to_iso begin
  dsimp [trunc_le.X],
  simpa only [if_neg (show ¬ n<i, by linarith), if_pos hn],
end

def trunc_le.d (n : ℤ) (i j : ℤ) : trunc_le.X K n i ⟶ trunc_le.X K n j :=
begin
  by_cases hij : i+1 = j,
  { by_cases hj₀ : n<j,
    { exact 0, },
    { by_cases hn : j = n,
      { exact ((K.sc' j).lift_cycles ((trunc_le.X_iso_X K n i (by linarith)).hom ≫ K.d i j)
          (by tidy)) ≫ (trunc_le.X_iso_cycles K n j hn).inv, },
      { exact (trunc_le.X_iso_X K n i (by linarith)).hom ≫ K.d i j ≫
          (trunc_le.X_iso_X K n j (by { cases (not_lt.1 hj₀).lt_or_eq; tauto, })).inv, }, }, },
  { exact 0, },
end

def trunc_le.ι_f (n i : ℤ) : trunc_le.X K n i ⟶ K.X i :=
begin
  by_cases hi : n < i,
  { exact 0, },
  { by_cases hn : i = n,
    { exact (trunc_le.X_iso_cycles K n i hn).hom ≫ (K.sc' i).cycles_i, },
    { exact (trunc_le.X_iso_X K n i (by { cases (not_lt.1 hi).lt_or_eq; tauto, })).hom, }, },
end

instance (n i : ℤ) : mono (trunc_le.ι_f K n i) :=
begin
  dsimp [trunc_le.ι_f],
  by_cases h₀ : n < i,
  { rw dif_pos h₀,
    constructor,
    intros Z f₁ f₂ eq,
    apply (trunc_le.is_zero_X K n i h₀).eq_of_tgt, },
  { rw dif_neg h₀,
    by_cases hn : i = n,
    { rw dif_pos hn,
      apply mono_comp, },
    { rw dif_neg hn,
      apply_instance, }, },
end

lemma trunc_le.is_iso_ι_f (n i : ℤ) (hi : i < n) :
  is_iso (trunc_le.ι_f K n i) :=
begin
  dsimp [trunc_le.ι_f],
  simp only [dif_neg (show ¬ n < i, by linarith),
    dif_neg (show i ≠ n, by linarith)],
  apply_instance,
end

lemma trunc_le.ι_f_eq_zero (n i : ℤ) (hi : n < i) :
  trunc_le.ι_f K n i = 0 :=
by { dsimp [trunc_le.ι_f], rw [dif_pos hi], }

lemma trunc_le.ι_f_eq_of_eq (n i : ℤ) (hn : i = n) :
  trunc_le.ι_f K n i = (trunc_le.X_iso_cycles K n i hn).hom ≫ (K.sc' i).cycles_i :=
by { dsimp [trunc_le.ι_f], rw [dif_neg (show ¬n<i, by linarith), dif_pos hn], }

lemma trunc_le.ι_f_eq_X_iso_X_inv (n i : ℤ) (hi : i < n) :
  trunc_le.ι_f K n i = (trunc_le.X_iso_X K n i hi).hom :=
by { dsimp [trunc_le.ι_f], rw [dif_neg, dif_neg]; linarith, }

lemma trunc_le.shape (n i j : ℤ) (hij : i+1 ≠ j) : trunc_le.d K n i j = 0 :=
by { dsimp only [trunc_le.d], rw dif_neg hij, }

lemma trunc_le.d_eq_zero (n : ℤ) (i j : ℤ) (hj : n ≤ i) :
  trunc_le.d K n i j = 0 :=
begin
  by_cases hij : i+1 = j,
  { dsimp [trunc_le.d],
    rw [dif_pos hij, dif_pos],
    linarith, },
  { rw trunc_le.shape K n i j hij, },
end

lemma trunc_le.d_eq_d (n : ℤ) (i j : ℤ) (hij : i + 1 = j) (hj : j < n) :
  trunc_le.d K n i j = (trunc_le.X_iso_X K n i
    (by { rw ← hij at hj, exact (lt_add_one i).trans hj, })).hom ≫ K.d i j ≫
    (trunc_le.X_iso_X K n j hj).inv :=
by { dsimp [trunc_le.d], rw [dif_pos hij, dif_neg, dif_neg]; linarith, }

lemma trunc_le.ι_comp_d_eq_zero (n : ℤ) (i j : ℤ) (hij : i + 1 = j) (hi : i = n) :
   trunc_le.ι_f K n i ≫ K.d i j = 0 :=
begin
  have hj : j = (complex_shape.up ℤ).next i := by { rw [next], linarith, },
  subst hj,
  dsimp [trunc_le.ι_f],
  erw [dif_neg (show ¬n<i, by linarith), dif_pos hi, assoc, (K.sc' i).cycles_i_g, comp_zero],
end

def trunc_le.ι_is_kernel (n i j : ℤ) (hij : i + 1 = j) (hi : i = n) :
  is_limit (kernel_fork.of_ι _ (trunc_le.ι_comp_d_eq_zero K n i j hij hi)) :=
begin
  have hij' : j = (complex_shape.up ℤ).next i := by { rw [next], linarith, },
  subst hij',
  exact is_limit.of_iso_limit (K.sc' i).cycles_is_kernel
    (iso.symm (fork.ext (trunc_le.X_iso_cycles K n i hi)
      (trunc_le.ι_f_eq_of_eq K n i hi).symm)),
end

@[simp, reassoc]
lemma trunc_le.d_comm (n i j : ℤ) :
  trunc_le.d K n i j ≫ trunc_le.ι_f K n j =
     trunc_le.ι_f K n i ≫ K.d i j :=
begin
  by_cases hij : i+1 = j,
  { by_cases hi₀ : n < i,
    { apply (trunc_le.is_zero_X K n i hi₀).eq_of_src, },
    by_cases hi : i = n,
    { simp only [trunc_le.ι_comp_d_eq_zero K n i j hij hi,
        trunc_le.d_eq_zero K n i j (by linarith), zero_comp], },
    by_cases hj : j = n,
    { dsimp [trunc_le.d, trunc_le.ι_f],
      simp only [dif_pos hij, dif_neg (show ¬ n < j, by linarith), dif_pos hj, dif_neg hi₀,
        dif_neg hi, assoc, iso.inv_hom_id_assoc, short_complex.lift_cycles_i], },
    { have hj' : j < n,
      { subst hij,
        cases (not_lt.1 hi₀).lt_or_eq,
        { rw lt_iff_le_and_ne,
          split,
          { linarith, },
          { exact hj, }, },
        { exfalso, exact hi h, }, },
      simp only [trunc_le.d_eq_d K n i j hij hj', trunc_le.ι_f_eq_X_iso_X_inv K n j hj', assoc,
        iso.inv_hom_id, comp_id, trunc_le.ι_f_eq_X_iso_X_inv K n i (by linarith)], }, },
  { rw [trunc_le.shape K n i j hij, K.shape i j hij, zero_comp, comp_zero], },
end

@[simp, reassoc]
lemma trunc_le.d_comp_d (n i j k : ℤ) : trunc_le.d K n i j ≫ trunc_le.d K n j k = 0 :=
by simp only [← cancel_mono (trunc_le.ι_f K n k), assoc, trunc_le.d_comm,
    trunc_le.d_comm_assoc, K.d_comp_d, zero_comp, comp_zero]

@[simps]
def trunc_le (n : ℤ) : cochain_complex C ℤ :=
{ X := trunc_le.X K n,
  d := trunc_le.d K n,
  shape' := trunc_le.shape K n,
  d_comp_d' := λ i j k hij hjk, trunc_le.d_comp_d K n i j k, }

@[simps]
def trunc_le.ι (n : ℤ) : K.trunc_le n ⟶ K :=
{ f := trunc_le.ι_f K n,
  comm' := λ i j hij, (trunc_le.d_comm K n i j).symm, }

variables {K L}

def trunc_le.map_f (φ : K ⟶ L) (n i : ℤ) :
  (K.trunc_le n).X i ⟶ (L.trunc_le n).X i :=
begin
  by_cases hi : i < n,
  { exact (trunc_le.X_iso_X K n i hi).hom ≫ φ.f i ≫
    (trunc_le.X_iso_X L n i hi).inv, },
  { by_cases hn : i = n,
    { exact (trunc_le.X_iso_cycles K n i hn).hom ≫
        (homological_complex.short_complex_functor C (complex_shape.up ℤ) i ⋙
        short_complex.cycles_functor C).map φ≫ (trunc_le.X_iso_cycles L n i hn).inv, },
    { exact 0, }, },
end

lemma trunc_le.map_f_eq_f (φ : K ⟶ L) (n i : ℤ) (hi : i < n) :
  trunc_le.map_f φ n i = (trunc_le.X_iso_X K n i hi).hom ≫ φ.f i ≫
    (trunc_le.X_iso_X L n i hi).inv :=
begin
  dsimp only [trunc_le.map_f],
  simp only [dif_pos hi],
end

@[simp, reassoc]
lemma trunc_le.map_f_comm_ι_f (φ : K ⟶ L) (n i : ℤ) :
  trunc_le.map_f φ n i ≫ trunc_le.ι_f L n i =
    trunc_le.ι_f K n i ≫ φ.f i :=
begin
  by_cases hi : i < n,
  { simp only [trunc_le.ι_f_eq_X_iso_X_inv _ n i hi, trunc_le.map_f_eq_f φ n i hi, assoc,
      iso.inv_hom_id, comp_id], },
  { by_cases hn : i = n,
    { dsimp [trunc_le.map_f, trunc_ge.π_f],
      simp only [dif_neg hi, dif_pos hn, assoc, iso.inv_hom_id_assoc,
        trunc_le.ι_f_eq_of_eq _ n i hn],
      erw (short_complex.cycles_i_nat_trans C).naturality
        ((homological_complex.short_complex_functor C (complex_shape.up ℤ) i).map φ),
      refl,   },
    { refine (trunc_le.is_zero_X K n i _).eq_of_src _ _,
      cases (not_lt.1 hi).lt_or_eq,
      { exact h, },
      { exfalso, exact hn h.symm, }, }, },
end

@[reassoc]
lemma trunc_le.map_comm_f (φ : K ⟶ L) (n i j : ℤ) :
  trunc_le.map_f φ n i ≫ trunc_le.d L n i j =
    trunc_le.d K n i j ≫ trunc_le.map_f φ n j :=
by simp only [← cancel_mono (trunc_le.ι_f L n j), assoc, trunc_le.d_comm,
    trunc_le.map_f_comm_ι_f_assoc, homological_complex.hom.comm, trunc_le.map_f_comm_ι_f,
    trunc_le.d_comm_assoc]

@[simp]
lemma trunc_le.map_id_f (K : cochain_complex C ℤ) (n i : ℤ) :
  trunc_le.map_f (𝟙 K) n i = 𝟙 _ :=
by simp only [← cancel_mono (trunc_le.ι_f K n i),
  trunc_le.map_f_comm_ι_f, homological_complex.id_f, comp_id, id_comp]

@[simp]
lemma trunc_le.map_comp_f {K L M : cochain_complex C ℤ}
  (φ : K ⟶ L) (φ' : L ⟶ M) (n i : ℤ) :
  trunc_le.map_f (φ ≫ φ') n i =
    trunc_le.map_f φ n i ≫ trunc_le.map_f φ' n i :=
by simp only [← cancel_mono (trunc_le.ι_f M n i),
  trunc_le.map_f_comm_ι_f, homological_complex.comp_f, assoc, trunc_le.map_f_comm_ι_f_assoc]

variable (C)

@[simps]
def trunc_le_functor (n : ℤ) :
  cochain_complex C ℤ ⥤ cochain_complex C ℤ :=
{ obj := λ K, K.trunc_le n,
  map := λ K L φ,
  { f := λ i, trunc_le.map_f φ n i,
    comm' := λ i j hij, trunc_le.map_comm_f φ n i j, }, }

@[simps]
def trunc_le.nat_trans_ι (n : ℤ) :
  trunc_le_functor C n ⟶ 𝟭 _ :=
{ app := λ K, trunc_le.ι K n,
  naturality' := λ K L φ, begin
    ext i
    dsimp,
    simp only [functor.id_map, homological_complex.comp_f, trunc_le_functor_map_f],
    dsimp,
    simp only [trunc_le.map_f_comm_ι_f],
  end, }

variables {C} (K)

lemma trunc_le.is_zero_homology (n i : ℤ) (hi : n < i) :
  is_zero ((homology_functor C _ i).obj (K.trunc_le n)) :=
begin
  dsimp [homology_functor],
  rw ← short_complex.exact_iff_is_zero_homology,
  exact short_complex.exact.of_is_zero_X₂ _ (trunc_le.is_zero_X K n i hi),
end

lemma trunc_le.is_iso_homology_map_ι (n i : ℤ) (hi : i ≤ n) :
  is_iso ((homology_functor C _ i).map (trunc_le.ι K n)) :=
begin
  let φ := (homological_complex.short_complex_functor C (complex_shape.up ℤ) i).map
    (trunc_le.ι K n),
  haveI : is_iso φ.τ₁ := trunc_le.is_iso_ι_f K n _ (by { rw [prev], linarith, }),
  cases hi.lt_or_eq,
  { haveI : mono φ.τ₃ := by { dsimp, apply_instance, },
    haveI : is_iso φ.τ₂ := trunc_le.is_iso_ι_f K n i h,
    exact short_complex.quasi_iso.of_epi_of_is_iso_of_mono φ, },
  { exact category_theory.short_complex.quasi_iso.of_kernel_fork φ
    ((trunc_le.is_zero_X K n _ (by { rw [next], linarith, })).eq_of_tgt _ _)
      (trunc_le.ι_is_kernel K n i _ (by { rw [next], }) h), },
end

variables {K L}

lemma trunc_le.map_homology_iso (φ : K ⟶ L) (n i : ℤ) [is_iso (homology_map φ i)] :
  is_iso (homology_map ((trunc_le_functor C n).map φ) i) :=
begin
  by_cases hi : i ≤ n,
  { have eq := (homology_functor C _ i).congr_map ((trunc_le.nat_trans_ι C n).naturality φ),
    simp only [functor.map_comp, functor.id_map, trunc_le.nat_trans_ι_app] at eq,
    change homology_map _ i ≫ homology_map (trunc_le.ι L n) i =
      homology_map (trunc_le.ι K n) i ≫ homology_map φ i at eq,
    haveI : ∀ (M : cochain_complex C ℤ), is_iso (homology_map (trunc_le.ι M n) i) :=
      λ M, trunc_le.is_iso_homology_map_ι M n i hi,
    simp only [← cancel_mono (inv (homology_map (trunc_le.ι L n) i)),
      assoc, is_iso.hom_inv_id, comp_id] at eq,
    rw eq,
    apply_instance, },
  { simp only [not_le] at hi,
    exact ⟨⟨0, (trunc_le.is_zero_homology K n i hi).eq_of_src _ _,
       (trunc_le.is_zero_homology L n i hi).eq_of_src _ _⟩⟩, },
end

instance trunc_le.map_quasi_iso (φ : K ⟶ L) (n : ℤ) [quasi_iso φ] :
  quasi_iso ((trunc_le_functor _ n).map φ) :=
⟨λ i, trunc_le.map_homology_iso φ n i⟩

variable (C)

lemma trunc_le_functor_comp_Q_inverts_quasi_isomorphisms (n : ℤ) :
  (quasi_isomorphisms _ _).is_inverted_by
    (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) :=
λ K L φ hφ, begin
  haveI : quasi_iso φ := by simpa only [← mem_quasi_isomorphisms_iff] using hφ,
  dsimp,
  apply_instance,
end

variable {C}

class is_strictly_le (K : cochain_complex C ℤ) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.X i))

lemma is_strictly_le.is_zero (K : cochain_complex C ℤ) (n i : ℤ) [K.is_strictly_le n]
  (hi : n < i) : is_zero (K.X i) :=
is_strictly_le.is_zero' i hi

lemma is_strictly_le_of_le (K : cochain_complex C ℤ) (n m : ℤ) (hnm : n ≤ m)
  [K.is_strictly_le n] :
  K.is_strictly_le m :=
⟨λ i hi, is_strictly_le.is_zero K n i (by linarith)⟩

lemma is_strictly_le.of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ)
  [K.is_strictly_le n] : L.is_strictly_le n :=
⟨λ i hi, is_zero.of_iso (is_strictly_le.is_zero K n i hi)
  ((homological_complex.eval _ _ i).map_iso e.symm)⟩

lemma is_strictly_le.iff_of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) :
  K.is_strictly_le n ↔ L.is_strictly_le n :=
begin
  split,
  { introI,
    exact is_strictly_le.of_iso e n, },
  { introI,
    exact is_strictly_le.of_iso e.symm n, },
end

class is_le (K : cochain_complex C ℤ) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.homology i))

lemma is_le.is_zero (K : cochain_complex C ℤ) (n i : ℤ) [K.is_le n] (hi : n < i) :
  is_zero (K.homology i) :=
is_le.is_zero' i hi

lemma is_le_of_le (K : cochain_complex C ℤ) (n m : ℤ) (hnm : n ≤ m) [K.is_le n] : K.is_le m :=
⟨λ i hi, is_le.is_zero K n i (by linarith)⟩

lemma is_le.of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) [K.is_le n] : L.is_le n :=
⟨λ i hi, is_zero.of_iso (is_le.is_zero K n i hi) ((homology_functor _ _ i).map_iso e.symm)⟩

lemma is_le.iff_of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  split,
  { introI,
    exact is_le.of_iso e n, },
  { introI,
    exact is_le.of_iso e.symm n, },
end

@[priority 100]
instance is_le_of_is_strictly_le (K : cochain_complex C ℤ) (n : ℤ)
  [K.is_strictly_le n] : K.is_le n :=
⟨λ i hi, begin
  rw ← short_complex.exact_iff_is_zero_homology,
  exact short_complex.exact.of_is_zero_X₂ _ (is_strictly_le.is_zero K n i hi),
end⟩

instance trunc_le_is_strictly_le (K : cochain_complex C ℤ) (n : ℤ) :
  (K.trunc_le n).is_strictly_le n :=
⟨trunc_le.is_zero_X K n⟩

instance trunc_le_is_strictly_le' (K : cochain_complex C ℤ) (n : ℤ) :
  ((trunc_le_functor C n).obj K).is_strictly_le n :=
(infer_instance : (K.trunc_le n).is_strictly_le n)

lemma trunc_le.is_iso_ι_f_iff_d_eq_zero (K : cochain_complex C ℤ) (n i j : ℤ)
  (hij : i+1 = j) (hi : i = n) :
  is_iso ((trunc_le.ι K n).f i) ↔ K.d i j = 0 :=
begin
  split,
  { intro h,
    haveI : is_iso (trunc_le.ι_f K n i) := h,
    simp only [← cancel_epi (trunc_le.ι_f K n i),
      trunc_le.ι_comp_d_eq_zero K n i j hij hi, comp_zero], },
  { exact kernel_fork.is_limit.is_iso_ι_of_zero _ (trunc_le.ι_is_kernel K n i j hij hi), },
end

instance (K : cochain_complex C ℤ) (n : ℤ) [K.is_strictly_le n] :
  is_iso (trunc_le.ι K n) :=
begin
  haveI : ∀ (i : ℤ), is_iso ((trunc_le.ι K n).f i),
  { intro i,
    by_cases hi : i < n,
    { exact trunc_le.is_iso_ι_f K n i hi, },
    { cases (not_lt.1 hi).lt_or_eq,
      { refine ⟨⟨0, _, (is_strictly_le.is_zero K n i h).eq_of_tgt _ _⟩⟩,
        rw ← cancel_mono (trunc_le.ι_f K n i),
        apply (is_strictly_le.is_zero K n i h).eq_of_tgt, },
      { rw trunc_le.is_iso_ι_f_iff_d_eq_zero K n i (i+1) (by linarith) h.symm,
        apply (is_strictly_le.is_zero K n (i+1) (by linarith)).eq_of_tgt, }, }, },
  apply homological_complex.hom.is_iso_of_components,
end

end cochain_complex

namespace derived_category

variable (C)

def trunc_le_functor (n : ℤ) : derived_category C ⥤ derived_category C :=
localization.lift _ (cochain_complex.trunc_le_functor_comp_Q_inverts_quasi_isomorphisms C n) Q

instance (n : ℤ) : localization.lifting Q (quasi_isomorphisms _ _)
  (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) (trunc_le_functor C n) :=
localization.lifting_lift _ _ _

def trunc_le_functor_iso (n : ℤ) :
  Q ⋙ trunc_le_functor C n ≅ (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) :=
localization.lifting.iso _ (quasi_isomorphisms _ _) _ _

def trunc_le_nat_trans_ι (n : ℤ) : trunc_le_functor C n ⟶ 𝟭 (derived_category C) :=
localization.lift_nat_trans Q (quasi_isomorphisms _ _)
  (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) Q _ _
  (whisker_right (cochain_complex.trunc_le.nat_trans_ι C n) Q)

@[simp]
lemma trunc_le_nat_trans_ι_app (K : cochain_complex C ℤ) (n : ℤ) :
  (trunc_le_nat_trans_ι C n).app (Q.obj K) =
    (trunc_le_functor_iso C n).hom.app K ≫ Q.map (cochain_complex.trunc_le.ι K n) :=
begin
  dsimp only [trunc_le_nat_trans_ι, trunc_le_functor_iso],
  simp only [localization.lift_nat_trans_app, whisker_right_app,
    cochain_complex.trunc_le.nat_trans_ι_app,
    localization.lifting.id_iso, functor.right_unitor_inv_app, comp_id],
end

variable {C}

class is_le (K : derived_category C) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.homology i))

lemma is_le.is_zero (K : derived_category C) (n i : ℤ) [K.is_le n]
  (hi : n < i) : is_zero (K.homology i) :=
is_le.is_zero' i hi

lemma is_le_of_le (K : derived_category C) (n m : ℤ) (hnm : n ≤ m) [K.is_le n] : K.is_le m :=
⟨λ i hi, is_le.is_zero K n i (by linarith)⟩

lemma is_le.of_iso {K L : derived_category C} (e : K ≅ L) (n : ℤ) [K.is_le n] : L.is_le n :=
⟨λ i hi, is_zero.of_iso (is_le.is_zero K n i hi) ((homology_functor _ i).map_iso e.symm)⟩

lemma is_le.iff_of_iso {K L : derived_category C} (e : K ≅ L) (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  split,
  { introI,
    exact is_le.of_iso e n, },
  { introI,
    exact is_le.of_iso e.symm n, },
end

variable (C)

def Q_comp_trunc_le_functor_comp_homology_functor_iso (n i : ℤ) :
  Q ⋙ trunc_le_functor C n ⋙ homology_functor C i ≅
    cochain_complex.trunc_le_functor C n ⋙ _root_.homology_functor _ _ i :=
(functor.associator _ _ _).symm ≪≫
  iso_whisker_right (trunc_le_functor_iso C n) (homology_functor C i) ≪≫
  functor.associator _ _ _ ≪≫ iso_whisker_left _ (homology_functor_factors C i)

variable {C}

lemma is_zero_homology_trunc_le_of_lt (K : derived_category C) (n i : ℤ) (hi : n < i) :
  is_zero (((trunc_le_functor C n).obj K).homology i) :=
is_zero.of_iso (cochain_complex.is_le.is_zero _ n i hi)
  (((trunc_le_functor C n ⋙ homology_functor C i).map_iso (Q.obj_obj_preimage_iso K)).symm ≪≫
    ((Q_comp_trunc_le_functor_comp_homology_functor_iso C n i).app _))

lemma is_iso_homology_map_trunc_le_nat_trans_ι_of_le (K : derived_category C) (n i : ℤ)
  (hi : i ≤ n) :
  is_iso ((homology_functor C i).map ((trunc_le_nat_trans_ι C n).app K)) :=
begin
  erw ← (Q.obj_obj_preimage_iso K).is_iso_app_iff
    (whisker_right (trunc_le_nat_trans_ι C n) (homology_functor C i)),
  dsimp,
  erw [trunc_le_nat_trans_ι_app, functor.map_comp],
  haveI : ∀ (L : cochain_complex C ℤ), is_iso ((homology_functor C i).map (Q.map
    (cochain_complex.trunc_le.ι L n))),
  { intro L,
    erw nat_iso.is_iso_map_iff (homology_functor_factors C i),
    exact cochain_complex.trunc_le.is_iso_homology_map_ι L n i hi, },
  apply_instance,
end

lemma is_iso_trunc_le_nat_trans_ι_app_iff (K : derived_category C) (n : ℤ) :
  is_iso ((trunc_le_nat_trans_ι C n).app K) ↔ K.is_le n :=
begin
  rw is_iso_iff_is_iso_homology,
  split,
  { introI hK,
    exact ⟨λ i hi, is_zero.of_iso (is_zero_homology_trunc_le_of_lt K n i hi)
      (as_iso ((homology_functor C i).map ((trunc_le_nat_trans_ι C n).app K))).symm⟩, },
  { introI,
    intro i,
    by_cases hi : i ≤ n,
    { exact is_iso_homology_map_trunc_le_nat_trans_ι_of_le K n i hi, },
    { simp only [not_le] at hi,
      exact ⟨⟨0, (is_zero_homology_trunc_le_of_lt K n i hi).eq_of_src _ _,
        (is_le.is_zero K n i hi).eq_of_src _ _⟩⟩, }, },
end

instance is_iso_trunc_le_nat_trans_ι_of_le (K : derived_category C) (n : ℤ) [K.is_le n] :
  is_iso ((trunc_le_nat_trans_ι C n).app K) :=
by { rw is_iso_trunc_le_nat_trans_ι_app_iff, apply_instance, }

end derived_category

namespace cochain_complex

lemma is_le_iff_Q_obj_is_le (K : cochain_complex C ℤ) (n : ℤ) :
  K.is_le n ↔ (derived_category.Q.obj K).is_le n :=
begin
  split,
  { introI,
    exact ⟨λ i hi, by simpa only [← is_zero_homology_iff_is_zero_homology_Q_obj]
      using is_le.is_zero K n i hi⟩, },
  { introI,
    exact ⟨λ i hi, by simpa only [is_zero_homology_iff_is_zero_homology_Q_obj]
      using derived_category.is_le.is_zero (derived_category.Q.obj _) n i hi⟩, },
end

instance Q_obj_is_le_of_is_le (K : cochain_complex C ℤ) (n : ℤ) [K.is_le n] :
  (derived_category.Q.obj K).is_le n :=
begin
  rw ← is_le_iff_Q_obj_is_le,
  apply_instance,
end

lemma is_le_iff_of_quasi_iso {K L : cochain_complex C ℤ} (φ : K ⟶ L) [quasi_iso φ] (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  simp only [is_le_iff_Q_obj_is_le],
  exact derived_category.is_le.iff_of_iso (as_iso (derived_category.Q.map φ)) n,
end

lemma quasi_iso_trunc_le_ι_iff (K : cochain_complex C ℤ) (n : ℤ) :
  quasi_iso (trunc_le.ι K n) ↔ K.is_le n :=
begin
  rw [is_le_iff_Q_obj_is_le, ← derived_category.is_iso_Q_map_iff,
    ← derived_category.is_iso_trunc_le_nat_trans_ι_app_iff,
    derived_category.trunc_le_nat_trans_ι_app],
  split,
  { introI,
    apply_instance, },
  { apply is_iso.of_is_iso_comp_left, },
end

instance (K : cochain_complex C ℤ) (n : ℤ) [K.is_le n] :
  quasi_iso (trunc_le.ι K n) :=
by { rw quasi_iso_trunc_le_ι_iff, apply_instance, }

end cochain_complex

namespace derived_category

lemma right_factorisation_of_is_le {K L : cochain_complex C ℤ} (φ : Q.obj K ⟶ Q.obj L) (n : ℤ)
  [K.is_le n] :
  ∃ (K' : cochain_complex C ℤ) (hK' : K'.is_strictly_le n) (s : K' ⟶ K) (f : K' ⟶ L) (hs : quasi_iso s),
    φ = (by { haveI := hs, exact inv (Q.map s), }) ≫ Q.map f :=
begin
  obtain ⟨K', s, f, hs, eq⟩ := right_factorisation φ,
  haveI := hs,
  haveI : quasi_iso ((cochain_complex.trunc_le.nat_trans_ι C n).app K'),
  { erw cochain_complex.quasi_iso_trunc_le_ι_iff,
    dsimp,
    rw cochain_complex.is_le_iff_of_quasi_iso s,
    apply_instance, },
  exact ⟨_, infer_instance,
    (cochain_complex.trunc_le.nat_trans_ι _ n).app K' ≫ s,
    (cochain_complex.trunc_le.nat_trans_ι _ n).app K' ≫ f, infer_instance,
    by simp only [eq, functor.map_comp, is_iso.eq_inv_comp, assoc, is_iso.hom_inv_id_assoc]⟩,
end

lemma left_factorisation_of_is_strictly_le {K L : cochain_complex C ℤ} (φ : Q.obj K ⟶ Q.obj L)
  (n : ℤ) [K.is_strictly_le n] [L.is_strictly_le n] :
  ∃ (L' : cochain_complex C ℤ) (hL' : L'.is_strictly_le n) (f : K ⟶ L') (s : L ⟶ L') (hs : quasi_iso s),
    φ = Q.map f ≫ (by { haveI := hs, exact inv (Q.map s), }) :=
begin
  obtain ⟨L', f, s, hs, eq⟩ := left_factorisation φ,
  haveI := hs,
  haveI : quasi_iso (cochain_complex.trunc_le.ι L' n),
  { rw [cochain_complex.quasi_iso_trunc_le_ι_iff, ← cochain_complex.is_le_iff_of_quasi_iso s],
    apply_instance, },
  refine ⟨_, infer_instance,
    category_theory.inv (cochain_complex.trunc_le.ι K n) ≫
      (cochain_complex.trunc_le_functor C n).map f,
    category_theory.inv (cochain_complex.trunc_le.ι L n) ≫
    (cochain_complex.trunc_le_functor C n).map s, infer_instance, _⟩,
  have comms := Q.congr_map ((cochain_complex.trunc_le.nat_trans_ι C n).naturality s),
  have commf := Q.congr_map ((cochain_complex.trunc_le.nat_trans_ι C n).naturality f),
  dsimp at comms commf,
  simp only [Q.map_comp, ← cancel_mono (inv (Q.map ((cochain_complex.trunc_le.ι L' n)))),
    assoc, is_iso.hom_inv_id, comp_id] at comms commf,
  simp only [comms, commf, eq, functor.map_comp, functor.map_inv, is_iso.inv_hom_id_assoc,
    is_iso.inv_comp, is_iso.inv_inv, assoc],
end

lemma exists_iso_Q_obj_of_le (K : derived_category C) (n : ℤ) [K.is_le n] :
  ∃ (K' : cochain_complex C ℤ) (hK' : K'.is_strictly_le n),
    nonempty (K ≅ Q.obj K') :=
begin
  let K' := Q.obj_preimage K,
  haveI : K'.is_le n,
  { rw [cochain_complex.is_le_iff_Q_obj_is_le, is_le.iff_of_iso (Q.obj_obj_preimage_iso K)],
    apply_instance, },
  exact ⟨K'.trunc_le n, infer_instance, ⟨(Q.obj_obj_preimage_iso K).symm ≪≫
    (as_iso ((trunc_le_nat_trans_ι C n).app (Q.obj K'))).symm ≪≫
    (trunc_le_functor_iso C n).app K'⟩⟩,
end

end derived_category


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import category_theory.monoidal.of_chosen_finite_products
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.types

/-!
# The category of types is a symmetric monoidal category
-/

open category_theory
open category_theory.limits
open tactic

universes v u

namespace category_theory

instance types_monoidal : monoidal_category.{u} (Type u) :=
monoidal_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

instance types_symmetric : symmetric_category.{u} (Type u) :=
symmetric_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

@[simp] lemma tensor_apply {W X Y Z : Type u} (f : W ⟶ X) (g : Y ⟶ Z) (p : W ⊗ Y) :
  (f ⊗ g) p = (f p.1, g p.2) := rfl

@[simp] lemma left_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((λ_ X).hom : (𝟙_ (Type u)) ⊗ X → X) (p, x) = x := rfl
@[simp] lemma left_unitor_inv_apply {X : Type u} {x : X} :
  ((λ_ X).inv : X ⟶ (𝟙_ (Type u)) ⊗ X) x = (punit.star, x) := rfl

@[simp] lemma right_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((ρ_ X).hom : X ⊗ (𝟙_ (Type u)) → X) (x, p) = x := rfl
@[simp] lemma right_unitor_inv_apply {X : Type u} {x : X} :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ (Type u))) x = (x, punit.star) := rfl

@[simp] lemma associator_hom_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).hom : (X ⊗ Y) ⊗ Z → X ⊗ (Y ⊗ Z)) ((x, y), z) = (x, (y, z)) := rfl
@[simp] lemma associator_inv_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).inv : X ⊗ (Y ⊗ Z) → (X ⊗ Y) ⊗ Z) (x, (y, z)) = ((x, y), z) := rfl

@[simp] lemma braiding_hom_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).hom : X ⊗ Y → Y ⊗ X) (x, y) = (y, x) := rfl
@[simp] lemma braiding_inv_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).inv : Y ⊗ X → X ⊗ Y) (y, x) = (x, y) := rfl

open opposite

open monoidal_category

/-- `(𝟙_ C ⟶ -)` is a lax monoidal functor to `Type`. -/
def coyoneda_tensor_unit (C : Type u) [category.{v} C] [monoidal_category C] :
  lax_monoidal_functor C (Type v) :=
{ ε := λ p, 𝟙 _,
  μ := λ X Y p, (λ_ (𝟙_ C)).inv ≫ (p.1 ⊗ p.2),
  μ_natural' := by tidy,
  associativity' := λ X Y Z, begin
    ext ⟨⟨f, g⟩, h⟩, dsimp at f g h,
    dsimp, simp only [iso.cancel_iso_inv_left, category.assoc],
    conv_lhs { rw [←category.id_comp h, tensor_comp, category.assoc, associator_naturality,
      ←category.assoc, unitors_inv_equal, triangle_assoc_comp_right_inv], },
    conv_rhs { rw [←category.id_comp f, tensor_comp], },
  end,
  left_unitality' := by tidy,
  right_unitality' := λ X, begin
    ext ⟨f, ⟨⟩⟩, dsimp at f,
    dsimp, simp only [category.assoc],
    rw [right_unitor_naturality, unitors_inv_equal, iso.inv_hom_id_assoc],
  end,
  ..coyoneda.obj (op (𝟙_ C)) }

end category_theory


import tactic

open tactic expr

meta def add_nonneg_proof_aux (n : expr) (h : option name) : tactic unit :=
do pf ← mk_app `nat.zero_le [n],
   nm ← get_unused_name,
   note (h.get_or_else nm) none pf,
   skip

example (n : ℕ) : true :=
begin
  add_nonneg_proof_aux `(55) none,
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    _x : 0 ≤ 55
--    ⊢ true

namespace tactic
namespace interactive

setup_tactic_parser

meta def add_nonneg_proof (n : parse parser.pexpr) (h : parse ident?)
  : tactic unit :=
do n ← to_expr n,
   add_nonneg_proof_aux n h

meta def add_nonneg_proofs (l : parse pexpr_list) : tactic unit :=
do l ← l.mmap to_expr,
   l.mmap' (λ e, add_nonneg_proof_aux e none)

end interactive
end tactic

example (n : ℕ) : true :=
begin
  add_nonneg_proof 55 hx,
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    hx : 0 ≤ 55
--    ⊢ true

example (n : ℕ) : true :=
begin
  add_nonneg_proof 55 hx,
  add_nonneg_proofs [n+n+n, 2*n^2],
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    hx : 0 ≤ 55,
--    _x : 0 ≤ n + n + n,
--    _x_1 : 0 ≤ 2 * n ^ 2
--    ⊢ true

meta def mk_list : tactic (list ℕ) :=
return [1, 4, 6]

run_cmd  do
  l ← mk_list,
  match l with
  | (h::t) := trace h
  | _      := failed
  end

-- Comentario: Al colocar el cursor sobre run_cmd se obtiene 1.

run_cmd  do
  [a, b, c] ← mk_list,
  trace b

-- Comentario: Al colocar el cursor sobre run_cmd se obtiene 4.

example : true ∧ true :=
by do
  split,
  gs ← get_goals,
  gs.mmap' trace

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ true
--
--    ?m_1
--    ?m_1

example : true ∧ false :=
by do
  split,
  gs ← get_goals,
  gs.mmap' (λ e, do tp ← infer_type e, trace tp)

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ false
--
--    true
--    false

example : true ∧ false :=
by do
  split,
  gs ← get_goals,
  gs.mmap' (λ e, trace e.to_raw_fmt)

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ false
--
--    (mvar _mlocal._fresh.176.839 _mlocal._fresh.176.839 (const 2 []))
--    (mvar _mlocal._fresh.176.840 _mlocal._fresh.176.840 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  infer_type e1 >>= trace,
  infer_type e2 >>= trace

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ ?m_1 = ?m_1
--
--    ⊢ ℕ
--
--    ?m_1 = ?m_1
--    ℕ

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  infer_type e1 >>= trace,
  trace e1.to_raw_fmt,
  infer_type e2 >>= trace,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ ?m_1 = ?m_1
--
--    ⊢ ℕ
--
--    ?m_1 = ?m_1
--    (mvar _mlocal._fresh.215.1681 _mlocal._fresh.215.1681 (const 2 []))
--    ℕ
--    (mvar _mlocal._fresh.215.1680 _mlocal._fresh.215.1680 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ 7 = 7
--
--    7

set_option pp.instantiate_mvars false

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ ?m_1 = ?m_1
--
--    ?m_1
--    (mvar _mlocal._fresh.16.1433 _mlocal._fresh.16.1433 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2,
  trace e2.to_raw_fmt,
  e2 ← instantiate_mvars e2,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ ?m_1 = ?m_1
--
--    ?m_1
--    (mvar _mlocal._fresh.54.1667 _mlocal._fresh.54.1667 (const 2 []))
--    (app
--     (app
--      (app
--       (app (const bit1 [0]) (const nat []))
--       (const nat.has_one [])) (const nat.has_add []))
--     (app
--      (app
--       (app
--        (app (const bit1 [0]) (const nat []))
--        (const nat.has_one []))
--       (const nat.has_add []))
--      (app
--       (app (const has_one.one [0]) (const nat []))
--       (const nat.has_one []))))

------------------------------------------------------------------------
-- § Referencia                                                       --
------------------------------------------------------------------------

-- Basado en el vídeo "Metaprogramming in Lean tutorial: video 6" de Rob
-- Lewis que se encuentra en https://youtu.be/ZbijjKFtvJI


import data.equiv.basic
import analysis.topology.topological_structures

def transport_topological_ring {α β : Type}
  [topological_space α] [ring α] [topological_ring α] (f : α ≃ β) : @topological_ring β sorry sorry := sorry

def transport_ring {α β : Type*} [ring α] (f : α ≃ β) : ring β :=
{ add := λ x y, f (f.symm x + f.symm y),
  zero := f 0,
  neg := λ x, f (-f.symm x),
  mul := λ x y, f (f.symm x * f.symm y),
  one := f 1,
  add_assoc := λ x y z, by simp; from add_assoc _ _ _,
  zero_add := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (zero_add _),
  add_zero := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (add_zero _),
  add_left_neg := λ x, by simp; from add_left_neg _,
  add_comm := λ x y, by simp; from add_comm _ _,
  mul_assoc := λ x y z, by simp; from mul_assoc _ _ _,
  one_mul := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (one_mul _),
  mul_one := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (mul_one _),
  left_distrib := λ x y z, by simp; from left_distrib _ _ _,
  right_distrib := λ x y z, by simp; from right_distrib _ _ _, }

import data.equiv
--import analysis.topology.topological_structures
universes u v

def transport_ring {α : Type u} {β : Type v} [ring α] (f : α ≃ β) : ring β :=
{ add := λ x y, f (f.symm x + f.symm y),
  zero := f 0,
  neg := λ x, f (-f.symm x),
  mul := λ x y, f (f.symm x * f.symm y),
  one := f 1,
  add_assoc := λ x y z, by simp; from add_assoc _ _ _,
  zero_add := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (zero_add _),
  add_zero := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (add_zero _),
  add_left_neg := λ x, by simp; from add_left_neg _,
  add_comm := λ x y, by simp; from add_comm _ _,
  mul_assoc := λ x y z, by simp; from mul_assoc _ _ _,
  one_mul := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (one_mul _),
  mul_one := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (mul_one _),
  left_distrib := λ x y z, by simp; from left_distrib _ _ _,
  right_distrib := λ x y z, by simp; from right_distrib _ _ _, }

class transportable (f : Type u → Sort v) :=
(on_equiv : Π {α β : Type u} (e : equiv α β), equiv (f α) (f β))
(on_refl  : Π (α : Type u), on_equiv (equiv.refl α) = equiv.refl (f α))
(on_trans : Π {α β γ : Type u} (d : equiv α β) (e : equiv β γ), on_equiv (equiv.trans d e) = equiv.trans (on_equiv d) (on_equiv e))

#print topological_ring

#print sigma
-- Our goal is an automagic proof of the following
theorem group.transportable : transportable group := sorry
theorem topological_ring.transportable : transportable
  (λ R : (Σ (α : Type u), (topological_space α) × (ring α)) ,
    @topological_ring R.fst (R.snd).1 (R.snd).2) := sorry
#check topological_ring
-- These we might need to define and prove by hand
def Const : Type u → Type v := λ α, punit
def Fun : Type u → Type v → Type (max u v) := λ α β, α → β
def Prod : Type u → Type v → Type (max u v) := λ α β, α × β
def Swap : Type u → Type v → Type (max u v) := λ α β, β × α

lemma Const.transportable : (transportable Const) := {
  on_equiv := λ β γ H,⟨λ _,punit.star,λ _,punit.star,sorry,sorry⟩,
  on_refl := λ β,_,on_trans := λ β,_ }
lemma Fun.transportable (α : Type u) : (transportable (Fun α)) := sorry
lemma Prod.transportable (α : Type u) : (transportable (Prod α)) := sorry
lemma Swap.transportable (α : Type u) : (transportable (Swap α)) := sorry

-- And then we can define
def Hom1 (α : Type u) : Type v → Type (max u v) := λ β, α → β
def Hom2 (β : Type v) : Type u → Type (max u v) := λ α, α → β
def Aut : Type u → Type u := λ α, α → α

-- And hopefully automagically derive
lemma Hom1.transportable (α : Type u) : (transportable (Hom1 α)) := sorry
lemma Hom2.transportable (β : Type v) : (transportable (Hom1 β)) := sorry
lemma Aut.transportable (α : Type u) : (transportable Aut) := sorry

-- If we have all these in place...
-- A bit of magic might actually be able to derive `group.transportable` on line 11.
-- After all, a group just is a type plus some functions... and we can now transport functions.

structure equiv' (α : Type zfc_u) (β : Type zfc_u) :=
(i    : α → β)
(j    : β → α)
(ij : ∀ (x : α), j (i x) = x)
(ji  : ∀ (y : β), i (j y) = y)

definition mul_is_add {α : Type zfc_u} : equiv' (has_mul α) (has_add α) :=
{ i := λ ⟨mul⟩,⟨mul⟩,
  j := λ ⟨mul⟩,⟨mul⟩, -- didn't I just write that?
  ij := λ ⟨x⟩,rfl,
  ji := λ ⟨x⟩, rfl,  -- didn't I just write that?
}

definition : equiv'
definition equiv_mul {α β : Type zfc_u} : equiv' α β → equiv' (has_mul α) (has_mul β) := λ E,
{ i :=  λ αmul,⟨λ b1 b2, E.i (@has_mul.mul α αmul (E.j b1) (E.j b2))⟩,
  j := λ βmul,⟨λ a1 a2, E.j (@has_mul.mul β βmul (E.i a1) (E.i a2))⟩, -- didn't I just write that?
                                                                      -- should we introduce E-dual?
  ij := λ f, begin
    cases f, -- aargh why do I struggle
    suffices :  (λ (a1 a2 : α), E.j (E.i (f (E.j (E.i a1)) (E.j (E.i a2))))) = (λ a1 a2, f a1 a2),
      by rw this,
    funext,
    simp [E.ij,E.ji], -- got there in the end
  end,
  ji := -- I can't even do this in term mode so I just copy out the entire tactic mode proof again.
 λ g, begin
    cases g, -- aargh why do I struggle
    suffices :  (λ (b1 b2 : β), E.i (E.j (g (E.i (E.j b1)) (E.i (E.j b2))))) = (λ b1 b2, g b1 b2),
      by rw this,
    funext,
    simp [E.ij,E.ji], -- got there in the end
  end, -- didn't I just write that?
}

definition mul_to_add {α β : Type} : equiv' α β → equiv' (has_add α) (has_add β) := _ ∘ equiv_mul


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.category.Cat
import category_theory.groupoid
import category_theory.types

/-!
# Objects of a category up to an isomorphism

`is_isomorphic X Y := nonempty (X ≅ Y)` is an equivalence relation on the objects of a category.
The quotient with respect to this relation defines a functor from our category to `Type`.
-/

universes v u

namespace category_theory

section category

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

/-- An object `X` is isomorphic to an object `Y`, if `X ≅ Y` is not empty. -/
def is_isomorphic : C → C → Prop := λ X Y, nonempty (X ≅ Y)

variable (C)

/-- `is_isomorphic` defines a setoid. -/
def is_isomorphic_setoid : setoid C :=
{ r := is_isomorphic,
  iseqv := ⟨λ X, ⟨iso.refl X⟩, λ X Y ⟨α⟩, ⟨α.symm⟩, λ X Y Z ⟨α⟩ ⟨β⟩, ⟨α.trans β⟩⟩ }

end category

/--
The functor that sends each category to the quotient space of its objects up to an isomorphism.
-/
def isomorphism_classes : Cat.{v u} ⥤ Type u :=
{ obj := λ C, quotient (is_isomorphic_setoid C.α),
  map := λ C D F, quot.map F.obj $ λ X Y ⟨f⟩, ⟨F.map_iso f⟩ }

lemma groupoid.is_isomorphic_iff_nonempty_hom {C : Type u} [groupoid.{v} C] {X Y : C} :
  is_isomorphic X Y ↔ nonempty (X ⟶ Y) :=
(groupoid.iso_equiv_hom X Y).nonempty_congr

-- PROJECT: define `skeletal`, and show every category is equivalent to a skeletal category,
-- using the axiom of choice to pick a representative of every isomorphism class.
end category_theory


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

! This file was ported from Lean 3 source module data.fun_like.embedding
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.FunLike.Basic

/-!
# Typeclass for a type `F` with an injective map to `A ↪ B`

This typeclass is primarily for use by embeddings such as `RelEmbedding`.

## Basic usage of `EmbeddingLike`

A typical type of embeddings should be declared as:
```
structure MyEmbedding (A B : Type _) [MyClass A] [MyClass B] :=
(toFun : A → B)
(injective' : Function.Injective toFun)
(map_op' : ∀ {x y : A}, toFun (MyClass.op x y) = MyClass.op (toFun x) (toFun y))

namespace MyEmbedding

variables (A B : Type _) [MyClass A] [MyClass B]

-- This instance is optional if you follow the "Embedding class" design below:
instance : EmbeddingLike (MyEmbedding A B) A B :=
{ coe := MyEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective' }

/-- Helper instance for when there's too many metavariables to `EmbeddingLike.coe` directly. -/
instance : CoeFun (MyEmbedding A B) (λ _, A → B) := ⟨MyEmbedding.toFun⟩

@[ext] theorem ext {f g : MyEmbedding A B} (h : ∀ x, f x = g x) : f = g := FunLike.ext f g h

/-- Copy of a `MyEmbedding` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : MyEmbedding A B) (f' : A → B) (h : f' = ⇑f) : MyEmbedding A B :=
{ toFun := f',
  injective' := h.symm ▸ f.injective',
  map_op' := h.symm ▸ f.map_op' }

end MyEmbedding
```

This file will then provide a `CoeFun` instance and various
extensionality and simp lemmas.

## Embedding classes extending `EmbeddingLike`

The `EmbeddingLike` design provides further benefits if you put in a bit more work.
The first step is to extend `EmbeddingLike` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
section

/-- `MyEmbeddingClass F A B` states that `F` is a type of `MyClass.op`-preserving embeddings.
You should extend this class when you extend `MyEmbedding`. -/
class MyEmbeddingClass (F : Type _) (A B : outParam <| Type _) [MyClass A] [MyClass B]
  extends EmbeddingLike F A B :=
(map_op : ∀ (f : F) (x y : A), f (MyClass.op x y) = MyClass.op (f x) (f y))

end

@[simp] lemma map_op {F A B : Type _} [MyClass A] [MyClass B] [MyEmbeddingClass F A B]
  (f : F) (x y : A) : f (MyClass.op x y) = MyClass.op (f x) (f y) :=
MyEmbeddingClass.map_op

-- You can replace `MyEmbedding.EmbeddingLike` with the below instance:
instance : MyEmbeddingClass (MyEmbedding A B) A B :=
{ coe := MyEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective',
  map_op := MyEmbedding.map_op' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

The second step is to add instances of your new `MyEmbeddingClass` for all types extending
`MyEmbedding`.
Typically, you can just declare a new class analogous to `MyEmbeddingClass`:

```
structure CoolerEmbedding (A B : Type _) [CoolClass A] [CoolClass B]
  extends MyEmbedding A B :=
(map_cool' : toFun CoolClass.cool = CoolClass.cool)

section
set_option old_structure_cmd true

class CoolerEmbeddingClass (F : Type _) (A B : outParam <| Type _) [CoolClass A] [CoolClass B]
  extends MyEmbeddingClass F A B :=
(map_cool : ∀ (f : F), f CoolClass.cool = CoolClass.cool)

end

@[simp] lemma map_cool {F A B : Type _} [CoolClass A] [CoolClass B] [CoolerEmbeddingClass F A B]
  (f : F) : f CoolClass.cool = CoolClass.cool :=
MyEmbeddingClass.map_op

-- You can also replace `MyEmbedding.EmbeddingLike` with the below instance:
instance : CoolerEmbeddingClass (CoolerEmbedding A B) A B :=
{ coe := CoolerEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective',
  map_op := CoolerEmbedding.map_op',
  map_cool := CoolerEmbedding.map_cool' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : MyEmbedding A B) : sorry := sorry
lemma do_something {F : Type _} [MyEmbeddingClass F A B] (f : F) : sorry := sorry
```

This means anything set up for `MyEmbedding`s will automatically work for `CoolerEmbeddingClass`es,
and defining `CoolerEmbeddingClass` only takes a constant amount of effort,
instead of linearly increasing the work per `MyEmbedding`-related declaration.

-/

/-- The class `EmbeddingLike F α β` expresses that terms of type `F` have an
injective coercion to injective functions `α ↪ β`.
-/
class EmbeddingLike (F : Sort _) (α β : outParam (Sort _)) extends FunLike F α fun _ ↦ β where
  /-- The coercion to functions must produce injective functions. -/
  injective' : ∀ f : F, @Function.Injective α β (coe f)
#align embedding_like EmbeddingLike

namespace EmbeddingLike

variable {F α β γ : Sort _} [i : EmbeddingLike F α β]

protected theorem injective (f : F) : Function.Injective f :=
  injective' f
#align embedding_like.injective EmbeddingLike.injective

@[simp]
theorem apply_eq_iff_eq (f : F) {x y : α} : f x = f y ↔ x = y :=
  (EmbeddingLike.injective f).eq_iff
#align embedding_like.apply_eq_iff_eq EmbeddingLike.apply_eq_iff_eq

@[simp]
theorem comp_injective {F : Sort _} [EmbeddingLike F β γ] (f : α → β) (e : F) :
    Function.Injective (e ∘ f) ↔ Function.Injective f :=
  (EmbeddingLike.injective e).of_comp_iff f
#align embedding_like.comp_injective EmbeddingLike.comp_injective

end EmbeddingLike


def casesTFOn {motive : Prop → Sort _} (P) [inst : Decidable P] : (T : motive True) → (F : motive False) → motive P :=
  λ ht hf => match inst with
  | isTrue H => eq_true H ▸ ht
  | isFalse H => eq_false H ▸ hf

example (P) [Decidable P] : ¬¬P → P := by
  induction P using casesTFOn
  admit
  admit


constant f : Nat → Nat
constant q : Nat → (Nat → Prop) → Nat

@[simp]
theorem ex {x : Nat} {p : Nat → Prop} (h₁ : p x) (h₂ : q x p = x) : f x = x :=
  sorry

set_option trace.Meta.Tactic.simp.discharge true
theorem foo : f (f x) = x := by
  simp
  sorry


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import ring_theory.nilpotent
import topology.sheaves.sheaf_condition.sites
import algebra.category.Ring.constructions
import ring_theory.local_properties

/-!
# Basic properties of schemes

We provide some basic properties of schemes

## Main definition
* `algebraic_geometry.is_integral`: A scheme is integral if it is nontrivial and all nontrivial
  components of the structure sheaf are integral domains.
* `algebraic_geometry.is_reduced`: A scheme is reduced if all the components of the structure sheaf
  is reduced.
-/

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

instance : t0_space X.carrier :=
begin
  refine t0_space.of_open_cover (λ x, _),
  obtain ⟨U, R, ⟨e⟩⟩ := X.local_affine x,
  let e' : U.1 ≃ₜ prime_spectrum R :=
    homeo_of_iso ((LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget _).map_iso e),
  exact ⟨U.1.1, U.2, U.1.2, e'.embedding.t0_space⟩
end

instance : quasi_sober X.carrier :=
begin
  apply_with (quasi_sober_of_open_cover
    (set.range (λ x, set.range $ (X.affine_cover.map x).1.base)))
    { instances := ff },
  { rintro ⟨_,i,rfl⟩, exact (X.affine_cover.is_open i).base_open.open_range },
  { rintro ⟨_,i,rfl⟩,
    exact @@open_embedding.quasi_sober _ _ _
      (homeomorph.of_embedding _ (X.affine_cover.is_open i).base_open.to_embedding)
      .symm.open_embedding prime_spectrum.quasi_sober },
  { rw [set.top_eq_univ, set.sUnion_range, set.eq_univ_iff_forall],
    intro x, exact ⟨_, ⟨_, rfl⟩, X.affine_cover.covers x⟩ }
end

/-- A scheme `X` is reduced if all `𝒪ₓ(U)` are reduced. -/
class is_reduced : Prop :=
(component_reduced : ∀ U, _root_.is_reduced (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_reduced.component_reduced

lemma is_reduced_of_stalk_is_reduced [∀ x : X.carrier, _root_.is_reduced (X.presheaf.stalk x)] :
  is_reduced X :=
begin
  refine ⟨λ U, ⟨λ s hs, _⟩⟩,
  apply presheaf.section_ext X.sheaf U s 0,
  intro x,
  rw ring_hom.map_zero,
  change X.presheaf.germ x s = 0,
  exact (hs.map _).eq_zero
end

instance stalk_is_reduced_of_reduced [is_reduced X] (x : X.carrier) :
  _root_.is_reduced (X.presheaf.stalk x) :=
begin
  constructor,
  rintros g ⟨n, e⟩,
  obtain ⟨U, hxU, s, rfl⟩ := X.presheaf.germ_exist x g,
  rw [← map_pow, ← map_zero (X.presheaf.germ ⟨x, hxU⟩)] at e,
  obtain ⟨V, hxV, iU, iV, e'⟩ := X.presheaf.germ_eq x hxU hxU _ 0 e,
  rw [map_pow, map_zero] at e',
  replace e' := (is_nilpotent.mk _ _ e').eq_zero,
  erw ← concrete_category.congr_hom (X.presheaf.germ_res iU ⟨x, hxV⟩) s,
  rw [comp_apply, e', map_zero]
end

lemma is_reduced_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_reduced Y] : is_reduced X :=
begin
  constructor,
  intro U,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  exact is_reduced_of_injective (inv $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U))
    (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) : Y.presheaf.obj _ ≅ _).symm
      .CommRing_iso_to_ring_equiv.injective
end

instance {R : CommRing} [H : _root_.is_reduced R] : is_reduced (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_reduced_of_stalk_is_reduced { instances := ff },
  intro x, dsimp,
  haveI : _root_.is_reduced (CommRing.of $ localization.at_prime (prime_spectrum.as_ideal x)),
  { dsimp, apply_instance },
  exact is_reduced_of_injective (structure_sheaf.stalk_iso R x).hom
    (structure_sheaf.stalk_iso R x).CommRing_iso_to_ring_equiv.injective,
end

lemma affine_is_reduced_iff (R : CommRing) :
  is_reduced (Scheme.Spec.obj $ op R) ↔ _root_.is_reduced R :=
begin
  refine ⟨_, λ h, by exactI infer_instance⟩,
  intro h,
  resetI,
  haveI : _root_.is_reduced (LocallyRingedSpace.Γ.obj (op $ Spec.to_LocallyRingedSpace.obj $ op R)),
  { change _root_.is_reduced ((Scheme.Spec.obj $ op R).presheaf.obj $ op ⊤), apply_instance },
  exact is_reduced_of_injective (to_Spec_Γ R)
    ((as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv.injective)
end

lemma is_reduced_of_is_affine_is_reduced [is_affine X]
  [h : _root_.is_reduced (X.presheaf.obj (op ⊤))] : is_reduced X :=
begin
  haveI : is_reduced (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_reduced_iff, exact h },
  exact is_reduced_of_open_immersion X.iso_Spec.hom,
end

/-- To show that a statement `P` holds for all open subsets of all schemes, it suffices to show that
1. In any scheme `X`, if `P` holds for an open cover of `U`, then `P` holds for `U`.
2. For an open immerison `f : X ⟶ Y`, if `P` holds for the entire space of `X`, then `P` holds for
  the image of `f`.
3. `P` holds for the entire space of an affine scheme.
-/
lemma reduce_to_affine_global (P : ∀ (X : Scheme) (U : opens X.carrier), Prop)
  (h₁ : ∀ (X : Scheme) (U : opens X.carrier),
    (∀ (x : U), ∃ {V} (h : x.1 ∈ V) (i : V ⟶ U), P X V) → P X U)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [hf : is_open_immersion f], ∃ {U : set X.carrier} {V : set Y.carrier}
    (hU : U = ⊤) (hV : V = set.range f.1.base), P X ⟨U, hU.symm ▸ is_open_univ⟩ →
      P Y ⟨V, hV.symm ▸ hf.base_open.open_range⟩)
  (h₃ : ∀ (R : CommRing), P (Scheme.Spec.obj $ op R) ⊤) :
  ∀ (X : Scheme) (U : opens X.carrier), P X U :=
begin
  intros X U,
  apply h₁,
  intro x,
  obtain ⟨_, ⟨j, rfl⟩, hx, i⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open
    (set_like.mem_coe.2 x.prop) U.is_open,
  let U' : opens _ := ⟨_, (X.affine_basis_cover.is_open j).base_open.open_range⟩,
  let i' : U' ⟶ U :=
    hom_of_le i,
  refine ⟨U', hx, i', _⟩,
  obtain ⟨_,_,rfl,rfl,h₂'⟩ := h₂ (X.affine_basis_cover.map j),
  apply h₂',
  apply h₃
end

lemma eq_zero_of_basic_open_eq_bot {X : Scheme} [hX : is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj (op U)) (hs : X.basic_open s = ⊥) :
  s = 0 :=
begin
  apply Top.presheaf.section_ext X.sheaf U,
  simp_rw ring_hom.map_zero,
  unfreezingI { revert X U hX s },
  refine reduce_to_affine_global _ _ _ _,
  { intros X U hx hX s hs x,
    obtain ⟨V, hx, i, H⟩ := hx x,
    unfreezingI { specialize H (X.presheaf.map i.op s) },
    erw Scheme.basic_open_res at H,
    rw [hs] at H,
    specialize H inf_bot_eq ⟨x, hx⟩,
    erw Top.presheaf.germ_res_apply at H,
    exact H },
  { rintros X Y f hf,
    have e : (f.val.base) ⁻¹' set.range ⇑(f.val.base) = set.univ,
    { rw [← set.image_univ, set.preimage_image_eq _ hf.base_open.inj] },
    refine ⟨_, _, e, rfl, _⟩,
    rintros H hX s hs ⟨_, x, rfl⟩,
    unfreezingI { haveI := is_reduced_of_open_immersion f },
    specialize H (f.1.c.app _ s) _ ⟨x, by { rw [opens.mem_mk, e], trivial }⟩,
    { rw [← Scheme.preimage_basic_open, hs], ext1, simp [opens.map] },
    { erw ← PresheafedSpace.stalk_map_germ_apply f.1 ⟨_,_⟩ ⟨x,_⟩ at H,
      apply_fun (inv $ PresheafedSpace.stalk_map f.val x) at H,
      erw [category_theory.is_iso.hom_inv_id_apply, map_zero] at H,
      exact H } },
  { intros R hX s hs x,
    erw [basic_open_eq_of_affine', prime_spectrum.basic_open_eq_bot_iff] at hs,
    replace hs := (hs.map (Spec_Γ_identity.app R).inv),
    -- what the hell?!
    replace hs := @is_nilpotent.eq_zero _ _ _ _ (show _, from _) hs,
    rw iso.hom_inv_id_apply at hs,
    rw [hs, map_zero],
    exact @@is_reduced.component_reduced hX ⊤ }
end

@[simp]
lemma basic_open_eq_bot_iff {X : Scheme} [is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj $ op U) :
  X.basic_open s = ⊥ ↔ s = 0 :=
begin
  refine ⟨eq_zero_of_basic_open_eq_bot s, _⟩,
  rintro rfl,
  simp,
end

/-- A scheme `X` is integral if its carrier is nonempty,
and `𝒪ₓ(U)` is an integral domain for each `U ≠ ∅`. -/
class is_integral : Prop :=
(nonempty : nonempty X.carrier . tactic.apply_instance)
(component_integral : ∀ (U : opens X.carrier) [_root_.nonempty U],
  is_domain (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_integral.component_integral is_integral.nonempty

instance [h : is_integral X] : is_domain (X.presheaf.obj (op ⊤)) :=
@@is_integral.component_integral _ _ (by simp)

@[priority 900]
instance is_reduced_of_is_integral [is_integral X] : is_reduced X :=
begin
  constructor,
  intro U,
  cases U.1.eq_empty_or_nonempty with h h,
  { have : U = ⊥ := set_like.ext' h,
    haveI := CommRing.subsingleton_of_is_terminal (X.sheaf.is_terminal_of_eq_empty this),
    change _root_.is_reduced (X.sheaf.val.obj (op U)),
    apply_instance },
  { haveI : nonempty U := by simpa, apply_instance }
end

instance is_irreducible_of_is_integral [is_integral X] : irreducible_space X.carrier :=
begin
  by_contradiction H,
  replace H : ¬ is_preirreducible (⊤ : set X.carrier) := λ h,
    H { to_preirreducible_space := ⟨h⟩, to_nonempty := infer_instance },
  simp_rw [is_preirreducible_iff_closed_union_closed, not_forall, not_or_distrib] at H,
  rcases H with ⟨S, T, hS, hT, h₁, h₂, h₃⟩,
  erw not_forall at h₂ h₃,
  simp_rw not_forall at h₂ h₃,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ : opens X.carrier) := ⟨⟨_, h₂.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Tᶜ, hT.1⟩ : opens X.carrier) := ⟨⟨_, h₃.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ ⊔ ⟨Tᶜ, hT.1⟩ : opens X.carrier) :=
    ⟨⟨_, or.inl h₂.some_spec.some_spec⟩⟩,
  let e : X.presheaf.obj _ ≅ CommRing.of _ := (X.sheaf.is_product_of_disjoint ⟨_, hS.1⟩ ⟨_, hT.1⟩ _)
    .cone_point_unique_up_to_iso (CommRing.prod_fan_is_limit _ _),
  apply_with false_of_nontrivial_of_product_domain { instances := ff },
  { exact e.symm.CommRing_iso_to_ring_equiv.is_domain _ },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { ext x,
    split,
    { rintros ⟨hS,hT⟩,
      cases h₁ (show x ∈ ⊤, by trivial),
      exacts [hS h, hT h] },
    { intro x, exact x.rec _ } }
end

lemma is_integral_of_is_irreducible_is_reduced [is_reduced X] [H : irreducible_space X.carrier] :
  is_integral X :=
begin
  split, intros U hU,
  haveI := (@@LocallyRingedSpace.component_nontrivial X.to_LocallyRingedSpace U hU).1,
  haveI : no_zero_divisors
    (X.to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace.presheaf.obj (op U)),
  { refine ⟨λ a b e, _⟩,
    simp_rw [← basic_open_eq_bot_iff, ← opens.not_nonempty_iff_eq_bot],
    by_contra' h,
    obtain ⟨_, ⟨x, hx₁, rfl⟩, ⟨x, hx₂, e'⟩⟩ := @@nonempty_preirreducible_inter _ H.1
      (X.basic_open a).2 (X.basic_open b).2 h.1 h.2,
    replace e' := subtype.eq e',
    subst e',
    replace e := congr_arg (X.presheaf.germ x) e,
    rw [ring_hom.map_mul, ring_hom.map_zero] at e,
    refine zero_ne_one' (X.presheaf.stalk x.1) (is_unit_zero_iff.1 _),
    convert hx₁.mul hx₂,
    exact e.symm },
  exact no_zero_divisors.to_is_domain _
end

lemma is_integral_iff_is_irreducible_and_is_reduced :
  is_integral X ↔ irreducible_space X.carrier ∧ is_reduced X :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩,
  λ ⟨_, _⟩, by exactI is_integral_of_is_irreducible_is_reduced X⟩

lemma is_integral_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_integral Y] [nonempty X.carrier] : is_integral X :=
begin
  constructor,
  intros U hU,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  haveI : is_domain (Y.presheaf.obj (op (H.base_open.is_open_map.functor.obj U))),
  { apply_with is_integral.component_integral { instances := ff },
    apply_instance,
    refine ⟨⟨_, _, hU.some.prop, rfl⟩⟩ },
  exact (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) :
    Y.presheaf.obj _ ≅ _).symm.CommRing_iso_to_ring_equiv.is_domain _
end

instance {R : CommRing} [H : is_domain R] : is_integral (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_integral_of_is_irreducible_is_reduced { instances := ff },
  { apply_instance },
  { dsimp [Spec.Top_obj],
    apply_instance },
end

lemma affine_is_integral_iff (R : CommRing) :
  is_integral (Scheme.Spec.obj $ op R) ↔ is_domain R :=
⟨λ h, by exactI ring_equiv.is_domain ((Scheme.Spec.obj $ op R).presheaf.obj _)
  (as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv, λ h, by exactI infer_instance⟩

lemma is_integral_of_is_affine_is_domain [is_affine X] [nonempty X.carrier]
  [h : is_domain (X.presheaf.obj (op ⊤))] : is_integral X :=
begin
  haveI : is_integral (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_integral_iff, exact h },
  exact is_integral_of_open_immersion X.iso_Spec.hom,
end

lemma map_injective_of_is_integral [is_integral X] {U V : opens X.carrier} (i : U ⟶ V)
  [H : nonempty U] :
  function.injective (X.presheaf.map i.op) :=
begin
  rw injective_iff_map_eq_zero,
  intros x hx,
  rw ← basic_open_eq_bot_iff at ⊢ hx,
  rw Scheme.basic_open_res at hx,
  revert hx,
  contrapose!,
  simp_rw [← opens.not_nonempty_iff_eq_bot, not_not],
  apply nonempty_preirreducible_inter U.is_open (RingedSpace.basic_open _ _).is_open,
  simpa using H
end

end algebraic_geometry


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Simon Hudon
-/
import category_theory.monoidal.braided
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.terminal
import category_theory.pempty

/-!
# The monoidal structure on a category with chosen finite products.

This is a variant of the development in `category_theory.monoidal.of_has_finite_products`,
which uses specified choices of the terminal object and binary product,
enabling the construction of a cartesian category with specific definitions of the tensor unit
and tensor product.

(Because the construction in `category_theory.monoidal.of_has_finite_products` uses `has_limit`
classes, the actual definitions there are opaque behind `classical.choice`.)

We use this in `category_theory.monoidal.types` to construct the monoidal category of types
so that the tensor product is the usual cartesian product of types.

For now we only do the construction from products, and not from coproducts,
which seems less often useful.
-/

universes v u

noncomputable theory

namespace category_theory

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

namespace limits

section
variables {C}

/-- Swap the two sides of a `binary_fan`. -/
def binary_fan.swap {P Q : C} (t : binary_fan P Q) : binary_fan Q P :=
binary_fan.mk t.snd t.fst

@[simp] lemma binary_fan.swap_fst {P Q : C} (t : binary_fan P Q) : t.swap.fst = t.snd := rfl
@[simp] lemma binary_fan.swap_snd {P Q : C} (t : binary_fan P Q) : t.swap.snd = t.fst := rfl

/--
If a cone `t` over `P Q` is a limit cone, then `t.swap` is a limit cone over `Q P`.
-/
@[simps]
def is_limit.swap_binary_fan {P Q : C} {t : binary_fan P Q} (I : is_limit t) : is_limit t.swap :=
{ lift := λ s, I.lift (binary_fan.swap s),
  fac' := λ s, by { rintro ⟨⟩; simp, },
  uniq' := λ s m w,
  begin
    have h := I.uniq (binary_fan.swap s) m,
    rw h,
    intro j,
    specialize w j.swap,
    cases j; exact w,
  end }

/--
Construct `has_binary_product Q P` from `has_binary_product P Q`.
This can't be an instance, as it would cause a loop in typeclass search.
-/
lemma has_binary_product.swap (P Q : C) [has_binary_product P Q] : has_binary_product Q P :=
has_limit.mk ⟨binary_fan.swap (limit.cone (pair P Q)), (limit.is_limit (pair P Q)).swap_binary_fan⟩

/--
Given a limit cone over `X` and `Y`, and another limit cone over `Y` and `X`, we can construct
an isomorphism between the cone points. Relative to some fixed choice of limits cones for every
pair, these isomorphisms constitute a braiding.
-/
def binary_fan.braiding {X Y : C}
  {s : binary_fan X Y} (P : is_limit s) {t : binary_fan Y X} (Q : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso P Q.swap_binary_fan

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `sXY.X Z`,
if `sYZ` is a limit cone we can construct a binary fan over `X sYZ.X`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  binary_fan X sYZ.X :=
binary_fan.mk (s.fst ≫ sXY.fst) (Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd))

@[simp] lemma binary_fan.assoc_fst {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).fst = s.fst ≫ sXY.fst := rfl
@[simp] lemma binary_fan.assoc_snd {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).snd = Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd) := rfl

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `X sYZ.X`,
if `sYZ` is a limit cone we can construct a binary fan over `sXY.X Z`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc_inv {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  binary_fan sXY.X Z :=
binary_fan.mk (P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst))) (s.snd ≫ sYZ.snd)

@[simp] lemma binary_fan.assoc_inv_fst {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).fst = P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst)) := rfl
@[simp] lemma binary_fan.assoc_inv_snd {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).snd = s.snd ≫ sYZ.snd := rfl

/--
If all the binary fans involved a limit cones, `binary_fan.assoc` produces another limit cone.
-/
@[simps]
def is_limit.assoc {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) : is_limit (s.assoc Q) :=
{ lift := λ t, R.lift (binary_fan.assoc_inv P t),
  fac' := λ t,
  begin
    rintro ⟨⟩; simp,
    apply Q.hom_ext,
    rintro ⟨⟩; simp,
  end,
  uniq' := λ t m w,
  begin
    have h := R.uniq (binary_fan.assoc_inv P t) m,
    rw h,
    rintro ⟨⟩; simp,
    apply P.hom_ext,
    rintro ⟨⟩; simp,
    { exact w walking_pair.left, },
    { specialize w walking_pair.right,
      simp at w,
      rw [←w], simp, },
    { specialize w walking_pair.right,
      simp at w,
      rw [←w], simp, },
  end, }

/--
Given two pairs of limit cones corresponding to the parenthesisations of `X × Y × Z`,
we obtain an isomorphism between the cone points.
-/
@[reducible]
def binary_fan.associator {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) {t : binary_fan X sYZ.X} (S : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso (is_limit.assoc P Q R) S

/--
Given a fixed family of limit data for every pair `X Y`, we obtain an associator.
-/
@[reducible]
def binary_fan.associator_of_limit_cone
  (L : Π X Y : C, limit_cone (pair X Y)) (X Y Z : C) :
  (L (L X Y).cone.X Z).cone.X ≅ (L X (L Y Z).cone.X).cone.X :=
binary_fan.associator
  (L X Y).is_limit (L Y Z).is_limit
  (L (L X Y).cone.X Z).is_limit (L X (L Y Z).cone.X).is_limit

/--
Construct a left unitor from specified limit cones.
-/
@[simps]
def binary_fan.left_unitor
  {X : C} {s : cone (functor.empty C)} (P : is_limit s) {t : binary_fan s.X X} (Q : is_limit t) :
  t.X ≅ X :=
{ hom := t.snd,
  inv := Q.lift (binary_fan.mk (P.lift { X := X, π := { app := pempty.rec _ } }) (𝟙 X) ),
  hom_inv_id' := by { apply Q.hom_ext, rintro ⟨⟩, { apply P.hom_ext, rintro ⟨⟩, }, { simp, }, }, }

/--
Construct a right unitor from specified limit cones.
-/
@[simps]
def binary_fan.right_unitor
  {X : C} {s : cone (functor.empty C)} (P : is_limit s) {t : binary_fan X s.X} (Q : is_limit t) :
  t.X ≅ X :=
{ hom := t.fst,
  inv := Q.lift (binary_fan.mk (𝟙 X) (P.lift { X := X, π := { app := pempty.rec _ } })),
  hom_inv_id' := by { apply Q.hom_ext, rintro ⟨⟩, { simp, }, { apply P.hom_ext, rintro ⟨⟩, }, }, }

end

end limits

open category_theory.limits

section
local attribute [tidy] tactic.case_bash

variables {C}
variables (𝒯 : limit_cone (functor.empty C))
variables (ℬ : Π (X Y : C), limit_cone (pair X Y))

namespace monoidal_of_chosen_finite_products

/-- Implementation of the tensor product for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_obj (X Y : C) : C := (ℬ X Y).cone.X

/-- Implementation of the tensor product of morphisms for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_hom {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) : tensor_obj ℬ W Y ⟶ tensor_obj ℬ X Z :=
  (binary_fan.is_limit.lift' (ℬ X Z).is_limit
    ((ℬ W Y).cone.π.app walking_pair.left ≫ f)
    (((ℬ W Y).cone.π.app walking_pair.right : (ℬ W Y).cone.X ⟶ Y) ≫ g)).val

lemma tensor_id (X₁ X₂ : C) : tensor_hom ℬ (𝟙 X₁) (𝟙 X₂) = 𝟙 (tensor_obj ℬ X₁ X₂) :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩;
  { dsimp [tensor_hom], simp, },
end

lemma tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) :
  tensor_hom ℬ (f₁ ≫ g₁) (f₂ ≫ g₂) =
    tensor_hom ℬ f₁ f₂ ≫ tensor_hom ℬ g₁ g₂ :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩;
  { dsimp [tensor_hom], simp, },
end

lemma pentagon (W X Y Z : C) :
  tensor_hom ℬ (binary_fan.associator_of_limit_cone ℬ W X Y).hom (𝟙 Z) ≫
    (binary_fan.associator_of_limit_cone ℬ W (tensor_obj ℬ X Y) Z).hom ≫
      tensor_hom ℬ (𝟙 W) (binary_fan.associator_of_limit_cone ℬ X Y Z).hom =
  (binary_fan.associator_of_limit_cone ℬ (tensor_obj ℬ W X) Y Z).hom ≫
    (binary_fan.associator_of_limit_cone ℬ W X (tensor_obj ℬ Y Z)).hom :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩,
    { simp, },
    apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩,
    { simp, },
    { simp, }, }
end

lemma triangle (X Y : C) :
  (binary_fan.associator_of_limit_cone ℬ X 𝒯.cone.X Y).hom ≫
    tensor_hom ℬ (𝟙 X) (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X Y).is_limit).hom =
  tensor_hom ℬ (binary_fan.right_unitor 𝒯.is_limit (ℬ X 𝒯.cone.X).is_limit).hom (𝟙 Y) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩; simp,
end

lemma left_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ (𝟙 𝒯.cone.X) f ≫ (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₂).is_limit).hom =
    (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₁).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma right_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ f (𝟙 𝒯.cone.X) ≫
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₂ 𝒯.cone.X).is_limit).hom =
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₁ 𝒯.cone.X).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
  tensor_hom ℬ (tensor_hom ℬ f₁ f₂) f₃ ≫ (binary_fan.associator_of_limit_cone ℬ Y₁ Y₂ Y₃).hom =
    (binary_fan.associator_of_limit_cone ℬ X₁ X₂ X₃).hom ≫
      tensor_hom ℬ f₁ (tensor_hom ℬ f₂ f₃) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟩,
    { simp, },
    { simp, }, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/-- A category with a terminal object and binary products has a natural monoidal structure. -/
def monoidal_of_chosen_finite_products :
  monoidal_category C :=
{ tensor_unit  := 𝒯.cone.X,
  tensor_obj   := λ X Y, tensor_obj ℬ X Y,
  tensor_hom   := λ _ _ _ _ f g, tensor_hom ℬ f g,
  tensor_id'   := tensor_id ℬ,
  tensor_comp' := λ _ _ _ _ _ _ f₁ f₂ g₁ g₂, tensor_comp ℬ f₁ f₂ g₁ g₂,
  associator   := λ X Y Z, binary_fan.associator_of_limit_cone ℬ X Y Z,
  left_unitor  := λ X, binary_fan.left_unitor (𝒯.is_limit) (ℬ 𝒯.cone.X X).is_limit,
  right_unitor := λ X, binary_fan.right_unitor (𝒯.is_limit) (ℬ X 𝒯.cone.X).is_limit,
  pentagon'    := pentagon ℬ,
  triangle'    := triangle 𝒯 ℬ,
  left_unitor_naturality' := λ _ _ f, left_unitor_naturality 𝒯 ℬ f,
  right_unitor_naturality' := λ _ _ f, right_unitor_naturality 𝒯 ℬ f,
  associator_naturality' := λ _ _ _ _ _ _ f₁ f₂ f₃, associator_naturality ℬ f₁ f₂ f₃, }

namespace monoidal_of_chosen_finite_products

open monoidal_category

/--
A type synonym for `C` carrying a monoidal category structure corresponding to
a fixed choice of limit data for the empty functor, and for `pair X Y` for every `X Y : C`.

This is an implementation detail for `symmetric_of_chosen_finite_products`.
-/
@[derive category, nolint unused_arguments has_inhabited_instance]
def monoidal_of_chosen_finite_products_synonym
  (𝒯 : limit_cone (functor.empty C)) (ℬ : Π (X Y : C), limit_cone (pair X Y)):= C

instance : monoidal_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
monoidal_of_chosen_finite_products 𝒯 ℬ

lemma braiding_naturality {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
  (tensor_hom ℬ f g) ≫ (limits.binary_fan.braiding (ℬ Y Y').is_limit (ℬ Y' Y).is_limit).hom =
    (limits.binary_fan.braiding (ℬ X X').is_limit (ℬ X' X).is_limit).hom ≫ (tensor_hom ℬ g f) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

lemma hexagon_reverse (X Y Z : C) :
  (binary_fan.associator_of_limit_cone ℬ X Y Z).inv ≫
    (limits.binary_fan.braiding
      (ℬ (tensor_obj ℬ X Y) Z).is_limit
      (ℬ Z (tensor_obj ℬ X Y)).is_limit).hom ≫
    (binary_fan.associator_of_limit_cone ℬ Z X Y).inv =
    (tensor_hom ℬ (𝟙 X) (limits.binary_fan.braiding (ℬ Y Z).is_limit (ℬ Z Y).is_limit).hom) ≫
      (binary_fan.associator_of_limit_cone ℬ X Z Y).inv ≫
        (tensor_hom ℬ (limits.binary_fan.braiding (ℬ X Z).is_limit (ℬ Z X).is_limit).hom (𝟙 Y)) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟩,
  { apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟩;
    { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
        limits.is_limit.cone_point_unique_up_to_iso],
      simp, }, },
  { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
      limits.is_limit.cone_point_unique_up_to_iso],
    simp, },
end

lemma symmetry (X Y : C) :
  (limits.binary_fan.braiding (ℬ X Y).is_limit (ℬ Y X).is_limit).hom ≫
      (limits.binary_fan.braiding (ℬ Y X).is_limit (ℬ X Y).is_limit).hom =
    𝟙 (tensor_obj ℬ X Y) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/--
The monoidal structure coming from finite products is symmetric.
-/
def symmetric_of_chosen_finite_products :
  symmetric_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
{ braiding := λ X Y, limits.binary_fan.braiding (ℬ _ _).is_limit (ℬ _ _).is_limit,
  braiding_naturality' := λ X X' Y Y' f g, braiding_naturality ℬ f g,
  hexagon_forward' := λ X Y Z, hexagon_forward ℬ X Y Z,
  hexagon_reverse' := λ X Y Z, hexagon_reverse ℬ X Y Z,
  symmetry' := λ X Y, symmetry ℬ X Y, }

end

end category_theory


import exp.open
import .lc
import .subst

namespace tts ------------------------------------------------------------------
namespace exp ------------------------------------------------------------------
variables {V : Type} [decidable_eq V] -- Type of variable names
variables {v : V} -- Variable names
variables {k i : ℕ} -- Natural numbers
variables {x y : tagged V} -- Variable names
variables {e ex e₁ e₂ : exp V} -- Expressions
variables {L : finset (tagged V)} -- Variables sets

open occurs

@[simp] theorem subst_open_exp (lx : lc ex) :
  subst x ex (open_exp e₂ k e₁) = open_exp (subst x ex e₂) k (subst x ex e₁) :=
begin
  induction e₁ generalizing k,
  case exp.var : o y {
    cases o,
    { by_cases h : k = y.tag; simp [h] },
    { by_cases h : x = y; simp [h, open_exp_id lx] } },
  case exp.app : ef ea rf ra { simp [rf, ra] },
  case exp.lam : v eb rb { simp [rb] },
  case exp.let_ : v ed eb rd rb { simp [rd, rb] }
end

@[simp] theorem subst_open_exp₀ :
  lc ex → subst x ex (open_exp₀ e₂ e₁) = open_exp₀ (subst x ex e₂) (subst x ex e₁) :=
subst_open_exp

@[simp] theorem subst_open_var (lx : lc ex) (h : x ≠ y) :
  subst x ex (open_var y e₁) = open_var y (subst x ex e₁) :=
by simp [open_var, h, lx]

@[simp] theorem subst_open_fresh (lx : lc ex) (h : (fresh.tagged v).gen L ≠ x) :
  subst x ex (open_fresh v L e₁) = open_fresh v L (subst x ex e₁) :=
subst_open_var lx (ne.symm h)

/- subst_intro -/

theorem subst_intro : ∀ {e₁ : exp V} k,
  x ∉ fv e₁ → open_exp e₂ k e₁ = subst x e₂ (open_exp (var free x) k e₁)
| (var bound y)  k p := by by_cases h : k = y.tag; simp [h]
| (var free y)   k p := by simp at p; simp [p]
| (app ef ea)    k p := by simp at p; simp [subst_intro k p.1, subst_intro k p.2]
| (lam v eb)     k p := by simp at p; simp [subst_intro (k + 1) p]
| (let_ v ed eb) k p := by simp at p; simp [subst_intro k p.1, subst_intro (k + 1) p.2]

theorem subst_intro₀ : x ∉ fv e₁ → open_exp₀ e₂ e₁ = subst x e₂ (open_var x e₁) :=
subst_intro 0

-- Locally-closed expressions are stable over substitution
theorem subst_lc (x : tagged V) (lx : lc ex) (l : lc e) : lc (subst x ex e) :=
begin
  induction l generalizing ex lx x,
  case lc.var : y { by_cases h : x = y; simp [h, lx] },
  case lc.app : ef ea lf la rf ra { exact lc.app (rf lx x) (ra lx x) },
  case lc.lam : v L eb lb rb {
    apply lc.lam (L ∪ {x}),
    intros y Fy,
    simp [not_or_distrib] at Fy,
    rw ←subst_open_var lx (ne.symm Fy.2),
    exact rb Fy.1 lx x },
  case lc.let_ : v L ed eb ld lb rd rb {
    apply lc.let_ (L ∪ {x}) (rd lx x),
    intros y Fy,
    simp [not_or_distrib] at Fy,
    rw ←subst_open_var lx (ne.symm Fy.2),
    exact rb Fy.1 lx x }
end

theorem lc_open_exp₀ (v : V) (lb : lc_body e₁) (l₂ : lc e₂) : lc (open_exp₀ e₂ e₁) :=
begin
  cases lb with L l₁,
  have F : (fresh.tagged v).gen (L ∪ fv e₁) ∉ L ∧ (fresh.tagged v).gen (L ∪ fv e₁) ∉ fv e₁ :=
    (fresh.tagged v).gen_not_mem_union _ _,
  rw subst_intro₀ F.2,
  exact subst_lc _ l₂ (l₁ F.1)
end

end /- namespace -/ exp --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


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

import tactic.basic
import tactic.ext
import .recover

open tactic

meta def back_attribute : user_attribute := {
  name := `back,
  descr := "A lemma that should be applied to a goal whenever possible; use `backwards_reasoning` to automatically `apply` all lemmas tagged `[back]`."
}

run_cmd attribute.register `back_attribute

meta def apply_using_solve_by_elim (c : name) : tactic unit :=
do g::gs ← get_goals,
    set_goals [g],
    t ← mk_const c,
    r ← apply t,
    try (any_goals (terminal_goal >> solve_by_elim)),
    gs' ← get_goals,
    set_goals (gs' ++ gs)

/-- Try to apply one of the given lemmas; it succeeds as soon as one of them succeeds. -/
meta def any_apply : list name → tactic name
| []      := failed
| (c::cs) := (do
                apply_using_solve_by_elim c,
                pure c) <|> any_apply cs

meta def back'_attribute : user_attribute := {
  name := `back',
  descr := "A lemma that should be applied to a goal whenever possible, as long as all arguments to the lemma by be fulfilled from existing hypotheses; use `backwards_reasoning` to automatically apply all lemmas tagged `[back']`."
}

run_cmd attribute.register `back'_attribute
meta def seq (tac1 : tactic unit) (tac2 : tactic unit) : tactic unit :=
do g::gs ← get_goals,
   set_goals [g],
   tac1, all_goals tac2,
   gs' ← get_goals,
   set_goals (gs' ++ gs)

/-- Try to apply one of the given lemmas, fulfilling all new goals using existing hypotheses. It succeeds if one of them succeeds. -/
meta def any_apply_no_new_goals : list name → tactic name
| []      := failed
| (c::cs) := (do g::gs ← get_goals,
                 set_goals [g],
                 t ← mk_const c,
                 r ← apply t,
                 all_goals solve_by_elim,
                 a ← r.mmap (λ p, do e ← instantiate_mvars p.2, return e.list_meta_vars.length),
                 guard (a.all (λ n, n = 0)),
                 gs' ← get_goals,
                 set_goals (gs' ++ gs),
                 pure c) <|> any_apply_no_new_goals cs

/-- Try to apply any lemma marked with the attributes `@[back]` or `@[back']`. -/
meta def backwards_reasoning : tactic string :=
do cs ← attribute.get_instances `back',
   r ← try_core (any_apply_no_new_goals cs),
   match r with
   | (some n) := return ("apply " ++ n.to_string ++ " ; solve_by_elim")
   | none     :=  do
                    cs ← attribute.get_instances `back,
                    n ← any_apply cs <|> fail "no @[back] or @[back'] lemmas could be applied",
                    return ("apply " ++ n.to_string)
   end

attribute [extensionality] subtype.eq

-- TODO should `apply_instance` be in tidy? If so, these shouldn't be needed.
@[back] definition decidable_true  : decidable true  := is_true  dec_trivial
@[back] definition decidable_false : decidable false := is_false dec_trivial

attribute [back] quotient.mk quotient.sound

attribute [back] eqv_gen.rel
attribute [back'] Exists.intro