import for_mathlib.algebra.homology.hom_complex
import for_mathlib.algebra.homology.shift

open category_theory category_theory.category category_theory.limits

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

namespace cochain_complex

namespace hom_complex

namespace cochain

variables {K L : cochain_complex C ℤ} {i : ℤ}
  (γ γ₂ : cochain K L i) (n : ℤ) (γ' γ'₂: cochain K (L⟦n⟧) i)

def right_shift (j : ℤ) (hj : i = j + n) : cochain K (L⟦n⟧) j :=
cochain.mk (λ p q hpq, γ.v p (p+i) rfl ≫
  (L.shift_functor_obj_X_iso n q (p+i) (by linarith)).inv)

lemma right_shift_v (j : ℤ) (hj : i = j + n) (p q : ℤ) (hpq : q = p + j)
  (p' : ℤ) (hp' : p' = p + i) :
  (γ.right_shift n j hj).v p q hpq = γ.v p p' hp' ≫
    (L.shift_functor_obj_X_iso n q p' (by rw [hp', hpq, hj, add_assoc])).inv :=
by { subst hp', refl, }

@[simp]
lemma right_shift_zero (j : ℤ) (hj : i = j + n) :
  (0 : cochain K L i).right_shift n j hj = 0 :=
by { dsimp [right_shift], tidy, }

@[simp]
lemma right_shift_smul (j : ℤ) (hj : i = j + n) (a : ℤ) :
  (a • γ).right_shift n j hj = a • γ.right_shift n j hj :=
begin
  ext p q hpq,
  simp only [right_shift_v _ n j hj p q hpq _ rfl, zsmul_v, linear.smul_comp],
end

@[simp]
lemma right_shift_add (j : ℤ) (hj : i = j + n) :
  (γ + γ₂).right_shift n j hj = γ.right_shift n j hj + γ₂.right_shift n j hj :=
begin
  ext p q hpq,
  simp only [right_shift_v _ n j hj p q hpq _ rfl, add_v, preadditive.add_comp],
end

variable {n}

def right_unshift (j : ℤ) (hj : j = i + n) : cochain K L j :=
cochain.mk (λ p q hpq, γ'.v p (p+i) rfl ≫
  (L.shift_functor_obj_X_iso n (p+i) q (by linarith)).hom)

lemma right_unshift_v (j : ℤ) (hj : j = i + n) (p q : ℤ) (hpq : q = p + j)
  (p' : ℤ) (hp' : p' = p + i):
  (γ'.right_unshift j hj).v p q hpq = γ'.v p p' hp' ≫
    (L.shift_functor_obj_X_iso n p' q (by rw [hp', hpq, hj, add_assoc])).hom :=
by { subst hp', refl, }

@[simp]
lemma right_unshift_zero (j : ℤ) (hj : j = i + n) :
  (0 : cochain K (L⟦n⟧) i).right_unshift j hj = 0 :=
by { dsimp [right_unshift], tidy, }

@[simp]
lemma right_unshift_smul (j : ℤ) (hj : j = i + n) (a : ℤ) :
  (a • γ').right_unshift j hj = a • γ'.right_unshift j hj :=
begin
  ext p q hpq,
  simp only [right_unshift_v _ j hj p q hpq _ rfl, zsmul_v, linear.smul_comp],
end

@[simp]
lemma right_unshift_add (j : ℤ) (hj : j = i + n) :
  (γ' + γ'₂).right_unshift j hj = γ'.right_unshift j hj + γ'₂.right_unshift j hj :=
begin
  ext p q hpq,
  simp only [right_unshift_v _ j hj p q hpq _ rfl, add_v, preadditive.add_comp],
end

@[simp]
lemma right_unshift_shift (j : ℤ) (hj : j = i + n) :
  (γ'.right_unshift j hj).right_shift n i hj = γ' :=
begin
  ext p q hpq,
  simp only [cochain.right_shift_v _ n i hj p q hpq _ rfl,
    cochain.right_unshift_v _ j hj p (p+j) rfl q hpq,
    shift_functor_obj_X_iso, assoc,
    homological_complex.X_iso_of_eq_hom_inv,
    homological_complex.X_iso_of_eq_refl, iso.refl_hom],
  erw category.comp_id,
end

variable (n)

@[simp]
lemma right_shift_unshift (j : ℤ) (hj : i = j + n) :
  (γ.right_shift n j hj).right_unshift i hj = γ :=
begin
  ext p q hpq,
  simp only [cochain.right_unshift_v _ i hj p q hpq _ rfl,
    cochain.right_shift_v _ n j hj p (p+j) rfl q hpq,
    shift_functor_obj_X_iso, assoc,
    homological_complex.X_iso_of_eq_inv_hom,
    homological_complex.X_iso_of_eq_refl, iso.refl_hom, category.comp_id],
end

lemma δ_right_shift (i' j j' : ℤ) (hj : i = j + n) (hj' : i' = j' + n) :
  δ j j' (γ.right_shift n j hj) = ε n • (δ i i' γ).right_shift n j' hj' :=
begin
  by_cases h₁ : i+1 = i', swap,
  { have h₂ : j+1 ≠ j' := λ h₃, by { exfalso, apply h₁, linarith, },
    simp only [δ_shape _ _ h₁, δ_shape _ _ h₂, right_shift_zero, smul_zero], },
  { have h₂ : j' = j+1 := by linarith,
    substs h₁ h₂,
    ext p q hpq,
    simp only [δ_v j _ rfl _ p q hpq (p+j) (p+1) (by linarith) rfl,
      γ.right_shift_v n j hj p (p+j) rfl (p+j+n) (by linarith),
      γ.right_shift_v n j hj (p+1) q (by linarith) (p+1+i) rfl, zsmul_v,
      right_shift_v _ n (j+1) hj' p q hpq (p+1+i) (by linarith),
      δ_v i _ rfl _ p (p+1+i) (by linarith) (p+j+n) _ (by linarith) rfl,
      shift_functor_obj_X_iso, assoc, preadditive.add_comp,
      homological_complex.d_comp_X_iso_of_eq_inv, linear.smul_comp,
      smul_add, smul_smul, ← ε_add],
    congr' 1,
    { erw [shift_functor_obj_d,
        homological_complex.X_iso_of_eq_refl,
        iso.refl_inv, category.id_comp, linear.comp_smul], },
    { congr' 1,
      rw [ε_eq_iff],
      exact ⟨-n, by linarith⟩, }, },
end

variable {n}

lemma δ_right_unshift (i' j j' : ℤ) (hj : j = i + n) (hj' : j' = i' + n) :
  δ j j' (γ'.right_unshift j hj) = ε n • (δ i i' γ').right_unshift j' hj' :=
begin
  conv_rhs { rw ← γ'.right_unshift_shift j hj, },
  rw [(γ'.right_unshift j hj).δ_right_shift n j' i i' hj hj',
    right_unshift_smul, cochain.right_shift_unshift, smul_smul,
    ← ε_add, ε_even _ (even_add_self n), one_smul],
end

@[simps]
def right_shift_equiv (K L : cochain_complex C ℤ) (n i j : ℤ) (h : i = j + n) :
  cochain K L i ≃+ cochain K (L⟦n⟧) j :=
{ to_fun := λ γ, γ.right_shift n j h,
  inv_fun := λ γ', γ'.right_unshift i h,
  left_inv := λ γ, γ.right_shift_unshift _ _ _,
  right_inv := λ γ', γ'.right_unshift_shift _ _,
  map_add' := λ γ₁ γ₂, cochain.right_shift_add γ₁ γ₂ _ _ _, }

end cochain

namespace cocycle

variables {K L : cochain_complex C ℤ} {i : ℤ}
  (γ : cocycle K L i) (n : ℤ) (γ' : cocycle K (L⟦n⟧) i)

@[simps]
def right_shift (j : ℤ) (hj : i = j + n) : cocycle K (L⟦n⟧) j :=
⟨(γ : cochain K L i).right_shift n j hj, begin
  rw [cocycle.mem_iff j (j+1) rfl, cochain.δ_right_shift _ n (i+1) j (j+1) hj (by linarith)],
  simp only [subtype.val_eq_coe, δ_eq_zero, cochain.right_shift_zero, smul_zero],
end⟩

variable {n}

@[simps]
def right_unshift (j : ℤ) (hj : j = i + n) : cocycle K L j :=
⟨(γ' : cochain K (L⟦n⟧) i).right_unshift j hj, begin
  rw [cocycle.mem_iff j (j+1) rfl, cochain.δ_right_unshift _ (i+1) j (j+1) hj (by linarith)],
  simp only [subtype.val_eq_coe, δ_eq_zero, cochain.right_unshift_zero, smul_zero],
end⟩

@[simps]
def right_shift_equiv (K L : cochain_complex C ℤ) (n i j : ℤ) (h : i = j + n) :
  cocycle K L i ≃+ cocycle K (L⟦n⟧) j :=
{ to_fun := λ γ, right_shift γ n j h,
  inv_fun := λ γ', right_unshift γ' i h,
  left_inv := λ γ, by { ext1, exact γ.1.right_shift_unshift _ _ _, },
  right_inv := λ γ', by { ext1, exact γ'.1.right_unshift_shift _ _, },
  map_add' := λ γ₁ γ₂, by { ext1, exact cochain.right_shift_add γ₁.1 γ₂.1 _ _ _, }, }

end cocycle

@[simps]
def right_shift_iso (K L : cochain_complex C ℤ) (n : ℤ) :
  (hom_complex K L)⟦n⟧ ≅ hom_complex K (L⟦n⟧) :=
homological_complex.hom.iso_of_components
  (λ i, add_equiv.to_AddCommGroup_iso (cochain.right_shift_equiv K L n (i+n) i rfl))
  (λ i j hij, begin
    ext1 γ,
    simp only [comp_apply],
    dsimp [hom_complex, δ_hom],
    erw [γ.δ_right_shift n (j+n) i j rfl rfl, cochain.right_shift_smul],
  end)

namespace cochain

variables {K L : cochain_complex C ℤ} {i : ℤ}
  (γ γ₂ : cochain K L i) (n : ℤ) (γ' γ'₂: cochain (K⟦n⟧) L i)

def left_shift (j : ℤ) (hj : j = i + n) : cochain (K⟦n⟧) L j :=
cochain.mk (λ p q hpq,
  ε (n*j + (n*(n-1)/2)) • (K.shift_functor_obj_X_iso n p (p+n) rfl).hom ≫ γ.v (p+n) q (by { dsimp, linarith, }))

lemma left_shift_v (j : ℤ) (hj : j = i + n) (p q : ℤ) (hpq : q = p + j)
  (p' : ℤ) (hp' : p' = p + n) :
  (γ.left_shift n j hj).v p q hpq = ε (n*j + (n*(n-1)/2)) • (K.shift_functor_obj_X_iso n p p' hp').hom ≫
    γ.v p' q (by rw [hpq, hp', hj, add_assoc, add_comm i]) :=
by { subst hp', refl, }

@[simp]
lemma left_shift_zero (j : ℤ) (hj : j = i + n) :
  (0 : cochain K L i).left_shift n j hj = 0 :=
by { dsimp [left_shift], tidy, }

@[simp]
lemma left_shift_smul (j : ℤ) (hj : j = i + n) (a : ℤ) :
  (a • γ).left_shift n j hj = a • γ.left_shift n j hj :=
begin
  ext p q hpq,
  simp only [left_shift_v _ n j hj p q hpq _ rfl, zsmul_v, linear.comp_smul,
    ← mul_smul, mul_comm a],
end

@[simp]
lemma left_shift_add (j : ℤ) (hj : j = i + n) :
  (γ + γ₂).left_shift n j hj = γ.left_shift n j hj + γ₂.left_shift n j hj :=
begin
  ext p q hpq,
  simp only [left_shift_v _ n j hj p q hpq _ rfl, add_v, preadditive.comp_add, smul_add],
end

variable {n}

def left_unshift (j : ℤ) (hj : i = j + n) : cochain K L j :=
cochain.mk (λ p q hpq,
  ε (n*i + (n*(n-1)/2)) • (K.shift_functor_obj_X_iso n (p-n) p (by linarith)).inv ≫
    γ'.v (p-n) q (by { change _ = _ - _ + _, linarith,}))

lemma left_unshift_v (j : ℤ) (hj : i = j + n) (p q : ℤ) (hpq : q = p + j)
  (p' : ℤ) (hp' : p' = p - n):
  (γ'.left_unshift j hj).v p q hpq =
  ε (n*i + (n*(n-1)/2)) • (K.shift_functor_obj_X_iso n p' p (by rw [hp', sub_add_cancel])).inv ≫
    γ'.v p' q (by rw [hpq, hp', hj, sub_add_add_cancel]) :=
by { subst hp', refl, }

@[simp]
lemma left_unshift_zero (j : ℤ) (hj : i = j + n) :
  (0 : cochain (K⟦n⟧) L i).left_unshift j hj = 0 :=
by { dsimp [left_unshift], tidy, }

@[simp]
lemma left_unshift_smul (j : ℤ) (hj : i = j + n) (a : ℤ) :
  (a • γ').left_unshift j hj = a • γ'.left_unshift j hj :=
begin
  ext p q hpq,
  simp only [left_unshift_v _ j hj p q hpq _ rfl, zsmul_v, linear.smul_comp, linear.comp_smul,
    ← mul_smul, mul_comm a],
end

@[simp]
lemma left_unshift_add (j : ℤ) (hj : i = j + n) :
  (γ' + γ'₂).left_unshift j hj = γ'.left_unshift j hj + γ'₂.left_unshift j hj :=
begin
  ext p q hpq,
  simp only [left_unshift_v _ j hj p q hpq _ rfl, add_v, preadditive.comp_add, smul_add],
end

@[simp]
lemma left_unshift_shift (j : ℤ) (hj : i = j + n) :
  (γ'.left_unshift j hj).left_shift n i hj = γ' :=
begin
  ext p q hpq,
  simp only [cochain.left_shift_v _ n i hj p q hpq _ rfl,
    cochain.left_unshift_v _ j hj (p+n) q (by linarith) p (by linarith),
    ε_add, linear.comp_smul, iso.hom_inv_id_assoc, ← mul_smul],
  nth_rewrite 0 mul_comm (ε (n*i)),
  rw ← mul_assoc,
  nth_rewrite 1 mul_assoc,
  rw [← ε_add, ε_even _ (even_add_self _), mul_one],
  rw [← ε_add, ε_even _ (even_add_self _), one_smul],
end

variable (n)

@[simp]
lemma left_shift_unshift (j : ℤ) (hj : j = i + n) :
  (γ.left_shift n j hj).left_unshift i hj = γ :=
begin
  ext p q hpq,
  simp only [cochain.left_unshift_v _ i hj p q hpq _ rfl,
    cochain.left_shift_v _ n j hj (p-n) q (by linarith) p (by linarith)],
  simp only [shift_functor_obj_X_iso, ε_add, linear.comp_smul,
    homological_complex.X_iso_of_eq_inv_hom_assoc,
    homological_complex.X_iso_of_eq_refl, iso.refl_hom, category.id_comp, ← mul_smul],
  nth_rewrite 0 mul_comm (ε (n*j)),
  rw ← mul_assoc,
  nth_rewrite 1 mul_assoc,
  rw [← ε_add, ε_even _ (even_add_self _), mul_one],
  rw [← ε_add, ε_even _ (even_add_self _), one_smul],
end

variable (n)

lemma δ_left_shift (i' j j' : ℤ) (hj : j = i + n) (hj' : j' = i' + n) :
  δ j j' (γ.left_shift n j hj) = ε (n) • (δ i i' γ).left_shift n j' hj' :=
begin
  by_cases h₁ : i+1 = i', swap,
  { have h₂ : j+1 ≠ j' := λ h₃, by { exfalso, apply h₁, linarith, },
    simp only [δ_shape _ _ h₁, δ_shape _ _ h₂, left_shift_zero, smul_zero], },
  { have h₂ : j' = j+1 := by linarith,
    substs h₁ h₂,
    ext p q hpq,
    rw δ_v j _ rfl _ p q hpq (p+j) (p+1) (by linarith) rfl,
    rw γ.left_shift_v n j hj p _ rfl _ rfl,
    rw γ.left_shift_v n j hj (p+1) q (by linarith) _ rfl,
    rw zsmul_v,
    rw left_shift_v _ n (j+1) hj' p q hpq _ rfl,
    rw δ_v i _ rfl _ (p+n) q (by linarith) (p+j) (p+1+n) (by linarith) (by linarith),
    simp only [shift_functor_obj_X_iso, homological_complex.X_iso_of_eq_refl,
      linear.smul_comp, assoc, ε_succ, linear.comp_smul, neg_smul, preadditive.comp_add,
      preadditive.comp_neg, smul_add, zsmul_neg', add_right_inj, neg_inj, ← mul_smul],
    dsimp [iso.refl],
    simp only [preadditive.zsmul_comp, ← mul_smul],
    erw [category.id_comp, category.id_comp, category.id_comp],
    congr' 2,
    { simp only [mul_add, ε_add, mul_one, mul_comm _ (ε n)],
      simp only [← mul_assoc, ← ε_add n n, ε_even _ (even_add_self n)],
      ring, },
    { rw [hj],
      simp only [ε_add, neg_mul, mul_neg, neg_inj, mul_add],
      ring_nf, }, },
end

variable {n}

lemma δ_left_unshift (i' j j' : ℤ) (hj : i = j + n) (hj' : i' = j' + n) :
  δ j j' (γ'.left_unshift j hj) = ε n • (δ i i' γ').left_unshift j' hj' :=
begin
  conv_rhs { rw ← γ'.left_unshift_shift j hj, },
  rw [(γ'.left_unshift j hj).δ_left_shift n j' i i' hj hj',
    left_unshift_smul, cochain.left_shift_unshift, smul_smul,
    ← ε_add, ε_even _ (even_add_self n), one_smul],
end

@[simps]
def left_shift_equiv (K L : cochain_complex C ℤ) (n i j : ℤ) (h : j = i + n) :
  cochain K L i ≃+ cochain (K⟦n⟧) L j :=
{ to_fun := λ γ, γ.left_shift n j h,
  inv_fun := λ γ', γ'.left_unshift i h,
  left_inv := λ γ, γ.left_shift_unshift _ _ _,
  right_inv := λ γ', γ'.left_unshift_shift _ _,
  map_add' := λ γ₁ γ₂, cochain.left_shift_add γ₁ γ₂ _ _ _, }

end cochain

namespace cocycle

variables {K L : cochain_complex C ℤ} {i : ℤ}
  (γ : cocycle K L i) (n : ℤ) (γ' : cocycle (K⟦n⟧) L i)

@[simps]
def left_shift (j : ℤ) (hj : j = i + n) : cocycle (K⟦n⟧) L j :=
⟨(γ : cochain K L i).left_shift n j hj, begin
  rw [cocycle.mem_iff j (j+1) rfl, cochain.δ_left_shift _ n (i+1) j (j+1) hj (by linarith)],
  simp only [subtype.val_eq_coe, δ_eq_zero, cochain.left_shift_zero, smul_zero],
end⟩

variable {n}

@[simps]
def left_unshift (j : ℤ) (hj : i = j + n) : cocycle K L j :=
⟨(γ' : cochain (K⟦n⟧) L i).left_unshift j hj, begin
  rw [cocycle.mem_iff j (j+1) rfl, cochain.δ_left_unshift _ (i+1) j (j+1) hj (by linarith)],
  simp only [subtype.val_eq_coe, δ_eq_zero, cochain.left_unshift_zero, smul_zero],
end⟩

variables (K L)

@[simps]
def left_shift_equiv (n i j : ℤ) (h : j = i + n) :
  cocycle K L i ≃+ cocycle (K⟦n⟧) L j :=
{ to_fun := λ γ, left_shift γ n j h,
  inv_fun := λ γ', left_unshift γ' i h,
  left_inv := λ γ, by { ext1, exact γ.1.left_shift_unshift _ _ _, },
  right_inv := λ γ', by { ext1, exact γ'.1.left_unshift_shift _ _, },
  map_add' := λ γ₁ γ₂, by { ext1, exact cochain.left_shift_add γ₁.1 γ₂.1 _ _ _, }, }

end cocycle

@[simps]
def left_shift_iso (K L : cochain_complex C ℤ) (n : ℤ) :
  (hom_complex K L) ≅ (hom_complex (K⟦n⟧) L)⟦n⟧ :=
homological_complex.hom.iso_of_components
  (λ i, add_equiv.to_AddCommGroup_iso (cochain.left_shift_equiv K L n i (i+n) rfl))
  (λ i j hij, begin
    ext1 γ,
    simp only [comp_apply],
    dsimp [hom_complex, δ_hom],
    rw [γ.δ_left_shift n j (i+n) (j+n) rfl rfl, ← mul_smul, ← ε_add,
      ε_even _ (even_add_self n), one_smul],
  end)

def shift_iso (K L : cochain_complex C ℤ) (n : ℤ) :
  hom_complex K L ≅ hom_complex (K⟦n⟧) (L⟦n⟧) :=
left_shift_iso K L n ≪≫ right_shift_iso (K⟦n⟧) L n

lemma δ_shift_iso_hom_f {K L : cochain_complex C ℤ} (n i j : ℤ) (γ : cochain K L i) :
  δ i j ((shift_iso K L n).hom.f i γ) = (shift_iso K L n).hom.f j (δ i j γ) :=
congr_hom (((shift_iso K L n).hom.comm i j)) γ

lemma even_mul_succ (n : ℤ) : even (n * (n+1)) :=
begin
  by_cases hn : even n,
  { obtain ⟨k, rfl⟩ := hn,
    exact ⟨k * (2*k+1), by ring⟩, },
  { rw ← int.odd_iff_not_even at hn,
    obtain ⟨k, rfl⟩ := hn,
    exact ⟨(2*k+1)*(k+1), by ring⟩, },
end

lemma even_mul_pred (n : ℤ) : even (n * (n-1)) :=
begin
  rw mul_comm,
  convert (even_mul_succ (n-1)),
  linarith,
end

lemma mul_pred_div_two_of_even (k : ℤ) : ((k+k)* ((k+k)-1))/2 = k*(2*k-1) :=
by simp only [show k+k = 2*k, by ring, mul_assoc, int.mul_div_cancel_left, ne.def, bit0_eq_zero,
  one_ne_zero, not_false_iff]

lemma mul_succ_div_two_of_even (k : ℤ) : ((k+k)* (k+k+1))/2 = k*(2*k+1) :=
by simp only [show k+k = 2*k, by ring, mul_assoc, int.mul_div_cancel_left,
  int.mul_div_cancel_left, ne.def, bit0_eq_zero, one_ne_zero, not_false_iff]

lemma mul_pred_div_two_of_odd (k : ℤ) : ((2*k+1)* ((2*k+1)-1))/2 = k*(2*k+1) :=
by simp only [add_tsub_cancel_right, mul_comm _ (2*k), mul_assoc,
  int.mul_div_cancel_left, ne.def, bit0_eq_zero, one_ne_zero, not_false_iff]

lemma mul_succ_div_two_of_odd (k : ℤ) : ((2*k+1)* ((2*k+1)+1))/2 = (k+1)*(2*k+1) :=
by simp only [mul_comm (2*k+1), show 2*k+1+1 = 2*(k+1), by ring, mul_assoc,
  int.mul_div_cancel_left, ne.def, bit0_eq_zero, one_ne_zero, not_false_iff]

lemma mul_succ_div_two (n : ℤ) : (n * (n+1))/2 = (n*(n-1))/2 + n :=
begin
  by_cases hn : even n,
  { obtain ⟨k, rfl⟩ := hn,
    rw [mul_pred_div_two_of_even, mul_succ_div_two_of_even],
    ring, },
  { rw ← int.odd_iff_not_even at hn,
    obtain ⟨k, rfl⟩ := hn,
    rw [mul_succ_div_two_of_odd, mul_pred_div_two_of_odd],
    ring, },
end

lemma shift_iso_hom_f_of_hom {K L : cochain_complex C ℤ} (f : K ⟶ L) (n : ℤ) :
  ((shift_iso K L n).hom.f 0) (cochain.of_hom f) = ε ((n * (n+1))/2) • cochain.of_hom (f⟦n⟧') :=
begin
  ext p,
  dsimp only [shift_iso],
  simp only [iso.trans_hom, homological_complex.comp_f, comp_apply,
    left_shift_iso_hom_f_apply, right_shift_iso_hom_f_apply],
  rw cochain.right_shift_v _ n 0 rfl p p (by linarith) (p+n) (by linarith),
  rw cochain.left_shift_v _ n (0+n) rfl p (p+n) (by linarith) _ rfl,
  simp only [zero_add, shift_functor_obj_X_iso,
    homological_complex.X_iso_of_eq_refl, cochain.of_hom_v, linear.smul_comp, assoc],
  dsimp [iso.refl],
  have eq : ε (n * n + n * (n - 1) / 2) = ε (( n * (n+1)/2)),
  { simp only [mul_succ_div_two, ε_add, mul_comm _ (ε n)],
    congr' 1,
    by_cases hn : even n,
    { rw [ε_even _ hn, ε_even],
      obtain ⟨k, rfl⟩ := hn,
      exact ⟨2*k*k, by ring⟩, },
    { rw ← int.odd_iff_not_even at hn,
      rw [ε_odd _ hn, ε_odd],
      obtain ⟨k, rfl⟩ := hn,
      exact ⟨2*k*k+2*k, by ring⟩, }, },
  erw [id_comp, comp_id, eq],
  simpa only [cochain.of_hom_v],
end

end hom_complex

end cochain_complex

open cochain_complex.hom_complex

def homotopy.shift {K L : cochain_complex C ℤ} {f₁ f₂ : K ⟶ L} (h : homotopy f₁ f₂) (n : ℤ) :
  homotopy (f₁⟦n⟧') (f₂⟦n⟧') :=
(cochain_complex.hom_complex.equiv_homotopy _ _).symm begin
  obtain ⟨γ, hγ⟩ := (cochain_complex.hom_complex.equiv_homotopy _ _) h,
  replace hγ := congr_arg ((shift_iso K L n).hom.f 0) hγ.symm,
  simp only [map_add, shift_iso_hom_f_of_hom, ← δ_shift_iso_hom_f] at hγ,
  refine ⟨ε ((n*(n+1)/2)) • (shift_iso K L n).hom.f (-1) γ, _⟩,
  simp only [δ_zsmul, eq_sub_of_add_eq hγ, zsmul_sub, ← mul_smul, ← ε_add,
    ε_even _ (even_add_self _), one_smul, sub_add_cancel],
end

namespace homotopy_category

noncomputable instance : has_shift (homotopy_category C (complex_shape.up ℤ)) ℤ :=
quotient.shift (λ n K L f₁ f₂, by { rintro ⟨h⟩, exact ⟨h.shift n⟩, })

lemma quotient_map_shift {K L : cochain_complex C ℤ} (φ : K ⟶ L) (n : ℤ) :
  (homotopy_category.quotient _ _).map (φ⟦n⟧') = ((homotopy_category.quotient _ _).map φ)⟦n⟧' := rfl

end homotopy_category


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.tactic
import Mathlib.Lean3Lib.init.meta.format
import Mathlib.Lean3Lib.init.function

universes l

namespace Mathlib

/-- This is a kind attached to an argument of a congruence lemma that tells the simplifier how to fill it in.
- `fixed`: It is a parameter for the congruence lemma, the parameter occurs in the left and right hand sides.
  For example the α in the congruence generated from `f: Π {α : Type} α → α`.
- `fixed_no_param`: It is not a parameter for the congruence lemma, the lemma was specialized for this parameter.
  This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it.
- `eq`: The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i = b_i)`.
  `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality.
  For example the second argument in `f: Π {α : Type}, α → α`.
- `cast`: corresponds to arguments that are subsingletons/propositions.
  For example the `p` in the congruence generated from `f : Π (x y : ℕ) (p: x < y), ℕ`.
- `heq` The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i == b_i)`.
   `a_i` and `b_i` represent the left and right hand sides, and eq_i is a proof for their heterogeneous equality.
-/
inductive congr_arg_kind
where
| fixed : congr_arg_kind
| fixed_no_param : congr_arg_kind
| eq : congr_arg_kind
| cast : congr_arg_kind
| heq : congr_arg_kind

namespace congr_arg_kind

def to_string : congr_arg_kind → string :=
  sorry

protected instance has_repr : has_repr congr_arg_kind :=
  has_repr.mk to_string


import data.finsupp.basic
import finsupp_lemmas
import algebra.big_operators.fin
import data.nat.succ_pred
import tactic.linarith
import dynamics.periodic_pts

open_locale classical
noncomputable theory

universes u

structure Stream (ι : Type) (α : Type u) : Type (max 1 u) :=
(σ : Type)
(valid : σ → Prop)
(ready : σ → Prop)
(next  : Π (x : σ), valid x → σ)
(index : Π (x : σ), valid x → ι)
(value : Π (x : σ), ready x → α)

@[ext]
lemma Stream.ext {ι α} {s₁ s₂ : Stream ι α} (h₀ : s₁.σ = s₂.σ)
  (h₁ : ∀ x y, x == y → (s₁.valid x ↔ s₂.valid y)) (h₂ : ∀ x y, x == y → (s₁.ready x ↔ s₂.ready y)) (h₃ : ∀ x y H₁ H₂, x == y → s₁.next x H₁ == s₂.next y H₂)
  (h₄ : ∀ x y H₁ H₂, x == y → s₁.index x H₁ == s₂.index y H₂) (h₅ : ∀ x y H₁ H₂, x == y → s₁.value x H₁ == s₂.value y H₂) :
  s₁ = s₂ :=
begin
  cases s₁ with σ₁ v₁ r₁ n₁ i₁ l₁, cases s₂ with σ₂ v₂ r₂ n₂ i₂ l₂, dsimp only at *,
  subst h₀, simp only [heq_iff_eq] at *,
  obtain rfl : v₁ = v₂ := funext (λ x, propext $ h₁ x x rfl), obtain rfl : r₁ = r₂ := funext (λ x, propext $ h₂ x x rfl),
  refine ⟨rfl, rfl, rfl, _, _, _⟩; simp only [heq_iff_eq] at *; ext, { apply h₃ x x _ _ rfl; assumption, }, { apply h₄ x x _ _ rfl; assumption, },
  { apply h₅ x x _ _ rfl; assumption, },
end

section stream_defs
variables {ι : Type} {α : Type*}

def Stream.eval₀ [has_zero α] (s : Stream ι α) (σ₀ : s.σ) (h₁ : s.valid σ₀) : ι →₀ α :=
if h₂ : s.ready σ₀ then finsupp.single (s.index _ h₁) (s.value _ h₂) else 0

@[simp]
noncomputable def Stream.eval_steps [add_zero_class α] (s : Stream ι α) :
  ℕ → s.σ → ι →₀ α
| 0 _ := 0
| (n + 1) σ₀ := if h₁ : s.valid σ₀ then (Stream.eval_steps n (s.next σ₀ h₁)) + (s.eval₀ _ h₁) else 0

lemma Stream.eval_invalid [add_zero_class α] {s : Stream ι α} {σ₀ : s.σ} (h : ¬s.valid σ₀) (n : ℕ) :
  s.eval_steps n σ₀ = 0 :=
by cases n; simp [h]

inductive Stream.bound_valid : ℕ → ∀ (s : Stream ι α), s.σ → Prop
| start (n : ℕ) {s : Stream ι α} {σ₀ : s.σ} : ¬s.valid σ₀ → Stream.bound_valid n s σ₀
| step {n : ℕ} {s : Stream ι α} {σ₀ : s.σ} : ∀ (h : s.valid σ₀), Stream.bound_valid n s (s.next σ₀ h) → Stream.bound_valid (n + 1) s σ₀

end stream_defs

@[ext]
structure StreamExec (ι : Type) (α : Type u) :=
(stream : Stream ι α)
(state : stream.σ)
(bound : ℕ)
(bound_valid : stream.bound_valid bound state)

universes v w
variables {ι ι' ι'' : Type} {α : Type u} {β : Type v} {γ : Type w}

/-- Solve as many goals as possible by definitional simplification, use heq/eq, and `refl` -/
meta def tactic.interactive.solve_refl : tactic unit :=
let tactics : list (tactic unit) :=
[`[dsimp],
  `[simp only [heq_iff_eq]],
  `[intros],
  `[subst_vars],
  `[refl]] in
sequence (tactics.map (λ t, tactic.try t)) >> tactic.skip

@[simps]
def Stream.bimap (s : Stream ι α) (f : ι → ι') (g : α → β) : Stream ι' β :=
{ s with value := λ x hx, g (s.value x hx), index := λ x hx, f (s.index x hx) }

@[simp] lemma Stream.id_bimap (s : Stream ι α) : s.bimap id id = s :=
by ext; solve_refl

@[simp] lemma Stream.bimap_bimap (s : Stream ι α)
  (f : ι → ι') (f' : ι' → ι'') (g : α → β) (h : β → γ) :
  (s.bimap f g).bimap f' h = s.bimap (f' ∘ f) (h ∘ g) :=
by ext; solve_refl

notation f ` <$₁> `:1 s := s.bimap f id
notation g ` <$₂> `:1 s := s.bimap id g

@[reducible, inline]
def StreamExec.valid (s : StreamExec ι α) : Prop := s.stream.valid s.state

@[reducible, inline]
def StreamExec.ready (s : StreamExec ι α) : Prop := s.stream.ready s.state

open Stream.bound_valid (start step)

@[simp] lemma Stream.bound_valid_zero {s : Stream ι α} {σ₀ : s.σ} :
  s.bound_valid 0 σ₀ ↔ ¬s.valid σ₀ :=
⟨λ h, by { cases h, assumption, }, λ h, start _ h⟩

lemma Stream.bound_valid.mono {s : Stream ι α} {σ₀ : s.σ} {n m : ℕ} (h : s.bound_valid n σ₀) (n_le : n ≤ m) :
  s.bound_valid m σ₀ :=
begin
  induction h with _ _ _ _ _ _ _ hv _ ih generalizing m,
  { apply Stream.bound_valid.start, assumption, },
  cases m, { cases nat.not_succ_le_zero _ n_le, },
  exact Stream.bound_valid.step hv (ih (nat.le_of_succ_le_succ n_le)),
end

lemma Stream.eval_ge_bound [add_zero_class α] {s : Stream ι α} {σ₀ : s.σ} {n b : ℕ} (hb : s.bound_valid b σ₀) (hn : b ≤ n) :
  s.eval_steps n σ₀ = s.eval_steps b σ₀ :=
begin
  induction hb with _ _ _ _ n' σ₀' s' hv _ ih generalizing n,
  { simp [Stream.eval_invalid, *], },
  cases n, { cases nat.not_succ_le_zero _ hn, },
  simp [hv, ih (nat.le_of_succ_le_succ hn)],
end

lemma Stream.eval_min_bound [add_zero_class α] {s : Stream ι α} {σ₀ : s.σ} {n b : ℕ} (hb : s.bound_valid b σ₀) :
  s.eval_steps (min b n) σ₀ = s.eval_steps n σ₀ :=
by { rw min_def, split_ifs, { rw Stream.eval_ge_bound hb h, }, refl, }

lemma Stream.valid.bound_pos {s : Stream ι α} {σ₀ : s.σ} (h : s.valid σ₀) :
  ¬s.bound_valid 0 σ₀ := by simpa

lemma Stream.eval₀_support [has_zero α] (s : Stream ι α) (x : s.σ) (h : s.valid x) :
  (s.eval₀ x h).support ⊆ {s.index x h} :=
by { rw Stream.eval₀, split_ifs, { exact finsupp.support_single_subset, }, simp, }

@[simp] lemma Stream.bound_valid_succ {s : Stream ι α} {n : ℕ} {σ₀ : s.σ} :
  s.bound_valid (n + 1) σ₀ ↔ (∀ (h : s.valid σ₀), s.bound_valid n (s.next σ₀ h)) :=
⟨λ h, by { cases h, { intro, contradiction, }, intro, assumption, }, λ h, if H : s.valid σ₀ then step H (h H) else start _ H⟩

def StreamExec.eval [add_zero_class α] (s : StreamExec ι α) : ι →₀ α :=
s.stream.eval_steps s.bound s.state

section defs

@[simp] lemma imap_eval₀_spec [add_comm_monoid α] (f : ι → ι') (s : Stream ι α) (σ₀ : s.σ) (h : s.valid σ₀) :
  (f <$₁> s).eval₀ _ h = (s.eval₀ _ h).map_domain f :=
by { simp only [Stream.eval₀], split_ifs; simp, }

@[simp] lemma imap_eval_steps_spec [add_comm_monoid α] (f : ι → ι') (s : Stream ι α) (σ₀ : s.σ) (n : ℕ) :
  (f <$₁> s).eval_steps n σ₀ = (s.eval_steps n σ₀).map_domain f :=
begin
  induction n with n ih generalizing s σ₀; simp,
  split_ifs; simp [ih, finsupp.map_domain_add], refl,
end

@[simp] lemma bimap_bound_valid_iff (f : ι → ι') (g : α → β) (s : Stream ι α) (n : ℕ) (x : s.σ) :
  (s.bimap f g).bound_valid n x ↔ s.bound_valid n x :=
by { induction n with n ih generalizing x; simp [*]; refl, }

instance bimap_σ.has_zero {f : ι → ι'} {g : α → β} {s : Stream ι α} [z : has_zero s.σ] :
has_zero (s.bimap f g).σ := z

@[simp] lemma Stream.bifunctor_bimap_valid (s : Stream ι α) (f : ι → ι') (g : α → β) :
  (s.bimap f g).valid = s.valid := rfl

@[simp] lemma Stream.bifunctor_bimap_valid_apply (s : Stream ι α) (f : ι → ι') (g : α → β) (x : s.σ) :
  (s.bimap f g).valid x ↔ s.valid x := iff.rfl

@[simp] lemma Stream.bifunctor_bimap_ready (s : Stream ι α) (f : ι → ι') (g : α → β) :
  (s.bimap f g).ready = s.ready := rfl

@[simp] lemma Stream.bifunctor_bimap_ready_apply (s : Stream ι α) (f : ι → ι') (g : α → β) (x : s.σ) :
  (s.bimap f g).ready x ↔ s.ready x := iff.rfl

@[simps]
def StreamExec.bimap (s : StreamExec ι α) (f : ι → ι') (g : α → β) : StreamExec ι' β :=
{ s with stream := s.stream.bimap f g, bound_valid := by simpa using s.bound_valid }

@[simp] lemma StreamExec.id_bimap (s : StreamExec ι α) : s.bimap id id = s :=
by ext; solve_refl

@[simp] lemma StreamExec.bimap_bimap (s : StreamExec ι α)
  (f : ι → ι') (f' : ι' → ι'') (g : α → β) (h : β → γ) :
  (s.bimap f g).bimap f' h = s.bimap (f' ∘ f) (h ∘ g) :=
by ext; solve_refl

@[simp] lemma imap_stream (s : StreamExec ι α) (f : ι → ι') :
  (f <$₁> s).stream = (f <$₁> s.stream) := rfl

@[simp] lemma imap_stream_eval [add_zero_class α] (s : StreamExec ι α) (f : ι → ι') (n : ℕ) :
  (f <$₁> s).stream.eval_steps n s.state = (f <$₁> s.stream).eval_steps n s.state := rfl

@[simp] lemma StreamExec.bifunctor_bimap_valid (s : StreamExec ι α) (f : ι → ι') (g : α → β) :
  (s.bimap f g).valid ↔ s.valid := iff.rfl

@[simp] lemma StreamExec.bifunctor_bimap_ready (s : StreamExec ι α) (f : ι → ι') (g : α → β) :
  (s.bimap f g).ready ↔ s.ready := iff.rfl

@[simp] lemma StreamExec.bimap_eval [add_comm_monoid α] (s : StreamExec ι α) (f : ι → ι') :
  (f <$₁> s).eval = s.eval.map_domain f :=
by simp [StreamExec.eval]

def contract_stream (s : StreamExec ι α) : StreamExec unit α :=
(λ _, ()) <$₁> s

@[simp] lemma contract_stream_spec_apply [add_comm_monoid α] (s : StreamExec ι α) :
  (contract_stream s).eval () = (finsupp.sum_range s.eval) :=
by simp [finsupp.sum_range, contract_stream]

@[simp] lemma contract_stream_spec [add_comm_monoid α] (s : StreamExec ι α) :
  (contract_stream s).eval = finsupp.single () (finsupp.sum_range s.eval) :=
by { ext, simp, }

def Stream.index' (s : Stream ι α) (x : s.σ) : with_top ι :=
if h : s.valid x then s.index x h else ⊤

def Stream.value' [has_zero α] (s : Stream ι α) (x : s.σ) : α :=
if h : s.ready x then s.value _ h else 0

def Stream.next' (s : Stream ι α) (x : s.σ) : s.σ :=
if h : s.valid x then s.next x h else x

@[simp] lemma Stream.index'_lt_top_iff [preorder ι] {s : Stream ι α} {x : s.σ} :
  s.index' x < ⊤ ↔ s.valid x :=
by { rw Stream.index', split_ifs; simp [h], exact with_top.coe_lt_top _, }

lemma Stream.eval₀_eq_single [has_zero α] (s : Stream ι α) (x : s.σ) (h : s.valid x) :
  s.eval₀ x h = finsupp.single (s.index _ h) (s.value' x) :=
by { rw [Stream.eval₀, Stream.value'], split_ifs with hr; simp, }

lemma Stream.index'_val {s : Stream ι α} {x : s.σ} (h : s.valid x) : s.index' x = s.index x h := dif_pos h

lemma Stream.index'_invalid {s : Stream ι α} {x : s.σ} (h : ¬s.valid x) : s.index' x = ⊤ := dif_neg h

lemma Stream.value'_val [has_zero α] {s : Stream ι α} {x : s.σ} (h : s.ready x) : s.value' x = s.value x h := dif_pos h

@[simp] lemma Stream.next'_val {s : Stream ι α} {x : s.σ} (hx) : s.next' x = s.next x hx := dif_pos hx

@[simp] lemma Stream.next'_val_invalid {s : Stream ι α} {x : s.σ} (hx : ¬s.valid x) : s.next' x = x := dif_neg hx

@[simp] lemma Stream.next'_val_invalid' {s : Stream ι α} {x : s.σ} (hx : ¬s.valid x) (n : ℕ) :
  s.next'^[n] x = x := function.iterate_fixed (Stream.next'_val_invalid hx) n

lemma bound_valid_iff_next'_iterate {s : Stream ι α} {x : s.σ} {n : ℕ} :
  s.bound_valid n x ↔ ¬s.valid (s.next'^[n] x) :=
by { induction n with n ih generalizing x, { simp, }, by_cases H : s.valid x; simp [ih, H, Stream.next'_val, Stream.next'_val_invalid, Stream.next'_val_invalid'], }

lemma Stream.next'_ge_bound {s : Stream ι α} {σ₀ : s.σ} {n b : ℕ} (hb : s.bound_valid b σ₀) (hn : b ≤ n) :
  (s.next'^[n] σ₀) = (s.next'^[b] σ₀) :=
begin
  obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_le hn,
  rw add_comm b k,
  rw bound_valid_iff_next'_iterate at hb,
  simp [function.iterate_add_apply, Stream.next'_val_invalid' hb],
end

lemma Stream.next'_min_bound {s : Stream ι α} {σ₀ : s.σ} {n b : ℕ} (hb : s.bound_valid b σ₀) :
  (s.next'^[min b n] σ₀) = (s.next'^[n] σ₀) :=
by { rw min_def, split_ifs, { rw Stream.next'_ge_bound hb h, }, refl, }

lemma Stream.bound_valid.next'_iff {s : Stream ι α} {x : s.σ} {B : ℕ} (hB : s.bound_valid B x) :
  ¬s.valid x ↔ s.next'.is_fixed_pt x :=
⟨Stream.next'_val_invalid, λ h₁, by simpa [bound_valid_iff_next'_iterate, function.iterate_fixed h₁] using hB⟩

lemma Stream.bound_valid.iterate_is_fixed_point {s : Stream ι α} {x : s.σ} {B : ℕ} (hB : s.bound_valid B x) :
  s.next'.is_fixed_pt (s.next'^[B] x) :=
by simpa [function.iterate_succ'] using Stream.next'_ge_bound hB B.le_succ

lemma Stream.bound_valid.fixed_pt_iff_periodic_pt {s : Stream ι α} {x : s.σ} {B : ℕ} (hB : s.bound_valid B x) :
  s.next'.is_fixed_pt x ↔ x ∈ s.next'.periodic_pts :=
⟨λ h, function.mk_mem_periodic_pts zero_lt_one h, λ h, begin
  have hB' := function.is_fixed_point_iff_minimal_period_eq_one.mpr hB.iterate_is_fixed_point,
  simpa [hB', function.is_fixed_point_iff_minimal_period_eq_one] using (function.minimal_period_apply_iterate h B).symm,
end⟩

lemma Stream.next'_valid {s : Stream ι α} {x : s.σ}
  (h : s.valid (s.next' x)) : s.valid x :=
by { contrapose h, rwa [Stream.next'_val_invalid h] }

lemma Stream.next'_valid' {s : Stream ι α} {x : s.σ} (n : ℕ)
  (h : s.valid (s.next'^[n] x)) : s.valid x :=
begin
  induction n with _ ih generalizing x,
  { simpa using h },
  { rw [function.iterate_succ_apply] at h,
    exact Stream.next'_valid (ih h) }
end

theorem Stream.bound_valid.no_repeat' {s : Stream ι α} {x : s.σ} {B : ℕ}
  (bv : s.bound_valid B x) (h : s.valid x) (n : ℕ) : s.next'^[n.succ] x ≠ x :=
λ h', bv.fixed_pt_iff_periodic_pt.not.mp (bv.next'_iff.not_right.mp h) ⟨n + 1, nat.zero_lt_succ _, h'⟩

theorem Stream.bound_valid.no_repeat {s : Stream ι α} {x : s.σ} {B : ℕ}
  (bv : s.bound_valid B x) (h : s.valid x) : s.next' x ≠ x := bv.no_repeat' h 0

lemma Stream.bimap_value' [has_zero α] [has_zero β] (s : Stream ι α) (f : ι → ι') (g : α → β) (hg : g 0 = 0) :
  (s.bimap f g).value' = g ∘ s.value' :=
by { ext x, simp [Stream.value', apply_dite g, hg], refl, }

lemma Stream.bimap_value'_apply [has_zero α] [has_zero β] (s : Stream ι α) (f : ι → ι') (g : α → β) (hg : g 0 = 0) (x) :
  (s.bimap f g).value' x = g (s.value' x) :=
by rwa Stream.bimap_value'

lemma Stream.bimap_index'_eq_apply (s : Stream ι α) (f : ι → ι') (g : α → β) (x : s.σ) :
  (s.bimap f g).index' x = with_top.map f (s.index' x) :=
by unfold Stream.index'; split_ifs; split; simp

lemma Stream.bimap_index'_eq (s : Stream ι α) (f : ι → ι') (g : α → β) :
  (s.bimap f g).index' = with_top.map f ∘ s.index' :=
by ext; rw function.comp_app; simp [Stream.bimap_index'_eq_apply]

end defs

open_locale big_operators

lemma Stream.eval_steps_add [add_comm_monoid α] (s : Stream ι α) (m n : ℕ) (q : s.σ) :
  s.eval_steps (m + n) q = s.eval_steps m q + s.eval_steps n (s.next'^[m] q) :=
begin
  induction m with m ih generalizing q, { simp, },
  by_cases H : s.valid q,
  { simp [nat.succ_add, ih, H, Stream.next'_val], abel, },
  { simp only [Stream.eval_invalid H, Stream.next'_val_invalid' H, add_zero], },
end

lemma Stream.spec_of_iterate [add_comm_monoid α] (s : Stream ι α)
  (B : ℕ) (σ₀ : s.σ) (h : ∀ i < B, s.valid (s.next'^[i] σ₀)) :
  s.eval_steps B σ₀ = ∑ i : fin B, finsupp.single (s.index (s.next'^[i] σ₀) (h i i.prop)) (s.value' (s.next'^[i] σ₀)) :=
begin
  induction B with B ih generalizing σ₀,
  { simp, },
  have hv : s.valid σ₀, { exact h 0 (nat.zero_lt_succ _), },
  specialize ih (s.next _ hv) (λ i hi, by simpa [Stream.next'_val hv] using h (i + 1) (nat.succ_lt_succ hi)),
  simp [hv, fin.sum_univ_succ, ih, Stream.eval₀_eq_single _ _ hv, Stream.next'_val hv],
  rw add_comm,
end

namespace primitives

@[simps]
def externSparseVec_stream {len : ℕ} (inds : vector ι len) (vals : vector α len) :
  Stream ι α :=
{ σ := ℕ,
  valid := λ i, i < len,
  ready := λ i, i < len,
  next := λ i hi, i + 1,
  index := λ i hi, inds.nth ⟨i, hi⟩,
  value := λ i hi, vals.nth ⟨i, hi⟩ }

@[simp] lemma externSparseVec_stream_value' [has_zero α] {len : ℕ} (inds : vector ι len) (vals : vector α len) (i : fin len) :
  (externSparseVec_stream inds vals).value' (i : ℕ) = vals.nth i :=
by { rw Stream.value'_val, swap, { exact i.prop, }, simp, }

@[simp] lemma externSparseVec_next'_iterate {len : ℕ} (inds : vector ι len) (vals : vector α len) (i : ℕ) :
  ((externSparseVec_stream inds vals).next'^[i] 0 : ℕ) = min len i :=
begin
  induction i with i ih, { simp [externSparseVec_stream], },
  rw [function.iterate_succ_apply', ih],
  simp [Stream.next', min_def, nat.succ_eq_add_one], clear ih,
  split_ifs; linarith,
end

@[simps]
def externSparseVec {len : ℕ} (inds : vector ι len) (vals : vector α len) :
  StreamExec ι α :=
{ stream := externSparseVec_stream inds vals,
  state := (0 : ℕ),
  bound := len,
  bound_valid := by simp [bound_valid_iff_next'_iterate] }

@[simp] lemma externSparseVec.spec [add_comm_monoid α] {len : ℕ} (inds : vector ι len) (vals : vector α len) :
  (externSparseVec inds vals).eval = ∑ i : fin len, finsupp.single (inds.nth i) (vals.nth i) :=
begin
  rw [StreamExec.eval, Stream.spec_of_iterate], swap, { dsimp, simp, },
  dsimp, apply fintype.sum_congr,
  intro i,
  congr; { simp [min_eq_right i.prop.le], },
end

@[simps]
def range (n : ℕ) : Stream ℕ ℕ :=
{ σ := ℕ,
  next  := λ k _, k+1,
  index := λ k _, k,
  value := λ k _, k,
  ready := λ _, true,
  valid := λ k, k < n, }

@[simp] lemma range_iterate {n : ℕ} (i : ℕ) :
  ((range n).next'^[i] 0 : ℕ) = min n i :=
begin
  induction i with i ih, { simp [range], },
  rw [function.iterate_succ_apply', ih],
  simp [Stream.next', min_def, nat.succ_eq_add_one], clear ih,
  split_ifs; linarith,
end

@[simps]
def range_exec (n : ℕ) : StreamExec ℕ ℕ :=
{ stream := range n,
  state := (0 : ℕ),
  bound := n,
  bound_valid := by simp [bound_valid_iff_next'_iterate] }

end primitives


namespace Cached

structure Cached {α : Type u} {β : Type v} (f : α → β) (x : α) :=
  val : β
  isFX : f x = val
  deriving Repr

instance : EmptyCollection (Cached f x) where emptyCollection := ⟨f x, rfl⟩
instance : Inhabited (Cached f x) where default := {}
instance : Subsingleton (Cached f x) where
  allEq := fun ⟨b, hb⟩ ⟨c, hc⟩ => by subst hb; subst hc; rfl
instance : DecidableEq (Cached f x) := fun _ _ => isTrue (Subsingleton.allEq ..)
instance [ToString β] : ToString (@Cached α β f x) where
  toString c := toString c.val

@[simp]
theorem eq_of_subsingleton [Subsingleton α] {a b : α} : (a = b) = True := by
  simp [Subsingleton.allEq a b]

abbrev Cached' (a : α) := Cached id a

end Cached


import Iris.BI
import Iris.Proofmode.Classes
import Iris.Proofmode.Environments
import Iris.Std

namespace Iris.Proofmode
open Iris.BI Iris.Std
open BI

/-- Introduce one or multiple let-bound variables. -/
scoped macro "intro_let " names:(colGt Lean.binderIdent)* : tactic => `(
  intro _ ;
  split ;
  rename_i $[$names]*
)

-- proof mode
theorem tac_start [BI PROP] (P : PROP) :
  envs_entails ⟨.nil, .nil⟩ P →
  ⊢ P
:= by
  simp only [envs_entails, of_envs, big_op]
  rw' [intuitionistically_True_emp, (left_id : emp ∗ _ ⊣⊢ _)]
  intro h
  exact h

theorem tac_stop [BI PROP] {Γₚ Γₛ : Env PROP} (P : PROP) :
  let Ps := match Γₚ, Γₛ with
    | .nil, .nil => `[iprop| emp]
    | _   , .nil => `[iprop| □ [∧] Γₚ]
    | .nil, _    => `[iprop| [∗] Γₛ]
    | _   , _    => `[iprop| □ [∧] Γₚ ∗ [∗] Γₛ]
  (Ps ⊢ P) →
  envs_entails ⟨Γₚ, Γₛ⟩ P
:= by
  cases Γₚ
  <;> cases Γₛ
  all_goals
    simp [envs_entails, of_envs, big_op]
    intro Ps
    rw' [Ps]
  case cons.nil =>
    rw' [(right_id : _ ∗ emp ⊣⊢ _)]
  all_goals
    rw' [intuitionistically_True_emp, (left_id : emp ∗ _ ⊣⊢ _)]

theorem tac_clear [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  envs_entails (Δ.delete true i) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  intro inst_affine_absorbing
  cases p
  all_goals
    cases inst_affine_absorbing
    simp only [envs_entails]
    intro h_entails
    rw' [envs_lookup_delete_sound true h_lookup, h_entails]
    simp only [bi_intuitionistically_if, ite_true, ite_false]
    rw' [sep_elim_r]

-- pure
theorem tac_pure_intro [BI PROP] {Δ : Envs PROP} {a : Bool} {φ : Prop} (Q : PROP) :
  [FromPure a Q φ] →
  [TCIte a (AffineEnv Δ.spatial) TCTrue] →
  φ →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro _ inst_affine_env hφ
  rw' [← from_pure]
  cases a
  case false =>
    apply pure_intro
    exact hφ
  case true =>
    cases inst_affine_env
    simp only [of_envs, bi_affinely_if]
    rw' [
      affine,
      pure_True hφ,
      affinely_True_emp,
      affinely_emp]

-- implication and wand
theorem tac_impl_intro [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  [TCIte Δ.spatial.isEmpty TCTrue (Persistent P)] →
  [FromAffinely P' P] →
  envs_entails (Δ.append false P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ inst_pers _ h_entails
  rw' [← from_impl]
  cases h_empty : Δ.spatial.isEmpty
  <;> rw [h_empty] at inst_pers
  <;> cases inst_pers
  case false =>
    apply impl_intro_l
    rw' [
      envs_append_sound false P',
      (from_affinely : <affine>?true P ⊢ _),
      persistent_and_affinely_sep_l_1,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty]
    apply impl_intro_l
    rw' [
      envs_append_sound false P',
      (from_affinely : <affine>?true P ⊢ _)]
    simp only [bi_intuitionistically]
    rw' [
      ← affinely_and_lr,
      persistently_and_intuitionistically_sep_r,
      intuitionistically_elim,
      wand_elim_r,
      h_entails]

theorem tac_impl_intro_intuitionistic [BI PROP] {Δ : Envs PROP} {P P' Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  [IntoPersistent false P P'] →
  envs_entails (Δ.append true P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ _ h_entails
  rw' [← from_impl, envs_append_sound true P'] ; simp only
  apply impl_intro_l
  rw' [
    persistently_if_intro_false P,
    into_persistent,
    persistently_and_intuitionistically_sep_l,
    wand_elim_r,
    h_entails]

theorem tac_impl_intro_drop [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  envs_entails Δ Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_impl]
  apply impl_intro_l
  rw' [and_elim_r, h_entails]

theorem tac_wand_intro [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromWand R P Q] →
  envs_entails (Δ.append false P) Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [
    ← from_wand,
    envs_append_sound false P,
    h_entails]

theorem tac_wand_intro_intuitionistic [BI PROP] {Δ : Envs PROP} {P P' Q : PROP} (R : PROP) :
  [FromWand R P Q] →
  [IntoPersistent false P P'] →
  [TCOr (Affine P) (Absorbing Q)] →
  envs_entails (Δ.append true P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ _ inst_affine_absorbing h_entails
  rw' [← from_wand, envs_append_sound true P'] ; simp only
  apply wand_intro_l
  cases inst_affine_absorbing
  case a.l =>
    rw' [
      ← affine_affinely P,
      persistently_if_intro_false P,
      into_persistent,
      wand_elim_r,
      h_entails]
  case a.r =>
    rw' [
      persistently_if_intro_false P,
      into_persistent,
      ← absorbingly_intuitionistically_into_persistently,
      absorbingly_sep_l,
      wand_elim_r,
      h_entails,
      absorbing]

-- specialize
theorem tac_specialize [BI PROP] {Δ : Envs PROP} (rpPremise rpWand : Bool) (i j : EnvsIndex.of Δ) (h_ne : i.type = j.type → i.val ≠ j.val) {P2 : PROP} (R : PROP) :
  let (p, P1) := Δ.lookup i
  let Δ' := Δ.delete rpPremise i
  let j' := Δ.updateIndexAfterDelete rpPremise i j h_ne
  let (q, Q) := Δ'.lookup j'
  [IntoWand q p Q P1 P2] →
  envs_entails (Δ'.replace rpWand j' (p && q) P2) R →
  envs_entails Δ R
:= by
  intro_let p P1 h_lookup_i
  intro Δ' j'
  intro_let q Q h_lookup_j'
  simp only [envs_entails]
  intro _ h_entails
  rw' [
    envs_lookup_delete_sound rpPremise h_lookup_i,
    envs_lookup_replace_sound rpWand (p && q) P2 h_lookup_j']
  cases p
  case false =>
    rw' [(IntoWand.into_wand : □?q Q ⊢ □?false P1 -∗ P2)]
    simp only [bi_intuitionistically_if, Bool.false_and, ite_false]
    rw' [(assoc : P1 ∗ _ ⊣⊢ _), !wand_elim_r, h_entails]
  case true =>
    simp only [Bool.true_and, ← intuitionistically_if_intro_true]
    rw' [
      ← intuitionistically_idemp,
      ← intuitionistically_if_idemp,
      intuitionistically_intuitionistically_if q,
      (IntoWand.into_wand : □?q Q ⊢ □?true P1 -∗ P2),
      (assoc : □?q □ P1 ∗ _ ⊣⊢ _),
      intuitionistically_if_sep_2,
      !wand_elim_r,
      h_entails]

theorem tac_specialize_forall [BI PROP] {Δ : Envs PROP} (rpWand : Bool) (i : EnvsIndex.of Δ) {Φ : α → PROP} (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoForall P Φ] →
  (∃ x, envs_entails (Δ.replace rpWand i p (Φ x)) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ ⟨x, h_entails⟩
  rw' [
    envs_lookup_replace_sound rpWand p (Φ x) h_lookup,
    IntoForall.into_forall,
    forall_elim x,
    wand_elim_r,
    h_entails]

-- forall
theorem tac_forall_intro [BI PROP] {Δ : Envs PROP} {Ψ : α → PROP} (Q : PROP) :
  [FromForall Q Ψ] →
  (∀ a, envs_entails Δ `[iprop| Ψ a]) →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_forall]
  apply forall_intro
  exact h_entails

-- exist
theorem tac_exist [BI PROP] {Δ : Envs PROP} {Φ : α → PROP} (P : PROP) :
  [FromExist P Φ] →
  (∃ a, envs_entails Δ `[iprop| Φ a]) →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ ⟨a, h_entails⟩
  rw' [← from_exist, ← exist_intro a, h_entails]

theorem tac_exist_destruct [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) {Φ : α → PROP} (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoExist P Φ] →
  (∀ a, envs_entails (Δ.replace true i p (Φ a)) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails, Envs.replace]
  intro _ h_entails
  rw' [
    envs_lookup_delete_sound true h_lookup,
    into_exist,
    intuitionistically_if_exist,
    sep_exist_r] ; simp only
  apply exist_elim
  intro a
  rw' [
    envs_append_sound p (Φ a),
    wand_elim_r,
    h_entails a]

-- emp
theorem tac_emp_intro [BI PROP] {Γₚ Γₛ : Env PROP} :
  [AffineEnv Γₛ] →
  envs_entails ⟨Γₚ, Γₛ⟩ `[iprop| emp]
:= by
  intro _
  simp only [envs_entails, of_envs]
  rw' [
    affinely_elim_emp,
    (affine : [∗] Γₛ.toList ⊢ emp),
    (left_id : emp ∗ _ ⊣⊢ _)]

-- assumptions
theorem tac_assumption_lean [BI PROP] {Δ : Envs PROP} {P : PROP} (Q : PROP) :
  (⊢ P) →
  [FromAssumption true P Q] →
  [TCIte Δ.spatial.isEmpty TCTrue (TCOr (Absorbing Q) (AffineEnv Δ.spatial))] →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro h_P _ inst_absorbing_affine_env
  rw' [
    ← (left_id : emp ∗ of_envs Δ ⊣⊢ _),
    ← intuitionistically_emp,
    h_P,
    (from_assumption : □?true P ⊢ Q)]
  cases h_empty : Δ.spatial.isEmpty
  <;> rw [h_empty] at inst_absorbing_affine_env
  <;> cases inst_absorbing_affine_env
  case false.e inst_absorbing_affine_env =>
    cases inst_absorbing_affine_env
    <;> rw' [!sep_elim_l]
  case true.t =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty, sep_elim_l]

theorem tac_assumption [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [FromAssumption p P Q] →
  let Δ' := Δ.delete true i
  [TCIte Δ'.spatial.isEmpty TCTrue (TCOr (Absorbing Q) (AffineEnv Δ'.spatial))] →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_absorbing_affine_env
  rw' [envs_lookup_delete_sound true h_lookup]
  cases h_empty : (Δ.delete true i).spatial.isEmpty
  <;> rw [h_empty] at inst_absorbing_affine_env
  <;> cases inst_absorbing_affine_env
  case false.e inst_absorbing_affine_env =>
    rw' [(from_assumption : □?p P ⊢ Q)]
    cases inst_absorbing_affine_env
    <;> rw' [!sep_elim_l]
  case true.t =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty, sep_elim_l]
    exact from_assumption

-- false
theorem tac_ex_falso [BI PROP] {Δ : Envs PROP} (Q : PROP) :
  envs_entails Δ `[iprop| False] →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro h_entails
  rw' [h_entails]
  exact False_elim

theorem tac_false_destruct [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (_, P) := Δ.lookup i
  P = `[iprop| False] →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro h_false
  rw' [
    envs_lookup_delete_sound true h_lookup,
    intuitionistically_if_elim,
    h_false,
    sep_elim_l]
  exact False_elim

-- moving between contexts
theorem tac_pure [BI PROP] {Δ : Envs PROP} {φ : Prop} (i : EnvsIndex.of Δ) (Q : PROP) :
   let (p, P) := Δ.lookup i
  [IntoPure P φ] →
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  (φ → envs_entails (Δ.delete true i) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_affine_absorbing h_entails
  rw' [envs_lookup_delete_sound true h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  <;> cases inst_affine_absorbing
  case false.e inst_affine_absorbing =>
    cases inst_affine_absorbing
    case l =>
      rw' [
        ← affine_affinely P,
        into_pure,
        ← persistent_and_affinely_sep_l]
      apply pure_elim φ
      · exact and_elim_l
      · intro h_φ
        rw' [h_entails h_φ, and_elim_r]
    case r =>
      rw' [
        into_pure,
        persistent_absorbingly_affinely_2,
        absorbingly_sep_lr,
        ← persistent_and_affinely_sep_l]
      apply pure_elim_l
      intro h_φ
      rw' [h_entails h_φ, absorbing]
  case true.t =>
    rw' [
      into_pure,
      ← persistently_and_intuitionistically_sep_l,
      persistently_pure]
    apply pure_elim_l
    intro h_φ
    rw' [h_entails h_φ]

theorem tac_intuitionistic [BI PROP] {Δ : Envs PROP} {P' : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoPersistent p P P'] →
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  envs_entails (Δ.replace true i true P') Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_affine_absorbing h_entails
  rw' [envs_lookup_replace_sound true true P' h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false, bi_intuitionistically]
  <;> cases inst_affine_absorbing
  case false inst_affine_absorbing =>
    cases inst_affine_absorbing
    case l =>
      rw' [
        ← affine_affinely P,
        persistently_if_intro_false P,
        into_persistent,
        wand_elim_r,
        h_entails]
    case r =>
      rw' [persistently_if_intro_false P, into_persistent]
      conv =>
        lhs
        lhs
        rw [← absorbingly_intuitionistically_into_persistently]
      rw' [
        absorbingly_sep_l,
        wand_elim_r,
        h_entails,
        absorbing]
  case true =>
    rw' [
      persistently_if_intro_true P,
      into_persistent,
      wand_elim_r,
      h_entails]

theorem tac_spatial [BI PROP] {Δ : Envs PROP} {P' : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [FromAffinely P' P p] →
  envs_entails (Δ.replace true i false P') Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails
  rw' [envs_lookup_replace_sound true false P' h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  case false =>
    rw' [
      affinely_if_intro_false P,
      from_affinely,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [
      intuitionistically_affinely,
      affinely_if_intro_true P,
      from_affinely,
      wand_elim_r,
      h_entails]

-- (separating) conjunction splitting
theorem tac_and_split [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromAnd P Q1 Q2] →
  envs_entails Δ Q1 →
  envs_entails Δ Q2 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [← from_and]
  apply and_intro
  · exact h_entails_1
  · exact h_entails_2

theorem tac_sep_split [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (mask : List Bool) (h : mask.length = Δ.spatial.length) (P : PROP) :
  let (Δ₁, Δ₂) := Δ.split mask h
  [FromSep P Q1 Q2] →
  envs_entails Δ₁ Q1 →
  envs_entails Δ₂ Q2 →
  envs_entails Δ P
:= by
  intro_let Δ₁ Δ₂ h_split
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [
    envs_split_sound h_split,
    ← from_sep,
    h_entails_1,
    h_entails_2]

-- disjunction selection
theorem tac_disjunction_l [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromOr P Q1 Q2] →
  envs_entails Δ Q1 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_or]
  apply or_intro_l'
  exact h_entails

theorem tac_disjunction_r [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromOr P Q1 Q2] →
  envs_entails Δ Q2 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_or]
  apply or_intro_r'
  exact h_entails

-- destruction
class inductive IntoConjunction [BI PROP] (P : PROP) (P1 P2 : outParam PROP) : Bool → Type
  | and : [IntoAnd true P P1 P2] → IntoConjunction P P1 P2 true
  | sep : [IntoSep P P1 P2] → IntoConjunction P P1 P2 false

attribute [instance] IntoConjunction.and
attribute [instance] IntoConjunction.sep

theorem tac_conjunction_destruct [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoConjunction P P1 P2 p] →
  envs_entails (Δ |>.delete true i |>.append p P1 |>.append p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro inst_conjunction h_entails
  rw' [
    envs_lookup_delete_sound true h_lookup,
    envs_append_sound p P1,
    envs_append_sound p P2] ; simp only
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  <;> cases inst_conjunction
  case false.sep =>
    rw' [
      into_sep,
      (comm : P1 ∗ P2 ⊣⊢ _),
      ← (assoc : _ ⊣⊢ (P2 ∗ P1) ∗ _),
      wand_elim_r,
      wand_elim_r,
      h_entails]
  case true.and =>
    rw' [intuitionistically_if_intro_true P, into_and]
    simp only [bi_intuitionistically_if, ite_true]
    rw' [
      intuitionistically_and,
      and_sep_intuitionistically,
      (comm : □ P1 ∗ □ P2 ⊣⊢ _),
      ← (assoc : _ ⊣⊢ (□ P2 ∗ □ P1) ∗ _),
      wand_elim_r,
      wand_elim_r,
      h_entails]

theorem tac_conjunction_destruct_choice [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (d : Bool) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoAnd p P P1 P2] →
  envs_entails (if d then Δ.replace true i p P1 else Δ.replace true i p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails
  cases d
  case false =>
    rw' [
      envs_lookup_replace_sound true p P2 h_lookup,
      into_and,
      and_elim_r,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [
      envs_lookup_replace_sound true p P1 h_lookup,
      into_and,
      and_elim_l,
      wand_elim_r,
      h_entails]

theorem tac_disjunction_destruct [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoOr P P1 P2] →
  envs_entails (Δ.replace true i p P1) Q →
  envs_entails (Δ.replace true i p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [envs_lookup_delete_sound true h_lookup] ; simp only
  simp only [Envs.replace] at h_entails_1
  simp only [Envs.replace] at h_entails_2
  rw' [into_or, intuitionistically_if_or, sep_or_r]
  apply or_elim
  · rw' [envs_append_sound p P1, wand_elim_r, h_entails_1]
  · rw' [envs_append_sound p P2, wand_elim_r, h_entails_2]

end Iris.Proofmode


/- Tactic combinators -/

example : p → q → r → p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) := by
  intros
  repeat (any_goals constructor)
  all_goals assumption

example : p → q → r → p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) := by
  intros
  repeat (any_goals (first | assumption | constructor))


example {a : α} {as bs : List α} (h : bs = a::as) : as.length + 1 = bs.length := by
  rw [← List.length]
  trace_state -- lhs was folded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : (a::b::as).length = bs.length + 2 := by
  rw [List.length, List.length]
  trace_state -- lhs was unfolded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : (a::b::as).length = (b::bs).length + 1 := by
  conv => lhs; rw [List.length, List.length]
  trace_state -- lhs was unfolded
  conv => rhs; rw [List.length]
  trace_state -- rhs was unfolded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : id (id ((a::b::as).length)) = (b::bs).length + 1 := by
  rw [id]
  trace_state
  rw [id]
  trace_state
  rw [List.length, List.length, List.length]
  trace_state
  rw [h]


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import data.buffer data.dlist

inductive parse_result (α : Type)
| done (pos : ℕ) (result : α) : parse_result
| fail (pos : ℕ) (expected : dlist string) : parse_result

/-- The parser monad. If you are familiar with the Parsec library in Haskell, you will understand this.  -/
def parser (α : Type) :=
∀ (input : char_buffer) (start : ℕ), parse_result α

namespace parser
variables {α β γ : Type}

protected def bind (p : parser α) (f : α → parser β) : parser β :=
λ input pos, match p input pos with
| parse_result.done pos a           := f a input pos
| parse_result.fail pos expected := parse_result.fail pos expected
end

protected def pure (a : α) : parser α :=
λ input pos, parse_result.done pos a

private lemma parser.id_map (p : parser α) : parser.bind p parser.pure = p :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); exact rfl
end

private lemma parser.bind_assoc (p : parser α) (q : α → parser β) (r : β → parser γ) :
  parser.bind (parser.bind p q) r = parser.bind p (λ a, parser.bind (q a) r) :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); try {dunfold bind},
cases (q result input pos_1); try {dunfold bind},
all_goals {refl}
end

protected def fail (msg : string) : parser α :=
λ _ pos, parse_result.fail pos (dlist.singleton msg)

instance : monad parser :=
{ pure := @parser.pure, bind := @parser.bind }

instance : is_lawful_monad parser :=
{ id_map := @parser.id_map,
  pure_bind := λ _ _ _ _, rfl,
  bind_assoc := @parser.bind_assoc }

instance : monad_fail parser :=
{ fail := @parser.fail, ..parser.monad }

protected def failure : parser α :=
λ _ pos, parse_result.fail pos dlist.empty

protected def orelse (p q : parser α) : parser α :=
λ input pos, match p input pos with
| parse_result.fail pos₁ expected₁ :=
  if pos₁ ≠ pos then parse_result.fail pos₁ expected₁ else
  match q input pos with
  | parse_result.fail pos₂ expected₂ :=
    if pos₁ < pos₂ then
      parse_result.fail pos₁ expected₁
    else if pos₂ < pos₁ then
      parse_result.fail pos₂ expected₂
    else -- pos₁ = pos₂
      parse_result.fail pos₁ (expected₁ ++ expected₂)
  | ok := ok
  end
  | ok := ok
end

instance : alternative parser :=
{ failure := @parser.failure,
  orelse := @parser.orelse }

instance : inhabited (parser α) :=
⟨parser.failure⟩

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_errors (msgs : thunk (list string)) (p : parser α) : parser α :=
λ input pos, match p input pos with
| parse_result.fail _ expected :=
  parse_result.fail pos (dlist.lazy_of_list (msgs ()))
| ok := ok
end

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_error (msg : thunk string) (p : parser α) : parser α :=
decorate_errors [msg ()] p

/-- Matches a single character. Fails only if there is no more input. -/
def any_char : parser char :=
λ input pos,
if h : pos < input.size
  then
    let c := input.read ⟨pos, h⟩ in
    parse_result.done (pos+1) c
  else
    parse_result.fail pos dlist.empty

/-- Matches a single character satisfying the given predicate. -/
def sat (p : char → Prop) [decidable_pred p] : parser char :=
λ input pos,
if h : pos < input.size
  then
    let c := input.read ⟨pos, h⟩ in
    if p c then
      parse_result.done (pos+1) c
    else
      parse_result.fail pos dlist.empty
  else
    parse_result.fail pos dlist.empty

/-- Matches the empty word. -/
def eps : parser unit := return ()

/-- Matches the given character. -/
def ch (c : char) : parser unit :=
decorate_error c.to_string $ sat (= c) >> eps

/-- Matches a whole char_buffer.  Does not consume input in case of failure. -/
def char_buf (s : char_buffer) : parser unit :=
decorate_error s.to_string $ s.to_list.mmap' ch

/-- Matches one out of a list of characters. -/
def one_of (cs : list char) : parser char :=
decorate_errors (do c ← cs, return c.to_string) $
sat (∈ cs)

def one_of' (cs : list char) : parser unit :=
one_of cs >> eps

/-- Matches a string.  Does not consume input in case of failure. -/
def str (s : string) : parser unit :=
decorate_error s $ s.to_list.mmap' ch

/-- Number of remaining input characters. -/
def remaining : parser ℕ :=
λ input pos, parse_result.done pos (input.size - pos)

/-- Matches the end of the input. -/
def eof : parser unit :=
decorate_error "<end-of-file>" $
do rem ← remaining, guard $ rem = 0

def foldr_core (f : α → β → β) (p : parser α) (b : β) : ∀ (reps : ℕ), parser β
| 0 := failure
| (reps+1) := (do x ← p, xs ← foldr_core reps, return (f x xs)) <|> return b

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldr (f : α → β → β) (p : parser α) (b : β) : parser β :=
λ input pos, foldr_core f p b (input.size - pos + 1) input pos

def foldl_core (f : α → β → α) : ∀ (a : α) (p : parser β) (reps : ℕ), parser α
| a p 0 := failure
| a p (reps+1) := (do x ← p, foldl_core (f a x) p reps) <|> return a

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldl (f : α → β → α) (a : α) (p : parser β) : parser α :=
λ input pos, foldl_core f a p (input.size - pos + 1) input pos

/-- Matches zero or more occurrences of `p`. -/
def many (p : parser α) : parser (list α) :=
foldr list.cons p []

def many_char (p : parser char) : parser string :=
list.as_string <$> many p

/-- Matches zero or more occurrences of `p`. -/
def many' (p : parser α) : parser unit :=
many p >> eps

/-- Matches one or more occurrences of `p`. -/
def many1 (p : parser α) : parser (list α) :=
list.cons <$> p <*> many p

/-- Matches one or more occurences of the char parser `p` and implodes them into a string. -/
def many_char1 (p : parser char) : parser string :=
list.as_string <$> many1 p

/-- Matches one or more occurrences of `p`, separated by `sep`. -/
def sep_by1 (sep : parser unit) (p : parser α) : parser (list α) :=
list.cons <$> p <*> many (sep >> p)

/-- Matches zero or more occurrences of `p`, separated by `sep`. -/
def sep_by (sep : parser unit) (p : parser α) : parser (list α) :=
sep_by1 sep p <|> return []

def fix_core (F : parser α → parser α) : ∀ (max_depth : ℕ), parser α
| 0             := failure
| (max_depth+1) := F (fix_core max_depth)

/-- Matches a digit (0-9). -/
def digit : parser nat := decorate_error "<digit>" $ do
  c ← sat (λ c, '0' ≤ c ∧ c ≤ '9'),
  pure $ c.to_nat - '0'.to_nat

/-- Matches a natural number. Large numbers may cause performance issues, so
don't run this parser on untrusted input. -/
def nat : parser nat := decorate_error "<natural>" $ do
  digits ← many1 digit,
  pure $ prod.fst $ digits.foldr
    (λ digit ⟨sum, magnitude⟩, ⟨sum + digit * magnitude, magnitude * 10⟩)
    ⟨0, 1⟩

/-- Fixpoint combinator satisfying `fix F = F (fix F)`. -/
def fix (F : parser α → parser α) : parser α :=
λ input pos, fix_core F (input.size - pos + 1) input pos

private def make_monospaced : char → char
| '\n' := ' '
| '\t' := ' '
| '\x0d' := ' '
| c := c

def mk_error_msg (input : char_buffer) (pos : ℕ) (expected : dlist string) : char_buffer :=
let left_ctx := (input.take pos).take_right 10,
    right_ctx := (input.drop pos).take 10 in
left_ctx.map make_monospaced ++ right_ctx.map make_monospaced ++ "\n".to_char_buffer ++
left_ctx.map (λ _, ' ') ++ "^\n".to_char_buffer ++
"\n".to_char_buffer ++
"expected: ".to_char_buffer
  ++ string.to_char_buffer (" | ".intercalate expected.to_list)
  ++ "\n".to_char_buffer

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run (p : parser α) (input : char_buffer) : sum string α :=
match (p <* eof) input 0 with
| parse_result.done pos res := sum.inr res
| parse_result.fail pos expected :=
  sum.inl $ buffer.to_string $ mk_error_msg input pos expected
end

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run_string (p : parser α) (input : string) : sum string α :=
run p input.to_char_buffer

end parser


import category_theory.shift
import for_mathlib.category_theory.quotient_misc
import for_mathlib.category_theory.functor.shift

import for_mathlib.category_theory.functor.shift_compatibility

noncomputable theory

namespace category_theory

open category

variables {C A : Type*} [category C] (r : hom_rel C)

lemma quotient.functor_map_eq {X Y : C} (f : X ⟶ Y) :
  (quotient.functor r).map f = quot.mk _ f := rfl

variables [add_monoid A] [has_shift C A]
  (h : ∀ (a : A) ⦃X Y : C⦄ (f₁ f₂ : X ⟶ Y), r f₁ f₂ → r (f₁⟦a⟧') (f₂⟦a⟧'))

variable {r}

namespace quotient

@[protected]
def shift_functor (a : A) : quotient r ⥤ quotient r :=
lift r (shift_functor C a ⋙ functor r) (λ X Y f₁ f₂ rel, quotient.sound r (h a f₁ f₂ rel))

def comm_shift (a : A) :
  shift_functor C a ⋙ functor r ≅ functor r ⋙ quotient.shift_functor h a :=
(quotient.lift.is_lift _ _ _).symm

@[simp]
lemma comm_shift_hom_app (a : A) (X : C) :
  (comm_shift h a).hom.app X = 𝟙 _ := rfl

@[simp]
lemma comm_shift_inv_app (a : A) (X : C) :
  (comm_shift h a).inv.app X = 𝟙 _ := rfl

def shift_ε : 𝟭 _ ≅ quotient.shift_functor h 0 :=
quotient.lift_nat_iso _ _ (functor.right_unitor _ ≪≫ (functor.left_unitor _).symm ≪≫
      iso_whisker_right (shift_functor_zero C A).symm _ ≪≫ comm_shift h 0)

@[simp]
lemma shift_ε_hom_app (X : C) :
  (shift_ε h).hom.app ((functor r).obj X) =
    (functor r).map ((shift_functor_zero C A).inv.app X) :=
begin
  dsimp [shift_ε],
  simp only [id_comp, comp_id],
end

def shift_μ (a b : A) :
  quotient.shift_functor h a ⋙ quotient.shift_functor h b ≅
  quotient.shift_functor h (a + b) :=
quotient.lift_nat_iso _ _ ((functor.associator _ _ _).symm ≪≫
  iso_whisker_right (comm_shift h a).symm _ ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left _ (comm_shift h b).symm ≪≫ (functor.associator _ _ _).symm ≪≫
  iso_whisker_right (shift_functor_add C a b).symm _ ≪≫ comm_shift h (a + b))

@[simp]
lemma shift_μ_hom_app (a b : A) (X : C) :
  (shift_μ h a b).hom.app ((functor r).obj X) =
    (functor r).map ((shift_functor_add C a b).inv.app X) :=
begin
  dsimp [shift_μ],
  simpa only [functor.map_id, comp_id, id_comp],
end

local attribute [instance, reducible] endofunctor_monoidal_category
local attribute [reducible] discrete.add_monoidal

lemma associativity_compatibility (a b c : A) (X : C) :
  (shift_functor C c).map ((shift_functor_add C a b).inv.app X) ≫
    (shift_functor_add C (a + b) c).inv.app X =
  (shift_functor_add C b c).inv.app ((shift_functor C a).obj X) ≫
  (shift_functor_add C a (b + c)).inv.app X ≫ eq_to_hom (by rw add_assoc):=
begin
  dsimp,
  have eq := (congr_arg iso.hom (monoidal_functor.associativity_iso_eq
    (shift_monoidal_functor C A) (discrete.mk a) (discrete.mk b) (discrete.mk c))),
  replace eq := congr_app eq X,
  dsimp at eq,
  simp only [id_comp, functor.map_id, comp_id] at eq,
  erw ← reassoc_of eq, clear eq,
  simp only [eq_to_hom_map, eq_to_hom_app, eq_to_hom_trans, eq_to_hom_refl, comp_id],
end

lemma shift_associativity (a b c : A) :
  (shift_μ h a b).hom ◫ 𝟙 (quotient.shift_functor h c) ≫
    (shift_μ h (a + b) c).hom ≫ eq_to_hom (by rw add_assoc) =
  (functor.associator _ _ _).hom ≫ 𝟙 (quotient.shift_functor h a) ◫ (shift_μ h b c).hom ≫
    (shift_μ h a (b + c)).hom :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp only [functor.associator, nat_trans.comp_app, nat_trans.hcomp_app,
    nat_trans.id_app, quotient.shift_functor],
  erw [id_comp, id_comp, shift_μ_hom_app, shift_μ_hom_app, shift_μ_hom_app,
    shift_μ_hom_app, assoc, functor.map_id, id_comp, lift_map_functor_map],
  dsimp only ,
  simp only [functor.comp_map, ← functor.map_comp, ← functor.map_comp_assoc,
    associativity_compatibility],
  simpa only [assoc, functor.map_comp, eq_to_hom_app, eq_to_hom_map, eq_to_hom_trans,
    eq_to_hom_refl, comp_id],
end)

lemma shift_left_unitality (a : A) :
  (shift_ε h).hom ◫ 𝟙 (quotient.shift_functor h a) ≫ (shift_μ h 0 a).hom =
    eq_to_hom (congr_arg (quotient.shift_functor h) (zero_add a).symm) :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp [shift_ε, shift_μ, comm_shift],
  simp only [comp_id, id_comp, eq_to_hom_app],
  erw [functor.map_id, id_comp, id_comp],
  dsimp [quotient.shift_functor, lift_map],
  erw [← functor_map_eq, ← functor_map_eq, ← functor.map_comp],
  transitivity (functor r).map (eq_to_hom _), swap,
  { rw zero_add, },
  { congr' 1,
    simp only [obj_ε_app, eq_to_iso.inv, assoc, μ_inv_hom_app],
    erw [comp_id, eq_to_hom_map, eq_to_hom_app], },
  { apply eq_to_hom_map, },
end)

lemma shift_right_unitality (a : A) :
  𝟙 (quotient.shift_functor h a) ◫ (shift_ε h).hom ≫ (shift_μ h a 0).hom =
    eq_to_hom (congr_arg (quotient.shift_functor h) (add_zero a).symm) :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp only [shift_ε, shift_μ, iso.trans, nat_trans.hcomp, nat_trans.comp_app,
    quotient.shift_functor, comm_shift, lift.is_lift],
  simp only [iso.symm_inv, assoc, iso.symm_hom, iso_whisker_right_hom, lift_nat_iso_hom,
    nat_trans.id_app, lift_nat_trans_app, nat_trans.comp_app, whisker_right_app, functor.map_id,
    nat_iso.of_components_hom_app, iso.refl_hom, nat_iso.of_components_inv_app, iso.refl_inv],
  dsimp,
  simp only [id_comp, comp_id, eq_to_hom_app],
  erw [← functor_map_eq, ← functor_map_eq, ← functor.map_comp],
  transitivity (functor r).map (eq_to_hom _), swap,
  { rw add_zero, },
  { congr' 1,
    simp only [ε_app_obj, eq_to_iso.inv, assoc, μ_inv_hom_app, comp_id,
      eq_to_hom_map, eq_to_hom_app], },
  { apply eq_to_hom_map, },
end)

@[protected]
def shift : has_shift (quotient r) A :=
has_shift_mk _ _
{ F := quotient.shift_functor h,
  ε := shift_ε h,
  μ := shift_μ h,
  associativity := λ a b c X, by simpa using congr_app (shift_associativity h a b c) X,
  left_unitality := λ a X, by simpa using congr_app (shift_left_unitality h a) X,
  right_unitality := λ a X, by simpa using congr_app (shift_right_unitality h a) X, }

def functor_comm_shift :
  @functor.has_comm_shift _ _ _ _ (functor r) A _ _
    (quotient.shift h) :=
{ iso := quotient.comm_shift h,
  iso_add := λ a b, begin
    ext K,
    dsimp,
    simp only [functor.comm_shift.add_hom_app, comm_shift_hom_app, id_comp],
    erw [functor.map_id, id_comp, id_comp],
    change _ ≫ (shift_μ h a b).hom.app ((functor r).obj K) = _,
    erw [shift_μ_hom_app, ← functor.map_comp, iso.inv_hom_id_app, functor.map_id],
  end,
  iso_zero := begin
    ext K,
    simp only [nat_trans.comp_app, lift.is_lift_hom, nat_trans.id_app],
    dsimp only [functor.comm_shift.unit, shift.compatibility.comm_shift.unit,
      iso.trans, iso.symm, nat_trans.comp_app, iso_whisker_right, whiskering_right,
      functor.map_iso, whisker_right, iso_whisker_left, functor.left_unitor,
      functor.right_unitor, whiskering_left, whisker_left],
    erw [id_comp, id_comp, id_comp, shift_ε_hom_app, ← functor.map_comp,
      iso.inv_hom_id_app, functor.map_id],
    refl,
  end, }

section

variables
  {D : Type*} [category D]
  {F : C ⥤ D} {F' : quotient r ⥤ D} (e : functor r ⋙ F' ≅ F)
  {B : Type*} [add_monoid B] [has_shift C B] [has_shift D B]
  [has_shift (quotient r) B] [(functor r).has_comm_shift B]
  [F.has_comm_shift B]

def comm_shift_iso_of_fac (a : B) :
  shift_functor (quotient r) a ⋙ F' ≅ F' ⋙ shift_functor D a :=
lift_nat_iso _ _ ((functor.associator _ _ _).symm ≪≫
    iso_whisker_right ((functor r).comm_shift_iso a).symm F' ≪≫
    functor.associator _ _ _ ≪≫ iso_whisker_left _ e ≪≫
    F.comm_shift_iso a ≪≫ iso_whisker_right e.symm _ ≪≫ functor.associator _ _ _)

@[simp]
lemma comm_shift_iso_of_fac_hom_app (a : B) (X : C) :
  (comm_shift_iso_of_fac e a).hom.app ((functor r).obj X) =
    F'.map (((functor r).comm_shift_iso a).inv.app X) ≫
    e.hom.app ((shift_functor C a).obj X) ≫
    (F.comm_shift_iso a).hom.app X ≫
    (shift_functor D a).map (e.inv.app X) :=
begin
  dsimp only [comm_shift_iso_of_fac],
  simp only [lift_nat_iso_hom, iso.trans_hom, iso.symm_hom, iso_whisker_right_hom,
    iso_whisker_left_hom, lift_nat_trans_app, nat_trans.comp_app,
    functor.associator_inv_app, whisker_right_app, functor.associator_hom_app,
    whisker_left_app, comp_id, id_comp],
end

@[simp]
lemma comm_shift_iso_of_fac_inv_app (a : B) (X : C) :
  (comm_shift_iso_of_fac e a).inv.app ((functor r).obj X) =
    (shift_functor D a).map (e.hom.app X) ≫
    (F.comm_shift_iso a).inv.app X ≫
    e.inv.app ((shift_functor C a).obj X) ≫
    F'.map (((functor r).comm_shift_iso a).hom.app X) :=
begin
  dsimp only [comm_shift_iso_of_fac],
  simp only [lift_nat_iso_inv, iso.trans_inv, iso_whisker_right_inv, iso.symm_inv, assoc,
    iso_whisker_left_inv, lift_nat_trans_app, nat_trans.comp_app,
    functor.associator_inv_app, whisker_right_app, whisker_left_app,
    functor.associator_hom_app, comp_id, id_comp],
end

variable (B)

def has_comm_shift : F'.has_comm_shift B :=
{ iso := λ a, comm_shift_iso_of_fac e a,
  iso_zero := begin
    ext1,
    refine nat_trans_ext _ _ (λ X, _),
    simp only [comm_shift_iso_of_fac_hom_app, functor.comm_shift.unit_hom_app,
      functor.comm_shift_iso_zero, functor.comm_shift.unit_inv_app,
      F'.map_comp, assoc, ← e.hom.naturality_assoc, functor.comp_map],
    nth_rewrite 1 ← functor.map_comp_assoc,
    erw [← functor.map_comp, iso.inv_hom_id_app, (functor r).map_id, F'.map_id, id_comp,
      ← nat_trans.naturality],
    dsimp only [functor.id],
    rw e.hom_inv_id_app_assoc,
  end,
  iso_add := λ a b, begin
    ext1,
    refine nat_trans_ext _ _ (λ X, _),
    simp only [functor.comm_shift.add_hom_app, assoc, functor.comm_shift_iso_add,
      comm_shift_iso_of_fac_hom_app, functor.map_comp, functor.comm_shift.add_inv_app],
    erw [← nat_trans.naturality_assoc, ← nat_trans.naturality_assoc,
      comm_shift_iso_of_fac_hom_app, assoc, assoc, assoc],
    dsimp only [functor.comp_map],
    nth_rewrite 3 ← functor.map_comp_assoc,
    erw [← functor.map_comp, iso.inv_hom_id_app, (functor r).map_id, F'.map_id, id_comp],
    nth_rewrite 4 ← functor.map_comp_assoc,
    erw [e.inv_hom_id_app, functor.map_id, id_comp, (shift_functor_add D a b).inv.naturality],
    refl,
  end, }

instance lift_has_comm_shift
 (hF : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂) :
  (lift r F hF).has_comm_shift B :=
has_comm_shift (lift.is_lift r F hF) B

end

end quotient

end category_theory


import .arrow
import .cofibration_category
import tactic.slice

/- Brown factorization, aka "Ken Brown's lemma", and a relative version.
   Following Rădulescu-Banu, Cofibrations in Homotopy Theory, section 1.3. -/

universes v u

namespace homotopy_theory.cofibrations
open category_theory
open category_theory.category
open precofibration_category
open cofibration_category
open homotopy_theory.weak_equivalences

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

structure brown_factorization {a b : C} (f : a ⟶ b) : Type (max u v) :=
-- ab represents a coproduct of a and b, used to formulate the condition on f' + s
(ab : pushout (! a) (! b))
(b' : C)
(f' : a ⟶ b') (r : b' ⟶ b) (s : b ⟶ b')
(hf' : is_cof f')
(hf's : is_cof (ab.is_pushout.induced f' s (initial.uniqueness _ _)))
(hs : is_acof s)
(hf'r : f' ≫ r = f)
(hsr : s ≫ r = 𝟙 b)

lemma brown_factorization.hr {a b : C} {f : a ⟶ b} (c : brown_factorization f) :
  is_weq c.r :=
begin
  convert category_with_weak_equivalences.weq_of_comp_weq_left c.hs.2 _,
  rw c.hsr,
  apply weq_id
end

lemma brown_factorization.weq_f' {a b : C} {f : a ⟶ b} (c : brown_factorization f) (hf : is_weq f) :
  is_weq c.f' :=
begin
  convert category_with_weak_equivalences.weq_of_comp_weq_right c.hr _,
  rw c.hf'r,
  exact hf
end

--- Any map between cofibrant objects admits a Brown factorization (R-B, Lemma 1.3.1).
lemma exists_brown_factorization {a b : C} (ha : cofibrant a) (hb : cofibrant b) (f : a ⟶ b) :
  nonempty (brown_factorization f) :=
let ab := pushout_by_cof (! a) (! b) ha,
    ⟨b', j, g, hj, hg, hf⟩ :=
      factorization (ab.is_pushout.induced f (𝟙 b) (initial.uniqueness _ _)) in
⟨⟨ab, b', ab.map₀ ≫ j, g, ab.map₁ ≫ j,
  cof_comp (pushout_is_cof ab.is_pushout.transpose hb) hj,
  by convert hj; apply ab.is_pushout.uniqueness; simp,
  begin
    split,
    { refine cof_comp (pushout_is_cof ab.is_pushout ha) hj },
    { convert category_with_weak_equivalences.weq_of_comp_weq_right hg _,
      rw [assoc, hf], simpa using weq_id _ }
  end,
  by rw [assoc, hf]; simp,
  by rw [assoc, hf]; simp⟩⟩

--- R-B, Lemma 1.3.3
lemma relative_factorization {a₁ a₁' b₁ a₂ b₂ : C}
  (ha₁ : cofibrant a₁) (ha₂ : cofibrant a₂)
  (f₁' : a₁ ⟶ a₁') (r₁ : a₁' ⟶ b₁) (hf₁' : is_cof f₁') (hr : is_weq r₁)
  (f₂ : a₂ ⟶ b₂) (a : a₁ ⟶ a₂) (b : b₁ ⟶ b₂) (s : (f₁' ≫ r₁) ≫ b = a ≫ f₂) :
  ∃ a₂' (a' : a₁' ⟶ a₂') (f₂' : a₂ ⟶ a₂') (r₂ : a₂' ⟶ b₂)
  (hf' : f₁' ≫ a' = a ≫ f₂'), r₁ ≫ b = a' ≫ r₂ ∧ f₂' ≫ r₂ = f₂ ∧ is_cof f₂' ∧ is_weq r₂ ∧
  is_cof ((pushout_by_cof f₁' a hf₁').is_pushout.induced a' f₂' hf') :=
let po := pushout_by_cof f₁' a hf₁',
    g := po.is_pushout.induced (r₁ ≫ b) f₂ (by rw [←s, assoc]),
    ⟨a₂', s, r₂, hs, hr₂, hg⟩ := factorization g in
⟨a₂', po.map₀ ≫ s, po.map₁ ≫ s, r₂,
 by rw [←assoc, ←assoc, po.is_pushout.commutes],
 by rw [assoc, hg]; simp,
 by simp [hg],
 cof_comp (pushout_is_cof po.is_pushout hf₁') hs,
 hr₂,
 by convert hs; apply po.is_pushout.uniqueness; simp⟩

/-- R-B, Lemma 1.3.4. The statement there is missing hypotheses on the maps a and b,
  needed for the last two conclusions. -/
lemma exists_relative_brown_factorization {a₁ b₁ a₂ b₂ : C}
  (ha₁ : cofibrant a₁) (hb₁ : cofibrant b₁) (ha₂ : cofibrant a₂) (hb₂ : cofibrant b₂)
  (f₁ : a₁ ⟶ b₁) (f₂ : a₂ ⟶ b₂) (a : a₁ ⟶ a₂) (b : b₁ ⟶ b₂) (S : f₁ ≫ b = a ≫ f₂)
  (c₁ : brown_factorization f₁) : ∃ (c₂ : brown_factorization f₂) (b' : c₁.b' ⟶ c₂.b')
  (hf' : c₁.f' ≫ b' = a ≫ c₂.f') (hr : c₁.r ≫ b = b' ≫ c₂.r) (hs : c₁.s ≫ b' = b ≫ c₂.s),
  (is_cof b → is_cof ((pushout_by_cof c₁.f' a c₁.hf').is_pushout.induced b' c₂.f' hf')) ∧
  (is_cof a → is_acof ((pushout_by_cof c₁.s b c₁.hs.1).is_pushout.induced b' c₂.s hs)) :=
let po_a := pushout_by_cof c₁.f' a c₁.hf',
    a₃ := po_a.ob,
    f' := po_a.map₁,
    cof_f' : is_cof f' := pushout_is_cof po_a.is_pushout c₁.hf',
    po_b := pushout_by_cof c₁.s b c₁.hs.1,
    b₃ := po_b.ob,
    s := po_b.map₁,
    acof_s : is_acof s := pushout_is_acof po_b.is_pushout c₁.hs,
    r := po_b.is_pushout.induced (c₁.r ≫ b) (𝟙 _) (by rw [←assoc, c₁.hsr]; simp),
    f₃ : a₃ ⟶ b₃ := po_a.is_pushout.induced (c₁.r ≫ b ≫ s) (f₂ ≫ s) begin
      conv { to_rhs, rw [←assoc, ←S], rw [←c₁.hf'r, assoc] }, simp
    end,
    a₂b₂ := pushout_by_cof (! a₂) (! b₂) ha₂,
    -- TODO: lemma here?
    cof_a₃ : cofibrant a₃ := begin
      change is_cof _,
      convert cof_comp ha₂ (pushout_is_cof po_a.is_pushout c₁.hf'),
      apply initial.uniqueness
    end,
    cof_b₃ : cofibrant b₃ := begin
      change is_cof _,
      convert cof_comp hb₂ (pushout_is_cof po_b.is_pushout c₁.hs.1),
      apply initial.uniqueness
    end,
    a₃b₃ := pushout_by_cof (! a₃) (! b₃) cof_a₃,
    a₁_b₁ := c₁.ab.ob,
    cof_a₁_b₁ : cofibrant a₁_b₁ := begin
      change is_cof _,
      convert cof_comp hb₁ (pushout_is_cof c₁.ab.is_pushout ha₁),
      apply initial.uniqueness
    end,
    a₃_b₃ := a₃b₃.ob,
    cof_a₃_b₃ : cofibrant a₃_b₃ := begin
      change is_cof _,
      convert cof_comp cof_b₃ (pushout_is_cof a₃b₃.is_pushout cof_a₃),
      apply initial.uniqueness
    end,
    ⟨b₂', b', fs₃', r₃, hfs₃', hr₃, hf'sr, cof_fs₃', weq_r₃, cof_p⟩ := begin
      refine relative_factorization cof_a₁_b₁ cof_a₃_b₃ _ c₁.r c₁.hf's c₁.hr
        (a₃b₃.is_pushout.induced f₃ (𝟙 b₃) (initial.uniqueness _ _))
        (pushout_of_maps c₁.ab.is_pushout a₃b₃.is_pushout (𝟙 _) (a ≫ f') (b ≫ s)
          (initial.uniqueness _ _) (initial.uniqueness _ _))
        (b ≫ s) _,
      apply c₁.ab.is_pushout.uniqueness,
      { slice_lhs 1 2 { simp }, conv { to_lhs, rw [c₁.hf'r, S, assoc] },
        rw induced_pushout_of_maps, simp },
      { slice_lhs 1 2 { simp }, conv { to_lhs, rw [c₁.hsr, id_comp] },
        rw induced_pushout_of_maps, simp }
    end,
    f₃' := a₃b₃.map₀ ≫ fs₃',
    s₃ := a₃b₃.map₁ ≫ fs₃',
    f₂' := f' ≫ f₃',
    r₂ := r₃ ≫ r,
    s₂ := s ≫ s₃ in
have sr : s ≫ r = 𝟙 _, by simp,
have s₂r₂ : s₂ ≫ r₂ = 𝟙 _, begin
  slice_lhs 3 4 { rw hf'sr },
  slice_lhs 2 3 { rw Is_pushout.induced_commutes₁ },
  simp
end,
have weq_r₂ : is_weq r₂, begin
  refine weq_comp weq_r₃ _,
  rw ←weq_iff_weq_inv sr,
  exact acof_s.2
end,
⟨⟨a₂b₂, b₂', f₂', r₂, s₂,
  cof_comp (pushout_is_cof po_a.is_pushout c₁.hf')
    (cof_comp (pushout_is_cof a₃b₃.is_pushout.transpose cof_b₃) cof_fs₃'),
  begin
    have := cof_pushout cof_f' acof_s.1 a₂b₂.is_pushout
      (by convert a₃b₃.is_pushout; apply initial.uniqueness) (by apply initial.uniqueness),
    convert cof_comp this cof_fs₃',
    apply a₂b₂.is_pushout.uniqueness; conv { to_rhs, rw ←assoc }; simp
  end,
  begin
    refine ⟨_, (weq_iff_weq_inv s₂r₂).mpr weq_r₂⟩,
    exact cof_comp acof_s.1 (cof_comp (pushout_is_cof a₃b₃.is_pushout cof_a₃) cof_fs₃')
  end,
  begin
    slice_lhs 3 4 { rw hf'sr },
    slice_lhs 2 3 { rw Is_pushout.induced_commutes₀ },
    slice_lhs 1 2 { rw Is_pushout.induced_commutes₁ },
    simp [sr]
  end,
  s₂r₂⟩,
 b',
 begin
   convert congr_arg (λ z, c₁.ab.map₀ ≫ z) hfs₃' using 1,
   { slice_rhs 1 2 { rw Is_pushout.induced_commutes₀ } },
   { slice_rhs 1 2 { dsimp [pushout_of_maps], rw Is_pushout.induced_commutes₀ }, simp }
 end,
 begin
   have : c₁.r ≫ b = c₁.r ≫ b ≫ (s ≫ r), by rw [sr]; simp,
   rw this,
   slice_lhs 1 3 { rw hr₃ },
   simp
 end,
 begin
   convert congr_arg (λ z, c₁.ab.map₁ ≫ z) hfs₃' using 1,
   { slice_rhs 1 2 { rw Is_pushout.induced_commutes₁ } },
   { slice_rhs 1 2 { dsimp [pushout_of_maps], rw Is_pushout.induced_commutes₁ }, simp }
 end,
 begin
   intro hb,
   let v := _,
   let S₂ : cof_square v b' := ⟨_, _, _, _, cof_p⟩,
   let S₁ : cof_square a v,
   { refine ⟨c₁.ab.map₀, f' ≫ a₃b₃.map₀,
       by simp [v, pushout_of_maps], pushout_is_cof c₁.ab.is_pushout.transpose hb₁, _⟩,
     let po : pushout _ _ := _,
     change is_cof (po.is_pushout.induced _ _ _),
     have : is_cof (b ≫ s) := cof_comp hb acof_s.1,
     convert cof_pushout this cof_f'
       (Is_pushout_of_Is_pushout_of_Is_pushout c₁.ab.is_pushout.transpose po.is_pushout)
       (by convert a₃b₃.is_pushout.transpose; apply initial.uniqueness)
       (by apply initial.uniqueness) using 1,
     symmetry,
     apply pushout_induced_eq_iff; simp },
   have : c₁.f' = S₁.f₁ ≫ S₂.f₁, by simp,
   have S : is_cof_square a b' c₁.f' _ :=
     is_cof_square_comp ⟨S₁, rfl, rfl⟩ ⟨S₂, rfl, rfl⟩ this rfl,
   convert S.corner_cof.snd.snd,
   simp
 end,
 begin
   intro ha,
   let G := _,
   change is_acof G,
   suffices : is_cof G,
   { refine ⟨this, _⟩,
     have sG : s ≫ G = s₂, by simp,
     have : is_acof s := pushout_is_acof po_b.is_pushout c₁.hs,
     refine category_with_weak_equivalences.weq_of_comp_weq_left this.2 _,
     rw sG,
     exact (weq_iff_weq_inv s₂r₂).mpr weq_r₂ },
   -- From here on, the proof resembles the previous one
   let v := _,
   let S₂ : cof_square v b' := ⟨_, _, _, _, cof_p⟩,
   let S₁ : cof_square b v,
   { refine ⟨c₁.ab.map₁, s ≫ a₃b₃.map₁,
       by simp [v, pushout_of_maps], pushout_is_cof c₁.ab.is_pushout ha₁, _⟩,
     let po : pushout _ _ := _,
     change is_cof (po.is_pushout.induced _ _ _),
     have : is_cof (a ≫ f') := cof_comp ha cof_f',
     convert cof_pushout this acof_s.1
       (Is_pushout_of_Is_pushout_of_Is_pushout c₁.ab.is_pushout po.is_pushout)
       (by convert a₃b₃.is_pushout; apply initial.uniqueness)
       (by apply initial.uniqueness) using 1,
     symmetry,
     apply pushout_induced_eq_iff; simp },
   have : c₁.s = S₁.f₁ ≫ S₂.f₁, by simp,
   have S : is_cof_square b b' c₁.s _ :=
     is_cof_square_comp ⟨S₁, rfl, rfl⟩ ⟨S₂, rfl, rfl⟩ this rfl,
   convert S.corner_cof.snd.snd,
   simp
 end⟩

end homotopy_theory.cofibrations


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Stephen Morgan, Scott Morrison
import category_theory.tactics.obviously
import category_theory.equivalence

namespace category_theory

universes v₁ v₂ u₁ u₂

structure idempotent (C : Sort u₁) [category.{v₁+1} C] :=
(X : C)
(idem : X ⟶ X)
(w' : idem ≫ idem = idem . obviously)

restate_axiom idempotent.w'
attribute [simp] idempotent.w -- search

variables {C : Sort u₁} [𝒞 : category.{v₁+1} C]
include 𝒞

namespace idempotent

structure morphism (P Q : idempotent.{v₁} C) :=
(hom : P.X ⟶ Q.X)
(left' : P.idem ≫ hom = hom . obviously)
(right' : hom ≫ Q.idem = hom . obviously)

restate_axiom morphism.left'
restate_axiom morphism.right'
attribute [simp] morphism.left morphism.right -- search

@[extensionality] lemma ext {P Q : idempotent C} (f g : morphism P Q) (w : f.hom = g.hom) : f = g :=
begin
  induction f,
  induction g,
  tidy
end

end idempotent

instance idempotent_completion : category.{v₁+1} (idempotent C) :=
{ hom  := idempotent.morphism,
  id   := λ P, ⟨ P.idem ⟩,
  comp := λ _ _ _ f g,
  { hom := f.hom ≫ g.hom,
    left'  := by rw [←category.assoc, idempotent.morphism.left],
    right' := by rw [category.assoc, idempotent.morphism.right] } }

namespace idempotent_completion

@[simp] lemma id_hom (P : idempotent C) : ((𝟙 P) : idempotent.morphism P P).hom = P.idem := rfl
@[simp] lemma comp_hom {P Q R : idempotent C} (f : P ⟶ Q) (g : Q ⟶ R) : (f ≫ g).hom = f.hom ≫ g.hom := rfl

def to_completion (C : Type u₁) [𝒞 : category.{v₁+1} C] : C ⥤ (idempotent.{v₁} C) :=
{ obj := λ P, { X := P, idem := 𝟙 P },
  map := λ _ _ f, { hom := f } }

@[simp] private lemma double_idempotent_morphism_left (P Q : idempotent (idempotent C)) (f : P ⟶ Q)
  : (P.idem).hom ≫ (f.hom).hom = (f.hom).hom := congr_arg idempotent.morphism.hom f.left
@[simp] private lemma double_idempotent_morphism_right (P Q : idempotent (idempotent C)) (f : P ⟶ Q)
  : (f.hom).hom ≫ (Q.idem).hom = (f.hom).hom := congr_arg idempotent.morphism.hom f.right

@[simp] private def idempotent_functor : (idempotent (idempotent C)) ⥤ (idempotent C) :=
{ obj := λ P, ⟨ P.X.X, P.idem.hom, congr_arg idempotent.morphism.hom P.w ⟩,
  map := λ _ _ f, ⟨ f.hom.hom, by obviously ⟩ }.
@[simp] private def idempotent_inverse : (idempotent C) ⥤ (idempotent (idempotent C)) :=
{ obj := λ P, ⟨ P, ⟨ P.idem, by obviously ⟩, by obviously ⟩,
  map := λ _ _ f, ⟨ f, by obviously ⟩ }.

@[simp] lemma idem_hom_idempotent (X : idempotent (idempotent C)) : X.idem.hom ≫ X.idem.hom = X.idem.hom :=
begin
  rw ←comp_hom,
  simp,
end

lemma idempotent_idempotent :
  equivalence (idempotent (idempotent C)) (idempotent C) :=
equivalence.mk idempotent_functor idempotent_inverse
  { hom := { app := λ X, { hom := { hom := X.idem.hom } } },
    inv := { app := λ X, { hom := { hom := X.idem.hom } } } }
  { hom := { app := λ X, { hom := X.idem } },
    inv := { app := λ X, { hom := X.idem } } }

variable {D : Type u₂}
variable [𝒟 : category.{v₂+1} D]
include 𝒟

attribute [search] idempotent.w idempotent.morphism.left idempotent.morphism.right
  idem_hom_idempotent comp_hom id_hom

def extend_to_completion (F : C ⥤ (idempotent D)) : (idempotent C) ⥤ (idempotent D) :=
{ obj := λ P,
  { X := (F.obj P.X).X,
    idem := (F.map P.idem).hom,
    w' := begin rw [←comp_hom, ←functor.map_comp, idempotent.w], end },
  map := λ X Y f, { hom := (F.map f.hom).hom } }

end idempotent_completion
end category_theory


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.AppBuilder

namespace Lean.Meta

inductive CongrArgKind where
  | /-- It is a parameter for the congruence theorem, the parameter occurs in the left and right hand sides. -/
    fixed
  | /--
      It is not a parameter for the congruence theorem, the lemma was specialized for this parameter.
      This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it. -/
    fixedNoParam
  | /--
      The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : a_i = b_i`.
      `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality. -/
    eq
  | /--
      The congr-simp theorems contains only one parameter for this kind of argument, and congr theorems contains two.
      They correspond to arguments that are subsingletons/propositions. -/
    cast
  | /--
     The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : HEq a_i b_i`.
     `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their heterogeneous equality. -/
    heq

structure CongrTheorem where
  type     : Expr
  proof    : Expr
  argKinds : Array CongrArgKind

private def addPrimeToFVarUserNames (ys : Array Expr) (lctx : LocalContext) : LocalContext := do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setUserName decl.fvarId (decl.userName.appendAfter "'")
  return lctx

private def setBinderInfosD (ys : Array Expr) (lctx : LocalContext) : LocalContext := do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setBinderInfo decl.fvarId BinderInfo.default
  return lctx

partial def mkHCongrWithArity (f : Expr) (numArgs : Nat) : MetaM CongrTheorem := do
  let fType ← inferType f
  forallBoundedTelescope fType numArgs fun xs xType =>
  forallBoundedTelescope fType numArgs fun ys yType => do
    if xs.size != numArgs then
      throwError "failed to generate hcongr theorem, insufficient number of arguments"
    else
      let lctx := addPrimeToFVarUserNames ys (← getLCtx) |> setBinderInfosD ys |> setBinderInfosD xs
      withLCtx lctx (← getLocalInstances) do
      withNewEqs xs ys fun eqs argKinds => do
        let mut hs := #[]
        for x in xs, y in ys, eq in eqs do
          hs := hs.push x |>.push y |>.push eq
        let xType := xType.consumeAutoOptParam
        let yType := yType.consumeAutoOptParam
        let resultType ← if xType == yType then mkEq xType yType else mkHEq xType yType
        let congrType ← mkForallFVars hs resultType
        return {
          type  := congrType
          proof := (← mkProof congrType)
          argKinds
        }
where
  withNewEqs {α} (xs ys : Array Expr) (k : Array Expr → Array CongrArgKind → MetaM α) : MetaM α :=
    let rec loop (i : Nat) (eqs : Array Expr) (kinds : Array CongrArgKind) := do
      if  i < xs.size then
        let x := xs[i]
        let y := ys[i]
        let xType := (← inferType x).consumeAutoOptParam
        let yType := (← inferType y).consumeAutoOptParam
        if xType == yType then
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.eq)
        else
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkHEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.heq)
      else
        k eqs kinds
    loop 0 #[] #[]

  mkProof (type : Expr) : MetaM Expr := do
    if let some (_, lhs, _) := type.eq? then
      mkEqRefl lhs
    else if let some (_, lhs, _, _) := type.heq? then
      mkHEqRefl lhs
    else
      forallBoundedTelescope type (some 1) fun a type =>
      let a := a[0]
      forallBoundedTelescope type (some 1) fun b motive =>
      let b := b[0]
      let type := type.bindingBody!.instantiate1 a
      withLocalDeclD motive.bindingName! motive.bindingDomain! fun eqPr => do
      let type := type.bindingBody!
      let motive := motive.bindingBody!
      let minor ← mkProof type
      let mut major := eqPr
      if (← whnf (← inferType eqPr)).isHEq then
        major ← mkEqOfHEq major
      let motive ← mkLambdaFVars #[b] motive
      mkLambdaFVars #[a, b, eqPr] (← mkEqNDRec motive minor major)

def mkHCongr (f : Expr) : MetaM CongrTheorem := do
  mkHCongrWithArity f (← getFunInfo f).getArity

end Lean.Meta