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


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import init.data.list.basic
import init.data.char.basic

/- In the VM, strings are implemented using a dynamic array and UTF-8 encoding.

   TODO: we currently cannot mark string_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/
structure string_imp :=
(data : list char)

def string := string_imp

def list.as_string (s : list char) : string :=
⟨s⟩

namespace string

instance : has_lt string :=
⟨λ s₁ s₂, s₁.data < s₂.data⟩

/- Remark: this function has a VM builtin efficient implementation. -/
instance has_decidable_lt (s₁ s₂ : string) : decidable (s₁ < s₂) :=
list.has_decidable_lt s₁.data s₂.data

instance has_decidable_eq : decidable_eq string := λ ⟨x⟩ ⟨y⟩,
match list.has_dec_eq x y with
| is_true p := is_true (congr_arg string_imp.mk p)
| is_false p := is_false (λ q, p (string_imp.mk.inj q))
end

def empty : string :=
⟨[]⟩

def length : string → nat
| ⟨s⟩  := s.length

/- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/
def push : string → char → string
| ⟨s⟩ c := ⟨s ++ [c]⟩

/- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/
def append : string → string → string
| ⟨a⟩ ⟨b⟩ := ⟨a ++ b⟩

/- O(n) in the VM, where n is the length of the string -/
def to_list : string → list char
| ⟨s⟩ := s

def fold {α} (a : α) (f : α → char → α) (s : string) : α :=
s.to_list.foldl f a

/- In the VM, the string iterator is implemented as a pointer to the string being iterated + index.

   TODO: we currently cannot mark interator_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/
structure iterator_imp :=
(fst : list char) (snd : list char)

def iterator := iterator_imp

def mk_iterator : string → iterator
| ⟨s⟩ := ⟨[], s⟩

namespace iterator
def curr : iterator → char
| ⟨p, c::n⟩ := c
| _         := default

/- In the VM, `set_curr` is constant time if the string being iterated is not shared and linear time
   if it is. -/
def set_curr : iterator → char → iterator
| ⟨p, c::n⟩ c' := ⟨p, c'::n⟩
| it        c' := it

def next : iterator → iterator
| ⟨p, c::n⟩ := ⟨c::p, n⟩
| ⟨p, []⟩   := ⟨p, []⟩

def prev : iterator → iterator
| ⟨c::p, n⟩ := ⟨p, c::n⟩
| ⟨[],   n⟩ := ⟨[], n⟩

def has_next : iterator → bool
| ⟨p, []⟩ := ff
| _       := tt

def has_prev : iterator → bool
| ⟨[], n⟩ := ff
| _       := tt

def insert : iterator → string → iterator
| ⟨p, n⟩ ⟨s⟩ := ⟨p, s++n⟩

def remove : iterator → nat → iterator
| ⟨p, n⟩ m := ⟨p, n.drop m⟩

/- In the VM, `to_string` is a constant time operation. -/
def to_string : iterator → string
| ⟨p, n⟩ := ⟨p.reverse ++ n⟩

def to_end : iterator → iterator
| ⟨p, n⟩ := ⟨n.reverse ++ p, []⟩

def next_to_string : iterator → string
| ⟨p, n⟩ := ⟨n⟩

def prev_to_string : iterator → string
| ⟨p, n⟩ := ⟨p.reverse⟩

protected def extract_core : list char → list char → option (list char)
| []       cs  := none
| (c::cs₁) cs₂ :=
  if cs₁ = cs₂ then some [c] else
  match extract_core cs₁ cs₂ with
  | none   := none
  | some r := some (c::r)
  end

def extract : iterator → iterator → option string
| ⟨p₁, n₁⟩ ⟨p₂, n₂⟩ :=
  if p₁.reverse ++ n₁ ≠ p₂.reverse ++ n₂ then none
  else if n₁ = n₂ then some ""
  else match iterator.extract_core n₁ n₂ with
       | none := none
       | some r := some ⟨r⟩
       end

end iterator
end string

