import category_theory.shift
import tactic.linarith
import for_mathlib.category_theory.functor.shift_compatibility
import for_mathlib.category_theory.triangulated.shift_compatibility
import for_mathlib.category_theory.shift_misc

noncomputable theory

open category_theory category_theory.category

namespace category_theory

namespace functor

variables {C D E : Type*} [category C] [category D] [category E] (F : C ⥤ D)
  {A G : Type*} [add_monoid A] [add_group G]
  [has_shift C A] [has_shift D A] [has_shift E A]
  [hCℤ : has_shift C ℤ] [hDℤ : has_shift D ℤ]

variables (F A)

namespace comm_shift

def unit : shift_functor C (0 : A) ⋙ F ≅ F ⋙ shift_functor D (0 : A) :=
shift.compatibility.comm_shift.unit _ _ F

@[simp]
lemma unit_hom_app (X : C) :
  (unit F A).hom.app X = F.map ((shift_functor_zero C A).hom.app X) ≫
    (shift_functor_zero D A).inv.app (F.obj X) :=
begin
  dsimp [unit, shift.compatibility.comm_shift.unit],
  erw [id_comp, id_comp],
end

@[simp]
lemma unit_inv_app (X : C) :
  (unit F A).inv.app X = (shift_functor_zero D A).hom.app (F.obj X) ≫
    F.map ((shift_functor_zero C A).inv.app X) :=
begin
  dsimp [unit, shift.compatibility.comm_shift.unit],
  simp only [comp_id],
end

variables {F A}

@[simp]
def change {a b : A} (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (h : a = b) :
  shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b :=
shift.compatibility.comm_shift.change e (eq_to_iso (by subst h))

def add {a b : A} (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) :
  shift_functor C (a + b) ⋙ F ≅ F ⋙ shift_functor D (a + b) :=
shift.compatibility.comm_shift.comp e₁ e₂

@[simp]
lemma add_hom_app {a b : A} (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) (X : C) :
  (add e₁ e₂).hom.app X = F.map ((shift_functor_add C a b).hom.app X) ≫
    e₂.hom.app (X⟦a⟧) ≫ (e₁.hom.app X)⟦b⟧' ≫ (shift_functor_add D a b).inv.app (F.obj X) :=
begin
  dsimp [add, shift.compatibility.comm_shift.comp],
  erw [id_comp, id_comp, id_comp],
end

@[simp]
lemma add_inv_app {a b : A} (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) (X : C) :
  (add e₁ e₂).inv.app X = (shift_functor_add D a b).hom.app (F.obj X) ≫
    (e₁.inv.app X)⟦b⟧' ≫ e₂.inv.app (X⟦a⟧) ≫ F.map ((shift_functor_add C a b).inv.app X) :=
begin
  dsimp [add, shift.compatibility.comm_shift.comp],
  erw [comp_id, comp_id, comp_id, assoc, assoc],
end

@[simp]
def add' {a b c : A} (h : a + b = c) (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) :
  shift_functor C c ⋙ F ≅ F ⋙ shift_functor D c :=
(shift.compatibility.comm_shift.comp e₁ e₂).change (eq_to_iso (by simpa only [← h]))

lemma add'_eq_add {a b : A} (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) :
  add' rfl e₁ e₂ = add e₁ e₂ :=
by simp only [add', add, eq_to_iso_refl, shift.compatibility.comm_shift.change_refl]

def sub {a b : A} (e : shift_functor C (a + b) ⋙ F ≅ F ⋙ shift_functor D (a + b))
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) [is_equivalence (shift_functor D b)] :
  shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a :=
@shift.compatibility.comm_shift.comp_cancel _ _ _ _ _ _ _ _ _ F (discrete.mk a) (discrete.mk b) e f _

def add_equiv {b : A} (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b)
  [is_equivalence (shift_functor D b)] (a : A) :
  (shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a) ≃
    (shift_functor C (a + b) ⋙ F ≅ F ⋙ shift_functor D (a + b)) :=
{ to_fun := λ e, add e f,
  inv_fun := λ e, sub e f,
  left_inv := (shift.compatibility.comm_shift.comp_equiv f (discrete.mk a)).left_inv,
  right_inv := (shift.compatibility.comm_shift.comp_equiv f (discrete.mk a)).right_inv, }

def sub' {a b c : A} (h : a + b = c) (e : shift_functor C c ⋙ F ≅ F ⋙ shift_functor D c)
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) [is_equivalence (shift_functor D b)] :
  shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a :=
sub (change e h.symm) f

lemma sub'_eq_sub {a b : A} (e : shift_functor C (a + b) ⋙ F ≅ F ⋙ shift_functor D (a + b))
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) [is_equivalence (shift_functor D b)] :
  sub' rfl e f = sub e f :=
begin
  dsimp only [sub'],
  simp only [change, eq_to_iso_refl, shift.compatibility.comm_shift.change_refl],
end

def add'_equiv {a b c : A} (h : a + b = c)
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b)
  [is_equivalence (shift_functor D b)] :
  (shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a) ≃
    (shift_functor C c ⋙ F ≅ F ⋙ shift_functor D c) :=
{ to_fun := λ e, add' h e f,
  inv_fun := λ e, sub' h e f,
  left_inv := begin
    subst h,
    simpa only [sub'_eq_sub, add'_eq_add] using (add_equiv f a).left_inv,
  end,
  right_inv := begin
    subst h,
    simpa only [sub'_eq_sub, add'_eq_add] using (add_equiv f a).right_inv,
  end, }

lemma add_bijective {b : A} (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b)
  [is_equivalence (shift_functor D b)] (a : A) :
  function.bijective (λ (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a),
    add e f) :=
(add_equiv f a).bijective