/- The following definitions do not have builtin support in the VM -/

instance : inhabited string :=
⟨string.empty⟩

instance : has_sizeof string :=
⟨string.length⟩

instance : has_append string :=
⟨string.append⟩

namespace string
def str : string → char → string := push

def is_empty (s : string) : bool :=
to_bool (s.length = 0)

def front (s : string) : char :=
s.mk_iterator.curr

def back (s : string) : char :=
s.mk_iterator.to_end.prev.curr

def join (l : list string) : string :=
l.foldl (λ r s, r ++ s) ""

def singleton (c : char) : string :=
empty.push c

def intercalate (s : string) (ss : list string) : string :=
(list.intercalate s.to_list (ss.map to_list)).as_string

namespace iterator
def nextn : iterator → nat → iterator
| it 0     := it
| it (i+1) := nextn it.next i

def prevn : iterator → nat → iterator
| it 0     := it
| it (i+1) := prevn it.prev i
end iterator

def pop_back (s : string) : string :=
s.mk_iterator.to_end.prev.prev_to_string

def popn_back (s : string) (n : nat) : string :=
(s.mk_iterator.to_end.prevn n).prev_to_string

def backn (s : string) (n : nat) : string :=
(s.mk_iterator.to_end.prevn n).next_to_string

end string

protected def char.to_string (c : char) : string :=
string.singleton c

private def to_nat_core : string.iterator → nat → nat → nat
| it      0     r := r
| it      (i+1) r :=
  let c := it.curr in
  let r := r*10 + c.to_nat - '0'.to_nat in
  to_nat_core it.next i r

def string.to_nat (s : string) : nat :=
to_nat_core s.mk_iterator s.length 0

namespace string

private lemma nil_ne_append_singleton : ∀ (c : char) (l : list char), [] ≠ l ++ [c]
| c []     := λ h, list.no_confusion h
| c (d::l) := λ h, list.no_confusion h

lemma empty_ne_str : ∀ (c : char) (s : string), empty ≠ str s c
| c ⟨l⟩ :=
  λ h : string_imp.mk [] = string_imp.mk (l ++ [c]),
    string_imp.no_confusion h $ λ h, nil_ne_append_singleton _ _ h

lemma str_ne_empty (c : char) (s : string) : str s c ≠ empty :=
(empty_ne_str c s).symm

private lemma str_ne_str_left_aux : ∀ {c₁ c₂ : char} (l₁ l₂ : list char), c₁ ≠ c₂ → l₁ ++ [c₁] ≠ l₂ ++ [c₂]
| c₁ c₂ []       [] h₁ h₂ := list.no_confusion h₂ (λ h _, absurd h h₁)
| c₁ c₂ (d₁::l₁) [] h₁ h₂ :=
  have d₁ :: (l₁ ++ [c₁]) = [c₂], from h₂,
  have l₁ ++ [c₁] = [], from list.no_confusion this (λ _ h, h),
  absurd this.symm (nil_ne_append_singleton _ _)
| c₁ c₂ [] (d₂::l₂) h₁ h₂ :=
  have [c₁] = d₂ :: (l₂ ++ [c₂]), from h₂,
  have []   = l₂ ++ [c₂], from list.no_confusion this (λ _ h, h),
  absurd this (nil_ne_append_singleton _ _)
| c₁ c₂ (d₁::l₁) (d₂::l₂) h₁ h₂ :=
  have d₁ :: (l₁ ++ [c₁]) = d₂ :: (l₂ ++ [c₂]), from h₂,
  have l₁ ++ [c₁] = l₂ ++ [c₂], from list.no_confusion this (λ _ h, h),
  absurd this (str_ne_str_left_aux l₁ l₂ h₁)

private lemma str_ne_str_right_aux : ∀ (c₁ c₂ : char) {l₁ l₂ : list char}, l₁ ≠ l₂ → l₁ ++ [c₁] ≠ l₂ ++ [c₂]
| c₁ c₂ []       [] h₁ h₂ := absurd rfl h₁
| c₁ c₂ (d₁::l₁) [] h₁ h₂ :=
  have d₁ :: (l₁ ++ [c₁]) = [c₂], from h₂,
  have l₁ ++ [c₁] = [], from list.no_confusion this (λ _ h, h),
  absurd this.symm (nil_ne_append_singleton _ _)
| c₁ c₂ [] (d₂::l₂) h₁ h₂ :=
  have [c₁] = d₂ :: (l₂ ++ [c₂]), from h₂,
  have []   = l₂ ++ [c₂], from list.no_confusion this (λ _ h, h),
  absurd this (nil_ne_append_singleton _ _)
| c₁ c₂ (d₁::l₁) (d₂::l₂) h₁ h₂ :=
  have aux₁ : d₁ :: (l₁ ++ [c₁]) = d₂ :: (l₂ ++ [c₂]), from h₂,
  have d₁ = d₂, from list.no_confusion aux₁ (λ h _, h),
  have aux₂ : l₁ ≠ l₂, from λ h,
    have d₁ :: l₁ = d₂ :: l₂, from eq.subst h (eq.subst this rfl),
    absurd this h₁,
  have l₁ ++ [c₁] = l₂ ++ [c₂], from list.no_confusion aux₁ (λ _ h, h),
  absurd this (str_ne_str_right_aux c₁ c₂ aux₂)

lemma str_ne_str_right : ∀ (c₁ c₂ : char) {s₁ s₂ : string}, s₁ ≠ s₂ → str s₁ c₁ ≠ str s₂ c₂
| c₁ c₂ (string_imp.mk l₁) (string_imp.mk l₂) h₁ h₂ :=
  have aux : l₁ ≠ l₂, from λ h,
    have string_imp.mk l₁ = string_imp.mk l₂, from eq.subst h rfl,
    absurd this h₁,
  have l₁ ++ [c₁] = l₂ ++ [c₂], from string_imp.no_confusion h₂ id,
  absurd this (str_ne_str_right_aux c₁ c₂ aux)

end 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


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

Notation for operators defined at Prelude.lean
-/
prelude
import Init.Prelude

-- DSL for specifying parser precedences and priorities

namespace Lean.Parser.Syntax

syntax:65 (name := addPrec) prec " + " prec:66 : prec
syntax:65 (name := subPrec) prec " - " prec:66 : prec

syntax:65 (name := addPrio) prio " + " prio:66 : prio
syntax:65 (name := subPrio) prio " - " prio:66 : prio

end Lean.Parser.Syntax

macro "max"  : prec => `(1024) -- maximum precedence used in term parsers, in particular for terms in function position (`ident`, `paren`, ...)
macro "arg"  : prec => `(1023) -- precedence used for application arguments (`do`, `by`, ...)
macro "lead" : prec => `(1022) -- precedence used for terms not supposed to be used as arguments (`let`, `have`, ...)
macro "(" p:prec ")" : prec => p
macro "min"  : prec => `(10)   -- minimum precedence used in term parsers
macro "min1" : prec => `(11)   -- `(min+1) we can only `min+1` after `Meta.lean`
/-
  `max:prec` as a term. It is equivalent to `eval_prec max` for `eval_prec` defined at `Meta.lean`.
  We use `max_prec` to workaround bootstrapping issues. -/
macro "max_prec" : term => `(1024)

macro "default" : prio => `(1000)
macro "low"     : prio => `(100)
macro "mid"     : prio => `(1000)
macro "high"    : prio => `(10000)
macro "(" p:prio ")" : prio => p

-- Basic notation for defining parsers
syntax   stx "+" : stx
syntax   stx "*" : stx
syntax   stx "?" : stx
syntax:2 stx " <|> " stx:1 : stx

macro_rules
  | `(stx| $p +) => `(stx| many1($p))
  | `(stx| $p *) => `(stx| many($p))
  | `(stx| $p ?) => `(stx| optional($p))
  | `(stx| $p₁ <|> $p₂) => `(stx| orelse($p₁, $p₂))

/- Comma-separated sequence. -/
macro:max x:stx ",*"   : stx => `(stx| sepBy($x, ",", ", "))
macro:max x:stx ",+"   : stx => `(stx| sepBy1($x, ",", ", "))
/- Comma-separated sequence with optional trailing comma. -/
macro:max x:stx ",*,?" : stx => `(stx| sepBy($x, ",", ", ", allowTrailingSep))
macro:max x:stx ",+,?" : stx => `(stx| sepBy1($x, ",", ", ", allowTrailingSep))

macro "!" x:stx : stx => `(stx| notFollowedBy($x))