lemma add'_bijective {a b c : A} (h : a + b = c)
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b)
  [is_equivalence (shift_functor D b)] :
  function.bijective (λ (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a),
    add' h e f) :=
(add'_equiv h f).bijective

@[simp]
lemma add'_sub' {a b c : A} (h : a + b = c) (e : shift_functor C c ⋙ F ≅ F ⋙ shift_functor D c)
  (f : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b) [is_equivalence (shift_functor D b)] :
  add' h (sub' h e f) f = e :=
(add'_equiv h f).right_inv e

lemma add'_assoc (a b c ab bc abc : A) (hab : a + b = ab) (hbc : b + c = bc)
  (habc : a + b + c = abc)
  (e₁ : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (e₂ : shift_functor C b ⋙ F ≅ F ⋙ shift_functor D b)
  (e₃ : shift_functor C c ⋙ F ≅ F ⋙ shift_functor D c) :
  add' (show ab + c = abc, by rw [← hab, habc]) (add' hab e₁ e₂) e₃ =
    add' (show a + bc = abc, by rw [← hbc, ← add_assoc, habc]) e₁ (add' hbc e₂ e₃) :=
begin
  substs hab hbc habc,
  simp only [add'_eq_add],
  apply shift.compatibility.comm_shift.comp_assoc,
end

@[protected]
lemma zero_add {a : A} (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a) :
  add (unit _ _) e = change e (zero_add a).symm :=
shift.compatibility.comm_shift.unit_comp e

@[protected]
lemma add_zero {a : A} (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a) :
  add e (unit _ _) = change e (add_zero a).symm :=
shift.compatibility.comm_shift.comp_unit e

@[simp]
lemma add'_zero {a : A} (e : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a) :
  add' (add_zero a) e (unit _ _) = e :=
begin
  change change (add e (unit _ _)) (add_zero a) = e,
  rw comm_shift.add_zero,
  simp only [change, shift.compatibility.comm_shift.change_comp, eq_to_iso_trans,
    eq_to_iso_refl, shift.compatibility.comm_shift.change_refl],
end

end comm_shift

variables (F A)

@[ext, nolint has_nonempty_instance]
class has_comm_shift :=
(iso : Π (a : A), shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
(iso_zero : iso 0 = comm_shift.unit F A)
(iso_add : ∀ (a b : A), iso (a + b) = comm_shift.add (iso a) (iso b))

variable {A}
def comm_shift_iso [F.has_comm_shift A] (a : A) :
  shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a :=
has_comm_shift.iso a

lemma comm_shift_iso_add [F.has_comm_shift A] (a b : A) :
  F.comm_shift_iso (a + b) = comm_shift.add (F.comm_shift_iso a) (F.comm_shift_iso b) :=
has_comm_shift.iso_add _ _

variable (A)

lemma comm_shift_iso_zero [F.has_comm_shift A] :
  F.comm_shift_iso (0 : A) = comm_shift.unit F A :=
has_comm_shift.iso_zero

variable {A}
lemma comm_shift_congr_iso {a b : A} [F.has_comm_shift A] (h : a = b) (X : C) :
  (F.comm_shift_iso a).hom.app X = eq_to_hom (by rw h) ≫
    (F.comm_shift_iso b).hom.app X ≫ eq_to_hom (by rw h) :=
by { subst h, simp only [eq_to_hom_refl, comp_id, id_comp], }

namespace comm_shift

variables {F A}

lemma iso_add_eq_of_iso_eq (e₁ e₂ : F.has_comm_shift A) (a b : A)
  (ha : e₁.iso a = e₂.iso a) (hb : e₁.iso b = e₂.iso b) :
  e₁.iso (a + b) = e₂.iso (a + b) :=
by rw [e₁.iso_add, e₂.iso_add, ha, hb]

lemma iso_eq_of_iso_add_eq (e₁ e₂ : F.has_comm_shift A) (a b : A)
  (hb : e₁.iso b = e₂.iso b) (hab : e₁.iso (a + b) = e₂.iso (a+b))
  [is_equivalence (shift_functor D b)] : e₁.iso a = e₂.iso a :=
(comm_shift.add_bijective (e₁.iso b) a).1
  (by { dsimp only, rw [← e₁.iso_add, hb, ← e₂.iso_add, hab], })

include hCℤ hDℤ

@[ext]
lemma eq_of_iso_one_eq (e₁ e₂ : F.has_comm_shift ℤ)
  (h : e₁.iso (1 : ℤ) = e₂.iso (1 : ℤ)) : e₁ = e₂ :=
begin
  suffices : ∀ (n : ℕ), e₁.iso (n : ℤ) = e₂.iso (n : ℤ),
  { ext n : 2,
    cases n,
    { apply this, },
    { have eq : (-[1+n]+(1+n)) = 0,
      { simp only [int.neg_succ_of_nat_coe, nat.cast_add, nat.cast_one, neg_add_rev],
        linarith, },
      refine iso_eq_of_iso_add_eq e₁ e₂ (-[1+n]) (1+n) (this _) _,
      rw [eq, e₁.iso_zero, e₂.iso_zero], }, },
  intro n,
  induction n with n hn,
  { exact e₁.iso_zero.trans (e₂.iso_zero.symm), },
  { rw [nat.cast_succ, e₁.iso_add, e₂.iso_add, hn, h], },
end

variable (e : shift_functor C (1 : ℤ) ⋙ F ≅ F ⋙ shift_functor D (1 : ℤ))

namespace mk_ℤ

noncomputable
def iso_ℕ : Π (n : ℕ), shift_functor C (int.of_nat n) ⋙ F ≅ F ⋙ shift_functor D (int.of_nat n)
| 0 := unit _ _
| 1 := e
| (n+2) := add (iso_ℕ (n+1)) e

@[simp]
lemma iso_ℕ_zero : iso_ℕ e 0 = unit _ _ := rfl

@[simp]
lemma iso_ℕ_one : iso_ℕ e 1 = e := rfl

lemma iso_ℕ_add_one (n : ℕ) : add (iso_ℕ e n) e = iso_ℕ e (n+1) :=
begin
  cases n,
  { unfold iso_ℕ,
    simp only [comm_shift.zero_add, change, eq_to_iso_refl, shift.compatibility.comm_shift.change_refl], },
  { unfold iso_ℕ, },
end

lemma iso_ℕ_add'_one (n₀ n₁ : ℕ) (h : n₀ + 1 = n₁) :
  add' (by { simp only [← h, int.of_nat_eq_coe], push_cast, })
    (iso_ℕ e n₀) e = iso_ℕ e n₁ :=
begin
  subst h,
  erw add'_eq_add,
  apply iso_ℕ_add_one,
end

def iso_ℤ : Π (n : ℤ), shift_functor C (n : ℤ) ⋙ F ≅ F ⋙ shift_functor D (n : ℤ)
| (int.of_nat n) := iso_ℕ e n
| -[1+n] := sub' (by { rw int.of_nat_eq_coe, rw int.neg_succ_of_nat_coe', push_cast, linarith, })
  (unit F ℤ) (iso_ℕ e (1+n))

@[simp]
lemma iso_ℤ_zero : iso_ℤ e 0 = unit _ _ := rfl

@[simp]
lemma iso_ℤ_one : iso_ℤ e 1 = e := rfl

lemma iso_ℕ_add' (n₁ n₂ n₃ : ℕ) (h : n₁ + n₂ = n₃) :
  add' (by simp only [← h, int.of_nat_eq_coe, nat.cast_add]) (iso_ℕ e n₁) (iso_ℕ e n₂) =
    iso_ℕ e n₃ :=
begin
  revert h n₃ n₁,
  induction n₂ with n₂ hn₂,
  { intros n₁ n₃ h,
    have h' : n₁ = n₃ := by simpa only [add_zero] using h,
    subst h',
    exact add'_zero (iso_ℕ e n₁), },
  { intros n₁ n₃ h,
    rw ← iso_ℕ_add_one,
    rw ← add'_eq_add,
    conv_lhs { congr, skip, congr, skip, rw ← iso_ℕ_one e, },
    erw ← add'_assoc (int.of_nat n₁) (int.of_nat n₂) 1 (int.of_nat (n₁ + n₂))
      (int.of_nat n₂ + 1) n₃ (by simp) (by simp) (by { rw ← h, push_cast, simp, rw add_assoc,}),
    rw hn₂ _ _ rfl,
    erw iso_ℕ_add'_one,
    rw [← h, nat.succ_eq_add_one, add_assoc], },
end

lemma iso_ℤ_add'_nonneg (n₁ n₂ n₃ : ℤ) (h : n₁ + n₂ = n₃) (hn₁ : 0 ≤ n₁) (hn₂ : 0 ≤ n₂) :
  add' h (iso_ℤ e n₁) (iso_ℤ e n₂) = iso_ℤ e n₃ :=
begin
  have h₁ : ∃ (m₁ : ℕ), n₁ = int.of_nat m₁ := int.eq_coe_of_zero_le hn₁,
  have h₂ : ∃ (m₂ : ℕ), n₂ = int.of_nat m₂ := int.eq_coe_of_zero_le hn₂,
  rcases h₁ with ⟨m₁, hm₁⟩,
  rcases h₂ with ⟨m₂, hm₂⟩,
  have h₃ : n₃ = int.of_nat (m₁ + m₂),
  { simp only [← h, hm₁, hm₂, int.of_nat_eq_coe, nat.cast_add], },
  substs hm₁ hm₂ h₃,
  unfold iso_ℤ,
  exact iso_ℕ_add' e _ _ _ rfl,
end

lemma iso_ℤ_add'_neg (n₁ n₂ : ℤ) (h : n₁ + n₂ = 0) (hn₂ : 0 ≤ n₂):
  add' h (iso_ℤ e n₁) (iso_ℤ e n₂) = unit F ℤ :=
begin
  cases n₁,
  { have hn₁ : 0 ≤ int.of_nat n₁ := int.of_nat_nonneg n₁,
    have h₂ : n₂ = 0 := by linarith,
    subst h₂,
    have h₁ : n₁ = 0 := by simpa only [int.of_nat_eq_coe, add_zero, nat.cast_eq_zero] using h,
    subst h₁,
    erw [iso_ℤ_zero, add'_zero], },
  { have h₂ : n₂ = int.of_nat (1 + n₁),
    { rw int.neg_succ_of_nat_coe' at h,
      rw int.of_nat_eq_coe,
      push_cast,
      linarith, },
    subst h₂,
    unfold iso_ℤ,
    apply add'_sub', },
end

lemma iso_ℤ_add'_one (n₀ n₁ : ℤ) (h : n₀ + 1 = n₁) : add' h (iso_ℤ e n₀) e = iso_ℤ e n₁ :=
begin
  cases n₀,
  { have h₁ : n₁ = int.of_nat (n₀ + 1),
    { rw ← h, simp, },
    subst h₁,
    unfold iso_ℤ,
    rw ← iso_ℕ_add_one e n₀,
    apply add'_eq_add, },
  { have h' := h,
    rw int.neg_succ_of_nat_coe' at h',
    apply (add'_bijective (show n₁ + int.of_nat n₀ = 0, by { rw int.of_nat_eq_coe, linarith, })
      (iso_ℤ e (int.of_nat n₀))).1 _,
    simp only,
    rw iso_ℤ_add'_neg e, swap, { apply int.of_nat_nonneg, },
    rw add'_assoc (-[1+n₀]) 1 (int.of_nat n₀) n₁ (int.of_nat (1+n₀)) 0 h
      (by simp) (by { rw int.neg_succ_of_nat_coe', simp,}),
    conv_lhs { congr, skip, congr, rw ← iso_ℤ_one e, },
    rw iso_ℤ_add'_nonneg e 1 (int.of_nat n₀) (int.of_nat (1+n₀)) (by simp) zero_le_one (int.of_nat_nonneg n₀),
    apply iso_ℤ_add'_neg,
    apply int.of_nat_nonneg, },
end

lemma iso_ℤ_add_one (n : ℤ) : add (iso_ℤ e n) (iso_ℤ e 1) = iso_ℤ e (n + 1) :=
begin
  rw ← add'_eq_add,
  apply iso_ℤ_add'_one,
end

end mk_ℤ

@[simps]
def mk'_ℤ (iso : Π (a : ℤ), shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (iso_zero : iso 0 = comm_shift.unit F ℤ)
  (iso_add_one : ∀ (a : ℤ), iso (a + 1) = comm_shift.add (iso a) (iso 1)) :
  has_comm_shift F ℤ :=
{ iso := iso,
  iso_zero := iso_zero,
  iso_add := begin
    have iso_add_one' : ∀ (a b : ℤ) (h : a + 1 = b),
      iso b = comm_shift.add' h (iso a) (iso 1),
    { intros a b h,
      subst h,
      rw add'_eq_add,
      apply iso_add_one, },
    suffices : ∀ (a b c : ℤ) (h : a + b = c) (hb : 0 ≤ b),
      iso c = add' h (iso a) (iso b),
    { intros a b,
      by_cases hb : 0 ≤ b,
      { rw [this a b _ rfl hb, add'_eq_add], },
      { rw ← add'_eq_add,
        apply (add'_bijective (show (a+b)+(-b) = a, by linarith) (iso (-b))).1,
        simp only [← this (a+b) (-b) a (by linarith) (by linarith),
          add'_assoc a b (-b) (a+b) 0 a rfl (by linarith) (by linarith),
          ← this b (-b) 0 (by linarith) (by linarith), iso_zero, add'_zero], }, },
    intros a b c h hb,
    obtain ⟨b', hb'⟩ := int.eq_coe_of_zero_le hb,
    subst hb',
    clear hb,
    revert a c,
    induction b' with b hb,
    { intros a c h,
      have hc : c = a := by simp only [←h, nat.cast_zero, add_zero],
      subst hc,
      erw [iso_zero, add'_zero], },
    { intros a c h,
      rw iso_add_one' b b.succ (by push_cast),
      rw ← add'_assoc a b 1 _ b.succ c rfl (by push_cast)
        (by { rw ← h, push_cast, rw add_assoc, }),
      rw ← hb a _ rfl,
      apply iso_add_one', },
  end}

@[simps]
def mk_ℤ (e : shift_functor C (1 : ℤ) ⋙ F ≅ F ⋙ shift_functor D (1 : ℤ)) :
  has_comm_shift F ℤ :=
mk'_ℤ (mk_ℤ.iso_ℤ e) rfl (λ a, (mk_ℤ.iso_ℤ_add_one e a).symm)

variable (F)

@[simps]
def equiv_ℤ : has_comm_shift F ℤ ≃
  (shift_functor C (1 : ℤ) ⋙ F ≅ F ⋙ shift_functor D (1 : ℤ)) :=
{ to_fun := λ c, c.iso 1,
  inv_fun := λ e, mk_ℤ e,
  left_inv := λ c, by { ext, refl, },
  right_inv := λ e, rfl, }

end comm_shift

variable {A}

lemma iso_add_hom_app (F : C ⥤ D) [F.has_comm_shift A] (p q : A) (X : C) :
  (F.comm_shift_iso (p+q)).hom.app X = F.map ((shift_functor_add C p q).hom.app X) ≫
    (F.comm_shift_iso q).hom.app (X⟦p⟧) ≫ ((F.comm_shift_iso p).hom.app X)⟦q⟧' ≫
    (shift_functor_add D p q).inv.app (F.obj X) :=
begin
  simp only [comm_shift_iso_add, comm_shift.add, shift.compatibility.comm_shift.comp_hom_app,
    iso.symm_hom, iso.symm_inv, monoidal_functor.μ_iso_hom],
end

lemma map_shift_functor_add_comm {A : Type*} [add_comm_monoid A] (F : C ⥤ D)
  [has_shift C A] [has_shift D A] [F.has_comm_shift A] (p q : A) (X : C) :
    F.map ((shift_functor_add_comm C p q).hom.app X) ≫
      (F.comm_shift_iso p).hom.app (X⟦q⟧) ≫ ((F.comm_shift_iso q).hom.app X)⟦p⟧' =
    (F.comm_shift_iso q).hom.app (X⟦p⟧) ≫ ((F.comm_shift_iso p).hom.app X)⟦q⟧' ≫
      (shift_functor_add_comm D p q).hom.app (F.obj X) :=
begin
  have eq₁ := F.iso_add_hom_app p q X,
  simp only [← cancel_mono ((shift_functor_add D p q).hom.app (F.obj X)),
    assoc, iso.inv_hom_id_app] at eq₁,
  erw comp_id at eq₁,
  have eq₂ := F.iso_add_hom_app q p X,
  simp only [← cancel_epi (F.map ((shift_functor_add C q p).inv.app X)),
    ← F.map_comp_assoc, iso.inv_hom_id_app, F.map_id, id_comp] at eq₂,
  simp only [← cancel_epi (F.map ((shift_functor_add C p q).hom.app X)),
    ← cancel_mono ((shift_functor_add D q p).inv.app (F.obj X)), assoc],
  slice_rhs 1 3 { rw ← eq₁, },
  simp only [assoc, ← eq₂], clear eq₁ eq₂,
  dsimp only [shift_functor_add_comm, iso.symm, iso.trans, nat_trans.comp_app],
  simpa only [F.map_comp, ← F.map_comp_assoc, assoc, eq_to_iso, eq_to_hom_app, eq_to_hom_map,
    iso.hom_inv_id_app, iso.hom_inv_id_app_assoc, F.map_id, id_comp, comp_id,
    F.comm_shift_congr_iso (add_comm p q), assoc, eq_to_hom_trans, eq_to_hom_refl],
end

@[reassoc]
lemma compatibility_composition (F₁ : C ⥤ D) (F₂ : D ⥤ E)
  [F₁.has_comm_shift A] [F₂.has_comm_shift A] (a b : A) (X : C) :
  F₂.map ((shift_functor D b).map ((F₁.comm_shift_iso a).hom.app X)) ≫
  (F₂.comm_shift_iso b).hom.app ((shift_functor D a).obj (F₁.obj X)) =
  (F₂.comm_shift_iso b).hom.app (F₁.obj ((shift_functor C a).obj X)) ≫
    (shift_functor E b).map (F₂.map ((F₁.comm_shift_iso a).hom.app X)) :=
begin
  let α := (F₁.comm_shift_iso a).hom,
  let β := (F₂.comm_shift_iso b).hom,
  have eq := nat_trans.exchange (F₁.comm_shift_iso a).hom (𝟙 _) (𝟙 _) (F₂.comm_shift_iso b).hom,
  simp only [id_comp, comp_id] at eq,
  replace eq := congr_app eq.symm X,
  dsimp at eq,
  simpa only [assoc, id_comp, functor.map_id, comp_id] using eq,
end

instance has_comm_shift_comp (F₁ : C ⥤ D) (F₂ : D ⥤ E)
  [F₁.has_comm_shift A] [F₂.has_comm_shift A] : (F₁ ⋙ F₂).has_comm_shift A :=
{ iso := λ a, comm_shift_comp (F₁.comm_shift_iso a) (F₂.comm_shift_iso a),
  iso_zero := begin
    ext X,
    simp only [comm_shift_comp_hom_app, F₁.comm_shift_iso_zero A,
      F₂.comm_shift_iso_zero A],
    dsimp only [comm_shift.unit, shift.compatibility.comm_shift.unit],
    simp only [iso.trans_hom, iso_whisker_right_hom, iso.symm_hom,
      iso_whisker_left_hom, monoidal_functor.ε_iso_hom,
      nat_trans.comp_app, whisker_right_app, left_unitor_hom_app, right_unitor_inv_app,
      whisker_left_app, id_comp, map_comp, assoc, comp_map],
    erw [functor.map_id, id_comp, id_comp],
    dsimp [monoidal_functor.ε_iso],
    nth_rewrite 1 ← F₂.map_comp_assoc,
    rw [← nat_trans.comp_app, is_iso.hom_inv_id],
    erw [F₂.map_id, id_comp],
  end,
  iso_add := λ a b, begin
    ext X,
    simp only [assoc, comm_shift_comp_hom_app, comm_shift.add_hom_app, comp_map,
      comm_shift_iso_add, functor.map_comp, comp],
    slice_lhs 4 5 { erw [← F₂.map_comp, iso.inv_hom_id_app, F₂.map_id], },
    simpa only [assoc, id_comp, compatibility_composition_assoc],
  end, }

lemma shift_functor_add'_hom_app_obj [F.has_comm_shift A] (a b c : A) (h : c = a + b)
  (K : C) :
  ((shift_functor_add' D a b c) h).hom.app (F.obj K) =
    (F.comm_shift_iso c).inv.app K ≫
      F.map (((shift_functor_add' _ a b c) h).hom.app K) ≫
      (F.comm_shift_iso b).hom.app (K⟦a⟧) ≫
      (shift_functor D b).map ((F.comm_shift_iso a).hom.app K) :=
begin
  subst h,
  simp only [shift_functor_add'_eq_shift_functor_add, F.comm_shift_iso_add,
    comm_shift.add, iso.symm_hom, shift.compatibility.comm_shift.comp_inv_app, assoc,
    ← F.map_comp_assoc, μ_hom_inv_app],
  erw [F.map_id, id_comp, iso.inv_hom_id_app_assoc, ← functor.map_comp,
    iso.inv_hom_id_app, functor.map_id, comp_id],
end

variable (A)

lemma shift_functor_zero_hom_app_obj [F.has_comm_shift A] (K : C) :
  (shift_functor_zero D A).hom.app (F.obj K) =
    (F.comm_shift_iso 0).inv.app K ≫ F.map ((shift_functor_zero C A).hom.app K) :=
begin
  rw F.comm_shift_iso_zero,
  dsimp [comm_shift.unit, shift.compatibility.comm_shift.unit],
  erw [comp_id, comp_id, assoc, ← F.map_comp],
  simp only [ε_hom_inv_app, map_id, comp_id],
end

instance id_has_comm_shift {C A : Type*} [category C]
  [add_monoid A] [has_shift C A] :
  (𝟭 C).has_comm_shift A :=
{ iso := λ a, by refl,
  iso_add := λ a b, begin
    ext X,
    dsimp only [iso.refl, comm_shift.add],
    simp only [nat_trans.id_app, shift.compatibility.comm_shift.comp_hom_app, id_map],
    erw [id_comp, functor.map_id, id_comp, iso.inv_hom_id_app],
    refl,
  end,
  iso_zero := begin
    ext X,
    dsimp only [iso.refl, comm_shift.unit, shift.compatibility.comm_shift.unit,
      iso.trans, functor.left_unitor, iso_whisker_right, whiskering_right,
      functor.map_iso, whisker_right, nat_trans.id_app, nat_trans.comp_app,
      functor.id, functor.right_unitor, iso.symm, iso_whisker_left,
      whiskering_left, whisker_left],
    erw [id_comp, id_comp, iso.inv_hom_id_app],
    refl,
  end, }

@[simp]
lemma has_comm_shift.id_iso_hom_app {C A : Type*} [category C]
  [add_monoid A] [has_shift C A] (X : C) (a : A) :
  (comm_shift_iso (𝟭 C) a).hom.app X = 𝟙 _ := rfl

@[simp]
lemma has_comm_shift.id_iso_inv_app {C A : Type*} [category C]
  [add_monoid A] [has_shift C A] (X : C) (a : A) :
  (comm_shift_iso (𝟭 C) a).inv.app X = 𝟙 _ := rfl

@[simp]
lemma has_comm_shift.comp_hom_app (F₁ : C ⥤ D) (F₂ : D ⥤ E)
  [F₁.has_comm_shift A] [F₂.has_comm_shift A] (X : C) (a : A) :
  (comm_shift_iso (F₁ ⋙ F₂) a).hom.app X =
    F₂.map ((comm_shift_iso F₁ a).hom.app X) ≫
      (comm_shift_iso F₂ a).hom.app (F₁.obj X) :=
comm_shift_comp_hom_app _ _ _

@[simp]
lemma has_comm_shift.comp_inv_app (F₁ : C ⥤ D) (F₂ : D ⥤ E)
  [F₁.has_comm_shift A] [F₂.has_comm_shift A] (X : C) (a : A) :
  (comm_shift_iso (F₁ ⋙ F₂) a).inv.app X =
    (comm_shift_iso F₂ a).inv.app (F₁.obj X) ≫
      F₂.map ((comm_shift_iso F₁ a).inv.app X) :=
comm_shift_comp_inv_app _ _ _

end functor

namespace shift

section

variables {C D : Type*} [category C] [category D] (F : C ⥤ D)
  {A : Type*} [add_monoid A] [has_shift D A] [full F] [faithful F]
  (s : A → C ⥤ C) (hs : Π (a : A), s a ⋙ F ≅ F ⋙ shift_functor D a)

local attribute [instance] endofunctor_monoidal_category

lemma has_shift_of_fully_faithful_map_ε_iso_hom_app (X : C) :
  F.map ((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).ε_iso.hom.app X) =
  (shift_zero A (F.obj X)).inv ≫ (hs 0).inv.app X :=
begin
  dsimp [shift_monoidal_functor],
  erw [id_comp, id_comp],
  simp only [functor.image_preimage],
end

lemma has_shift_of_fully_faithful_map_ε_iso_inv_app (X : C) :
  F.map ((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).ε_iso.inv.app X) =
  (hs 0).hom.app X ≫ (shift_zero A (F.obj X)).hom :=
begin
  rw [← cancel_mono (F.map ((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).ε_iso.hom.app X)), ← F.map_comp,
    iso.inv_hom_id_app, F.map_id, has_shift_of_fully_faithful_map_ε_iso_hom_app,
    assoc, iso.hom_inv_id_assoc, iso.hom_inv_id_app],
  refl,
end

lemma has_shift_of_fully_faithful_map_μ_iso_hom_app (a b : A) (X : C) :
  F.map (((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).μ_iso (discrete.mk a) (discrete.mk b)).hom.app X) =
    (hs b).hom.app ((s a).obj X) ≫ (shift_functor D b).map ((hs a).hom.app X) ≫
      (shift_functor_add D a b).inv.app (F.obj X) ≫ (hs (a + b)).inv.app X :=
begin
  dsimp [shift_monoidal_functor],
  erw [assoc, assoc, assoc, id_comp, comp_id, id_comp, functor.image_preimage],
end

lemma has_shift_of_fully_faithful_map_μ_iso_inv_app (a b : A) (X : C) :
  F.map (((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).μ_iso (discrete.mk a) (discrete.mk b)).inv.app X) =
      (hs (a + b)).hom.app X ≫
      (shift_functor_add D a b).hom.app (F.obj X) ≫
    (shift_functor D b).map ((hs a).inv.app X) ≫
    (hs b).inv.app ((s a).obj X) :=
begin
  erw [← cancel_mono (F.map (((@shift_monoidal_functor C A _ _
    (has_shift_of_fully_faithful F s hs)).μ_iso (discrete.mk a) (discrete.mk b)).hom.app X)),
    ← F.map_comp, iso.inv_hom_id_app, F.map_id, assoc, assoc, assoc,
    has_shift_of_fully_faithful_map_μ_iso_hom_app, iso.inv_hom_id_app_assoc,
    ← functor.map_comp_assoc, iso.inv_hom_id_app, functor.map_id, id_comp,
    iso.hom_inv_id_app_assoc, iso.hom_inv_id_app],
  refl,
end

def has_comm_shift_of_fully_faithful :
  @functor.has_comm_shift _ _ _ _ F A _ (has_shift_of_fully_faithful F s hs) _ :=
{ iso := hs,
  iso_add := λ a b, begin
    ext X,
    dsimp only [functor.comm_shift.add, compatibility.comm_shift.comp,
      iso.trans, iso.symm, nat_trans.comp_app, iso_whisker_right,
      whiskering_right, functor.map_iso, whisker_right, functor.associator,
      iso_whisker_left, whiskering_left, whisker_left],
    erw [id_comp, id_comp, id_comp, has_shift_of_fully_faithful_map_μ_iso_inv_app,
      assoc, assoc, assoc, iso.inv_hom_id_app_assoc, ← functor.map_comp_assoc,
      iso.inv_hom_id_app, functor.map_id, id_comp,
      iso.symm_hom, monoidal_functor.μ_iso_hom, μ_inv_hom_app, comp_id],
  end,
  iso_zero := begin
    ext X,
    dsimp only [functor.comm_shift.unit, compatibility.comm_shift.unit, iso.trans,
      iso_whisker_right, whiskering_right, functor.left_unitor, nat_trans.comp_app,
      functor.right_unitor, iso.symm, iso_whisker_left, whiskering_left,
      functor.map_iso, whisker_right, whisker_left],
    erw [id_comp, id_comp, has_shift_of_fully_faithful_map_ε_iso_inv_app],
    simp only [iso.app_hom, iso.symm_hom, monoidal_functor.ε_iso_hom, assoc, ε_inv_hom_app],
    erw comp_id,
  end, }

end

end shift

end category_theory

section

open category_theory

variables {C : Type*} [category C]

class set.is_stable_by_shift (S : set C) (A : Type*) [add_monoid A] [has_shift C A] : Prop :=
(condition [] : ∀ (a : A) (X : C) (hX : X ∈ S), X⟦a⟧ ∈ S)

end

namespace category_theory

namespace shift

section

variables {C A : Type*} [category C] [add_monoid A] [has_shift C A]
  (S : set C) [S.is_stable_by_shift A]

instance has_shift_full_subcategory :
  has_shift (full_subcategory S) A :=
has_shift_of_fully_faithful (full_subcategory_inclusion S)
  (λ a, full_subcategory.lift _ (full_subcategory_inclusion S ⋙ shift_functor C a)
  (λ X, set.is_stable_by_shift.condition a X.1 X.2))
  (λ a, full_subcategory.lift_comp_inclusion _ _ _)

instance has_comm_shift_full_subcategory_inclusion :
  (full_subcategory_inclusion S).has_comm_shift A :=
has_comm_shift_of_fully_faithful _ _ _

end

end shift

namespace functor

namespace has_comm_shift

@[simps]
def of_iso {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (e : F ≅ G) (A : Type*) [add_monoid A] [has_shift C A] [has_shift D A]
  [F.has_comm_shift A] : G.has_comm_shift A :=
{ iso := λ a, iso_whisker_left _ e.symm ≪≫ comm_shift_iso F a ≪≫
      iso_whisker_right e _,
  iso_zero := begin
    ext X,
    simp only [iso.trans_hom, iso_whisker_left_hom, iso.symm_hom, iso_whisker_right_hom,
      nat_trans.comp_app, whisker_left_app, whisker_right_app, comm_shift.unit_hom_app,
      iso.symm_inv, monoidal_functor.ε_iso_hom, comm_shift_iso_zero, assoc,
      ← nat_trans.naturality_assoc, ← nat_trans.naturality],
    dsimp,
    simp only [iso.inv_hom_id_app_assoc],
  end,
  iso_add := λ a b, begin
    ext X,
    simp only [iso.trans_hom, iso_whisker_left_hom, iso.symm_hom, iso_whisker_right_hom,
      nat_trans.comp_app, whisker_left_app, whisker_right_app, comm_shift.add_hom_app,
      map_comp, iso.symm_inv, monoidal_functor.μ_iso_hom, assoc, μ_naturality,
      comm_shift_iso_add],
    erw nat_trans.naturality_assoc,
    rw [← functor.map_comp_assoc, iso.hom_inv_id_app, functor.map_id, id_comp],
    refl,
  end, }

end has_comm_shift

end functor

namespace nat_trans

variables {C D : Type*} [category C] [category D] {F G : C ⥤ D} (τ : F ⟶ G) (e : F ≅ G)
  (A : Type*) [add_monoid A] [has_shift C A] [has_shift D A] [F.has_comm_shift A]
  [G.has_comm_shift A]

class respects_comm_shift : Prop :=
(comm [] : ∀ (a : A), (F.comm_shift_iso a).hom ≫ whisker_right τ _ =
  whisker_left _ τ ≫ (G.comm_shift_iso a).hom)

variable {A}

namespace respects_comm_shift

@[reassoc]
lemma comm_app (a : A) (X : C) [τ.respects_comm_shift A] :
  (F.comm_shift_iso a).hom.app X ≫ (τ.app X)⟦a⟧' =
  τ.app (X⟦a⟧) ≫ (G.comm_shift_iso a).hom.app X :=
congr_app (respects_comm_shift.comm τ a) X

lemma app_shift (a : A) (X : C) [τ.respects_comm_shift A] :
  τ.app (X⟦a⟧) = (F.comm_shift_iso a).hom.app X ≫
    (τ.app X)⟦a⟧' ≫ (G.comm_shift_iso a).inv.app X :=
by erw [comm_app_assoc, iso.hom_inv_id_app, comp_id]

lemma of_iso {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (e : F ≅ G) (A : Type*) [add_monoid A] [has_shift C A] [has_shift D A]
  [F.has_comm_shift A] :
  @respects_comm_shift _ _ _ _ _ _ e.hom A _ _ _ _ (functor.has_comm_shift.of_iso e A) :=
begin
  letI := functor.has_comm_shift.of_iso e A,
  refine ⟨λ a, _⟩,
  conv_rhs { dsimp [functor.comm_shift_iso, functor.has_comm_shift.iso], },
  ext X,
  simpa only [comp_app, whisker_left_app, iso.hom_inv_id_app_assoc],
end

instance nat_iso_inv [e.hom.respects_comm_shift A] : e.inv.respects_comm_shift A :=
⟨λ a, begin
  ext X,
  simp only [comp_app, whisker_right_app, whisker_left_app,
    ← cancel_mono ((shift_functor D a).map (e.hom.app X)), assoc,
    respects_comm_shift.comm_app e.hom a X, e.inv_hom_id_app_assoc,
    ← functor.map_comp, e.inv_hom_id_app, functor.map_id],
  apply comp_id,
end⟩

lemma of_iso_hom : e.hom.respects_comm_shift A ↔ e.inv.respects_comm_shift A :=
begin
  split,
  { introI,
    apply_instance, },
  { intro h,
    haveI : e.symm.hom.respects_comm_shift A := h,
    change e.symm.inv.respects_comm_shift A,
    apply_instance, },
end

instance of_comp {H : C ⥤ D} (τ' : G ⟶ H) [H.has_comm_shift A] [τ.respects_comm_shift A]
  [τ'.respects_comm_shift A] : (τ ≫ τ').respects_comm_shift A :=
⟨λ a, begin
  ext X,
  simp only [whisker_right_comp, comp_app, whisker_right_app, whisker_left_comp, assoc,
    whisker_left_app, comm_app_assoc, comm_app],
end⟩

instance associator {C₁ C₂ C₃ C₄ : Type*} [category C₁] [category C₂] [category C₃] [category C₄]
  [has_shift C₁ A] [has_shift C₂ A] [has_shift C₃ A] [has_shift C₄ A]
  (F₁ : C₁ ⥤ C₂) (F₂ : C₂ ⥤ C₃) (F₃ : C₃ ⥤ C₄)
  [F₁.has_comm_shift A] [F₂.has_comm_shift A][F₃.has_comm_shift A] :
  (functor.associator F₁ F₂ F₃).hom.respects_comm_shift A :=
⟨λ a, begin
  ext X,
  simp only [comp_app, functor.has_comm_shift.comp_hom_app, functor.map_comp, assoc,
    whisker_right_app, functor.associator_hom_app, functor.map_id, whisker_left_app,
    functor.comp_map],
  dsimp,
  simp only [comp_id, id_comp],
end⟩

instance whisker_left {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃]
  [has_shift C₁ A] [has_shift C₂ A] [has_shift C₃ A]
  (F : C₁ ⥤ C₂) {G G' : C₂ ⥤ C₃} [F.has_comm_shift A] [G.has_comm_shift A]
  [G'.has_comm_shift A] (τ : G ⟶ G') [τ.respects_comm_shift A] :
  (whisker_left F τ).respects_comm_shift A :=
⟨λ a, begin
  ext X,
  simp only [comp_app, functor.has_comm_shift.comp_hom_app, whisker_right_app, whisker_left_app,
    assoc, whisker_left_twice, comm_app],
  apply nat_trans.naturality_assoc,
end⟩

instance whisker_right {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃]
  [has_shift C₁ A] [has_shift C₂ A] [has_shift C₃ A]
  {F F' : C₁ ⥤ C₂} [F.has_comm_shift A] [F'.has_comm_shift A]
  (G : C₂ ⥤ C₃) [G.has_comm_shift A]
  (τ : F ⟶ F') [τ.respects_comm_shift A] :
  (whisker_right τ G).respects_comm_shift A :=
⟨λ a, begin
  ext X,
  simp only [whisker_right_twice, comp_app, functor.has_comm_shift.comp_hom_app,
    whisker_right_app, functor.comp_map, assoc, whisker_left_app, ← G.map_comp_assoc,
    ← comm_app τ a X],
  erw [G.map_comp, assoc, ← nat_trans.naturality],
  refl,
end⟩

instance id : respects_comm_shift (𝟙 F) A :=
⟨λ a, by simp only [whisker_right_id', comp_id, whisker_left_id', id_comp]⟩

end respects_comm_shift

end nat_trans

namespace functor

namespace has_comm_shift

section

variables {C D E : Type*} [category C] [category D] [category E]
  {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} (e : F ⋙ G ≅ H)
  {A : Type*} [add_monoid A]
  [has_shift C A] [has_shift D A] [has_shift E A]
  [G.has_comm_shift A] [H.has_comm_shift A]
  [full G] [faithful G]

include e

def of_fully_faithful.iso (a : A) :
  shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a :=
nat_iso_of_comp_fully_faithful G
  (functor.associator _ _ _ ≪≫ iso_whisker_left _ e ≪≫
  H.comm_shift_iso a ≪≫ iso_whisker_right e.symm _ ≪≫
  functor.associator _ _ _ ≪≫ iso_whisker_left _ (G.comm_shift_iso a).symm ≪≫
  (functor.associator _ _ _).symm)

@[simp]
lemma of_fully_faithful.map_iso_hom_app (a : A) (X : C) :
  G.map ((of_fully_faithful.iso e a).hom.app X) =
    e.hom.app ((shift_functor C a).obj X) ≫ (H.comm_shift_iso a).hom.app X ≫
      (shift_functor E a).map (e.inv.app X) ≫ (G.comm_shift_iso a).inv.app (F.obj X) :=
begin
  dsimp [of_fully_faithful.iso],
  simp only [category.comp_id, category.id_comp, image_preimage],
end

@[simp]
lemma of_fully_faithful.map_iso_inv_app (a : A) (X : C) :
  G.map ((of_fully_faithful.iso e a).inv.app X) =
    (G.comm_shift_iso a).hom.app (F.obj X) ≫ (shift_functor E a).map (e.hom.app X) ≫
      (H.comm_shift_iso a).inv.app X ≫ e.inv.app ((shift_functor C a).obj X) :=
begin
  dsimp [of_fully_faithful.iso],
  simp only [category.id_comp, category.comp_id, category.assoc, image_preimage],
end

variable (A)

@[simps]
def of_fully_faithful : F.has_comm_shift A :=
{ iso := of_fully_faithful.iso e,
  iso_zero := begin
    ext X,
    apply G.map_injective,
    simp only [of_fully_faithful.map_iso_hom_app, comm_shift.unit_hom_app,
      iso.symm_hom, iso.symm_inv, monoidal_functor.ε_iso_hom, map_comp,
      comm_shift_iso_zero, comm_shift.unit_inv_app, assoc],
    erw nat_trans.naturality_assoc,
    simp only [id_map, ε_hom_inv_app_assoc],
    erw nat_trans.naturality_assoc,
    simp only [comp_map, iso.hom_inv_id_app_assoc],
  end,
  iso_add := λ a b, begin
    ext X,
    apply G.map_injective,
    simp only [of_fully_faithful.map_iso_hom_app, comm_shift.add_hom_app, iso.symm_hom,
      iso.symm_inv, monoidal_functor.μ_iso_hom, map_comp, assoc, comm_shift_iso_add,
      comm_shift.add_inv_app],
    erw [← nat_trans.naturality_assoc, ← nat_trans.naturality_assoc, ← nat_trans.naturality_assoc],
    dsimp,
    simp only [μ_hom_inv_app_assoc, of_fully_faithful.map_iso_hom_app, map_comp, assoc],
    nth_rewrite 2 ← functor.map_comp_assoc,
    rw [iso.inv_hom_id_app, functor.map_id, id_comp],
  end, }

include A

lemma of_fully_faithful_iso_hom_respects_comm_shift :
  by { haveI := of_fully_faithful e A, exact e.hom.respects_comm_shift A } :=
begin
  constructor,
  intro a,
  ext X,
  simp only [nat_trans.comp_app, comp_hom_app, whisker_right_app, assoc, whisker_left_app],
  conv_lhs { congr, dsimp [functor.comm_shift_iso], },
  simp only [of_fully_faithful.map_iso_hom_app, assoc, iso.inv_hom_id_app_assoc,
    nat_iso.cancel_nat_iso_hom_left, ← functor.map_comp, iso.inv_hom_id_app, functor.map_id],
  apply comp_id,
end

end

section

instance of_full_subcategory_lift {C D : Type*} [category C] [category D]
  (F : C ⥤ D) (S : set D) (A : Type*) [add_monoid A]
  [has_shift C A] [has_shift D A] [S.is_stable_by_shift A]
  [F.has_comm_shift A] (hS : ∀ (X : C), S (F.obj X)) :
  (full_subcategory.lift S F hS).has_comm_shift A :=
of_fully_faithful (full_subcategory.lift_comp_inclusion S F hS) A

instance of_full_subcategory_lift_iso_hom_respects_comm_shift
  {C D : Type*} [category C] [category D]
  (F : C ⥤ D) (S : set D) (A : Type*) [add_monoid A]
  [has_shift C A] [has_shift D A] [S.is_stable_by_shift A]
  [F.has_comm_shift A] (hS : ∀ (X : C), S (F.obj X)) :
  (full_subcategory.lift_comp_inclusion S F hS).hom.respects_comm_shift A :=
of_fully_faithful_iso_hom_respects_comm_shift _ _

end

end has_comm_shift

end functor

end category_theory


import pseudo_normed_group.CLC
/-!

# V-hat((M_c)^n)^{T⁻¹}

This file defines a fundamental construction defined just above Definition 9.3
in `analytic.pdf`: the subspac of V-hat(M_c^n) where the two actions of T⁻¹ coincide.

## Main definition

Here `M` is a profinitely filtered pseudo-normed group with `T⁻¹` scaling things by `r'`,
`V` is a seminormed group with `T⁻¹` scaling norms by `r`, `c` is a real (a filtration coefficient)
and `n` is a natural.

- `CLCFPTinv r V r' c n M`: the seminormed group defined as the subgroup of `V-hat(M_c^n)` where
  the two actions of `T⁻¹` (one coming from the action on M, the other coming from the
  action on V) coincide.

-/
open_locale classical nnreal
noncomputable theory
local attribute [instance] type_pow

namespace category_theory

theorem comm_sq₂ {C} [category C] {A₁ A₂ A₃ B₁ B₂ B₃ : C}
  {f₁ : A₁ ⟶ B₁} {f₂ : A₂ ⟶ B₂} {f₃ : A₃ ⟶ B₃}
  {a : A₁ ⟶ A₂} {a' : A₂ ⟶ A₃} {b : B₁ ⟶ B₂} {b' : B₂ ⟶ B₃}
  (h₁ : a ≫ f₂ = f₁ ≫ b) (h₂ : a' ≫ f₃ = f₂ ≫ b') : (a ≫ a') ≫ f₃ = f₁ ≫ b ≫ b' :=
by rw [category.assoc, h₂, ← category.assoc, h₁, ← category.assoc]

end category_theory

open SemiNormedGroup opposite Profinite pseudo_normed_group category_theory breen_deligne
open profinitely_filtered_pseudo_normed_group category_theory.limits
open normed_add_group_hom

namespace SemiNormedGroup

def equalizer {V W : SemiNormedGroup} (f g : V ⟶ W) := of (f.equalizer g)

namespace equalizer

def ι {V W : SemiNormedGroup} (f g : V ⟶ W) :
  equalizer f g ⟶ V :=
normed_add_group_hom.equalizer.ι _ _

@[reassoc] lemma condition {V W : SemiNormedGroup} (f g : V ⟶ W) :
  ι f g ≫ f = ι f g ≫ g :=
normed_add_group_hom.equalizer.comp_ι_eq _ _

lemma ι_range {V W : SemiNormedGroup} (f g : V ⟶ W) :
  (ι f g).range = (f - g).ker :=
begin
  ext, rw [normed_add_group_hom.mem_range, normed_add_group_hom.mem_ker],
  split,
  { rintro ⟨x, rfl⟩, rw [normed_add_group_hom.sub_apply], exact x.2 },
  { intro h, refine ⟨⟨x, h⟩, rfl⟩, }
end

lemma ι_range' {V W : SemiNormedGroup} (f g : V ⟶ W) :
  (ι f g).range = (g - f).ker :=
begin
  rw ι_range, ext x,
  simp only [normed_add_group_hom.mem_ker, normed_add_group_hom.sub_apply, sub_eq_zero],
  rw eq_comm
end

def map {V₁ V₂ W₁ W₂ : SemiNormedGroup} {f₁ f₂ g₁ g₂} (φ : V₁ ⟶ V₂) (ψ : W₁ ⟶ W₂)
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ) :
  equalizer f₁ g₁ ⟶ equalizer f₂ g₂ :=
normed_add_group_hom.equalizer.map _ _ hf.symm hg.symm

lemma map_comp_ι {V₁ V₂ W₁ W₂ : SemiNormedGroup} {f₁ f₂ g₁ g₂} (φ : V₁ ⟶ V₂) (ψ : W₁ ⟶ W₂)
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ) :
  map φ ψ hf hg ≫ ι _ _ = ι _ _ ≫ φ :=
rfl

theorem map_congr
  {V₁ V₂ W₁ W₂ : SemiNormedGroup} {f₁ f₂ g₁ g₂} {φ : V₁ ⟶ V₂} {ψ : W₁ ⟶ W₂}
  {V₁' V₂' W₁' W₂' : SemiNormedGroup} {f₁' f₂' g₁' g₂'} {φ' : V₁' ⟶ V₂'} {ψ' : W₁' ⟶ W₂'}
  {hf : φ ≫ f₂ = f₁ ≫ ψ} {hg : φ ≫ g₂ = g₁ ≫ ψ}
  {hf' : φ' ≫ f₂' = f₁' ≫ ψ'} {hg' : φ' ≫ g₂' = g₁' ≫ ψ'}
  (Hφ : arrow.mk φ = arrow.mk φ') (Hψ : arrow.mk ψ = arrow.mk ψ')
  (Hf₁ : arrow.mk f₁ = arrow.mk f₁') (Hf₂ : arrow.mk f₂ = arrow.mk f₂')
  (Hg₁ : arrow.mk g₁ = arrow.mk g₁') (Hg₂ : arrow.mk g₂ = arrow.mk g₂') :
  arrow.mk (map φ ψ hf hg) = arrow.mk (map φ' ψ' hf' hg') :=
by { cases Hφ, cases Hψ, cases Hf₁, cases Hf₂, cases Hg₁, cases Hg₂, refl }

lemma map_comp_map {V₁ V₂ V₃ W₁ W₂ W₃ : SemiNormedGroup} {f₁ f₂ f₃ g₁ g₂ g₃}
  {φ : V₁ ⟶ V₂} {ψ : W₁ ⟶ W₂} {φ' : V₂ ⟶ V₃} {ψ' : W₂ ⟶ W₃}
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ)
  (hf' : φ' ≫ f₃ = f₂ ≫ ψ') (hg' : φ' ≫ g₃ = g₂ ≫ ψ') :
  map φ ψ hf hg ≫ map φ' ψ' hf' hg' =
  map (φ ≫ φ') (ψ ≫ ψ') (comm_sq₂ hf hf') (comm_sq₂ hg hg') :=
by { ext, refl }

lemma map_id {J} [category J] {V W : SemiNormedGroup} (f g : V ⟶ W) :
  map (𝟙 V) (𝟙 W) (show 𝟙 V ≫ f = f ≫ 𝟙 W, by simp) (show 𝟙 V ≫ g = g ≫ 𝟙 W, by simp) = 𝟙 _ :=
by { ext, refl }

lemma norm_map_le {V₁ V₂ W₁ W₂ : SemiNormedGroup} {f₁ f₂ g₁ g₂} {φ : V₁ ⟶ V₂} {ψ : W₁ ⟶ W₂}
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ) (C : ℝ) (hφ : ∥ι f₁ g₁ ≫ φ∥ ≤ C) :
  ∥map φ ψ hf hg∥ ≤ C :=
normed_add_group_hom.equalizer.norm_map_le _ _ C hφ

@[simps obj map]
protected def F {J} [category J] {V W : J ⥤ SemiNormedGroup} (f g : V ⟶ W) : J ⥤ SemiNormedGroup :=
{ obj := λ X, of ((f.app X).equalizer (g.app X)),
  map := λ X Y φ, equalizer.map (V.map φ) (W.map φ) (f.naturality _) (g.naturality _),
  map_id' := λ X, by simp only [category_theory.functor.map_id]; exact normed_add_group_hom.equalizer.map_id,
  map_comp' := λ X Y Z φ ψ, begin
    simp only [functor.map_comp],
    exact (map_comp_map _ _ _ _).symm
  end }

@[simps]
def map_nat {J} [category J] {V₁ V₂ W₁ W₂ : J ⥤ SemiNormedGroup}
  {f₁ f₂ g₁ g₂} (φ : V₁ ⟶ V₂) (ψ : W₁ ⟶ W₂)
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ) :
  equalizer.F f₁ g₁ ⟶ equalizer.F f₂ g₂ :=
{ app := λ X, equalizer.map (φ.app X) (ψ.app X)
    (by rw [← nat_trans.comp_app, ← nat_trans.comp_app, hf])
    (by rw [← nat_trans.comp_app, ← nat_trans.comp_app, hg]),
  naturality' := λ X Y α, by simp only [equalizer.F_map, map_comp_map, nat_trans.naturality] }

lemma map_nat_comp_map_nat {J} [category J] {V₁ V₂ V₃ W₁ W₂ W₃ : J ⥤ SemiNormedGroup}
  {f₁ f₂ f₃ g₁ g₂ g₃} {φ : V₁ ⟶ V₂} {ψ : W₁ ⟶ W₂} {φ' : V₂ ⟶ V₃} {ψ' : W₂ ⟶ W₃}
  (hf : φ ≫ f₂ = f₁ ≫ ψ) (hg : φ ≫ g₂ = g₁ ≫ ψ)
  (hf' : φ' ≫ f₃ = f₂ ≫ ψ') (hg' : φ' ≫ g₃ = g₂ ≫ ψ') :
  map_nat φ ψ hf hg ≫ map_nat φ' ψ' hf' hg' =
  map_nat (φ ≫ φ') (ψ ≫ ψ') (comm_sq₂ hf hf') (comm_sq₂ hg hg') :=
by { ext, refl }

lemma map_nat_id {J} [category J] {V W : J ⥤ SemiNormedGroup} (f g : V ⟶ W) :
  map_nat (𝟙 V) (𝟙 W) (show 𝟙 V ≫ f = f ≫ 𝟙 W, by simp) (show 𝟙 V ≫ g = g ≫ 𝟙 W, by simp) = 𝟙 _ :=
by { ext, refl }

end equalizer
end SemiNormedGroup

universe variable u
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)]
variables (M M₁ M₂ M₃ : ProFiltPseuNormGrpWithTinv.{u} r')
variables (c c₁ c₂ c₃ c₄ c₅ c₆ c₇ c₈ : ℝ≥0) (l m n : ℕ)
variables (f : M₁ ⟶ M₂) (g : M₂ ⟶ M₃)

def CLCTinv (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : Profiniteᵒᵖ} (f g : A ⟶ B) :
  SemiNormedGroup :=
SemiNormedGroup.of $ normed_add_group_hom.equalizer
  ((CLC V).map f)
  ((CLC V).map g ≫ (CLC.T_inv r V).app B)

namespace CLCTinv

def ι (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : Profiniteᵒᵖ} (f g : A ⟶ B) :
  CLCTinv r V f g ⟶ (CLC V).obj A :=
SemiNormedGroup.equalizer.ι _ _

lemma ι_range (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : Profiniteᵒᵖ} (f g : A ⟶ B) :
  (ι r V f g).range =
    normed_add_group_hom.ker ((CLC V).map f - ((CLC V).map g ≫ (CLC.T_inv r V).app B)) :=
SemiNormedGroup.equalizer.ι_range _ _

lemma ι_range' (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : Profiniteᵒᵖ} (f g : A ⟶ B) :
  (ι r V f g).range =
    normed_add_group_hom.ker (((CLC V).map g ≫ (CLC.T_inv r V).app B) - (CLC V).map f) :=
SemiNormedGroup.equalizer.ι_range' _ _

def map {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ : ϕ ≫ f₂ = f₁ ≫ ψ) (h₂ : ϕ ≫ g₂ = g₁ ≫ ψ) :
  CLCTinv r V f₁ g₁ ⟶ CLCTinv r V f₂ g₂ :=
SemiNormedGroup.equalizer.map ((CLC V).map ϕ) ((CLC V).map ψ)
  (by rw [← functor.map_comp, ← functor.map_comp, h₁]) $
by rw [← category.assoc, ← functor.map_comp, h₂, functor.map_comp,
  category.assoc, (CLC.T_inv _ _).naturality, category.assoc]

lemma map_comp_ι {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ : ϕ ≫ f₂ = f₁ ≫ ψ) (h₂ : ϕ ≫ g₂ = g₁ ≫ ψ) :
  map r V f₁ g₁ f₂ g₂ ϕ ψ h₁ h₂ ≫ ι r V _ _ = ι _ _ _ _ ≫ (CLC V).map ϕ :=
normed_add_group_hom.equalizer.ι_comp_map _ _

lemma map_norm_noninc {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ h₂) :
  (CLCTinv.map r V f₁ g₁ f₂ g₂ ϕ ψ h₁ h₂).norm_noninc :=
equalizer.map_norm_noninc _ _ $ CLC.map_norm_noninc _ _

lemma norm_map_le {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ h₂) (C : ℝ≥0)
  (H : ∥SemiNormedGroup.equalizer.ι
         ((CLC V).map f₁)
         ((CLC V).map g₁ ≫ (CLC.T_inv r V).app B₁) ≫
       (CLC V).map ϕ∥ ≤ C) :
  ∥CLCTinv.map r V f₁ g₁ f₂ g₂ ϕ ψ h₁ h₂∥ ≤ C :=
SemiNormedGroup.equalizer.norm_map_le _ _ C H

@[simp] lemma map_id {A B : Profiniteᵒᵖ} (f g : A ⟶ B) :
  map r V f g f g (𝟙 A) (𝟙 B) rfl rfl = 𝟙 _ :=
begin
  simp only [map, SemiNormedGroup.equalizer.map, category_theory.functor.map_id],
  exact equalizer.map_id,
end

lemma map_comp {A₁ A₂ A₃ B₁ B₂ B₃ : Profiniteᵒᵖ}
  {f₁ g₁ : A₁ ⟶ B₁} {f₂ g₂ : A₂ ⟶ B₂} {f₃ g₃ : A₃ ⟶ B₃}
  (ϕ₁ : A₁ ⟶ A₂) (ϕ₂ : A₂ ⟶ A₃) (ψ₁ : B₁ ⟶ B₂) (ψ₂ : B₂ ⟶ B₃)
  (h1 h2 h3 h4 h5 h6) :
  CLCTinv.map r V f₁ g₁ f₃ g₃ (ϕ₁ ≫ ϕ₂) (ψ₁ ≫ ψ₂) h1 h2 =
  CLCTinv.map r V f₁ g₁ f₂ g₂ ϕ₁ ψ₁ h3 h4 ≫
  CLCTinv.map r V f₂ g₂ f₃ g₃ ϕ₂ ψ₂ h5 h6 :=
begin
  simp only [map, SemiNormedGroup.equalizer.map, category_theory.functor.map_comp],
  exact (equalizer.map_comp_map _ _ _ _).symm,
end

lemma map_comp_map {A₁ A₂ A₃ B₁ B₂ B₃ : Profiniteᵒᵖ}
  {f₁ g₁ : A₁ ⟶ B₁} {f₂ g₂ : A₂ ⟶ B₂} {f₃ g₃ : A₃ ⟶ B₃}
  (ϕ₁ : A₁ ⟶ A₂) (ϕ₂ : A₂ ⟶ A₃) (ψ₁ : B₁ ⟶ B₂) (ψ₂ : B₂ ⟶ B₃)
  (h₁ h₂ h₃ h₄) :
  CLCTinv.map r V f₁ g₁ f₂ g₂ ϕ₁ ψ₁ h₁ h₂ ≫
  CLCTinv.map r V f₂ g₂ f₃ g₃ ϕ₂ ψ₂ h₃ h₄ =
  CLCTinv.map r V f₁ g₁ f₃ g₃ (ϕ₁ ≫ ϕ₂) (ψ₁ ≫ ψ₂) (comm_sq₂ h₁ h₃) (comm_sq₂ h₂ h₄) :=
(map_comp _ _ _ _ _ _ _ _ _ _ _ _).symm

@[simps]
def map_iso {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ≅ A₂) (ψ : B₁ ≅ B₂) (h₁ : ϕ.hom ≫ f₂ = f₁ ≫ ψ.hom) (h₂ : ϕ.hom ≫ g₂ = g₁ ≫ ψ.hom) :
  CLCTinv r V f₁ g₁ ≅ CLCTinv r V f₂ g₂ :=
{ hom := map r V f₁ g₁ f₂ g₂ ϕ.hom ψ.hom h₁ h₂,
  inv := map r V f₂ g₂ f₁ g₁ ϕ.inv ψ.inv
    (by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, h₁])
    (by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, h₂]),
  hom_inv_id' := by { simp only [map_comp_map, iso.hom_inv_id], apply map_id },
  inv_hom_id' := by { simp only [map_comp_map, iso.inv_hom_id], apply map_id } }

lemma map_iso_isometry {A₁ B₁ A₂ B₂ : Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ≅ A₂) (ψ : B₁ ≅ B₂) (h₁ : ϕ.hom ≫ f₂ = f₁ ≫ ψ.hom) (h₂ : ϕ.hom ≫ g₂ = g₁ ≫ ψ.hom) :
  isometry (map_iso r V f₁ g₁ f₂ g₂ ϕ ψ h₁ h₂).hom :=
begin
  apply SemiNormedGroup.iso_isometry_of_norm_noninc;
  apply map_norm_noninc
end

@[simps]
protected def F {J} [category J] (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : J ⥤ Profiniteᵒᵖ} (f g : A ⟶ B) :
  J ⥤ SemiNormedGroup :=
{ obj := λ X, CLCTinv r V (f.app X) (g.app X),
  map := λ X Y φ, map _ _ _ _ _ _ (A.map φ) (B.map φ) (f.naturality _) (g.naturality _),
  map_id' := λ X, by simp only [category_theory.functor.map_id]; apply map_id,
  map_comp' := λ X Y Z φ ψ, by simp only [functor.map_comp]; apply map_comp }

theorem F_def {J} [category J] (r : ℝ≥0) (V : SemiNormedGroup)
  [normed_with_aut r V] [fact (0 < r)] {A B : J ⥤ Profiniteᵒᵖ} (f g : A ⟶ B) :
  CLCTinv.F r V f g = SemiNormedGroup.equalizer.F
    (whisker_right f (CLC V))
    (whisker_right g (CLC V) ≫ whisker_left B (CLC.T_inv r V)) := rfl

@[simps]
def map_nat {J} [category J] {A₁ B₁ A₂ B₂ : J ⥤ Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ : ϕ ≫ f₂ = f₁ ≫ ψ) (h₂ : ϕ ≫ g₂ = g₁ ≫ ψ) :
  CLCTinv.F r V f₁ g₁ ⟶ CLCTinv.F r V f₂ g₂ :=
{ app := λ X, map _ _ _ _ _ _ (ϕ.app X) (ψ.app X)
    (by rw [← nat_trans.comp_app, h₁, nat_trans.comp_app])
    (by rw [← nat_trans.comp_app, h₂, nat_trans.comp_app]),
  naturality' := λ X Y α, by simp only [CLCTinv.F_map, map_comp_map, ϕ.naturality, ψ.naturality] }

theorem map_nat_def {J} [category J] {A₁ B₁ A₂ B₂ : J ⥤ Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ⟶ A₂) (ψ : B₁ ⟶ B₂) (h₁ : ϕ ≫ f₂ = f₁ ≫ ψ) (h₂ : ϕ ≫ g₂ = g₁ ≫ ψ) :
  map_nat r V f₁ g₁ f₂ g₂ ϕ ψ h₁ h₂ = begin
    dsimp only [F_def],
    refine SemiNormedGroup.equalizer.map_nat
      (whisker_right ϕ (CLC V))
      (whisker_right ψ (CLC V))
      (by rw [← whisker_right_comp, ← whisker_right_comp, h₁])
      (comm_sq₂ _ _).symm,
    { exact whisker_right ψ _ },
    { rw [← whisker_right_comp, ← whisker_right_comp, h₂] },
    ext x : 2,
    simp only [nat_trans.comp_app, whisker_left_app, whisker_right_app,
      (CLC.T_inv _ _).naturality],
  end := rfl
.

-- @[simps]
def map_nat_iso {J} [category J] {A₁ B₁ A₂ B₂ : J ⥤ Profiniteᵒᵖ} (f₁ g₁ : A₁ ⟶ B₁) (f₂ g₂ : A₂ ⟶ B₂)
  (ϕ : A₁ ≅ A₂) (ψ : B₁ ≅ B₂) (h₁ : ϕ.hom ≫ f₂ = f₁ ≫ ψ.hom) (h₂ : ϕ.hom ≫ g₂ = g₁ ≫ ψ.hom) :
  CLCTinv.F r V f₁ g₁ ≅ CLCTinv.F r V f₂ g₂ :=
{ hom := map_nat r V f₁ g₁ f₂ g₂ ϕ.hom ψ.hom h₁ h₂,
  inv := map_nat r V f₂ g₂ f₁ g₁ ϕ.inv ψ.inv
    (by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, h₁])
    (by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, h₂]),
  hom_inv_id' :=
  begin
    simp only [map_nat_def, _root_.id, SemiNormedGroup.equalizer.map_nat_comp_map_nat,
      ← whisker_right_comp, iso.hom_inv_id, whisker_right_id', SemiNormedGroup.equalizer.map_nat_id],
    refl
  end,
  inv_hom_id' :=
  begin
    simp only [map_nat_def, _root_.id, SemiNormedGroup.equalizer.map_nat_comp_map_nat,
      ← whisker_right_comp, iso.inv_hom_id, whisker_right_id', SemiNormedGroup.equalizer.map_nat_id],
    refl
  end, }

end CLCTinv

lemma aux (r' c c₂ : ℝ≥0) [r1 : fact (r' ≤ 1)] [h : fact (c₂ ≤ r' * c)] : fact (c₂ ≤ c) :=
⟨h.1.trans $ (mul_le_mul' r1.1 le_rfl).trans (by simp)⟩

@[simps obj]
def CLCFPTinv₂ (r : ℝ≥0) (V : SemiNormedGroup)
  (r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [r1 : fact (r' ≤ 1)] [normed_with_aut r V]
  (c c₂ : ℝ≥0) [fact (c₂ ≤ r' * c)] (n : ℕ) : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
by haveI : fact (c₂ ≤ c) := aux r' c c₂; exact
CLCTinv.F r V
  (nat_trans.op (FiltrationPow.Tinv r' c₂ c n))
  (nat_trans.op (FiltrationPow.cast_le r' c₂ c n))

theorem CLCFPTinv₂_def (r : ℝ≥0) (V : SemiNormedGroup)
  (r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [r1 : fact (r' ≤ 1)] [normed_with_aut r V]
  (c c₂ : ℝ≥0) [fact (c₂ ≤ r' * c)] (n : ℕ) :
  CLCFPTinv₂ r V r' c c₂ n = SemiNormedGroup.equalizer.F
    (CLCFP.Tinv V r' c c₂ n)
    (@CLCFP.res V r' c c₂ n (aux r' c c₂) ≫ CLCFP.T_inv r V r' c₂ n) := rfl

instance CLCFPTinv₂.separated_space [fact (c₂ ≤ r' * c₁)] (M) :
  separated_space ((CLCFPTinv₂ r V r' c₁ c₂ n).obj M) :=
begin
  rw separated_iff_t2,
  refine @subtype.t2_space _ _ (id _) (id _),
  rw ← separated_iff_t2,
  apply uniform_space.completion.separated_space
end

instance CLCFPTinv₂.complete_space [fact (c₂ ≤ r' * c₁)] (M) :
  complete_space ((CLCFPTinv₂ r V r' c₁ c₂ n).obj M) :=
begin
  refine @is_closed.complete_space_coe _ (id _) (id _) _ _,
  { apply uniform_space.completion.complete_space },
  { refine is_closed_eq _ continuous_const,
    apply normed_add_group_hom.continuous }
end

/-- The functor that sends `M` and `c` to `V-hat((filtration M c)^n)^{T⁻¹}`,
defined by taking `T⁻¹`-invariants for two different actions by `T⁻¹`:

* The first comes from the action of `T⁻¹` on `M`.
* The second comes from the action of `T⁻¹` on `V`.

We take the equalizer of those two actions.

See the lines just above Definition 9.3 of [Analytic]. -/
def CLCFPTinv (r : ℝ≥0) (V : SemiNormedGroup) (r' : ℝ≥0)
  (c : ℝ≥0) (n : ℕ) [normed_with_aut r V] [fact (0 < r)] [fact (0 < r')] [fact (r' ≤ 1)] :
  (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
CLCFPTinv₂ r V r' c (r' * c) n

namespace CLCFPTinv₂

lemma map_norm_noninc [fact (c₂ ≤ r' * c)] [fact (c₂ ≤ c)]
  {M₁ M₂} (f : M₁ ⟶ M₂) : ((CLCFPTinv₂ r V r' c c₂ n).map f).norm_noninc :=
CLCTinv.map_norm_noninc _ _ _ _ _ _ _ _ _ _

def res [fact (c₂ ≤ r' * c₁)] [fact (c₂ ≤ c₁)] [fact (c₄ ≤ r' * c₃)] [fact (c₄ ≤ c₃)]
  [fact (c₃ ≤ c₁)] [fact (c₄ ≤ c₂)] : CLCFPTinv₂ r V r' c₁ c₂ n ⟶ CLCFPTinv₂ r V r' c₃ c₄ n :=
CLCTinv.map_nat r V _ _ _ _
  (nat_trans.op (FiltrationPow.cast_le _ c₃ c₁ n))
  (nat_trans.op (FiltrationPow.cast_le _ c₄ c₂ n)) rfl rfl

@[simp] lemma res_refl [fact (c₂ ≤ r' * c₁)] [fact (c₂ ≤ c₁)] : res r V r' c₁ c₂ c₁ c₂ n = 𝟙 _ :=
by { simp only [res, FiltrationPow.cast_le_refl, nat_trans.op_id], ext x : 2, apply CLCTinv.map_id }

lemma res_comp_res
  [fact (c₂ ≤ r' * c₁)] [fact (c₂ ≤ c₁)]
  [fact (c₄ ≤ r' * c₃)] [fact (c₄ ≤ c₃)]
  [fact (c₆ ≤ r' * c₅)] [fact (c₆ ≤ c₅)]
  [fact (c₃ ≤ c₁)] [fact (c₄ ≤ c₂)]
  [fact (c₅ ≤ c₃)] [fact (c₆ ≤ c₄)]
  [fact (c₅ ≤ c₁)] [fact (c₆ ≤ c₂)] :
  res r V r' c₁ c₂ c₃ c₄ n ≫ res r V r' c₃ c₄ c₅ c₆ n = res r V r' c₁ c₂ c₅ c₆ n :=
begin
  ext x : 2, simp only [res, nat_trans.comp_app],
  exact (CLCTinv.map_comp _ _ _ _ _ _ _ _ _ _ _ _).symm
end

lemma res_norm_noninc {_ : fact (c₂ ≤ r' * c₁)} {_ : fact (c₂ ≤ c₁)}
  {_ : fact (c₄ ≤ r' * c₃)} {_ : fact (c₄ ≤ c₃)} {_ : fact (c₃ ≤ c₁)} {_ : fact (c₄ ≤ c₂)} (M) :
  ((res r V r' c₁ c₂ c₃ c₄ n).app M).norm_noninc :=
CLCTinv.map_norm_noninc _ _ _ _ _ _ _ _ _ _

lemma norm_res_le [fact (c₂ ≤ r' * c₁)] [fact (c₂ ≤ c₁)] [fact (c₄ ≤ r' * c₃)] [fact (c₄ ≤ c₃)]
  [fact (c₃ ≤ c₁)] [fact (c₄ ≤ c₂)] (h₂₃ : c₂ = c₃) (M) :
  ∥(res r V r' c₁ c₂ c₃ c₄ n).app M∥ ≤ r :=
begin
  apply CLCTinv.norm_map_le,
  rw [← category.comp_id ((CLC V).map ((nat_trans.op (FiltrationPow.cast_le r' c₃ c₁ n)).app M))],
  have := nat_trans.congr_app (CLC.T r V).inv_hom_id ((FiltrationPow r' c₃ n).op.obj M),
  dsimp only [nat_trans.id_app] at this,
  rw [← this, CLC.T_inv_eq, nat_trans.comp_app, ← category.assoc ((CLC V).map _)],
  unfreezingI { subst c₃ },
  rw [← SemiNormedGroup.equalizer.condition_assoc, ← category.assoc],
  refine normed_add_group_hom.norm_comp_le_of_le' 1 r r (mul_one ↑r).symm _ _,
  { apply CLC.norm_T_le },
  { apply norm_noninc.norm_noninc_iff_norm_le_one.1,
    exact (CLC.map_norm_noninc V _).comp equalizer.ι_norm_noninc }
end

end CLCFPTinv₂

namespace CLCFPTinv

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) : ((CLCFPTinv r V r' c n).map f).norm_noninc :=
CLCFPTinv₂.map_norm_noninc _ _ _ _ _ _ _

def res [fact (c₂ ≤ c₁)] : CLCFPTinv r V r' c₁ n ⟶ CLCFPTinv r V r' c₂ n :=
CLCFPTinv₂.res r V r' c₁ _ c₂ _ n

@[simp] lemma res_refl : res r V r' c₁ c₁ n = 𝟙 _ :=
CLCFPTinv₂.res_refl _ _ _ _ _ _

lemma res_comp_res [fact (c₃ ≤ c₁)] [fact (c₅ ≤ c₃)] [fact (c₅ ≤ c₁)] :
  res r V r' c₁ c₃ n ≫ res r V r' c₃ c₅ n = res r V r' c₁ c₅ n :=
CLCFPTinv₂.res_comp_res _ _ _ _ _ _ _ _ _ _

lemma res_norm_noninc {_ : fact (c₂ ≤ c₁)} (M) :
  ((res r V r' c₁ c₂ n).app M).norm_noninc :=
CLCFPTinv₂.res_norm_noninc r V r' _ _ _ _ _ _

lemma norm_res_le [fact (c₂ ≤ c₁)] [fact (c₂ ≤ r' * c₁)] (M) :
  ∥(res r V r' c₁ c₂ n).app M∥ ≤ r :=
begin
  rw ← res_comp_res r V r' c₁ (r' * c₁) c₂,
  refine norm_comp_le_of_le' _ _ _ (one_mul ↑r).symm _ (CLCFPTinv₂.norm_res_le r V r' _ _ _ _ n rfl M),
  apply norm_noninc.norm_noninc_iff_norm_le_one.1,
  exact CLCTinv.map_norm_noninc r V _ _ _ _ _ _ _ _
end

lemma norm_res_le_pow (N : ℕ) [fact (c₂ ≤ c₁)] [h : fact (c₂ ≤ r' ^ N * c₁)] (M) :
  ∥(res r V r' c₁ c₂ n).app M∥ ≤ (r ^ N) :=
begin
  unfreezingI { induction N with N ih generalizing c₁ c₂ },
  { rw pow_zero,
    apply norm_noninc.norm_noninc_iff_norm_le_one.1,
    exact CLCTinv.map_norm_noninc r V _ _ _ _ _ _ _ _ },
  haveI : fact (c₂ ≤ r' ^ N * c₁) := nnreal.fact_le_pow_mul_of_le_pow_succ_mul _ _ _,
  rw [pow_succ, mul_assoc] at h, resetI,
  rw [← res_comp_res r V r' c₁ (r' ^ N * c₁) c₂],
  exact norm_comp_le_of_le' _ _ _ (pow_succ _ _) (norm_res_le r V r' _ _ n M) (ih _ _)
end

end CLCFPTinv

namespace breen_deligne

open CLCFPTinv

variables (M) {l m n}

namespace universal_map

variables (ϕ ψ : universal_map m n)

def eval_CLCFPTinv₂
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂] :
  CLCFPTinv₂ r V r' c₁ c₂ n ⟶ CLCFPTinv₂ r V r' c₃ c₄ m :=
begin
  dsimp only [CLCFPTinv₂_def],
  refine SemiNormedGroup.equalizer.map_nat (ϕ.eval_CLCFP _ _ _ _) (ϕ.eval_CLCFP _ _ _ _)
    (Tinv_comp_eval_CLCFP V r' c₁ c₂ c₃ c₄ ϕ).symm _,
  haveI : fact (c₂ ≤ c₁) := aux r' _ _, haveI : fact (c₄ ≤ c₃) := aux r' _ _,
  have h₁ := res_comp_eval_CLCFP V r' c₁ c₂ c₃ c₄ ϕ,
  have h₂ := T_inv_comp_eval_CLCFP r V r' c₂ c₄ ϕ,
  have := comm_sq₂ h₁ h₂,
  exact this.symm
end

@[simp] lemma eval_CLCFPTinv₂_zero
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)] :
  (0 : universal_map m n).eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ = 0 :=
by { simp only [eval_CLCFPTinv₂, eval_CLCFP_zero], ext, refl }

@[simp] lemma eval_CLCFPTinv₂_add
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂]
  [ψ.suitable c₃ c₁] [ψ.suitable c₄ c₂] :
  (ϕ + ψ : universal_map m n).eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ =
  ϕ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ + ψ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ :=
by { simp only [eval_CLCFPTinv₂, eval_CLCFP_add], ext, refl }

@[simp] lemma eval_CLCFPTinv₂_sub
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂]
  [ψ.suitable c₃ c₁] [ψ.suitable c₄ c₂] :
  (ϕ - ψ : universal_map m n).eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ =
  ϕ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ - ψ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ :=
by { simp only [eval_CLCFPTinv₂, eval_CLCFP_sub], ext, refl }

lemma eval_CLCFPTinv₂_comp {l m n : FreeMat} (f : l ⟶ m) (g : m ⟶ n)
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)] [fact (c₆ ≤ r' * c₅)]
  [f.suitable c₅ c₃] [f.suitable c₆ c₄] [g.suitable c₃ c₁] [g.suitable c₄ c₂] :
  @eval_CLCFPTinv₂ r V _ _ r' _ _ c₁ c₂ c₅ c₆ _ _ (f ≫ g)
    _ _ (suitable.comp c₃) (suitable.comp c₄) =
  g.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ ≫ f.eval_CLCFPTinv₂ r V r' c₃ c₄ c₅ c₆ :=
begin
  dsimp only [eval_CLCFPTinv₂, CLCFPTinv₂_def], delta id,
  simp only [SemiNormedGroup.equalizer.map_nat_comp_map_nat],
  generalize_proofs h1 h2 h3 h4 h5 h6 h7 h8,
  revert h5 h6 h7 h8, resetI,
  have H1 : eval_CLCFP V r' c₁ c₅ (f ≫ g) = eval_CLCFP V r' c₁ c₃ g ≫ eval_CLCFP V r' c₃ c₅ f :=
    eval_CLCFP_comp V r' c₁ c₃ c₅ g f,
  have H2 : eval_CLCFP V r' c₂ c₆ (f ≫ g) = eval_CLCFP V r' c₂ c₄ g ≫ eval_CLCFP V r' c₄ c₆ f :=
    eval_CLCFP_comp V r' c₂ c₄ c₆ g f,
  rw [H1, H2],
  intros, refl,
end

lemma res_comp_eval_CLCFPTinv₂
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [fact (c₆ ≤ r' * c₅)] [fact (c₈ ≤ r' * c₇)]
  [fact (c₂ ≤ c₁)] [fact (c₃ ≤ c₁)] [fact (c₄ ≤ c₂)] [fact (c₄ ≤ c₃)]
  [fact (c₆ ≤ c₅)] [fact (c₇ ≤ c₅)] [fact (c₈ ≤ c₆)] [fact (c₈ ≤ c₇)]
  [ϕ.suitable c₅ c₁] [ϕ.suitable c₆ c₂]
  [ϕ.suitable c₇ c₃] [ϕ.suitable c₈ c₄] :
  CLCFPTinv₂.res r V r' c₁ c₂ c₃ c₄ n ≫ ϕ.eval_CLCFPTinv₂ r V r' c₃ c₄ c₇ c₈ =
    ϕ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₅ c₆ ≫ CLCFPTinv₂.res r V r' c₅ c₆ c₇ c₈ m :=
begin
  dsimp only [CLCFPTinv₂.res, eval_CLCFPTinv₂, CLCFPTinv₂_def, CLCTinv.map_nat_def], delta id,
  simp only [SemiNormedGroup.equalizer.map_nat_comp_map_nat],
  congr' 1; { simp only [← CLCFP.res_def], apply res_comp_eval_CLCFP },
end

lemma norm_eval_CLCFPTinv₂_le [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂] (N : ℕ) (h : ϕ.bound_by N) (M) :
  ∥(ϕ.eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄).app M∥ ≤ N :=
begin
  apply SemiNormedGroup.equalizer.norm_map_le,
  refine normed_add_group_hom.norm_comp_le_of_le' _ _ _ (mul_one _).symm _ _,
  { apply norm_eval_CLCFP_le, exact h },
  { apply norm_noninc.norm_noninc_iff_norm_le_one.1,
    exact equalizer.ι_norm_noninc }
end

def eval_CLCFPTinv [ϕ.suitable c₂ c₁] :
  CLCFPTinv r V r' c₁ n ⟶ CLCFPTinv r V r' c₂ m :=
ϕ.eval_CLCFPTinv₂ r V r' c₁ _ c₂ _

lemma eval_CLCFPTinv_def [ϕ.suitable c₂ c₁] :
  ϕ.eval_CLCFPTinv r V r' c₁ c₂ = ϕ.eval_CLCFPTinv₂ r V r' c₁ _ c₂ _ := rfl

@[simp] lemma eval_CLCFPTinv_zero :
  (0 : universal_map m n).eval_CLCFPTinv r V r' c₁ c₂ = 0 :=
by apply eval_CLCFPTinv₂_zero

@[simp] lemma eval_CLCFPTinv_add [ϕ.suitable c₂ c₁] [ψ.suitable c₂ c₁] :
  (ϕ + ψ : universal_map m n).eval_CLCFPTinv r V r' c₁ c₂ =
  ϕ.eval_CLCFPTinv r V r' c₁ c₂ + ψ.eval_CLCFPTinv r V r' c₁ c₂ :=
eval_CLCFPTinv₂_add _ _ _ _ _ _ _ _ _

@[simp] lemma eval_CLCFPTinv_sub [ϕ.suitable c₂ c₁] [ψ.suitable c₂ c₁] :
  (ϕ - ψ : universal_map m n).eval_CLCFPTinv r V r' c₁ c₂ =
  ϕ.eval_CLCFPTinv r V r' c₁ c₂ - ψ.eval_CLCFPTinv r V r' c₁ c₂ :=
eval_CLCFPTinv₂_sub _ _ _ _ _ _ _ _ _

lemma eval_CLCFPTinv_comp {l m n : FreeMat} (f : l ⟶ m) (g : m ⟶ n)
  [hg : g.suitable c₂ c₁] [hf : f.suitable c₃ c₂] :
  @eval_CLCFPTinv r V _ _ r' _ _ c₁ c₃ _ _ (f ≫ g) (suitable.comp c₂) =
    g.eval_CLCFPTinv r V r' c₁ c₂ ≫ f.eval_CLCFPTinv r V r' c₂ c₃ :=
by apply eval_CLCFPTinv₂_comp

lemma res_comp_eval_CLCFPTinv
  [fact (c₂ ≤ c₁)] [ϕ.suitable c₄ c₂] [ϕ.suitable c₃ c₁] [fact (c₄ ≤ c₃)] :
  res r V r' c₁ c₂ n ≫ ϕ.eval_CLCFPTinv r V r' c₂ c₄ =
    ϕ.eval_CLCFPTinv r V r' c₁ c₃ ≫ res r V r' c₃ c₄ m :=
by apply res_comp_eval_CLCFPTinv₂

lemma res_comp_eval_CLCFPTinv_absorb
  [fact (c₂ ≤ c₁)] [hϕ : ϕ.suitable c₃ c₂] :
  res r V r' c₁ c₂ n ≫ ϕ.eval_CLCFPTinv r V r' c₂ c₃ =
    @eval_CLCFPTinv r V _ _ r' _ _ c₁ c₃ _ _ ϕ (hϕ.le _ _ _ _ le_rfl (fact.out _)) :=
by rw [@res_comp_eval_CLCFPTinv r V _ _ r' _ _ c₁ c₂ c₃ c₃ _ _ ϕ
      (_root_.id _) (_root_.id _) (_root_.id _) (_root_.id _),
    res_refl, category.comp_id]

lemma eval_CLCFPTinv_comp_res_absorb
  {_: fact (c₃ ≤ c₂)} [hϕ : ϕ.suitable c₂ c₁] :
  ϕ.eval_CLCFPTinv r V r' c₁ c₂ ≫ res r V r' c₂ c₃ m =
    @eval_CLCFPTinv r V _ _ r' _ _ c₁ c₃ _ _ ϕ (hϕ.le _ _ _ _ (fact.out _) le_rfl) :=
by rw [← @res_comp_eval_CLCFPTinv r V _ _ r' _ _ c₁ c₁ c₂ c₃ _ _ ϕ
      (_root_.id _) (_root_.id _) (_root_.id _) (_root_.id _),
    res_refl, category.id_comp]

lemma norm_eval_CLCFPTinv_le [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁]
  (N : ℕ) (h : ϕ.bound_by N) (M) :
  ∥(ϕ.eval_CLCFPTinv r V r' c₁ c₂).app M∥ ≤ N :=
norm_eval_CLCFPTinv₂_le r V r' _ _ _ _ _ N h M

lemma eval_CLCFPTinv_norm_noninc [normed_with_aut r V] [fact (0 < r)]
  [h : ϕ.very_suitable r r' c₂ c₁] (M) :
  ((ϕ.eval_CLCFPTinv r V r' c₁ c₂).app M).norm_noninc :=
begin
  apply norm_noninc.norm_noninc_iff_norm_le_one.2,
  have h' := h,
  unfreezingI { rcases h with ⟨N, k, c', hN, hϕ, hr, H⟩ },
  haveI : fact (c' ≤ c₁) := ⟨H.trans $ fact.out _⟩,
  have aux := res_comp_eval_CLCFPTinv r V r' c₁ c' c₂ c₂ ϕ,
  rw [res_refl, category.comp_id] at aux,
  rw ← aux,
  refine le_trans _ hr,
  rw mul_comm,
  apply normed_add_group_hom.norm_comp_le_of_le,
  { apply_mod_cast norm_eval_CLCFPTinv_le, exact hN },
  { haveI : fact (c' ≤ r' ^ k * c₁) := ⟨H⟩,
    rw nnreal.coe_pow,
    apply norm_res_le_pow },
end

end universal_map

end breen_deligne

attribute [irreducible] CLCFPTinv₂ CLCFPTinv₂.res
  breen_deligne.universal_map.eval_CLCFPTinv₂


import Cdclt.Euf

open proof
open proof.sort proof.term
open rules eufRules

def U := atom 50
def a₁ := const 100 U
def a₂ := const 101 U
def a₃ := const 102 U
def a₄ := const 103 U
def b₁ := const 104 U
def b₂ := const 105 U
def f₁ := const 106 (mkArrowN [U, U, U])
def f₂ := const 107 (mkArrowN [U, U, U])
def f₃ := const 108 (mkArrowN [U, U])

theorem binCong :
  thHolds (mkEq a₁ a₂) → thHolds (mkEq b₁ b₂) → (thHolds (mkEq (mkApp (mkApp f₁ a₁) b₁) (mkApp (mkApp f₁ a₂) b₂))) :=
λ s0 : thHolds (mkEq a₁ a₂) =>
λ s1 : thHolds (mkEq b₁ b₂) =>
have s2 : thHolds (mkEq f₁ f₁) from refl
show (thHolds (mkEq (mkApp (mkApp f₁ a₁) b₁) (mkApp (mkApp f₁ a₂) b₂))) from cong (cong s2 s0) s1

/-
(SCOPE |:conclusion| (not (and (= a b) (or (not p3) (not (= (f a) (f b)))) p1 (or (not p1) (and p2 p3))))
  (EQ_RESOLVE |:conclusion| false
    (CHAIN_RESOLUTION |:conclusion| (not (= (f a) (f b)))
      (ASSUME |:conclusion| (or (not p3) (not (= (f a) (f b)))) |:args| ((or (not p3) (not (= (f a) (f b))))))
      (AND_ELIM |:conclusion| p3
        (CHAIN_RESOLUTION |:conclusion| (and p2 p3)
          (ASSUME |:conclusion| (or (not p1) (and p2 p3)) |:args| ((or (not p1) (and p2 p3))))
          (ASSUME |:conclusion| p1 |:args| (p1)) |:args| (false p1))
        |:args| (1))
      |:args| (false p3))
    (TRANS |:conclusion| (= (not (= (f a) (f b))) false)
      (CONG |:conclusion| (= (not (= (f a) (f b))) (not (= (f b) (f b))))
        (CONG |:conclusion| (= (= (f a) (f b)) (= (f b) (f b)))
          (CONG |:conclusion| (= (f a) (f b))
            (ASSUME |:conclusion| (= a b) |:args| ((= a b))) |:args| (23 f))
          (REFL |:conclusion| (= (f b) (f b)) |:args| ((f b))) |:args| (6))
        |:args| (17))
      (TRANS |:conclusion| (= (not (= (f b) (f b))) false)
        (CONG |:conclusion| (= (not (= (f b) (f b))) (not true))
          (THEORY_REWRITE |:conclusion| (= (= (f b) (f b)) true) |:args| ((= (= (f b) (f b)) true) 2 5))
          |:args| (17))
        (THEORY_REWRITE |:conclusion| (= (not true) false) |:args| ((= (not true) false) 1 6)))))
  |:args| ((= a b) (or (not p3) (not (= (f a) (f b)))) p1 (or (not p1) (and p2 p3))))
-/

def a := const 1000 U
def b := const 1001 U
def p₁ := const 1002 boolSort
def p₂ := const 1003 boolSort
def p₃ := const 1004 boolSort
def f := const 1005 (mkArrowN [U, U])
def fa := mkApp f a
def fb := mkApp f b

def eqab := mkEq a b
def eqfafb := mkEq fa fb
def eqfbfb := mkEq fb fb
def eqfbfbtop := mkEq eqfbfb top
def neqfbfb := mkNot eqfbfb
def eqneqfbfbbot := mkEq neqfbfb bot
def eqeqfafbeqfbfb := mkEq eqfafb eqfbfb
def eqneqfafbneqfbfb := mkEq (mkNot eqfafb) (mkNot eqfbfb)
def neqfafb := mkNot eqfafb
def eqneqfafbbot := mkEq neqfafb bot
def np₁ := mkNot p₁
def np₃ := mkNot p₃
def andp₂p₃ := mkAnd p₂ p₃
def ornp₁andp₂p₃ := mkOr np₁ andp₂p₃
def ornp₃neqfafb := mkOr np₃ neqfafb

theorem simpleCongRw :
  thHolds eqab → thHolds ornp₃neqfafb → thHolds p₁ → thHolds ornp₁andp₂p₃ → thHolds bot :=
λ s0 : thHolds eqab =>
λ s1 : thHolds ornp₃neqfafb =>
λ s2 : thHolds p₁ =>
λ s3 : thHolds ornp₁andp₂p₃ =>

have s4 : thHolds andp₂p₃ from thAssume (R1 (clOr s3) (clAssume s2) p₁)
have s5 : thHolds p₃ from andElim s4 1
have s6 : thHolds neqfafb from thAssume (R1 (clOr s1) (clAssume s5) p₃)

have s7 : thHolds eqfafb from cong refl s0
let s8_1 := @refl eqConst
let s8_2 := (cong s8_1 s7)
have s8 : thHolds eqeqfafbeqfbfb from cong s8_2 (@refl fb)
have s9 : thHolds eqneqfafbneqfbfb from cong (@refl notConst) s8
have s10 : thHolds (mkEq (mkNot top) bot) from thTrustValid
have s11 : thHolds eqfbfbtop from thTrustValid
have s12 : thHolds ((mkEq neqfbfb) (mkNot top)) from cong (@refl notConst) s11
have s13 : thHolds (mkEq neqfbfb bot) from trans s12 s10
have s14 : thHolds eqneqfafbbot from trans s9 s13
show thHolds bot from eqResolve s6 s14

/-
(SCOPE |:conclusion| (not (and (= a b) (and p1 true) (or (not p1) (and p2 p3)) (or (not p3) (not (= (f a) (f b))))))
  (CHAIN_RESOLUTION |:conclusion| false
    (REORDERING |:conclusion| (or (= (f a) (f b)) (not (= a b)))
      (IMPLIES_ELIM |:conclusion| (or (not (= a b)) (= (f a) (f b)))
        (SCOPE |:conclusion| (=> (= a b) (= (f a) (f b)))
          (CONG |:conclusion| (= (f a) (f b))
            (SYMM |:conclusion| (= a b)
              (SYMM |:conclusion| (= b a)
                (ASSUME |:conclusion| (= a b) |:args| ((= a b))))) |:args| (23 f))
          |:args| ((= a b))))
      |:args| ((or (= (f a) (f b)) (not (= a b)))))
    (CHAIN_RESOLUTION |:conclusion| (not (= (f a) (f b)))
      (ASSUME |:conclusion| (or (not p3) (not (= (f a) (f b)))) |:args| ((or (not p3) (not (= (f a) (f b))))))
      (CHAIN_RESOLUTION |:conclusion| p3
        (REORDERING |:conclusion| (or p3 (not (and p2 p3)))
          (CNF_AND_POS |:conclusion| (or (not (and p2 p3)) p3) |:args| ((and p2 p3) 1)) |:args| ((or p3 (not (and p2 p3)))))
        (CHAIN_RESOLUTION |:conclusion| (and p2 p3)
          (ASSUME |:conclusion| (or (not p1) (and p2 p3)) |:args| ((or (not p1) (and p2 p3))))
          (EQ_RESOLVE |:conclusion| p1
            (ASSUME |:conclusion| (and p1 true) |:args| ((and p1 true)))
            (THEORY_REWRITE |:conclusion| (= (and p1 true) p1) |:args| ((= (and p1 true) p1) 1 5)))
          |:args| (false p1))
        |:args| (false (and p2 p3)))
      |:args| (false p3))
    (ASSUME |:conclusion| (= a b) |:args| ((= a b))) |:args| (true (= (f a) (f b)) false (= a b)))
  |:args| ((= a b) (and p1 true) (or (not p1) (and p2 p3)) (or (not p3) (not (= (f a) (f b))))))
-/

def andp₁t := mkAnd p₁ (val (value.bool true) boolSort)

theorem simpleCong :
  thHolds eqab → thHolds andp₁t → thHolds ornp₃neqfafb → thHolds p₁ → thHolds ornp₁andp₂p₃ → holds [] :=
  -- thHolds eqab → thHolds andp₁t → thHolds ornp₃neqfafb → thHolds p₁ → thHolds ornp₁andp₂p₃ → thHolds (mkOr (mkNot eqab) eqfafb) :=
fun a0 : thHolds eqab =>
fun a1 : thHolds andp₁t =>
fun a2 : thHolds ornp₃neqfafb =>
fun a3 : thHolds p₁ =>
fun a4 : thHolds ornp₁andp₂p₃ =>

have s0 : holds [mkNot eqab, eqfafb] from clOr (scope (
  fun a0 : thHolds eqab =>
  have s0 : thHolds (mkEq b a) from symm a0
  have s1 : thHolds eqab from symm s0
  show thHolds eqfafb from cong (@refl f) s1
  ))
have s1 : holds [eqfafb, mkNot eqab] from reorder s0 [1,0]

have s2 : holds [andp₂p₃] from R1 (clOr a4) (clAssume a3) p₁
have s3 : holds ([(mkNot (mkAndN [p₂, p₃])), p₃]) from @cnfAndPos ([p₂, p₃]) 1
have s4 : holds [p₃, mkNot andp₂p₃] from reorder s3 [1,0]

have s5 : thHolds (mkEq andp₁t p₁) from thTrustValid
have s6 : thHolds p₁ from eqResolve a1 s5
have s7 : holds [andp₂p₃] from R1 (clOr a4) (clAssume s6) p₁
have s8 : holds [p₃] from R1 s4 s7 andp₂p₃

have s9 : holds [neqfafb] from R1 (clOr a2) s8 p₃

show holds [] from R1 (R0 s1 s9 eqfafb) (clOr a0) eqab


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.traversable.derive
import control.traversable.lemmas
import data.dlist
import tactic.monotonicity.basic

variables {a b c p : Prop}

namespace tactic.interactive

open lean lean.parser  interactive
open interactive.types
open tactic

local postfix `?`:9001 := optional
local postfix *:9001 := many

meta inductive mono_function (elab : bool := tt)
 | non_assoc : expr elab → list (expr elab) → list (expr elab) → mono_function
 | assoc : expr elab → option (expr elab) → option (expr elab) → mono_function
 | assoc_comm : expr elab → expr elab → mono_function

meta instance : decidable_eq mono_function :=
by mk_dec_eq_instance

meta def mono_function.to_tactic_format : mono_function → tactic format
 | (mono_function.non_assoc fn xs ys) := do
  fn' ← pp fn,
  xs' ← mmap pp xs,
  ys' ← mmap pp ys,
  return format!"{fn'} {xs'} _ {ys'}"
 | (mono_function.assoc fn xs ys) := do
  fn' ← pp fn,
  xs' ← pp xs,
  ys' ← pp ys,
  return format!"{fn'} {xs'} _ {ys'}"
 | (mono_function.assoc_comm fn xs) := do
  fn' ← pp fn,
  xs' ← pp xs,
  return format!"{fn'} _ {xs'}"

meta instance has_to_tactic_format_mono_function : has_to_tactic_format mono_function :=
{ to_tactic_format := mono_function.to_tactic_format }

@[derive traversable]
meta structure ac_mono_ctx' (rel : Type) :=
  (to_rel : rel)
  (function : mono_function)
  (left right rel_def : expr)

@[reducible]
meta def ac_mono_ctx := ac_mono_ctx' (option (expr → expr → expr))
@[reducible]
meta def ac_mono_ctx_ne := ac_mono_ctx' (expr → expr → expr)

meta def ac_mono_ctx.to_tactic_format (ctx : ac_mono_ctx) : tactic format :=
do fn  ← pp ctx.function,
   l   ← pp ctx.left,
   r   ← pp ctx.right,
   rel ← pp ctx.rel_def,
   return format!"{{ function := {fn}\n, left  := {l}\n, right := {r}\n, rel_def := {rel} }"

meta instance has_to_tactic_format_mono_ctx : has_to_tactic_format ac_mono_ctx :=
{ to_tactic_format := ac_mono_ctx.to_tactic_format }

meta def as_goal (e : expr) (tac : tactic unit) : tactic unit :=
do gs ← get_goals,
   set_goals [e],
   tac,
   set_goals gs

open list (hiding map) functor dlist

section config

parameter opt : mono_cfg
parameter asms : list expr

meta def unify_with_instance (e : expr) : tactic unit :=
as_goal e $
apply_instance
<|>
apply_opt_param
<|>
apply_auto_param
<|>
tactic.solve_by_elim { lemmas := some asms }
<|>
reflexivity
<|>
applyc ``id
<|>
return ()

private meta def match_rule_head  (p : expr)
: list expr → expr → expr → tactic expr
 | vs e t :=
(unify t p >> mmap' unify_with_instance vs >> instantiate_mvars e)
<|>
do (expr.pi _ _ d b) ← return t | failed,
   v ← mk_meta_var d,
   match_rule_head (v::vs) (expr.app e v) (b.instantiate_var v)

meta def pi_head : expr → tactic expr
| (expr.pi n _ t b) :=
do v ← mk_meta_var t,
   pi_head (b.instantiate_var v)
| e := return e

meta def delete_expr (e : expr)
: list expr → tactic (option (list expr))
 | [] := return none
 | (x :: xs) :=
(compare opt e x >> return (some xs))
<|>
(map (cons x) <$> delete_expr xs)

meta def match_ac'
: list expr → list expr → tactic (list expr × list expr × list expr)
 | es (x :: xs) := do
    es' ← delete_expr x es,
    match es' with
     | (some es') := do
       (c,l,r) ← match_ac' es' xs, return (x::c,l,r)
     | none := do
       (c,l,r) ← match_ac' es xs, return (c,l,x::r)
    end
 | es [] := do
return ([],es,[])

meta def match_ac (l : list expr) (r : list expr)
: tactic (list expr × list expr × list expr) :=
do (s',l',r') ← match_ac' l r,
   s' ← mmap instantiate_mvars s',
   l' ← mmap instantiate_mvars l',
   r' ← mmap instantiate_mvars r',
   return (s',l',r')

meta def match_prefix
: list expr → list expr → tactic (list expr × list expr × list expr)
| (x :: xs) (y :: ys) :=
  (do compare opt x y,
      prod.map ((::) x) id <$> match_prefix xs ys)
<|> return ([],x :: xs,y :: ys)
| xs ys := return ([],xs,ys)

/--
`(prefix,left,right,suffix) ← match_assoc unif l r` finds the
longest prefix and suffix common to `l` and `r` and
returns them along with the differences  -/
meta def match_assoc (l : list expr) (r : list expr)
: tactic (list expr × list expr × list expr × list expr) :=
do (pre,l₁,r₁) ← match_prefix l r,
   (suf,l₂,r₂) ← match_prefix (reverse l₁) (reverse r₁),
   return (pre,reverse l₂,reverse r₂,reverse suf)

meta def check_ac : expr → tactic (bool × bool × option (expr × expr × expr) × expr)
 | (expr.app (expr.app f x) y) :=
   do t ← infer_type x,
      a ← try_core $ to_expr ``(is_associative %%t %%f) >>= mk_instance,
      c ← try_core $ to_expr ``(is_commutative %%t %%f) >>= mk_instance,
      i ← try_core (do
          v ← mk_meta_var t,
          l_inst_p ← to_expr ``(is_left_id %%t %%f %%v),
          r_inst_p ← to_expr ``(is_right_id %%t %%f %%v),
          l_v ← mk_meta_var l_inst_p,
          r_v ← mk_meta_var r_inst_p ,
          l_id ← mk_mapp `is_left_id.left_id [some t,f,v,some l_v],
          mk_instance l_inst_p >>= unify l_v,
          r_id ← mk_mapp `is_right_id.right_id [none,f,v,some r_v],
          mk_instance r_inst_p >>= unify r_v,
          v' ← instantiate_mvars v,
          return (l_id,r_id,v')),
      return (a.is_some,c.is_some,i,f)
 | _ := return (ff,ff,none,expr.var 1)

meta def parse_assoc_chain' (f : expr) : expr → tactic (dlist expr)
 | e :=
 (do (expr.app (expr.app f' x) y) ← return e,
     is_def_eq f f',
     (++) <$> parse_assoc_chain' x <*> parse_assoc_chain' y)
<|> return (singleton e)

meta def parse_assoc_chain (f : expr) : expr → tactic (list expr) :=
map dlist.to_list ∘ parse_assoc_chain' f

meta def fold_assoc (op : expr) :
  option (expr × expr × expr) → list expr → option (expr × list expr)
| _ (x::xs) := some (foldl (expr.app ∘ expr.app op) x xs, [])
| none []   := none
| (some (l_id,r_id,x₀)) [] := some (x₀,[l_id,r_id])

meta def fold_assoc1 (op : expr) : list expr → option expr
| (x::xs) := some $ foldl (expr.app ∘ expr.app op) x xs
| []   := none

meta def same_function_aux
: list expr → list expr → expr → expr → tactic (expr × list expr × list expr)
 | xs₀ xs₁ (expr.app f₀ a₀) (expr.app f₁ a₁) :=
   same_function_aux (a₀ :: xs₀) (a₁ :: xs₁) f₀ f₁
 | xs₀ xs₁ e₀ e₁ := is_def_eq e₀ e₁ >> return (e₀,xs₀,xs₁)

meta def same_function : expr → expr → tactic (expr × list expr × list expr) :=
same_function_aux [] []

meta def parse_ac_mono_function (l r : expr)
: tactic (expr × expr × list expr × mono_function) :=
do (full_f,ls,rs) ← same_function l r,
   (a,c,i,f) ← check_ac l,
   if a
   then if c
   then do
     (s,ls,rs) ← monad.join (match_ac
                   <$> parse_assoc_chain f l
                   <*> parse_assoc_chain f r),
     (l',l_id) ← fold_assoc f i ls,
     (r',r_id) ← fold_assoc f i rs,
     s' ← fold_assoc1 f s,
     return (l',r',l_id ++ r_id,mono_function.assoc_comm f s')
   else do -- a ∧ ¬ c
     (pre,ls,rs,suff) ← monad.join (match_assoc
                   <$> parse_assoc_chain f l
                   <*> parse_assoc_chain f r),
     (l',l_id) ← fold_assoc f i ls,
     (r',r_id) ← fold_assoc f i rs,
     let pre'  := fold_assoc1 f pre,
     let suff' := fold_assoc1 f suff,
     return (l',r',l_id ++ r_id,mono_function.assoc f pre' suff')
   else do -- ¬ a
     (xs₀,x₀,x₁,xs₁) ← find_one_difference opt ls rs,
     return (x₀,x₁,[],mono_function.non_assoc full_f xs₀ xs₁)

meta def parse_ac_mono_function' (l r : pexpr) :=
do l' ← to_expr l,
   r' ← to_expr r,
   parse_ac_mono_function l' r'

meta def ac_monotonicity_goal : expr → tactic (expr × expr × list expr × ac_mono_ctx)
 | `(%%e₀ → %%e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     t₀ ← infer_type e₀,
     t₁ ← infer_type e₁,
     rel_def ← to_expr ``(λ x₀ x₁, (x₀ : %%t₀) → (x₁ : %%t₁)),
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := some $ expr.pi `x binder_info.default
            , rel_def := rel_def })
 | `(%%e₀ = %%e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     t₀ ← infer_type e₀,
     t₁ ← infer_type e₁,
     rel_def ← to_expr ``(λ x₀ x₁, (x₀ : %%t₀) = (x₁ : %%t₁)),
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := none
            , rel_def := rel_def })
 | (expr.app (expr.app rel e₀) e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := expr.app ∘ expr.app rel
            , rel_def := rel })
 | _ := fail "invalid monotonicity goal"

meta def bin_op_left (f : expr)  : option expr → expr → expr
| none e := e
| (some e₀) e₁ := f.mk_app [e₀,e₁]

meta def bin_op (f a b : expr) : expr :=
f.mk_app [a,b]

meta def bin_op_right (f : expr) : expr → option expr → expr
| e none := e
| e₀ (some e₁) := f.mk_app [e₀,e₁]

meta def mk_fun_app : mono_function → expr → expr
 | (mono_function.non_assoc f x y) z := f.mk_app (x ++ z :: y)
 | (mono_function.assoc f x y) z := bin_op_left f x (bin_op_right f z y)
 | (mono_function.assoc_comm f x) z := f.mk_app [z,x]

meta inductive mono_law
   /- `assoc (l₀,r₀) (r₁,l₁)` gives first how to find rules to prove
      x+(y₀+z) R x+(y₁+z);
      if that fails, helps prove (x+y₀)+z R (x+y₁)+z -/
 | assoc : expr × expr → expr × expr → mono_law
   /- `congr r` gives the rule to prove `x = y → f x = f y` -/
 | congr : expr → mono_law
 | other : expr → mono_law

meta def mono_law.to_tactic_format : mono_law → tactic format
 | (mono_law.other e) := do e ← pp e, return format!"other {e}"
 | (mono_law.congr r) := do e ← pp r, return format!"congr {e}"
 | (mono_law.assoc (x₀,x₁) (y₀,y₁)) :=
do x₀ ← pp x₀,
   x₁ ← pp x₁,
   y₀ ← pp y₀,
   y₁ ← pp y₁,
   return format!"assoc {x₀}; {x₁} | {y₀}; {y₁}"

meta instance has_to_tactic_format_mono_law : has_to_tactic_format mono_law :=
{ to_tactic_format := mono_law.to_tactic_format }

meta def mk_rel (ctx : ac_mono_ctx_ne) (f : expr → expr) : expr :=
ctx.to_rel (f ctx.left) (f ctx.right)

meta def mk_congr_args (fn : expr) (xs₀ xs₁ : list expr) (l r : expr) : tactic expr :=
do p ← mk_app `eq [fn.mk_app $ xs₀ ++ l :: xs₁,fn.mk_app $ xs₀ ++ r :: xs₁],
   prod.snd <$> solve_aux p
     (do iterate_exactly (xs₁.length) (applyc `congr_fun),
         applyc `congr_arg)

meta def mk_congr_law (ctx : ac_mono_ctx) : tactic expr :=
match ctx.function with
 | (mono_function.assoc f x₀ x₁) :=
    if (x₀ <|> x₁).is_some
       then mk_congr_args f x₀.to_monad x₁.to_monad ctx.left ctx.right
       else failed
 | (mono_function.assoc_comm f x₀) := mk_congr_args f [x₀] [] ctx.left ctx.right
 | (mono_function.non_assoc f x₀ x₁) := mk_congr_args f x₀ x₁ ctx.left ctx.right
end

meta def mk_pattern (ctx : ac_mono_ctx) : tactic mono_law :=
match (sequence ctx : option (ac_mono_ctx' _)) with
 | (some ctx) :=
   match ctx.function with
    | (mono_function.assoc f (some x) (some y)) :=
      return $ mono_law.assoc
       ( mk_rel ctx (λ i, bin_op f x (bin_op f i y))
       , mk_rel ctx (λ i, bin_op f i y))
       ( mk_rel ctx (λ i, bin_op f (bin_op f x i) y)
       , mk_rel ctx (λ i, bin_op f x i))
    | (mono_function.assoc f (some x) none) :=
      return $ mono_law.other $
        mk_rel ctx (λ e, mk_fun_app ctx.function e)
    | (mono_function.assoc f none (some y)) :=
      return $ mono_law.other $
        mk_rel ctx (λ e, mk_fun_app ctx.function e)
    | (mono_function.assoc f none none) :=
      none
    | _ :=
      return $ mono_law.other $
         mk_rel ctx (λ e, mk_fun_app ctx.function e)
   end
 | none := mono_law.congr <$> mk_congr_law ctx
end

meta def match_rule (pat : expr) (r : name) : tactic expr :=
do  r' ← mk_const r,
    t  ← infer_type r',
    t  ← expr.dsimp t { fail_if_unchanged := ff } tt [] [
      simp_arg_type.expr ``(monotone), simp_arg_type.expr ``(strict_mono)],
    match_rule_head pat [] r' t

meta def find_lemma (pat : expr) : list name → tactic (list expr)
 | [] := return []
 | (r :: rs) :=
 do (cons <$> match_rule pat r <|> pure id) <*> find_lemma rs

meta def match_chaining_rules (ls : list name) (x₀ x₁ : expr) : tactic (list expr) :=
do x' ← to_expr ``(%%x₁ → %%x₀),
   r₀ ← find_lemma x' ls,
   r₁ ← find_lemma x₁ ls,
   return (expr.app <$> r₀ <*> r₁)

meta def find_rule (ls : list name) : mono_law → tactic (list expr)
 | (mono_law.assoc (x₀,x₁) (y₀,y₁)) :=
(match_chaining_rules ls x₀ x₁)
<|> (match_chaining_rules ls y₀ y₁)
 | (mono_law.congr r) := return [r]
 | (mono_law.other p) := find_lemma p ls

universes u v

def apply_rel {α : Sort u} (R : α → α → Sort v) {x y : α}
  (x' y' : α)
  (h : R x y)
  (hx : x = x')
  (hy : y = y')
: R x' y' :=
by { rw [← hx,← hy], apply h }

meta def ac_refine (e : expr) : tactic unit :=
refine ``(eq.mp _ %%e) ; ac_refl

meta def one_line (e : expr) : tactic format :=
do lbl ← pp e,
   asm ← infer_type e >>= pp,
   return format!"\t{asm}\n"

meta def side_conditions (e : expr) : tactic format :=
do let vs := e.list_meta_vars,
   ts ← mmap one_line vs.tail,
   let r := e.get_app_fn.const_name,
   return format!"{r}:\n{format.join ts}"

open monad

/-- tactic-facing function, similar to `interactive.tactic.generalize` with the
exception that meta variables -/
private meta def monotonicity.generalize' (h : name) (v : expr) (x : name) : tactic (expr × expr) :=
do tgt ← target,
   t ← infer_type v,
   tgt' ← do
   { ⟨tgt', _⟩ ← solve_aux tgt (tactic.generalize v x >> target),
     to_expr ``(λ y : %%t, Π x, y = x → %%(tgt'.binding_body.lift_vars 0 1)) }
   <|> to_expr ``(λ y : %%t, Π x, %%v = x → %%tgt),
   t ← head_beta (tgt' v) >>= assert h,
   swap,
   r ← mk_eq_refl v,
   solve1 $ tactic.exact (t v r),
   prod.mk <$> tactic.intro x <*> tactic.intro h

private meta def hide_meta_vars (tac : list expr → tactic unit) : tactic unit :=
focus1 $
do tgt ← target >>= instantiate_mvars,
   tactic.change tgt,
   ctx ← local_context,
   let vs := tgt.list_meta_vars,
   vs' ← mmap (λ v,
             do h ← get_unused_name `h,
                x ← get_unused_name `x,
                prod.snd <$> monotonicity.generalize' h v x) vs,
     tac ctx;
     vs'.mmap' (try ∘ tactic.subst)

meta def hide_meta_vars' (tac : itactic) : itactic :=
hide_meta_vars $ λ _, tac

end config

meta def solve_mvar (v : expr) (tac : tactic unit) : tactic unit :=
do gs ← get_goals,
   set_goals [v],
   target >>= instantiate_mvars >>= tactic.change,
   tac, done,
   set_goals $ gs

def list.minimum_on {α β} [linear_order β] (f : α → β) : list α → list α
| [] := []
| (x :: xs) := prod.snd $ xs.foldl (λ ⟨k,a⟩ b,
     let k' := f b in
     if k < k' then (k,a)
     else if k' < k then (k', [b])
     else (k,b :: a)) (f x, [x])

open format mono_selection

meta def best_match {β} (xs : list expr) (tac : expr → tactic β) : tactic unit :=
do t ← target,
   xs ← xs.mmap (λ x,
     try_core $ prod.mk x <$> solve_aux t (tac x >> get_goals)),
   let xs := xs.filter_map id,
   let r := list.minimum_on (list.length ∘ prod.fst ∘ prod.snd) xs,
   match r with
   | [(_,gs,pr)] :=  tactic.exact pr >> set_goals gs
   | [] := fail "no good match found"
   | _ :=
     do lmms ← r.mmap (λ ⟨l,gs,_⟩,
          do ts ← gs.mmap infer_type,
             msg ← ts.mmap pp,
             pure $ foldl compose "\n\n" $
               list.intersperse "\n" $ to_fmt l.get_app_fn.const_name :: msg),
        let msg := foldl compose "" lmms,
        fail format!("ambiguous match: {msg}\n\n" ++
          "Tip: try asserting a side condition to distinguish between the lemmas")
   end

meta def mono_aux (dir : parse side) :
  tactic unit :=
do t ← target >>= instantiate_mvars,
   ns ← get_monotonicity_lemmas t dir,
   asms ← local_context,
   rs ← find_lemma asms t ns,
   focus1 $ () <$ best_match rs (λ law, tactic.refine $ to_pexpr law)

/--
- `mono` applies a monotonicity rule.
- `mono*` applies monotonicity rules repetitively.
- `mono with x ≤ y` or `mono with [0 ≤ x,0 ≤ y]` creates an assertion for the listed
  propositions. Those help to select the right monotonicity rule.
- `mono left` or `mono right` is useful when proving strict orderings:
   for `x + y < w + z` could be broken down into either
    - left:  `x ≤ w` and `y < z` or
    - right: `x < w` and `y ≤ z`
- `mono using [rule1,rule2]` calls `simp [rule1,rule2]` before applying mono.
- The general syntax is
  `mono '*'? ('with' hyp | 'with' [hyp1,hyp2])? ('using' [hyp1,hyp2])? mono_cfg?`

To use it, first import `tactic.monotonicity`.

Here is an example of mono:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, -- unfold `(-)`, apply add_le_add
  { -- ⊢ k + 3 + x ≤ k + 4 + x
    mono, -- apply add_le_add, refl
    -- ⊢ k + 3 ≤ k + 4
    mono },
  { -- ⊢ -y ≤ -z
    mono /- apply neg_le_neg -/ }
end
```

More succinctly, we can prove the same goal as:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
by mono*
```

-/
meta def mono (many : parse (tk "*")?)
  (dir : parse side)
  (hyps : parse $ tk "with" *> pexpr_list_or_texpr <|> pure [])
  (simp_rules : parse $ tk "using" *> simp_arg_list <|> pure []) :
  tactic unit :=
do hyps ← hyps.mmap (λ p, to_expr p >>= mk_meta_var),
   hyps.mmap' (λ pr, do h ← get_unused_name `h, note h none pr),
   when (¬ simp_rules.empty) (simp_core { } failed tt simp_rules [] (loc.ns [none]) >> skip),
   if many.is_some
     then repeat $ mono_aux dir
     else mono_aux dir,
   gs ← get_goals,
   set_goals $ hyps ++ gs

add_tactic_doc
{ name       := "mono",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.mono],
  tags       := ["monotonicity"] }

/--
transforms a goal of the form `f x ≼ f y` into `x ≤ y` using lemmas
marked as `monotonic`.

Special care is taken when `f` is the repeated application of an
associative operator and if the operator is commutative
-/
meta def ac_mono_aux (cfg : mono_cfg := { mono_cfg . }) :
  tactic unit :=
hide_meta_vars $ λ asms,
do try `[simp only [sub_eq_add_neg]],
   tgt ← target >>= instantiate_mvars,
   (l,r,id_rs,g) ← ac_monotonicity_goal cfg tgt
             <|> fail "monotonic context not found",
   ns ← get_monotonicity_lemmas tgt both,
   p ← mk_pattern g,
   rules ← find_rule asms ns p <|> fail "no applicable rules found",
   when (rules = []) (fail "no applicable rules found"),
   err ← format.join <$> mmap side_conditions rules,
   focus1 $ best_match rules (λ rule, do
     t₀ ← mk_meta_var `(Prop),
     v₀ ← mk_meta_var t₀,
     t₁ ← mk_meta_var `(Prop),
     v₁ ← mk_meta_var t₁,
     tactic.refine $ ``(apply_rel %%(g.rel_def) %%l %%r %%rule %%v₀ %%v₁),
     solve_mvar v₀ (try (any_of id_rs rewrite_target) >>
             ( done <|>
               refl <|>
               ac_refl <|>
               `[simp only [is_associative.assoc]]) ),
     solve_mvar v₁ (try (any_of id_rs rewrite_target) >>
             ( done <|>
               refl <|>
               ac_refl <|>
               `[simp only [is_associative.assoc]]) ),
     n ← num_goals,
     iterate_exactly (n-1) (try $ solve1 $ apply_instance <|>
       tactic.solve_by_elim { lemmas := some asms }))

open sum nat

/-- (repeat_until_or_at_most n t u): repeat tactic `t` at most n times or until u succeeds -/
meta def repeat_until_or_at_most : nat → tactic unit → tactic unit → tactic unit
| 0        t _ := fail "too many applications"
| (succ n) t u := u <|> (t >> repeat_until_or_at_most n t u)

meta def repeat_until : tactic unit → tactic unit → tactic unit :=
repeat_until_or_at_most 100000

@[derive _root_.has_reflect, derive _root_.inhabited]
inductive rep_arity : Type
| one | exactly (n : ℕ) | many

meta def repeat_or_not : rep_arity → tactic unit → option (tactic unit) → tactic unit
 | rep_arity.one  tac none := tac
 | rep_arity.many tac none := repeat tac
 | (rep_arity.exactly n) tac none := iterate_exactly' n tac
 | rep_arity.one  tac (some until) := tac >> until
 | rep_arity.many tac (some until) := repeat_until tac until
 | (rep_arity.exactly n) tac (some until) := iterate_exactly n tac >> until

meta def assert_or_rule : lean.parser (pexpr ⊕ pexpr) :=
(tk ":=" *> inl <$> texpr <|> (tk ":" *> inr <$> texpr))

meta def arity : lean.parser rep_arity :=
rep_arity.many <$ tk "*" <|>
rep_arity.exactly <$> (tk "^" *> small_nat) <|>
pure rep_arity.one

/--

`ac_mono` reduces the `f x ⊑ f y`, for some relation `⊑` and a
monotonic function `f` to `x ≺ y`.

`ac_mono*` unwraps monotonic functions until it can't.

`ac_mono^k`, for some literal number `k` applies monotonicity `k`
times.

`ac_mono := h`, with `h` a hypothesis, unwraps monotonic functions and
uses `h` to solve the remaining goal. Can be combined with `*` or `^k`:
`ac_mono* := h`

`ac_mono : p` asserts `p` and uses it to discharge the goal result
unwrapping a series of monotonic functions. Can be combined with * or
^k: `ac_mono* : p`

In the case where `f` is an associative or commutative operator,
`ac_mono` will consider any possible permutation of its arguments and
use the one the minimizes the difference between the left-hand side
and the right-hand side.

To use it, first import `tactic.monotonicity`.

`ac_mono` can be used as follows:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
  ac_mono,
  -- ⊢ m + x + n ≤ y + n + m
  ac_mono,
end
```

As with `mono*`, `ac_mono*` solves the goal in one go and so does
`ac_mono* := h₁`. The latter syntax becomes especially interesting in the
following example:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : m + x + n ≤ y + n + m) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by ac_mono* := h₁.
```

By giving `ac_mono` the assumption `h₁`, we are asking `ac_refl` to
stop earlier than it would normally would.
-/
meta def ac_mono (rep : parse arity) :
         parse assert_or_rule? →
         opt_param mono_cfg { mono_cfg . } →
         tactic unit
 | none opt := focus1 $ repeat_or_not rep (ac_mono_aux opt) none
 | (some (inl h)) opt :=
do focus1 $ repeat_or_not rep (ac_mono_aux opt) (some $ done <|> to_expr h >>= ac_refine)
 | (some (inr t)) opt :=
do h ← i_to_expr t >>= assert `h,
   tactic.swap,
   focus1 $ repeat_or_not rep (ac_mono_aux opt) (some $ done <|> ac_refine h)
/-
TODO(Simon): with `ac_mono := h` and `ac_mono : p` split the remaining
  gaol if the provided rule does not solve it completely.
-/

add_tactic_doc
{ name       := "ac_mono",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.ac_mono],
  tags       := ["monotonicity"] }

attribute [mono] and.imp or.imp

end tactic.interactive