syntax (name := rawNatLit) "nat_lit " num : term

infixr:90 " ∘ "  => Function.comp
infixr:35 " × "  => Prod

infixl:55 " ||| "  => HOr.hOr
infixl:58 " ^^^ "  => HXor.hXor
infixl:60 " &&& "  => HAnd.hAnd
infixl:65 " + "  => HAdd.hAdd
infixl:65 " - "  => HSub.hSub
infixl:70 " * "  => HMul.hMul
infixl:70 " / "  => HDiv.hDiv
infixl:70 " % "  => HMod.hMod
infixl:75 " <<< "  => HShiftLeft.hShiftLeft
infixl:75 " >>> "  => HShiftRight.hShiftRight
infixr:80 " ^ "  => HPow.hPow
prefix:100 "-"   => Neg.neg
prefix:100 "~~~"   => Complement.complement
/-
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binop%` elaboration helper for binary operators.
  It addresses issue #382. -/
macro_rules | `($x ||| $y) => `(binop% HOr.hOr $x $y)
macro_rules | `($x ^^^ $y) => `(binop% HXor.hXor $x $y)
macro_rules | `($x &&& $y) => `(binop% HAnd.hAnd $x $y)
macro_rules | `($x + $y)   => `(binop% HAdd.hAdd $x $y)
macro_rules | `($x - $y)   => `(binop% HSub.hSub $x $y)
macro_rules | `($x * $y)   => `(binop% HMul.hMul $x $y)
macro_rules | `($x / $y)   => `(binop% HDiv.hDiv $x $y)
macro_rules | `($x % $y)   => `(binop% HMod.hMod $x $y)
macro_rules | `($x <<< $y) => `(binop% HShiftLeft.hShiftLeft $x $y)
macro_rules | `($x >>> $y) => `(binop% HShiftRight.hShiftRight $x $y)
macro_rules | `($x ^ $y)   => `(binop% HPow.hPow $x $y)

-- declare ASCII alternatives first so that the latter Unicode unexpander wins
infix:50 " <= " => LE.le
infix:50 " ≤ "  => LE.le
infix:50 " < "  => LT.lt
infix:50 " >= " => GE.ge
infix:50 " ≥ "  => GE.ge
infix:50 " > "  => GT.gt
infix:50 " = "  => Eq
infix:50 " == " => BEq.beq
infix:50 " ~= " => HEq
infix:50 " ≅ "  => HEq
/-
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binrel%` elaboration helper for binary relations.
  It has better support for applying coercions. For example, suppose we have `binrel% Eq n i` where `n : Nat` and
  `i : Int`. The default elaborator fails because we don't have a coercion from `Int` to `Nat`, but
  `binrel%` succeeds because it also tries a coercion from `Nat` to `Int` even when the nat occurs before the int. -/
macro_rules | `($x <= $y) => `(binrel% LE.le $x $y)
macro_rules | `($x ≤ $y)  => `(binrel% LE.le $x $y)
macro_rules | `($x < $y)  => `(binrel% LT.lt $x $y)
macro_rules | `($x > $y)  => `(binrel% GT.gt $x $y)
macro_rules | `($x >= $y) => `(binrel% GE.ge $x $y)
macro_rules | `($x ≥ $y)  => `(binrel% GE.ge $x $y)
macro_rules | `($x = $y)  => `(binrel% Eq $x $y)
macro_rules | `($x == $y) => `(binrel% BEq.beq $x $y)

infixr:35 " /\\ " => And
infixr:35 " ∧ "   => And
infixr:30 " \\/ " => Or
infixr:30 " ∨  "  => Or
notation:max "¬" p:40 => Not p

infixl:35 " && " => and
infixl:30 " || " => or
notation:max "!" b:40 => not b

infixl:65 " ++ " => HAppend.hAppend
infixr:67 " :: " => List.cons

infixr:20  " <|> " => HOrElse.hOrElse
infixr:60  " >> "  => HAndThen.hAndThen
infixl:55  " >>= " => Bind.bind
infixl:60  " <*> " => Seq.seq
infixl:60  " <* "  => SeqLeft.seqLeft
infixr:60  " *> "  => SeqRight.seqRight
infixr:100 " <$> " => Functor.map

syntax (name := termDepIfThenElse) ppGroup(ppDedent("if " ident " : " term " then" ppSpace term ppDedent(ppSpace "else") ppSpace term)) : term

macro_rules
  | `(if $h:ident : $c then $t:term else $e:term) => ``(dite $c (fun $h:ident => $t) (fun $h:ident => $e))

syntax (name := termIfThenElse) ppGroup(ppDedent("if " term " then" ppSpace term ppDedent(ppSpace "else") ppSpace term)) : term

macro_rules
  | `(if $c then $t:term else $e:term) => ``(ite $c $t $e)

macro "if " "let " pat:term " := " d:term " then " t:term " else " e:term : term =>
  `(match $d:term with | $pat:term => $t | _ => $e)

syntax:min term "<|" term:min : term

macro_rules
  | `($f $args* <| $a) => let args := args.push a; `($f $args*)
  | `($f <| $a) => `($f $a)

syntax:min term "|>" term:min1 : term

macro_rules
  | `($a |> $f $args*) => let args := args.push a; `($f $args*)
  | `($a |> $f)        => `($f $a)

-- Haskell-like pipe <|
-- Note that we have a whitespace after `$` to avoid an ambiguity with the antiquotations.
syntax:min term atomic("$" ws) term:min : term

macro_rules
  | `($f $args* $ $a) => let args := args.push a; `($f $args*)
  | `($f $ $a) => `($f $a)

syntax "{ " ident (" : " term)? " // " term " }" : term

macro_rules
  | `({ $x : $type // $p }) => ``(Subtype (fun ($x:ident : $type) => $p))
  | `({ $x // $p })         => ``(Subtype (fun ($x:ident : _) => $p))

/-
  `without_expected_type t` instructs Lean to elaborate `t` without an expected type.
  Recall that terms such as `match ... with ...` and `⟨...⟩` will postpone elaboration until
  expected type is known. So, `without_expected_type` is not effective in this case. -/
macro "without_expected_type " x:term : term => `(let aux := $x; aux)

syntax "[" term,* "]"  : term
syntax "%[" term,* "|" term "]" : term -- auxiliary notation for creating big list literals

namespace Lean

macro_rules
  | `([ $elems,* ]) => do
    let rec expandListLit (i : Nat) (skip : Bool) (result : Syntax) : MacroM Syntax := do
      match i, skip with
      | 0,   _     => pure result
      | i+1, true  => expandListLit i false result
      | i+1, false => expandListLit i true  (← ``(List.cons $(elems.elemsAndSeps[i]) $result))
    if elems.elemsAndSeps.size < 64 then
      expandListLit elems.elemsAndSeps.size false (← ``(List.nil))
    else
      `(%[ $elems,* | List.nil ])

notation:50 e:51 " matches " p:51 => match e with | p => true | _ => false

namespace Parser.Tactic
/--
Introduce one or more hypotheses, optionally naming and/or pattern-matching them.
For each hypothesis to be introduced, the remaining main goal's target type must be a `let` or function type.
* `intro` by itself introduces one anonymous hypothesis, which can be accessed by e.g. `assumption`.
* `intro x y` introduces two hypotheses and names them. Individual hypotheses can be anonymized via `_`,
  or matched against a pattern:
  ```lean
  -- ... ⊢ α × β → ...
  intro (a, b)
  -- ..., a : α, b : β ⊢ ...
  ```
* Alternatively, `intro` can be combined with pattern matching much like `fun`:
  ```lean
  intro
  | n + 1, 0 => tac
  | ...
  ```
-/
syntax (name := intro) "intro " notFollowedBy("|") (colGt term:max)* : tactic
/-- `intros x...` behaves like `intro x...`, but then keeps introducing (anonymous) hypotheses until goal is not of a function type. -/
syntax (name := intros) "intros " (colGt (ident <|> "_"))* : tactic
/--
`rename t => x` renames the most recent hypothesis whose type matches `t` (which may contain placeholders) to `x`,
or fails if no such hypothesis could be found. -/
syntax (name := rename) "rename " term " => " ident : tactic
/-- `revert x...` is the inverse of `intro x...`: it moves the given hypotheses into the main goal's target type. -/
syntax (name := revert) "revert " (colGt ident)+ : tactic
/-- `clear x...` removes the given hypotheses, or fails if there are remaining references to a hypothesis. -/
syntax (name := clear) "clear " (colGt ident)+ : tactic
/--
`subst x...` substitutes each `x` with `e` in the goal if there is a hypothesis of type `x = e` or `e = x`.
If `x` is itself a hypothesis of type `y = e` or `e = y`, `y` is substituted instead. -/
syntax (name := subst) "subst " (colGt ident)+ : tactic
/--
`assumption` tries to solve the main goal using a hypothesis of compatible type, or else fails.
Note also the `‹t›` term notation, which is a shorthand for `show t by assumption`. -/
syntax (name := assumption) "assumption" : tactic
/--
`contradiction` closes the main goal if its hypotheses are "trivially contradictory".
```lean
example (h : False) : p := by contradiction  -- inductive type/family with no applicable constructors
example (h : none = some true) : p := by contradiction  -- injectivity of constructors
example (h : 2 + 2 = 3) : p := by contradiction  -- decidable false proposition
example (h : p) (h' : ¬ p) : q := by contradiction
example (x : Nat) (h : x ≠ x) : p := by contradiction
```
-/
syntax (name := contradiction) "contradiction" : tactic
/--
`apply e` tries to match the current goal against the conclusion of `e`'s type.
If it succeeds, then the tactic returns as many subgoals as the number of premises that
have not been fixed by type inference or type class resolution.
Non-dependent premises are added before dependent ones.

The `apply` tactic uses higher-order pattern matching, type class resolution, and first-order unification with dependent types.
-/
syntax (name := apply) "apply " term : tactic
/--
`exact e` closes the main goal if its target type matches that of `e`.
-/
syntax (name := exact) "exact " term : tactic
/--
`refine e` behaves like `exact e`, except that named (`?x`) or unnamed (`?_`) holes in `e` that are not solved
by unification with the main goal's target type are converted into new goals, using the hole's name, if any, as the goal case name.
-/
syntax (name := refine) "refine " term : tactic
/-- `refine' e` behaves like `refine e`, except that unsolved placeholders (`_`) and implicit parameters are also converted into new goals. -/
syntax (name := refine') "refine' " term : tactic
/-- If the main goal's target type is an inductive type, `constructor` solves it with the first matching constructor, or else fails. -/
syntax (name := constructor) "constructor" : tactic
/--
`case tag => tac` focuses on the goal with case name `tag` and solves it using `tac`, or else fails.
`case tag x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses with inaccessible names to the given names. -/
syntax (name := case) "case " ident (ident <|> "_")* " => " tacticSeq : tactic
/-- `allGoals tac` runs `tac` on each goal, concatenating the resulting goals, if any. -/
syntax (name := allGoals) "allGoals " tacticSeq : tactic
/--
`focus tac` focuses on the main goal, suppressing all other goals, and runs `tac` on it.
Usually `· tac`, which enforces that the goal is closed by `tac`, should be preferred. -/
syntax (name := focus) "focus " tacticSeq : tactic
/-- `skip` does nothing. -/
syntax (name := skip) "skip" : tactic
/-- `done` succeeds iff there are no remaining goals. -/
syntax (name := done) "done" : tactic
syntax (name := traceState) "traceState" : tactic
syntax (name := failIfSuccess) "failIfSuccess " tacticSeq : tactic
/--
`generalize [h :] e = x` replaces all occurrences of the term `e` in the main goal with a fresh hypothesis `x`.
If `h` is given, `h : e = x` is introduced as well. -/
syntax (name := generalize) "generalize " atomic(ident " : ")? term:51 " = " ident : tactic
syntax (name := paren) "(" tacticSeq ")" : tactic
syntax (name := withReducible) "withReducible " tacticSeq : tactic
syntax (name := withReducibleAndInstances) "withReducibleAndInstances " tacticSeq : tactic
/-- `first | tac | ...` runs each `tac` until one succeeds, or else fails. -/
syntax (name := first) "first " withPosition((group(colGe "|" tacticSeq))+) : tactic
syntax (name := rotateLeft) "rotateLeft" (num)? : tactic
syntax (name := rotateRight) "rotateRight" (num)? : tactic
/-- `try tac` runs `tac` and succeeds even if `tac` failed. -/
macro "try " t:tacticSeq : tactic => `(first | $t | skip)
/-- `tac <;> tac'` runs `tac` on the main goal and `tac'` on each produced goal, concatenating all goals produced by `tac'`. -/
macro:1 x:tactic " <;> " y:tactic:0 : tactic => `(tactic| focus ($x:tactic; allGoals $y:tactic))

/-- `· tac` focuses on the main goal and tries to solve it using `tac`, or else fails. -/
macro dot:("·" <|> ".") ts:tacticSeq : tactic => `(tactic| {%$dot ($ts:tacticSeq) })

/-- `rfl` is a shorthand for `exact rfl`. -/
macro "rfl" : tactic => `(exact rfl)
/-- `admit` is a shorthand for `exact sorry`. -/
macro "admit" : tactic => `(exact sorry)
macro "inferInstance" : tactic => `(exact inferInstance)

syntax locationWildcard := "*"
syntax locationHyp      := (colGt ident)+ ("⊢" <|> "|-")? -- TODO: delete
syntax locationTargets  := (colGt ident)+ ("⊢" <|> "|-")?
syntax location         := withPosition("at " locationWildcard <|> locationHyp)

syntax (name := change) "change " term (location)? : tactic
syntax (name := changeWith) "change " term " with " term (location)? : tactic

syntax rwRule    := ("←" <|> "<-")? term
syntax rwRuleSeq := "[" rwRule,+,? "]"

syntax (name := rewriteSeq) "rewrite " rwRuleSeq (location)? : tactic
syntax (name := erewriteSeq) "erewrite " rwRuleSeq (location)? : tactic

syntax (name := rwSeq) "rw " rwRuleSeq (location)? : tactic
syntax (name := erwSeq) "erw " rwRuleSeq (location)? : tactic

def rwWithRfl (kind : SyntaxNodeKind) (atom : String) (stx : Syntax) : MacroM Syntax := do
  -- We show the `rfl` state on `]`
  let seq   := stx[1]
  let rbrak := seq[2]
  -- Replace `]` token with one without position information in the expanded tactic
  let seq   := seq.setArg 2 (mkAtom "]")
  let tac   := stx.setKind kind |>.setArg 0 (mkAtomFrom stx atom) |>.setArg 1 seq
  `(tactic| $tac; try (withReducible rfl%$rbrak))

@[macro rwSeq] def expandRwSeq : Macro :=
  rwWithRfl ``Lean.Parser.Tactic.rewriteSeq "rewrite"

@[macro erwSeq] def expandERwSeq : Macro :=
  rwWithRfl ``Lean.Parser.Tactic.erewriteSeq "erewrite"

syntax (name := injection) "injection " term (" with " (colGt (ident <|> "_"))+)? : tactic

syntax simpPre   := "↓"
syntax simpPost  := "↑"
syntax simpLemma := (simpPre <|> simpPost)? term
syntax simpErase := "-" ident
syntax (name := simp) "simp " ("(" &"config" " := " term ")")? (&"only ")? ("[" (simpErase <|> simpLemma),* "]")? (location)? : tactic
syntax (name := simpAll) "simp_all " ("(" &"config" " := " term ")")? (&"only ")? ("[" (simpErase <|> simpLemma),* "]")? : tactic

-- Auxiliary macro for lifting have/suffices/let/...
-- It makes sure the "continuation" `?_` is the main goal after refining
macro "refineLift " e:term : tactic => `(focus (refine noImplicitLambda% $e; rotateRight))

macro "have " d:haveDecl : tactic => `(refineLift have $d:haveDecl; ?_)
/- We use a priority > default, to avoid ambiguity with previous `have` notation -/
macro (priority := high) "have" x:ident " := " p:term : tactic => `(have $x:ident : _ := $p)
macro "suffices " d:sufficesDecl : tactic => `(refineLift suffices $d:sufficesDecl; ?_)
macro "let " d:letDecl : tactic => `(refineLift let $d:letDecl; ?_)
macro "show " e:term : tactic => `(refineLift show $e:term from ?_)
syntax (name := letrec) withPosition(atomic(group("let " &"rec ")) letRecDecls) : tactic
macro_rules
  | `(tactic| let rec $d:letRecDecls) => `(tactic| refineLift let rec $d:letRecDecls; ?_)

-- Similar to `refineLift`, but using `refine'`
macro "refineLift' " e:term : tactic => `(focus (refine' noImplicitLambda% $e; rotateRight))
macro "have' " d:haveDecl : tactic => `(refineLift' have $d:haveDecl; ?_)
macro (priority := high) "have'" x:ident " := " p:term : tactic => `(have' $x:ident : _ := $p)
macro "let' " d:letDecl : tactic => `(refineLift' let $d:letDecl; ?_)

syntax inductionAlt  := "| " (group("@"? ident) <|> "_") (ident <|> "_")* " => " (hole <|> syntheticHole <|> tacticSeq)
syntax inductionAlts := "with " (tactic)? withPosition( (colGe inductionAlt)+)
syntax (name := induction) "induction " term,+ (" using " ident)?  ("generalizing " ident+)? (inductionAlts)? : tactic
syntax casesTarget := atomic(ident " : ")? term
syntax (name := cases) "cases " casesTarget,+ (" using " ident)? (inductionAlts)? : tactic

syntax (name := existsIntro) "exists " term : tactic

syntax "repeat " tacticSeq : tactic
macro_rules
  | `(tactic| repeat $seq) => `(tactic| first | ($seq); repeat $seq | skip)

syntax "trivial" : tactic

macro_rules | `(tactic| trivial) => `(tactic| assumption)
macro_rules | `(tactic| trivial) => `(tactic| rfl)
macro_rules | `(tactic| trivial) => `(tactic| contradiction)
macro_rules | `(tactic| trivial) => `(tactic| apply True.intro)
macro_rules | `(tactic| trivial) => `(tactic| apply And.intro <;> trivial)

macro "unhygienic " t:tacticSeq : tactic => `(set_option tactic.hygienic false in $t:tacticSeq)

end Tactic

namespace Attr
-- simp attribute syntax
syntax (name := simp) "simp" (Tactic.simpPre <|> Tactic.simpPost)? (prio)? : attr
end Attr

end Parser
end Lean

macro "‹" type:term "›" : term => `((by assumption : $type))


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v1) ≠ (((((a3).write i2 (v1)).write i1 (v1)).write i2 (v1)).read i1) → False := by
  arr


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