/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Eric Wieser

! This file was ported from Lean 3 source module ring_theory.graded_algebra.radical
! leanprover-community/mathlib commit f1944b30c97c5eb626e498307dec8b022a05bd0a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.GradedAlgebra.HomogeneousIdeal

/-!

This file contains a proof that the radical of any homogeneous ideal is a homogeneous ideal

## Main statements

* `ideal.is_homogeneous.is_prime_iff`: for any `I : ideal A`, if `I` is homogeneous, then
  `I` is prime if and only if `I` is homogeneously prime, i.e. `I ≠ ⊤` and if `x, y` are
  homogeneous elements such that `x * y ∈ I`, then at least one of `x,y` is in `I`.
* `ideal.is_prime.homogeneous_core`: for any `I : ideal A`, if `I` is prime, then
  `I.homogeneous_core 𝒜` (i.e. the largest homogeneous ideal contained in `I`) is also prime.
* `ideal.is_homogeneous.radical`: for any `I : ideal A`, if `I` is homogeneous, then the
  radical of `I` is homogeneous as well.
* `homogeneous_ideal.radical`: for any `I : homogeneous_ideal 𝒜`, `I.radical` is the the
  radical of `I` as a `homogeneous_ideal 𝒜`

## Implementation details

Throughout this file, the indexing type `ι` of grading is assumed to be a
`linear_ordered_cancel_add_comm_monoid`. This might be stronger than necessary but cancelling
property is strictly necessary; for a counterexample of how `ideal.is_homogeneous.is_prime_iff`
fails for a non-cancellative set see `counterexample/homogeneous_prime_not_prime.lean`.

## Tags

homogeneous, radical
-/

open GradedRing DirectSum SetLike Finset

open BigOperators

variable {ι σ A : Type _}

variable [CommRing A]

variable [LinearOrderedCancelAddCommMonoid ι]

variable [SetLike σ A] [AddSubmonoidClass σ A] {𝒜 : ι → σ} [GradedRing 𝒜]

include A

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Ideal.IsHomogeneous.isPrime_of_homogeneous_mem_or_mem {I : Ideal A} (hI : I.Homogeneous 𝒜)
    (I_ne_top : I ≠ ⊤)
    (homogeneous_mem_or_mem :
      ∀ {x y : A}, Homogeneous 𝒜 x → Homogeneous 𝒜 y → x * y ∈ I → x ∈ I ∨ y ∈ I) :
    Ideal.IsPrime I :=
  ⟨I_ne_top, by
    intro x y hxy
    by_contra rid
    obtain ⟨rid₁, rid₂⟩ := not_or_distrib.mp rid
    classical
      /-
        The idea of the proof is the following :
        since `x * y ∈ I` and `I` homogeneous, then `proj i (x * y) ∈ I` for any `i : ι`.
        Then consider two sets `{i ∈ x.support | xᵢ ∉ I}` and `{j ∈ y.support | yⱼ ∉ J}`;
        let `max₁, max₂` be the maximum of the two sets, then `proj (max₁ + max₂) (x * y) ∈ I`.
        Then, `proj max₁ x ∉ I` and `proj max₂ j ∉ I`
        but `proj i x ∈ I` for all `max₁ < i` and `proj j y ∈ I` for all `max₂ < j`.
        `  proj (max₁ + max₂) (x * y)`
        `= ∑ {(i, j) ∈ supports | i + j = max₁ + max₂}, xᵢ * yⱼ`
        `= proj max₁ x * proj max₂ y`
        `  + ∑ {(i, j) ∈ supports \ {(max₁, max₂)} | i + j = max₁ + max₂}, xᵢ * yⱼ`.
        This is a contradiction, because both `proj (max₁ + max₂) (x * y) ∈ I` and the sum on the
        right hand side is in `I` however `proj max₁ x * proj max₂ y` is not in `I`.
        -/
      set set₁ := (decompose 𝒜 x).support.filterₓ fun i => proj 𝒜 i x ∉ I with set₁_eq
      set set₂ := (decompose 𝒜 y).support.filterₓ fun i => proj 𝒜 i y ∉ I with set₂_eq
      have nonempty :
        ∀ x : A, x ∉ I → ((decompose 𝒜 x).support.filterₓ fun i => proj 𝒜 i x ∉ I).Nonempty :=
        by
        intro x hx
        rw [filter_nonempty_iff]
        contrapose! hx
        simp_rw [proj_apply] at hx
        rw [← sum_support_decompose 𝒜 x]
        exact Ideal.sum_mem _ hx
      set max₁ := set₁.max' (Nonempty x rid₁) with max₁_eq
      set max₂ := set₂.max' (Nonempty y rid₂) with max₂_eq
      have mem_max₁ : max₁ ∈ set₁ := max'_mem set₁ (Nonempty x rid₁)
      have mem_max₂ : max₂ ∈ set₂ := max'_mem set₂ (Nonempty y rid₂)
      replace hxy : proj 𝒜 (max₁ + max₂) (x * y) ∈ I := hI _ hxy
      have mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∈ I :=
        by
        set antidiag :=
          ((decompose 𝒜 x).support ×ˢ (decompose 𝒜 y).support).filterₓ fun z : ι × ι =>
            z.1 + z.2 = max₁ + max₂ with
          ha
        have mem_antidiag : (max₁, max₂) ∈ antidiag :=
          by
          simp only [add_sum_erase, mem_filter, mem_product]
          exact ⟨⟨mem_of_mem_filter _ mem_max₁, mem_of_mem_filter _ mem_max₂⟩, rfl⟩
        have eq_add_sum :=
          calc
            proj 𝒜 (max₁ + max₂) (x * y) = ∑ ij in antidiag, proj 𝒜 ij.1 x * proj 𝒜 ij.2 y := by
              simp_rw [ha, proj_apply, DirectSum.decompose_mul, DirectSum.coe_mul_apply 𝒜]
            _ =
                proj 𝒜 max₁ x * proj 𝒜 max₂ y +
                  ∑ ij in antidiag.erase (max₁, max₂), proj 𝒜 ij.1 x * proj 𝒜 ij.2 y :=
              (add_sum_erase _ _ mem_antidiag).symm

        rw [eq_sub_of_add_eq eq_add_sum.symm]
        refine' Ideal.sub_mem _ hxy (Ideal.sum_mem _ fun z H => _)
        rcases z with ⟨i, j⟩
        simp only [mem_erase, Prod.mk.inj_iff, Ne.def, mem_filter, mem_product] at H
        rcases H with ⟨H₁, ⟨H₂, H₃⟩, H₄⟩
        have max_lt : max₁ < i ∨ max₂ < j :=
          by
          rcases lt_trichotomy max₁ i with (h | rfl | h)
          · exact Or.inl h
          · refine' False.elim (H₁ ⟨rfl, add_left_cancel H₄⟩)
          · apply Or.inr
            have := add_lt_add_right h j
            rw [H₄] at this
            exact lt_of_add_lt_add_left this
        cases max_lt
        · -- in this case `max₁ < i`, then `xᵢ ∈ I`; for otherwise `i ∈ set₁` then `i ≤ max₁`.
          have not_mem : i ∉ set₁ := fun h =>
            lt_irrefl _ ((max'_lt_iff set₁ (Nonempty x rid₁)).mp max_lt i h)
          rw [set₁_eq] at not_mem
          simp only [not_and, Classical.not_not, Ne.def, mem_filter] at not_mem
          exact Ideal.mul_mem_right _ I (not_mem H₂)
        · -- in this case  `max₂ < j`, then `yⱼ ∈ I`; for otherwise `j ∈ set₂`, then `j ≤ max₂`.
          have not_mem : j ∉ set₂ := fun h =>
            lt_irrefl _ ((max'_lt_iff set₂ (Nonempty y rid₂)).mp max_lt j h)
          rw [set₂_eq] at not_mem
          simp only [not_and, Classical.not_not, Ne.def, mem_filter] at not_mem
          exact Ideal.mul_mem_left I _ (not_mem H₃)
      have not_mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∉ I :=
        by
        have neither_mem : proj 𝒜 max₁ x ∉ I ∧ proj 𝒜 max₂ y ∉ I :=
          by
          rw [mem_filter] at mem_max₁ mem_max₂
          exact ⟨mem_max₁.2, mem_max₂.2⟩
        intro rid
        cases homogeneous_mem_or_mem ⟨max₁, SetLike.coe_mem _⟩ ⟨max₂, SetLike.coe_mem _⟩ mem_I
        · apply neither_mem.1 h
        · apply neither_mem.2 h
      exact not_mem_I mem_I⟩
#align ideal.is_homogeneous.is_prime_of_homogeneous_mem_or_mem Ideal.IsHomogeneous.isPrime_of_homogeneous_mem_or_mem

theorem Ideal.IsHomogeneous.isPrime_iff {I : Ideal A} (h : I.Homogeneous 𝒜) :
    I.IsPrime ↔
      I ≠ ⊤ ∧
        ∀ {x y : A},
          SetLike.Homogeneous 𝒜 x → SetLike.Homogeneous 𝒜 y → x * y ∈ I → x ∈ I ∨ y ∈ I :=
  ⟨fun HI => ⟨ne_of_apply_ne _ HI.ne_top, fun x y hx hy hxy => Ideal.IsPrime.mem_or_mem HI hxy⟩,
    fun ⟨I_ne_top, homogeneous_mem_or_mem⟩ =>
    h.isPrime_of_homogeneous_mem_or_mem I_ne_top @homogeneous_mem_or_mem⟩
#align ideal.is_homogeneous.is_prime_iff Ideal.IsHomogeneous.isPrime_iff

theorem Ideal.IsPrime.homogeneousCore {I : Ideal A} (h : I.IsPrime) :
    (I.homogeneousCore 𝒜).toIdeal.IsPrime :=
  by
  apply (Ideal.homogeneousCore 𝒜 I).Homogeneous.isPrime_of_homogeneous_mem_or_mem
  · exact ne_top_of_le_ne_top h.ne_top (Ideal.toIdeal_homogeneousCore_le 𝒜 I)
  rintro x y hx hy hxy
  have H := h.mem_or_mem (Ideal.toIdeal_homogeneousCore_le 𝒜 I hxy)
  refine' H.imp _ _
  · exact Ideal.mem_homogeneousCore_of_homogeneous_of_mem hx
  · exact Ideal.mem_homogeneousCore_of_homogeneous_of_mem hy
#align ideal.is_prime.homogeneous_core Ideal.IsPrime.homogeneousCore

theorem Ideal.IsHomogeneous.radical_eq {I : Ideal A} (hI : I.Homogeneous 𝒜) :
    I.radical = infₛ { J | J.Homogeneous 𝒜 ∧ I ≤ J ∧ J.IsPrime } :=
  by
  rw [Ideal.radical_eq_infₛ]
  apply le_antisymm
  · exact infₛ_le_infₛ fun J => And.right
  · refine' infₛ_le_infₛ_of_forall_exists_le _
    rintro J ⟨HJ₁, HJ₂⟩
    refine' ⟨(J.homogeneous_core 𝒜).toIdeal, _, J.to_ideal_homogeneous_core_le _⟩
    refine' ⟨HomogeneousIdeal.isHomogeneous _, _, HJ₂.homogeneous_core⟩
    refine' hI.to_ideal_homogeneous_core_eq_self.symm.trans_le (Ideal.homogeneousCore_mono _ HJ₁)
#align ideal.is_homogeneous.radical_eq Ideal.IsHomogeneous.radical_eq

theorem Ideal.IsHomogeneous.radical {I : Ideal A} (h : I.Homogeneous 𝒜) : I.radical.Homogeneous 𝒜 :=
  by
  rw [h.radical_eq]
  exact Ideal.IsHomogeneous.inf fun _ => And.left
#align ideal.is_homogeneous.radical Ideal.IsHomogeneous.radical

/-- The radical of a homogenous ideal, as another homogenous ideal. -/
def HomogeneousIdeal.radical (I : HomogeneousIdeal 𝒜) : HomogeneousIdeal 𝒜 :=
  ⟨I.toIdeal.radical, I.Homogeneous.radical⟩
#align homogeneous_ideal.radical HomogeneousIdeal.radical

@[simp]
theorem HomogeneousIdeal.coe_radical (I : HomogeneousIdeal 𝒜) :
    I.radical.toIdeal = I.toIdeal.radical :=
  rfl
#align homogeneous_ideal.coe_radical HomogeneousIdeal.coe_radical


import unitb.code.syntax

section finite

open nat

parameters (σ : Type) {lbl : Type}

private def pred := σ → Prop

parameters {σ}

def control_nodes : Π {p q : pred}, code lbl p q → ℕ
  | ._ ._ (code.skip _) := 0
  | ._ ._ (code.action _ _ _ _) := 1
  | ._ ._ (@code.seq ._ ._ p q r c₀ c₁) := control_nodes c₀ + control_nodes c₁
  | ._ ._ (@code.if_then_else ._ ._ c pa pb q _ _ c₀ c₁) :=
     control_nodes c₀ + control_nodes c₁ + 1
  | ._ ._ (@code.while ._ ._ p inv q _ c b) :=
     control_nodes b + 1

def to_fin : Π {p q : pred} {c : code lbl p q}, current c → fin (control_nodes c)
  | ._ ._ ._ (current.action _ _ _ _) := ⟨0,zero_lt_one⟩
  | ._ ._ ._ (current.seq_left p q r c₀ c₁ pc) := fin.nest (to_fin pc)
  | ._ ._ ._ (current.seq_right p q r c₀ c₁ pc) := fin.shift (to_fin pc)
  | ._ ._ ._ (current.ite_cond p t pa pb _ q c₀ c₁) :=
    (fin.max : fin (succ $ _ + _))
  | ._ ._ ._ (current.ite_left p t pa pb q _ c₀ c₁ pc) :=
    (fin.nest $ fin.nest $ to_fin pc : fin (control_nodes c₀ + control_nodes c₁ + 1))
  | ._ ._ ._ (current.ite_right p t pa pb q _ c₀ c₁ pc) :=
    (fin.nest $ fin.shift $ to_fin pc : fin (control_nodes c₀ + control_nodes c₁ + 1))
  | ._ ._ ._ (current.while_cond p inv q _ w c) :=
    (fin.max : fin (control_nodes c + 1))
  | ._ ._ ._ (current.while_body p inv q _ w c pc) :=
    (fin.nest $ to_fin pc : fin (control_nodes c + 1))

def from_fin : Π {p q} (c : code lbl p q), fin (control_nodes c) → current c
  | ._ ._ (code.skip _) ⟨_,P⟩ := by cases (nat.not_lt_zero _ P)
  | ._ ._ (code.action p q _ l) _ := current.action p q _ l
  | ._ ._ (@code.seq ._ ._ p q r c₀ c₁) m :=
    match fin.split m with
     | (sum.inl n) := seq_left  c₁ $ from_fin c₀ n
     | (sum.inr n) := seq_right c₀ $ from_fin c₁ n
    end
  | ._ ._ (@code.if_then_else ._ ._ p pa pb q ds t c₀ c₁) n :=
    match (fin.split n : fin (control_nodes c₀ + control_nodes c₁) ⊕ fin 1) with
     | (sum.inl n') :=
        match (fin.split n' : fin (control_nodes c₀) ⊕ fin (control_nodes c₁)) with
         | (sum.inl n) := ite_left  _ _ _ c₁ $ from_fin c₀ n
         | (sum.inr n) := ite_right _ _ _ c₀ $ from_fin c₁ n
        end
     | (sum.inr _) := ite_cond p t ds c₀ c₁
    end
  | ._ ._ (@code.while ._ ._ p inv q _ t b) n :=
    match (fin.split n : fin (control_nodes b) ⊕ fin 1) with
     | (sum.inl n') := while_body q _ t $ from_fin b n'
     | (sum.inr _) := while_cond q _ t b
    end

section g_over_constr

lemma from_fin_eq_seq_left
  {p q r : pred}
  {c₀ : code lbl p q} {c₁ : code lbl q r}
  {n : fin (control_nodes c₀ + control_nodes c₁)}
  {k : fin (control_nodes c₀)}
  (Hk : fin.split n = sum.inl k)
:   from_fin (code.seq c₀ c₁) n
  = seq_left c₁ (from_fin c₀ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_seq_right
  {p q r : pred}
  {c₀ : code lbl p q} {c₁ : code lbl q r}
  {n : fin (control_nodes c₀ + control_nodes c₁)}
  {k : fin (control_nodes c₁)}
  (Hk : fin.split n = sum.inr k)
:   from_fin (code.seq c₀ c₁) n
  = seq_right c₀ (from_fin c₁ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_ite_left
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin (control_nodes c₀ + control_nodes c₁)}
  {k' : fin (control_nodes c₀)}
  (Hk : fin.split n = sum.inl k)
  (Hk' : fin.split k = sum.inl k')
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_left p t ds c₁ (from_fin c₀ k') :=
begin
  dunfold from_fin, simp [Hk],
  dunfold from_fin._match_2, simp [Hk'],
  refl,
end

lemma from_fin_eq_ite_right
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin (control_nodes c₀ + control_nodes c₁)}
  {k' : fin (control_nodes c₁)}
  (Hk : fin.split n = sum.inl k)
  (Hk' : fin.split k = sum.inr k')
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_right p t ds c₀ (from_fin c₁ k') :=
begin
  dunfold from_fin, simp [Hk],
  dunfold from_fin._match_2, simp [Hk'],
  refl,
end

lemma from_fin_eq_ite_cond
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin 1}
  (Hk : fin.split n = sum.inr k)
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_cond p t ds c₀ c₁ :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_while_body
  {p t inv q : pred}
  {ds : set lbl}
  {c₀ : code lbl p inv}
  {n  : fin (control_nodes c₀ + 1)}
  {k  : fin $ control_nodes c₀}
  (Hk : fin.split n = sum.inl k)
:   from_fin (while q ds t c₀) n
  = while_body q ds t (from_fin c₀ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_while_cond
  {p t inv q : pred}
  {ds : set lbl}
  {c₀ : code lbl p inv}
  {n  : fin (control_nodes c₀ + 1)}
  {k  : fin 1}
  (Hk : fin.split n = sum.inr k)
:   from_fin (while q ds t c₀) n
  = while_cond q ds t c₀  :=
by { dunfold from_fin, simp [Hk], refl }

end g_over_constr

lemma from_fin_inv {p q} {c : code lbl p q} (n : fin (control_nodes c))
: to_fin (from_fin c n) = n :=
begin
  induction c
  ; dunfold control_nodes at n,
  { apply fin.elim0 n, },
  { dunfold from_fin to_fin
  ; apply fin.eq_of_veq,
    unfold fin.val,
    apply le_antisymm (zero_le _),
    apply le_of_lt_succ,
    apply n.is_lt },
  { destruct fin.split n
    ; intros k Hk,
    { rw [from_fin_eq_seq_left Hk], dunfold to_fin,
      rw [ih_1,fin.nest_eq_iff_eq_split,Hk], },
    { rw [from_fin_eq_seq_right Hk], dunfold to_fin,
      rw [ih_2,fin.shift_eq_iff_eq_split,Hk], }, },
  { destruct fin.split n
    ; intros k Hk,
    destruct fin.split k
    ; intros k' Hk',
    { rw [from_fin_eq_ite_left Hk Hk'], dunfold to_fin,
      simp [ih_1,fin.nest_eq_iff_eq_split,Hk],
      apply congr_arg,
      simp [fin.nest_eq_iff_eq_split,Hk'] },
    { rw [from_fin_eq_ite_right Hk Hk'], dunfold to_fin,
      simp [ih_2,fin.nest_eq_iff_eq_split,Hk],
      apply congr_arg,
      simp [fin.shift_eq_iff_eq_split,Hk'] },
    { rw [from_fin_eq_ite_cond Hk], dunfold to_fin,
      apply fin.split_injective _ n,
      simp [Hk,eq_comm],
      rw [← fin.shift_eq_iff_eq_split,fin.all_eq_zero k],
      apply fin.eq_of_veq, simp [fin.val_shift_zero], refl }, },
  { destruct fin.split n
    ; intros k Hk,
    { rw [from_fin_eq_while_body Hk], dunfold to_fin,
      rw [ih_1,fin.nest_eq_iff_eq_split,Hk], },
    { rw [from_fin_eq_while_cond Hk], dunfold to_fin,
      apply fin.split_injective _ n,
      simp [Hk,eq_comm],
      rw [← fin.shift_eq_iff_eq_split,fin.all_eq_zero k],
      apply fin.eq_of_veq, simp [fin.val_shift_zero], refl, }, }
end

lemma to_fin_inv {p q} {c : code lbl p q} (pc : current c)
: from_fin c (to_fin pc) = pc :=
begin
  induction pc
  ; dunfold to_fin
  ; try { refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_1,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.split_shift],
    dunfold from_fin._match_1,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.shift_zero,fin.split_shift],
    dunfold from_fin._match_2, refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_2,
    simp [fin.split_nest],
    dunfold from_fin._match_3,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_2,
    simp [fin.split_shift],
    dunfold from_fin._match_3,
    simp [ih_1] },
  { dunfold from_fin,
    simp [fin.shift_zero,fin.split_shift],
    refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_4,
    simp [ih_1] },
end

instance current_finite {p q : pred} {c : code lbl p q} : finite (current c) :=
⟨ control_nodes c,
  bijection.mk to_fin (from_fin c) to_fin_inv from_fin_inv ⟩

instance current_sched {p q : pred} {c : code lbl p q} : scheduling.sched (current c) :=
scheduling.sched.fin (by apply_instance)

end finite


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.isomorphism
import category_theory.functor_category

/-!
# Whiskering

Given a functor `F  : C ⥤ D` and functors `G H : D ⥤ E` and a natural transformation `α : G ⟶ H`,
we can construct a new natural transformation `F ⋙ G ⟶ F ⋙ H`,
called `whisker_left F α`. This is the same as the horizontal composition of `𝟙 F` with `α`.

This operation is functorial in `F`, and we package this as `whiskering_left`. Here
`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
(That is, we might have alternatively named this as the "left composition functor".)

We also provide analogues for composition on the right, and for these operations on isomorphisms.

At the end of the file, we provide the left and right unitors, and the associator,
for functor composition.
(In fact functor composition is definitionally associative, but very often relying on this causes
extremely slow elaboration, so it is better to insert it explicitly.)
We also show these natural isomorphisms satisfy the triangle and pentagon identities.
-/

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃ u₄ v₄

section
variables {C : Type u₁} [category.{v₁} C]
          {D : Type u₂} [category.{v₂} D]
          {E : Type u₃} [category.{v₃} E]

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simps] def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) : (F ⋙ G) ⟶ (F ⋙ H) :=
{ app := λ X, α.app (F.obj X),
  naturality' := λ X Y f, by rw [functor.comp_map, functor.comp_map, α.naturality] }

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
@[simps] def whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : (G ⋙ F) ⟶ (H ⋙ F) :=
{ app := λ X, F.map (α.app X),
  naturality' := λ X Y f,
    by rw [functor.comp_map, functor.comp_map, ←F.map_comp, ←F.map_comp, α.naturality] }

variables (C D E)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
-/
@[simps] def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α, whisker_left F α },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [f.naturality] end } }

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simps] def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α, whisker_right α H },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl
@[simp] lemma whisker_left_id' (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (𝟙 G) = 𝟙 (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _
@[simp] lemma whisker_right_id' {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (𝟙 G) F = 𝟙 (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_comp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) :
  whisker_left F (α ≫ β) = (whisker_left F α) ≫ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_comp {G H K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E)  :
  whisker_right (α ≫ β) F = (whisker_right α F) ≫ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) : (F ⋙ G) ≅ (F ⋙ H) :=
((whiskering_left C D E).obj F).map_iso α
@[simp] lemma iso_whisker_left_hom (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).hom = whisker_left F α.hom :=
rfl
@[simp] lemma iso_whisker_left_inv (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).inv = whisker_left F α.inv :=
rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (H ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : (G ⋙ F) ≅ (H ⋙ F) :=
((whiskering_right C D E).obj F).map_iso α
@[simp] lemma iso_whisker_right_hom {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).hom = whisker_right α.hom F :=
rfl
@[simp] lemma iso_whisker_right_inv {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).inv = whisker_right α.inv F :=
rfl

instance is_iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
  is_iso (whisker_left F α) :=
is_iso.of_iso (iso_whisker_left F (as_iso α))
instance is_iso_whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
  is_iso (whisker_right α F) :=
is_iso.of_iso (iso_whisker_right (as_iso α) F)

variables {B : Type u₄} [category.{v₄} B]

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟶ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simps] def left_unitor (F : A ⥤ B) : ((𝟭 A) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simps] def right_unitor (F : A ⥤ B) : (F ⋙ (𝟭 B)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

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

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simps] def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (𝟭 B) G).hom ≫ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
by { ext, dsimp, simp }  -- See note [dsimp, simp].

variables {E : Type u₅} [category.{v₅} E]

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ≫
    (associator F (G ⋙ H) K).hom ≫
    (whisker_left F (associator G H K).hom) =
  ((associator (F ⋙ G) H K).hom ≫ (associator F G (H ⋙ K)).hom) :=
by { ext, dsimp, simp }

end functor

end category_theory


import for_mathlib.category_theory.triangulated.homological_functor
import for_mathlib.category_theory.shift_op

noncomputable theory

namespace category_theory

open category limits

namespace functor

variables {C₁ C₂ D : Type*} [category C₁] [category C₂] [category D]

section

variables (F : C₁ ⥤ C₂ ⥤ D) {A G : Type*} [add_comm_monoid A]
  [has_shift C₁ A] [has_shift C₂ A]

def shift_swap (a : A) :=
  (shift_functor C₁ a) ⋙ F ≅ F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ a)

namespace shift_swap

variable (A)

def zero : shift_swap F (0 : A) :=
iso_whisker_right (shift_functor_zero C₁ A) F ≪≫ F.left_unitor ≪≫
  F.right_unitor.symm ≪≫
  iso_whisker_left F ((whiskering_left_id _ _).symm ≪≫
    (whiskering_left _ _ D).map_iso (shift_functor_zero C₂ A).symm)

lemma zero_hom_app_app (X₁ : C₁) (X₂ : C₂) :
  ((zero F A).hom.app X₁).app X₂ =
  (F.map ((shift_functor_zero C₁ A).hom.app X₁)).app X₂ ≫
    (F.obj X₁).map ((shift_functor_zero C₂ A).inv.app X₂) :=
begin
  dsimp only [zero, left_unitor, right_unitor, iso.trans, iso_whisker_right, iso_whisker_left,
    whiskering_right, whiskering_left, iso.symm, nat_trans.comp_app, whiskering_left_id,
    nat_iso.of_components, map_iso, whisker_left, whisker_right],
  erw [id_comp, id_comp, id_comp],
end

lemma zero_inv_app_app (X₁ : C₁) (X₂ : C₂) :
  ((zero F A).inv.app X₁).app X₂ =
  (F.obj X₁).map ((shift_functor_zero C₂ A).hom.app X₂) ≫
  (F.map ((shift_functor_zero C₁ A).inv.app X₁)).app X₂ :=
begin
  dsimp only [zero, left_unitor, right_unitor, iso.trans, iso_whisker_right, iso_whisker_left,
    whiskering_right, whiskering_left, iso.symm, nat_trans.comp_app, whiskering_left_id,
    nat_iso.of_components, map_iso, whisker_left, whisker_right],
  erw [comp_id, comp_id, comp_id],
end

variables {F A}

def add' {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b) (c : A) (h : c = a+b) :
  shift_swap F c :=
iso_whisker_right (shift_functor_add' C₁ a b c h) F ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left _ e₂ ≪≫ (functor.associator _ _ _).symm ≪≫
  iso_whisker_right e₁ _ ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left F ((whiskering_left _ _ D).map_iso
    (shift_functor_add' C₂ b a c (by rw [h, add_comm])).symm)

def add {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b) :
  shift_swap F (a+b) := add' e₁ e₂ (a+b) rfl

lemma add'_hom_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (c : A) (h : c = a+b) (X₁ : C₁) (X₂ : C₂) :
  ((add' e₁ e₂ c h).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add' C₁ a b c h).hom.app X₁)).app X₂ ≫
    (e₂.hom.app (X₁⟦a⟧)).app X₂ ≫ (e₁.hom.app X₁).app (X₂⟦b⟧) ≫
    (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).inv.app X₂) :=
begin
  dsimp [add'],
  erw [id_comp, id_comp, id_comp],
end

lemma add_hom_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
   (X₁ : C₁) (X₂ : C₂) :
  ((add e₁ e₂).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add C₁ a b).hom.app X₁)).app X₂ ≫
    (e₂.hom.app (X₁⟦a⟧)).app X₂ ≫ (e₁.hom.app X₁).app (X₂⟦b⟧) ≫
    (F.obj X₁).map
      ((shift_functor_add' C₂ b a (a+b) (add_comm a b)).inv.app X₂) :=
begin
  dsimp only [add],
  rw [add'_hom_app_app, shift_functor_add'_eq_shift_functor_add],
end

lemma add'_inv_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (c : A) (h : c = a+b) (X₁ : C₁) (X₂ : C₂) :
  ((add' e₁ e₂ c h).inv.app X₁).app X₂ =
    (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).hom.app X₂) ≫
    (e₁.inv.app X₁).app (X₂⟦b⟧) ≫
    (e₂.inv.app (X₁⟦a⟧)).app X₂ ≫
    (F.map ((shift_functor_add' C₁ a b c h).inv.app X₁)).app X₂ :=
begin
  dsimp [add'],
  erw [comp_id, comp_id, comp_id, assoc, assoc],
end

lemma add_inv_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (X₁ : C₁) (X₂ : C₂) :
  ((add e₁ e₂).inv.app X₁).app X₂ =
    (F.obj X₁).map ((shift_functor_add' C₂ b a _ (add_comm a b)).hom.app X₂) ≫
    (e₁.inv.app X₁).app (X₂⟦b⟧) ≫
    (e₂.inv.app (X₁⟦a⟧)).app X₂ ≫
    (F.map ((shift_functor_add C₁ a b).inv.app X₁)).app X₂ :=
begin
  dsimp only [add],
  rw [add'_inv_app_app, shift_functor_add'_eq_shift_functor_add],
end

end shift_swap

variable (A)

class has_shift_swap :=
(iso [] : Π (a : A), F.shift_swap a)
(iso_zero [] : iso 0 = shift_swap.zero F A)
(iso_add [] : ∀ (a b : A), iso (a+b) = shift_swap.add (iso a) (iso b))

variable {A}

def has_shift_swap.iso' [F.has_shift_swap A] (a b c : A) (h : c = a + b) :
  (shift_functor C₁ a) ⋙ F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ b) ≅
    F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ c) :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right (has_shift_swap.iso F a) _ ≪≫
  functor.associator _ _ _ ≪≫ iso_whisker_left _ ((whiskering_left C₂ C₂ D).map_iso (shift_functor_add' C₂ b a c (by rw [h, add_comm])).symm)

namespace has_shift_swap

variable [F.has_shift_swap A]

lemma iso'_hom_app_app (a b c : A) (h : c = a + b) (X₁ : C₁) (X₂ : C₂ ):
  ((iso' F a b c h).hom.app X₁).app X₂ =
    ((iso F a).hom.app X₁).app ((shift_functor C₂ b).obj X₂) ≫
      (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).inv.app X₂) :=
begin
  dsimp [iso'],
  rw [id_comp, id_comp],
end

lemma iso'_zero_hom_app_app (b : A) (X₁ : C₁) (X₂ : C₂ ):
  ((iso' F 0 b b (zero_add b).symm).hom.app X₁).app X₂ =
    (F.map ((shift_functor_zero C₁ A).hom.app X₁)).app (X₂⟦b⟧) :=
begin
  simp only [iso'_hom_app_app, has_shift_swap.iso_zero,
    shift_swap.zero_hom_app_app, assoc, ← functor.map_comp],
  convert comp_id _,
  convert functor.map_id _ _,
  sorry,
end

lemma iso'_hom_app_app_comp (a b c a' d e : A) (hc : c = a + b) (he : e = a'+a) (hd : d = a'+c)
   (X₁ : C₁) (X₂ : C₂ ) :
  ((iso' F a b c hc).hom.app (X₁⟦a'⟧)).app X₂ ≫ ((iso' F a' c d hd).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add' C₁ a' a e he).inv.app X₁)).app (X₂⟦b⟧) ≫
      ((iso' F e b d (by rw [hd, he, hc, add_assoc])).hom.app X₁).app X₂ :=
begin
  sorry,
end

end has_shift_swap

end

section

variables {C : Type*} [category C] [has_shift C ℤ]
  [preadditive C] [∀ (n : ℤ), (shift_functor C n).additive]

local attribute [instance] has_shift_op_neg_ℤ

@[simps]
def preadditive_yoneda_shift_swap_add_equiv (X₁ X₂ : C) (n : ℤ) :
  (X₂ ⟶ X₁⟦n⟧) ≃+ (X₂⟦-n⟧ ⟶ X₁) :=
{ to_fun := λ f, f⟦-n⟧' ≫ (shift_equiv C n).unit_iso.inv.app X₁,
  inv_fun := λ f, (shift_equiv C n).counit_iso.inv.app X₂ ≫ f⟦n⟧',
  left_inv := λ f, begin
    dsimp only,
    erw [functor.map_comp, ← nat_trans.naturality_assoc,
      (shift_equiv C n).counit_inv_functor_comp, comp_id],
    refl,
  end,
  right_inv := λ f, begin
    dsimp only,
    erw [functor.map_comp, assoc],
    erw (shift_equiv C n).unit_iso.inv.naturality f,
    slice_lhs 1 2 { erw (shift_equiv C n).inverse_counit_inv_comp, },
    erw id_comp,
    refl,
  end,
  map_add' := λ f₁ f₂, by rw [functor.map_add, preadditive.add_comp], }

variable (C)

@[simps]
def preadditive_yoneda_shift_swap (n : ℤ) :
  shift_swap (preadditive_yoneda : C ⥤ _) n :=
nat_iso.of_components (λ X₁, nat_iso.of_components
  (λ X₂, add_equiv.to_AddCommGroup_iso (preadditive_yoneda_shift_swap_add_equiv X₁ X₂.unop n))
  (by tidy)) (by tidy)

-- this would be better with coyoneda instead

def hom_functor_has_shift_swap : (preadditive_yoneda : C ⥤ _).has_shift_swap ℤ :=
{ iso := preadditive_yoneda_shift_swap C,
  iso_zero := begin
    ext X₁ X₂ x,
    dsimp at x,
    rw shift_swap.zero_hom_app_app,
    dsimp only [preadditive_yoneda_shift_swap, nat_iso.of_components,
      preadditive_yoneda_shift_swap_add_equiv, add_equiv.to_AddCommGroup_iso,
      add_equiv.to_add_monoid_hom, add_monoid_hom.coe_mk],
    rw [comp_apply, preadditive_yoneda_map_app_apply],
    erw preadditive_yoneda_obj_map_apply,
    --let y := ((shift_functor_zero Cᵒᵖ ℤ).inv.app X₂).unop,
    --let y' := (shift_functor_zero C ℤ).hom.app (opposite.unop X₂),
    --change _ = y ≫ _,
    sorry,
  end,
  iso_add := sorry, }

end

section

variables (F : C₁ ⥤ C₂ ⥤ D) [has_shift C₁ ℤ] [has_shift C₂ ℤ] [abelian D]
  [preadditive C₁] [has_zero_object C₁] [∀ (n : ℤ), (shift_functor C₁ n).additive]
  [pretriangulated C₁]
  [∀ (Y₂ : C₂), (((whiskering_right _ _ _).obj
    ((evaluation C₂ D).obj Y₂)).obj F).preserves_zero_morphisms]
  [∀ (Y₂ : C₂), (((whiskering_right _ _ _).obj
    ((evaluation C₂ D).obj Y₂)).obj F).is_homological]

lemma is_homological.bifunctor_map_distinguished (T : pretriangulated.triangle C₁)
  (hT : T ∈ dist_triang C₁) (Y₂ : C₂) :
  ((T.short_complex hT).map (((whiskering_right C₁ (C₂ ⥤ D) D).obj
    ((evaluation C₂ D).obj Y₂)).obj F)).exact :=
is_homological.map_distinguished (((whiskering_right _ _ _).obj
  ((evaluation C₂ D).obj Y₂)).obj F) T hT

lemma is_homological.bifunctor_ex₁₂ (T : pretriangulated.triangle C₁)
  (hT : T ∈ dist_triang C₁) (Y₂ : C₂) (n : ℤ) :
  (short_complex.mk ((F.map T.mor₁).app (Y₂⟦n⟧)) ((F.map T.mor₂).app (Y₂⟦n⟧))
    (by simpa only [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₁₂ T hT]
        using (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero T.obj₁ T.obj₃)).exact :=
is_homological.map_distinguished (((whiskering_right _ _ _).obj
  ((evaluation C₂ D).obj (Y₂⟦n⟧))).obj F) T hT

variables [F.has_shift_swap ℤ]

def is_homological.bifunctor_δ₁ (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (F.obj T.obj₃).obj (Y₂⟦n₀⟧) ⟶ (F.obj T.obj₁).obj (Y₂⟦n₁⟧) :=
(F.map T.mor₃).app (Y₂⟦n₀⟧) ≫
  ((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).hom.app T.obj₁).app Y₂

lemma is_homological.bifunctor_comp_δ₁
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (F.map T.mor₂).app (Y₂⟦n₀⟧) ≫ is_homological.bifunctor_δ₁ F T hT Y₂ _ _ h = 0 :=
begin
  dsimp only [is_homological.bifunctor_δ₁],
  rw ← assoc,
  convert zero_comp,
  rw [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₂₃ T hT],
  exact (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero _ _,
end

lemma is_homological.bifunctor_ex₁₃
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk _ _ (is_homological.bifunctor_comp_δ₁ F T hT Y₂ _ _ h)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1 (is_homological.map_distinguished
    (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj (Y₂⟦n₀⟧))).obj F)
    _ ((pretriangulated.rotate_distinguished_triangle T).1 hT)),
  refine short_complex.mk_iso (iso.refl _) (iso.refl _)
    (((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).app T.obj₁).app Y₂) _ _,
  { dsimp, rw [id_comp, comp_id], },
  { dsimp,
    rw id_comp,
    refl, },
end

def is_homological.bifunctor_δ₁_comp
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  is_homological.bifunctor_δ₁ F T hT Y₂ _ _ h ≫ (F.map T.mor₁).app (Y₂⟦n₁⟧) = 0 :=
begin
  dsimp only [is_homological.bifunctor_δ₁],
  have eq := congr_app ((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).hom.naturality T.mor₁) Y₂,
  dsimp at eq,
  rw [assoc, ← eq, ← assoc],
  convert zero_comp,
  rw [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₃₁ T hT],
  exact (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero _ _,
end

lemma is_homological.bifunctor_ex₁₁
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk _ _ (is_homological.bifunctor_δ₁_comp F T hT Y₂ _ _ h)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1 (is_homological.map_distinguished
    (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj (Y₂⟦n₁⟧))).obj F)
    _ ((pretriangulated.inv_rotate_distinguished_triangle T).2 hT)),
  refine short_complex.mk_iso (preadditive.mul_iso (-1) ((((has_shift_swap.iso' F (-1) n₁ n₀ (by linarith)).app T.obj₃)).app Y₂)) (iso.refl _) (iso.refl _) _ _,
  { dsimp only [preadditive.mul_iso, iso.refl,
      pretriangulated.triangle.inv_rotate, pretriangulated.triangle.mk,
      short_complex.map, whiskering_right, evaluation, functor.comp,
      pretriangulated.triangle.short_complex,
      pretriangulated.candidate_triangle.of_distinguished,
      pretriangulated.candidate_triangle.short_complex,
      is_homological.bifunctor_δ₁],
    have eq := congr_app ((has_shift_swap.iso' F (-1) n₁ n₀ (by linarith)).hom.naturality T.mor₃) Y₂,
    dsimp at eq,
    rw [comp_id, units.coe_neg_one, neg_smul, one_smul],
    nth_rewrite 0 preadditive.neg_comp,
    erw [← reassoc_of eq, ← preadditive.neg_comp, ← preadditive.neg_comp, F.map_comp],
    conv_rhs { rw nat_trans.comp_app, },
    congr' 1,
    { exact (functor.map_neg (((whiskering_right _ _ _).obj
        ((evaluation C₂ D).obj (Y₂⟦n₁⟧))).obj F)).symm, },
    { rw [has_shift_swap.iso'_hom_app_app_comp F (-1) n₁ n₀ 1 n₁ 0 (by linarith)
        (by linarith) (by linarith), has_shift_swap.iso'_zero_hom_app_app,
        ← nat_trans.comp_app, ← F.map_comp,
        ← shift_functor_comp_shift_functor_neg_eq_add'_comp_zero],
      refl, }, },
  { dsimp,
    rw [id_comp, comp_id], },
end

end

end functor

end category_theory


import data.finset.basic
import data.fintype.basic
import .extensionality

namespace extensionality

universe u

instance finset_ext_lemmas (T : Type*) [decidable_eq T] :
  (boolalg_ext_lemmas (finset T) T) :=
{
  simpl_eq := by tidy,
  simpl_lt := by tidy,
  ext_bot := by tidy,
  ext_sdiff := by tidy,
  ext_le := by tidy,
  ext_meet := by tidy,
  ext_join := by simp only [finset.inf_eq_inter, forall_const, iff_self, finset.mem_inter, forall_true_iff],
}

instance finset_ext_lemmas_compl (T : Type*) [fintype T] [decidable_eq T] :
  (boolalg_ext_lemmas_compl (finset T) T) :=
{
  ext_compl := by apply finset.mem_compl
}

instance finset_ext_lemmas_top (T : Type*) [fintype T] [decidable_eq T] :
  (boolalg_ext_lemmas_top (finset T) T) :=
{
  ext_top := by unfold_projs; finish,
}
end extensionality

namespace cleanup
lemma finset_union_sup (T : Type*) [decidable_eq T] (A B : finset T) : (A ∪ B) = (A ⊔ B) := by refl
lemma finset_inter_inf (T : Type*) [decidable_eq T] (A B : finset T) : (A ∩ B) = (A ⊓ B) := by refl
lemma finset_subset_le (T : Type*) [decidable_eq T] (A B : finset T) : (A ⊆ B) = (A ≤ B) := by refl
lemma finset_subset_lt (T : Type*) [decidable_eq T] (A B : finset T) : (A ⊂ B) = (A < B) := by refl
lemma finset_univ_top (T : Type*) [decidable_eq T] [fintype T] : (finset.univ : finset T) = ⊤ := by refl
lemma finset_empt_bot (T : Type*) [decidable_eq T] : (∅ : finset T) = ⊥ := by refl

meta def finset_cleanup : tactic unit :=
  `[simp only [cleanup.finset_union_sup, cleanup.finset_inter_inf, cleanup.finset_subset_le,
    cleanup.finset_subset_lt, cleanup.finset_univ_top, cleanup.finset_empt_bot] at *]
end cleanup


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.bifunctor
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Functor and bifunctors can be applied to `equiv`s.

We define
```lean
def functor.map_equiv (f : Type u → Type v) [functor f] [is_lawful_functor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def bifunctor.map_equiv (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

namespace functor

/-- Apply a functor to an `equiv`. -/
def map_equiv {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) : f α ≃ f β :=
  equiv.mk (Functor.map ⇑h) (Functor.map ⇑(equiv.symm h)) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) (x : f α) : coe_fn (map_equiv f h) x = ⇑h <$> x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) (y : f β) : coe_fn (equiv.symm (map_equiv f h)) y = ⇑(equiv.symm h) <$> y :=
  rfl

@[simp] theorem map_equiv_refl {α : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] : map_equiv f (equiv.refl α) = equiv.refl (f α) := sorry

end functor

namespace bifunctor

/-- Apply a bifunctor to a pair of `equiv`s. -/
def map_equiv {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' :=
  equiv.mk (bimap ⇑h ⇑h') (bimap ⇑(equiv.symm h) ⇑(equiv.symm h')) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') (x : F α α') : coe_fn (map_equiv F h h') x = bimap (⇑h) (⇑h') x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') (y : F β β') : coe_fn (equiv.symm (map_equiv F h h')) y = bimap (⇑(equiv.symm h)) (⇑(equiv.symm h')) y :=
  rfl

@[simp] theorem map_equiv_refl_refl {α : Type u} {α' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] : map_equiv F (equiv.refl α) (equiv.refl α') = equiv.refl (F α α') := sorry


import EggTactic

set_option trace.EggTactic.egg true
-- TODO @andres: what egg gives us back is wrong. What we really need to know is the rewrite term that we need to use.
-- This means we should build the sexpr (<rewrite-term> <arg-1> ... <arg-n>) and then use this to perform the rewrite.
-- Instead, what `egg` gives us is the goal state after the rewrite.
--
-- This is a problem because we need to know the rewrite term to perform the rewrite.
-- We can't just use the goal state because the goal state is the result of the rewrite.

theorem testSuccess0 (anat: Nat) (bnat: Nat) (H: anat = bnat): anat = bnat := by {
  intros;
  eggxplosion [H]
}

#print testSuccess0

set_option pp.analyze true in
theorem testSuccess (anat: Nat) (bint: Int) (cnat: Nat)
  (dint: Int) (eint: Int) (a_eq_a: anat = anat) (b_eq_d: bint = dint) (d_eq_e: dint = eint): bint = eint := by
  --  eggxplosion [not_rewrite]
  --  eggxplosion [rewrite_wrong_type]
  -- rewrite [b_eq_d]
  -- rewrite [d_eq_e]
  -- rfl
  eggxplosion [b_eq_d, d_eq_e]

#print testSuccess

theorem testSuccess0Symm (anat: Nat) (bnat: Nat) (H: bnat = anat): anat = bnat := by {
  intros;
  eggxplosion [H]
}

#print testSuccess0Symm

-- elab "boiledEgg" "[" rewrites:ident,* "]" : tactic =>  withMainContext  do

-- | test that we can run rewrites

-- | test that we can run theorems in reverse.
theorem testSuccessRev : ∀ (anat: Nat) (bint: Int) (cnat: Nat)
  (dint: Int) (eint: Int) (a_eq_a: anat = anat) (b_eq_d: bint = dint) (d_eq_e: dint = eint),
  eint = bint := by
   intros a b c d e aeqa beqd deqe
   eggxplosion [beqd, deqe]

#print testSuccessRev

/-
theorem testManualInstantiation
(group_inv: forall (g: Int), g - g  = 0)
(h: Int) (k: Int): h - h = k - k := by
  have gh : h - h = 0 := group_inv h
  have gk : k - k = 0 := group_inv k
  -- TODO: figure out how to get these
  -- manually instantiated locals to work.
  -- @bollu's hypothesis is that we need to force
  -- metavariable resolution at the value and type level
  -- with a couple 'reduce's.
  eggxplosion [gh, gk]

#print testManualInstantiation
-/

theorem assoc_instantiate(G: Type)
  (mul: G → G → G)
  (assocMul: forall (a b c: G), (mul (mul a b) c) = mul a (mul b c))
  (x y z: G) : mul x (mul y z) = mul (mul x y) z := by {
  eggxplosion [assocMul]
}

#print assoc_instantiate

/-
theorem testGoalNotEqualityMustFail : ∀ (a: Nat) (b: Int) (c: Nat) , Nat := by
 intros a b c
 eggxplosion []
 sorry
-/

/-
      rw!("assoc-mul"; "(* ?a (* ?b ?c))" => "(* (* ?a ?b) ?c)"),
      rw!("assoc-mul'"; "(* (* ?a ?b) ?c)" => "(* ?a (* ?b ?c))"),
      rw!("one-mul";  "(* 1 ?a)" => "?a"),
      rw!("one-mul'";  "?a" => "(* 1 ?a)"),
      rw!("inv-left";  "(* (^-1 ?a) ?a)" => "1"),
      rw!("inv-left'";  "1" => "(* (^-1 a) a)"),
      rw!("inv-left''";  "1" => "(* (^-1 b) b)"),
      rw!("mul-one";  "(* ?a 1)" => "?a"),
      rw!("mul-one'";  "?a" => "(* ?a 1)" ),
      rw!("inv-right";  "(* ?a (^-1 ?a))" => "1"),
      rw!("inv-right'";  "1" => "(* a (^-1 a))"),
      rw!("inv-right''";  "1" => "(* b (^-1 b))"),
      //rw!("anwser''";  "(* (^-1 b)(^-1 a))" => "ANSWER"),
-/
theorem inv_mul_cancel_left (G: Type)
  (inv: G → G)
  (mul: G → G → G)
  (one: G)
  (x: G)
  (assocMul: forall (a b c: G), mul a (mul b c) = (mul (mul a b) c))
  (invLeft: forall (a: G), mul (inv a) a = one)
  (mulOne: forall (a: G), a = mul a one)
  (invRight: forall (a: G), one = mul a (inv a))
  --(invRightX: one = mul x (inv x))
  : (inv (inv x) = x) := by
  eggxplosion [assocMul, invLeft, mulOne, invRight] (timeLimit := 3)

#print inv_mul_cancel_left

def all {α  : Type} (p : α → Bool) (xs : List α) := List.and (List.map p xs)
def all'{α  : Type} (p : α → Bool) (xs : List α) := List.foldr (λ a b => b && (p a)) True xs

theorem deforestation : ∀ (p : α → Bool) (xs : List α), all p xs = all' p xs := by
  intros p xs
  unfold all
  unfold all'
  unfold List.map
  unfold List.and
  unfold List.all
  induction xs with
    | nil =>
      simp
      rfl
    | cons head tail ih =>
      -- ⊢ List.foldr (fun a r => a && r) true (p head :: List.map p tail) = List.foldr (fun a b => b && p a) true (head :: tail)

theorem testInstantiation
  -- TODO: need to change definitions to make all arguments implicit, since those are the only kinds of rewrites
  -- egg can cope with!
  (group_inv: forall {g: Int}, g - g  = 0)
  (h: Int) (k: Int): h - h = k - k := by {
   -- expected no bound variables, we use locally nameless.
   -- @andres: I strongly suspect the toExplode
   -- array somehow leaking in `bvars` on accident. A cursory glance at it did not show me what it
   -- does when it doesn't explode a variable; I would have expected it to instantiate an `mvar`.
   eggxplosion [group_inv];
}

#print testInstantiation


/-
Copyright (c) 2020 Gabriel Ebner, Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.Lean3Lib.data.stream
import Mathlib.data.list.basic
import Mathlib.data.list.range
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Additional instances and attributes for streams
-/

protected instance stream.inhabited {α : Type u_1} [Inhabited α] : Inhabited (stream α) :=
  { default := stream.const Inhabited.default }

namespace stream

/-- `take s n` returns a list of the `n` first elements of stream `s` -/
def take {α : Type u_1} (s : stream α) (n : ℕ) : List α :=
  list.map s (list.range n)

theorem length_take {α : Type u_1} (s : stream α) (n : ℕ) : list.length (take s n) = n := sorry

/-- Use a state monad to generate a stream through corecursion -/
def corec_state {σ : Type u_1} {α : Type u_1} (cmd : state σ α) (s : σ) : stream α :=
  corec prod.fst (state_t.run cmd ∘ prod.snd) (state_t.run cmd s)


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry,
end

--OUTPUT 2
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h2 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h3 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h4 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h5 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h6 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h7 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h8 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h9 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h10 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h11 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h12 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h13 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h14 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h15 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h16 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h17 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h18 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h19 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h20 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h21 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h22 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h23 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h24 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h25 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h26 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h27 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h28 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h29 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h30 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h31 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h32 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h33 : ∀ m : ℕ,
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry
end

--OUTPUT 4
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with d hd,
  {
    show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(-1),
    {
      rw polynomial.bernoulli,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry,
end

--OUTPUT 6
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, m < n → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h2 : ∀ m : ℕ, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h3 : (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from sorry,
  show (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/


#exit

import Structure.Generic.Axioms
import Structure.Generic.DerivedFunctors

import mathlib4_experiments.Data.Equiv.Basic

open GeneralizedRelation

set_option autoBoundImplicitLocal false

universes u v w

namespace GeneralizedProperty

  def ConstProp (α : Sort u) {V : Universe} {β : V} (c : β) : GeneralizedProperty α V := λ _ => β

  namespace ConstProp

    variable (α : Sort u) {V : Universe} {β : V} (c : β)

    instance hasInst : HasInst (ConstProp α c) := ⟨λ _ => c⟩

  end ConstProp

end GeneralizedProperty

namespace GeneralizedRelation

  def ConstRel (α : Sort u) {V : Universe} {β : V} (c : β) : GeneralizedRelation α V := λ _ _ => β

  namespace ConstRel

    variable (α : Sort u) {V : Universe} {β : V} (c : β)

    instance hasRefl  : HasRefl  (ConstRel α c) := ⟨λ _ => c⟩

    variable [HasInternalFunctors V] [HasAffineFunOp V]

    instance hasSymm  : HasSymm  (ConstRel α c) := ⟨HasLinearFunOp.idFun β⟩
    instance hasTrans : HasTrans (ConstRel α c) := ⟨HasAffineFunOp.constFun β (HasLinearFunOp.idFun β)⟩

    instance isPreorder    : IsPreorder    (ConstRel α c) := ⟨⟩
    instance isEquivalence : IsEquivalence (ConstRel α c) := ⟨⟩

    @[simp] theorem symmEq  {a₁ a₂    : α} : (hasSymm  α c).symm'  (a := a₁) (b := a₂)           c   = c :=
    HasLinearFunOp.idFun.eff β c
    @[simp] theorem transEq {a₁ a₂ a₃ : α} : (hasTrans α c).trans' (a := a₁) (b := a₂) (c := a₃) c c = c :=
    let h₁ := congrArg HasInternalFunctors.funCoe (HasAffineFunOp.constFun.eff β (HasLinearFunOp.idFun β) c);
    Eq.trans (congrFun h₁ c) (HasLinearFunOp.idFun.eff β c)

  end ConstRel

end GeneralizedRelation

open GeneralizedRelation

-- TODO: Should we use actual abstract equivalence here?

structure Iff' {U : Universe} [HasInternalFunctors U] (α β : U) where
(mp  : α ⟶ β)
(mpr : β ⟶ α)

infix:20 " ⟷' " => Iff'

section Morphisms

  variable {α : Sort u} {U : Universe} [HasInternalFunctors U] [he : HasFunctorialEquivalences U]
           [HasLinearFunOp he.equivUniverse] {R : GeneralizedRelation α U}

  instance : HasFunctorialArrows U := HasFunctorialEquivalences.toHasFunctorialArrows U

  open IsCompositionRelation

  namespace IsCompositionRelation

    variable [HasTrans R] [IsCompositionRelation R]

    def comp_congrArg {a b c : α} {f₁ f₂ : R a b} {g₁ g₂ : R b c} : f₁ ≃ f₂ ⟶ g₁ ≃ g₂ ⟶ g₁ • f₁ ≃ g₂ • f₂ :=
    he.equivCongr ⊙ HasFunctorialEquivalences.equiv_congrArg U HasTrans.trans

    def comp_congrArg_left  {a b c : α} {f : R a b} {g₁ g₂ : R b c} : g₁ ≃ g₂ ⟶ g₁ • f ≃ g₂ • f :=
    HasFunctorialEquivalences.equiv_congrArg U (HasTrans.trans ⟮f⟯)

    def comp_congrArg_right {a b c : α} {f₁ f₂ : R a b} {g : R b c} : f₁ ≃ f₂ ⟶ g • f₁ ≃ g • f₂ :=
    HasLinearFunOp.swapFun comp_congrArg (HasRefl.refl g)

    def comp_subst  {a b c : α} {f₁ f₂ : R a b} {g₁ g₂ : R b c} {e : R a c} : f₁ ≃ f₂ ⟶ g₁ ≃ g₂ ⟶ g₂ • f₂ ≃ e ⟶ g₁ • f₁ ≃ e :=
    HasLinearFunOp.compFun₂ comp_congrArg HasTrans.trans
    def comp_subst' {a b c : α} {f₁ f₂ : R a b} {g₁ g₂ : R b c} {e : R a c} : f₁ ≃ f₂ ⟶ g₁ ≃ g₂ ⟶ e ≃ g₁ • f₁ ⟶ e ≃ g₂ • f₂ :=
    HasLinearFunOp.compFun₂ comp_congrArg HasTrans.revTrans

    def comp_subst_left   {a b c : α} (f : R a b) {g₁ g₂ : R b c} {e : R a c} : g₁ ≃ g₂ ⟶ g₂ • f ≃ e ⟶ g₁ • f ≃ e :=
    HasTrans.trans    ⊙ comp_congrArg_left
    def comp_subst_left'  {a b c : α} (f : R a b) {g₁ g₂ : R b c} {e : R a c} : g₁ ≃ g₂ ⟶ e ≃ g₁ • f ⟶ e ≃ g₂ • f :=
    HasTrans.revTrans ⊙ comp_congrArg_left

    def comp_subst_right  {a b c : α} {f₁ f₂ : R a b} (g : R b c) {e : R a c} : f₁ ≃ f₂ ⟶ g • f₂ ≃ e ⟶ g • f₁ ≃ e :=
    HasTrans.trans    ⊙ comp_congrArg_right
    def comp_subst_right' {a b c : α} {f₁ f₂ : R a b} (g : R b c) {e : R a c} : f₁ ≃ f₂ ⟶ e ≃ g • f₁ ⟶ e ≃ g • f₂ :=
    HasTrans.revTrans ⊙ comp_congrArg_right

    def applyAssocLR_left  {a b c d : α} {f : R a b} {g : R b c} {h : R c d} {e : R a d} : (h • g) • f ≃ e ⟶ h • (g • f) ≃ e :=
    HasTrans.trans ⟮assocRL f g h⟯
    def applyAssocRL_left  {a b c d : α} {f : R a b} {g : R b c} {h : R c d} {e : R a d} : h • (g • f) ≃ e ⟶ (h • g) • f ≃ e :=
    HasTrans.trans ⟮assocLR f g h⟯
    def applyAssocLR_right {a b c d : α} {f : R a b} {g : R b c} {h : R c d} {e : R a d} : e ≃ (h • g) • f ⟶ e ≃ h • (g • f) :=
    HasTrans.revTrans'' (assocLR f g h)
    def applyAssocRL_right {a b c d : α} {f : R a b} {g : R b c} {h : R c d} {e : R a d} : e ≃ h • (g • f) ⟶ e ≃ (h • g) • f :=
    HasTrans.revTrans'' (assocRL f g h)

    def applyAssocLR {a β₁ β₂ γ₁ γ₂ d : α} {f₁ : R a β₁} {f₂ : R a β₂} {g₁ : R β₁ γ₁} {g₂ : R β₂ γ₂} {h₁ : R γ₁ d} {h₂ : R γ₂ d} :
      (h₁ • g₁) • f₁ ≃ (h₂ • g₂) • f₂ ⟶ h₁ • (g₁ • f₁) ≃ h₂ • (g₂ • f₂) :=
    applyAssocLR_right ⊙ applyAssocLR_left
    def applyAssocRL {a β₁ β₂ γ₁ γ₂ d : α} {f₁ : R a β₁} {f₂ : R a β₂} {g₁ : R β₁ γ₁} {g₂ : R β₂ γ₂} {h₁ : R γ₁ d} {h₂ : R γ₂ d} :
      h₁ • (g₁ • f₁) ≃ h₂ • (g₂ • f₂) ⟶ (h₁ • g₁) • f₁ ≃ (h₂ • g₂) • f₂ :=
    applyAssocRL_right ⊙ applyAssocRL_left

  end IsCompositionRelation

  namespace IsMorphismRelation

    variable [IsPreorder R] [IsMorphismRelation R]

    def leftCancelId  {a b : α} (f : R a b) {e : R b b} : e ≃ ident R b ⟶ e • f ≃ f :=
    HasLinearFunOp.swapFun (comp_subst_left  f) (leftId  f)
    def rightCancelId {a b : α} (f : R a b) {e : R a a} : e ≃ ident R a ⟶ f • e ≃ f :=
    HasLinearFunOp.swapFun (comp_subst_right f) (rightId f)

  end IsMorphismRelation

  open IsMorphismRelation

  namespace IsIsomorphismRelation

    variable [IsEquivalence R] [IsIsomorphismRelation R]

    def inv_congrArg {a b : α} {f₁ f₂ : R a b} : f₁ ≃ f₂ ⟶ f₁⁻¹ ≃ f₂⁻¹ :=
    HasFunctorialEquivalences.equiv_congrArg U HasSymm.symm

    def inv_subst  {a b : α} {f₁ f₂ : R a b} {e : R b a} : f₁ ≃ f₂ ⟶ f₂⁻¹ ≃ e ⟶ f₁⁻¹ ≃ e :=
    HasTrans.trans    ⊙ inv_congrArg
    def inv_subst' {a b : α} {f₁ f₂ : R a b} {e : R b a} : f₁ ≃ f₂ ⟶ e ≃ f₁⁻¹ ⟶ e ≃ f₂⁻¹ :=
    HasTrans.revTrans ⊙ inv_congrArg

    def leftCancel'     {a b c : α} (f : R a b) (g : R b c) : (g⁻¹ • g) • f ≃ f := (leftCancelId  f) (leftInv  g)
    def leftCancel      {a b c : α} (f : R a b) (g : R b c) : g⁻¹ • (g • f) ≃ f := applyAssocLR_left ⟮leftCancel'     f g⟯
    def leftCancelInv'  {a b c : α} (f : R a b) (g : R c b) : (g • g⁻¹) • f ≃ f := (leftCancelId  f) (rightInv g)
    def leftCancelInv   {a b c : α} (f : R a b) (g : R c b) : g • (g⁻¹ • f) ≃ f := applyAssocLR_left ⟮leftCancelInv'  f g⟯
    def rightCancel'    {a b c : α} (f : R a b) (g : R c a) : f • (g • g⁻¹) ≃ f := (rightCancelId f) (rightInv g)
    def rightCancel     {a b c : α} (f : R a b) (g : R c a) : (f • g) • g⁻¹ ≃ f := applyAssocRL_left ⟮rightCancel'    f g⟯
    def rightCancelInv' {a b c : α} (f : R a b) (g : R a c) : f • (g⁻¹ • g) ≃ f := (rightCancelId f) (leftInv  g)
    def rightCancelInv  {a b c : α} (f : R a b) (g : R a c) : (f • g⁻¹) • g ≃ f := applyAssocRL_left ⟮rightCancelInv' f g⟯

    def leftMulInv  {a b c : α} (f₁ : R a b) (f₂ : R a c) (g : R b c) : g • f₁ ≃ f₂ ⟷' f₁ ≃ g⁻¹ • f₂ :=
    ⟨HasLinearFunOp.swapFun (comp_subst_right' g⁻¹) (HasSymm.symm' (leftCancel f₁ g)),
     HasLinearFunOp.swapFun (comp_subst_right  g)   (leftCancelInv f₂ g)⟩
    def leftMulInv' {a b c : α} (f₁ : R a b) (f₂ : R a c) (g : R c b) : g⁻¹ • f₁ ≃ f₂ ⟷' f₁ ≃ g • f₂ :=
    ⟨HasLinearFunOp.swapFun (comp_subst_right' g)   (HasSymm.symm' (leftCancelInv f₁ g)),
     HasLinearFunOp.swapFun (comp_subst_right  g⁻¹) (leftCancel f₂ g)⟩

    def leftMul {a b c : α} (f₁ f₂ : R a b) (g : R b c) : g • f₁ ≃ g • f₂ ⟷' f₁ ≃ f₂ :=
    ⟨HasTrans.revTrans'' (leftCancel f₂ g) ⊙ (leftMulInv f₁ (g • f₂) g).mp, comp_congrArg_right⟩

    def rightMulInv  {a b c : α} (f₁ : R a c) (f₂ : R b c) (g : R b a) : f₁ • g ≃ f₂ ⟷' f₁ ≃ f₂ • g⁻¹ :=
    ⟨HasLinearFunOp.swapFun (comp_subst_left' g⁻¹) (HasSymm.symm' (rightCancel f₁ g)),
     HasLinearFunOp.swapFun (comp_subst_left  g)   (rightCancelInv f₂ g)⟩
    def rightMulInv' {a b c : α} (f₁ : R a c) (f₂ : R b c) (g : R a b) : f₁ • g⁻¹ ≃ f₂ ⟷' f₁ ≃ f₂ • g :=
    ⟨HasLinearFunOp.swapFun (comp_subst_left' g)   (HasSymm.symm' (rightCancelInv f₁ g)),
     HasLinearFunOp.swapFun (comp_subst_left  g⁻¹) (rightCancel f₂ g)⟩

    def rightMul {a b c : α} (f₁ f₂ : R a b) (g : R c a) : f₁ • g ≃ f₂ • g ⟷' f₁ ≃ f₂ :=
    ⟨HasTrans.revTrans'' (rightCancel f₂ g) ⊙ (rightMulInv f₁ (f₂ • g) g).mp, comp_congrArg_left⟩

    def eqInvIffInvEq {a b : α} (f : R a b) (g : R b a) : f ≃ g⁻¹ ⟷' f⁻¹ ≃ g :=
    ⟨HasLinearFunOp.swapFun inv_subst  (invInv g),
     HasLinearFunOp.swapFun inv_subst' (HasSymm.symm' (invInv f))⟩

    def eqIffEqInv {a b : α} (f₁ f₂ : R a b) : f₁⁻¹ ≃ f₂⁻¹ ⟷' f₁ ≃ f₂ :=
    ⟨HasTrans.revTrans'' (invInv f₂) ⊙ (eqInvIffInvEq f₁ f₂⁻¹).mpr, inv_congrArg⟩

    def leftRightMul {a b c d : α} (f₁ : R a b) (f₂ : R a c) (g₁ : R b d) (g₂ : R c d) :
      g₂⁻¹ • g₁ ≃ f₂ • f₁⁻¹ ⟷' g₁ • f₁ ≃ g₂ • f₂ :=
    ⟨(leftMulInv' (g₁ • f₁) f₂ g₂).mp ⊙ applyAssocLR_left ⊙ (rightMulInv (g₂⁻¹ • g₁) f₂ f₁).mpr,
     (leftMulInv' g₁ (f₂ • f₁⁻¹) g₂).mpr ⊙ applyAssocLR_right ⊙ (rightMulInv g₁ (g₂ • f₂) f₁).mp⟩

    def swapInv  {a b c d : α} (f₁ : R a b) (f₂ : R c d) (g₁ : R d b) (g₂ : R c a) :
      g₁⁻¹ • f₁ ≃ f₂ • g₂⁻¹ ⟶ f₁⁻¹ • g₁ ≃ g₂ • f₂⁻¹ :=
    (leftRightMul f₂ g₂ g₁ f₁).mpr ⊙ HasSymm.symm ⊙ (leftRightMul g₂ f₂ f₁ g₁).mp

    def swapInv' {a b c d : α} (f₁ : R a b) (f₂ : R c d) (g₁ : R d b) (g₂ : R c a) :
      f₂ • g₂⁻¹ ≃ g₁⁻¹ • f₁ ⟶ g₂ • f₂⁻¹ ≃ f₁⁻¹ • g₁ :=
    HasSymm.symm ⊙ swapInv f₁ f₂ g₁ g₂ ⊙ HasSymm.symm

  end IsIsomorphismRelation

  open IsIsomorphismRelation

end Morphisms

section Functors

  variable {α : Sort u}

  namespace idFun

    variable {U : Universe} [HasInstanceArrows U] [HasExternalFunctors U U]
             [HasIdFun U] (R : GeneralizedRelation α U)

    instance isReflFunctor  [HasRefl  R] : IsReflFunctor  R R (HasIdFun.idFun' _) :=
    ⟨λ a   => HasRefl.refl (ident R a)⟩

    variable [HasInternalFunctors U]

    instance isSymmFunctor  [HasSymm  R] : IsSymmFunctor  R R (HasIdFun.idFun' _) :=
    ⟨λ f   => HasRefl.refl f⁻¹⟩

    instance isTransFunctor [HasTrans R] : IsTransFunctor R R (HasIdFun.idFun' _) :=
    ⟨λ f g => HasRefl.refl (g • f)⟩

    instance isPreorderFunctor    [IsPreorder    R] : IsPreorderFunctor    R R (HasIdFun.idFun' _) := ⟨⟩
    instance isEquivalenceFunctor [IsEquivalence R] : IsEquivalenceFunctor R R (HasIdFun.idFun' _) := ⟨⟩

  end idFun

  namespace constFun

    variable {U V : Universe} [HasInstanceArrows V] [HasExternalFunctors U V]
             [HasConstFun U V] (R : GeneralizedRelation α U) {β : V} (c : β)

    def idArrow : c ⇝ c := ident (HasInstanceArrows.Arrow β) c

    instance isReflFunctor  [HasRefl  R] : IsReflFunctor  R (ConstRel α c) (HasConstFun.constFun' _ c) :=
    ⟨λ _   => idArrow c⟩

    variable [HasInternalFunctors U] [HasInternalFunctors V] [HasAffineFunOp V]

    instance isSymmFunctor  [HasSymm  R] : IsSymmFunctor  R (ConstRel α c) (HasConstFun.constFun' _ c) :=
    ⟨λ _   => Eq.ndrec (motive := λ b : β => ⌈c ⇝ b⌉) (idArrow c) (Eq.symm (ConstRel.symmEq  α c))⟩

    instance isTransFunctor [HasTrans R] : IsTransFunctor R (ConstRel α c) (HasConstFun.constFun' _ c) :=
    ⟨λ _ _ => Eq.ndrec (motive := λ b : β => ⌈c ⇝ b⌉) (idArrow c) (Eq.symm (ConstRel.transEq α c))⟩

    instance isPreorderFunctor    [IsPreorder    R] : IsPreorderFunctor    R (ConstRel α c) (HasConstFun.constFun' _ c) := ⟨⟩
    instance isEquivalenceFunctor [IsEquivalence R] : IsEquivalenceFunctor R (ConstRel α c) (HasConstFun.constFun' _ c) := ⟨⟩

  end constFun

  namespace compFun

    variable {U V W : Universe} [hV : HasInstanceArrows V] [hW : HasInstanceArrows W]
             [HasExternalFunctors U V] [HasExternalFunctors V W] [HasExternalFunctors U W]
             [HasExternalFunctors hV.arrowUniverse hW.arrowUniverse] [HasArrowCongrArg V W]
             [HasCompFun U V W]
             {R : GeneralizedRelation α U} {S : GeneralizedRelation α V} {T : GeneralizedRelation α W}
             (F : BaseFunctor R S) (G : BaseFunctor S T)

    instance isReflFunctor  [HasRefl  R] [HasRefl  S] [HasRefl  T] [hF : IsReflFunctor  R S F] [hG : IsReflFunctor  S T G] :
      IsReflFunctor  R T (G ⊙' F) :=
    ⟨λ a   => let e₁ : G (F (ident R a)) ⇝ G (ident S a) := HasArrowCongrArg.arrowCongrArg G (hF.respectsRefl a);
              let e₂ : G (ident S a) ⇝ ident T a         := hG.respectsRefl a;
              HasTrans.trans' e₁ e₂⟩

    variable [HasInternalFunctors U] [HasInternalFunctors V] [HasInternalFunctors W]

    instance isSymmFunctor  [HasSymm  R] [HasSymm  S] [HasSymm  T] [hF : IsSymmFunctor  R S F] [hG : IsSymmFunctor  S T G] :
      IsSymmFunctor  R T (G ⊙' F) :=
    ⟨λ f   => let e₁ : G (F f⁻¹) ⇝ G (F f)⁻¹   := HasArrowCongrArg.arrowCongrArg G (hF.respectsSymm f);
              let e₂ : G (F f)⁻¹ ⇝ (G (F f))⁻¹ := hG.respectsSymm (F f);
              HasTrans.trans' e₁ e₂⟩

    instance isTransFunctor [HasTrans R] [HasTrans S] [HasTrans T] [hF : IsTransFunctor R S F] [hG : IsTransFunctor S T G] :
      IsTransFunctor R T (G ⊙' F) :=
    ⟨λ f g => let e₁ : G (F (g • f)) ⇝ G (F g • F f)     := HasArrowCongrArg.arrowCongrArg G (hF.respectsTrans f g);
              let e₂ : G (F g • F f) ⇝ G (F g) • G (F f) := hG.respectsTrans (F f) (F g);
              HasTrans.trans' e₁ e₂⟩

    instance isPreorderFunctor    [IsPreorder    R] [IsPreorder    S] [IsPreorder    T] [IsPreorderFunctor    R S F] [IsPreorderFunctor    S T G] :
      IsPreorderFunctor    R T (G ⊙' F) := ⟨⟩
    instance isEquivalenceFunctor [IsEquivalence R] [IsEquivalence S] [IsEquivalence T] [IsEquivalenceFunctor R S F] [IsEquivalenceFunctor S T G] :
      IsEquivalenceFunctor R T (G ⊙' F) := ⟨⟩

  end compFun

end Functors

section NaturalTransformations

  variable {α : Sort u} {V W : Universe} [HasInternalFunctors W] [hW : HasFunctorialEquivalences W] [HasExternalFunctors V W]
           {β : Sort w} (R : GeneralizedRelation α V) (S : GeneralizedRelation β W)

  instance : HasFunctorialArrows W := hW.toHasFunctorialArrows W

  namespace IsNaturalTransformation

    def refl  [IsPreorder    S] [h : IsMorphismRelation    S] {mF       : α → β}
              (F : ∀ {a b}, R a b ⟶' S (mF a) (mF b)) :
      IsNatural R S F F (λ a => ident S (mF a)) :=
    ⟨λ f => HasTrans.trans' (h.rightId (F f)) (HasSymm.symm' (h.leftId (F f)))⟩

    variable [HasLinearFunOp hW.equivUniverse]

    def symm  [IsEquivalence S] [h : IsIsomorphismRelation S] {mF mG    : α → β}
              (F : ∀ {a b}, R a b ⟶' S (mF a) (mF b)) (G : ∀ {a b}, R a b ⟶' S (mG a) (mG b))
              (n : ∀ a, S (mF a) (mG a)) [hn : IsNatural R S F G n] :
      IsNatural R S G F (λ a => (n a)⁻¹) :=
    ⟨λ {a b} f => HasSymm.symm' ((IsIsomorphismRelation.leftRightMul (n a) (F f) (G f) (n b)).mpr (hn.nat f))⟩

    def trans [HasTrans      S] [h : IsCompositionRelation S] {mF mG mH : α → β}
              (F : ∀ {a b}, R a b ⟶' S (mF a) (mF b)) (G : ∀ {a b}, R a b ⟶' S (mG a) (mG b)) (H : ∀ {a b}, R a b ⟶' S (mH a) (mH b))
              (nFG : ∀ a, S (mF a) (mG a))   (nGH : ∀ a, S (mG a) (mH a))
              [hnFG : IsNatural R S F G nFG] [hnGH : IsNatural R S G H nGH] :
      IsNatural R S F H (λ a => nGH a • nFG a) :=
    ⟨λ {a b} f => let e₁ := IsCompositionRelation.applyAssocLR_left ⟮IsCompositionRelation.comp_congrArg_left  (f := nFG a) (hnGH.nat f)⟯;
                  let e₂ := IsCompositionRelation.applyAssocRL      ⟮IsCompositionRelation.comp_congrArg_right (g := nGH b) (hnFG.nat f)⟯;
                  HasTrans.trans' e₁ e₂⟩

  end IsNaturalTransformation

end NaturalTransformations


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Floris van Doorn
-/
import category_theory.limits.shapes.finite_products
import category_theory.discrete_category

/-!
# Limits in `C` give colimits in `Cᵒᵖ`.

We also give special cases for (co)products,
but not yet for pullbacks / pushouts or for (co)equalizers.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.functor
open opposite

namespace category_theory.limits

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

/-- Turn a colimit for `F : J ⥤ C` into a limit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cocone_op (F : J ⥤ C) {c : cocone F} (hc : is_colimit c) :
  is_limit c.op :=
{ lift := λ s, (hc.desc s.unop).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F : J ⥤ C` into a colimit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cone_op (F : J ⥤ C) {c : cone F} (hc : is_limit c) :
  is_colimit c.op :=
{ desc := λ s, (hc.lift s.unop).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (op j)
  end }

/-- Turn a colimit for `F : J ⥤ Cᵒᵖ` into a limit for `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps] def is_limit_cone_left_op_of_cocone (F : J ⥤ Cᵒᵖ) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_left_op_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_left_op s)).unop,
  fac' :=  λ s j, quiver.hom.op_inj $ by simpa only [cone_left_op_of_cocone_π_app, op_comp,
    quiver.hom.op_unop, is_colimit.fac, cocone_of_cone_left_op_ι_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac, cocone_of_cone_left_op_ι_app] using w (op j)
  end }

/-- Turn a limit of `F : J ⥤ Cᵒᵖ` into a colimit of `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps] def is_colimit_cocone_left_op_of_cone (F : J ⥤ Cᵒᵖ) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_left_op_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_left_op s)).unop,
  fac' := λ s j, quiver.hom.op_inj $ by simpa only [cocone_left_op_of_cone_ι_app, op_comp,
    quiver.hom.op_unop, is_limit.fac, cone_of_cocone_left_op_π_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac, cone_of_cocone_left_op_π_app] using w (op j)
  end }

/-- Turn a colimit for `F : Jᵒᵖ ⥤ C` into a limit for `F.right_op : J ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_right_op_of_cocone (F : Jᵒᵖ ⥤ C) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_right_op_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_right_op s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit for `F : Jᵒᵖ ⥤ C` into a colimit for `F.right_op : J ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cocone_right_op_of_cone (F : Jᵒᵖ ⥤ C) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_right_op_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_right_op s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F : Jᵒᵖ ⥤ Cᵒᵖ` into a limit for `F.unop : J ⥤ C`. -/
@[simps] def is_limit_cone_unop_of_cocone (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_unop_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_unop s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit of `F : Jᵒᵖ ⥤ Cᵒᵖ` into a colimit of `F.unop : J ⥤ C`. -/
@[simps] def is_colimit_cocone_unop_of_cone (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_unop_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_unop s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ` into a limit for `F : J ⥤ C`. -/
@[simps] def is_limit_cocone_unop (F : J ⥤ C) {c : cocone F.op} (hc : is_colimit c) :
  is_limit c.unop :=
{ lift := λ s, (hc.desc s.op).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ` into a colimit for `F : J ⥤ C`. -/
@[simps] def is_colimit_cone_unop (F : J ⥤ C) {c : cone F.op} (hc : is_limit c) :
  is_colimit c.unop :=
{ desc := λ s, (hc.lift s.op).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F.left_op : Jᵒᵖ ⥤ C` into a limit for `F : J ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_of_cocone_left_op (F : J ⥤ Cᵒᵖ) {c : cocone F.left_op}
  (hc : is_colimit c) : is_limit (cone_of_cocone_left_op c) :=
{ lift := λ s, (hc.desc (cocone_left_op_of_cone s)).op,
  fac' := λ s j, quiver.hom.unop_inj $ by simpa only [cone_of_cocone_left_op_π_app, unop_comp,
    quiver.hom.unop_op, is_colimit.fac, cocone_left_op_of_cone_ι_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac, cone_of_cocone_left_op_π_app] using w (unop j)
  end }

/-- Turn a limit of `F.left_op : Jᵒᵖ ⥤ C` into a colimit of `F : J ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cocone_of_cone_left_op (F : J ⥤ Cᵒᵖ) {c : cone (F.left_op)}
  (hc : is_limit c) : is_colimit (cocone_of_cone_left_op c) :=
{ desc := λ s, (hc.lift (cone_left_op_of_cocone s)).op,
  fac' := λ s j, quiver.hom.unop_inj $ by simpa only [cocone_of_cone_left_op_ι_app, unop_comp,
    quiver.hom.unop_op, is_limit.fac, cone_left_op_of_cocone_π_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac, cocone_of_cone_left_op_ι_app] using w (unop j)
  end }

/-- Turn a colimit for `F.right_op : J ⥤ Cᵒᵖ` into a limit for `F : Jᵒᵖ ⥤ C`. -/
@[simps] def is_limit_cone_of_cocone_right_op (F : Jᵒᵖ ⥤ C) {c : cocone F.right_op}
  (hc : is_colimit c) : is_limit (cone_of_cocone_right_op c) :=
{ lift := λ s, (hc.desc (cocone_right_op_of_cone s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F.right_op : J ⥤ Cᵒᵖ` into a limit for `F : Jᵒᵖ ⥤ C`. -/
@[simps] def is_colimit_cocone_of_cone_right_op (F : Jᵒᵖ ⥤ C) {c : cone F.right_op}
  (hc : is_limit c) : is_colimit (cocone_of_cone_right_op c) :=
{ desc := λ s, (hc.lift (cone_right_op_of_cocone s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (op j)
  end }

/-- Turn a colimit for `F.unop : J ⥤ C` into a limit for `F : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_of_cocone_unop (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cocone F.unop} (hc : is_colimit c) :
  is_limit (cone_of_cocone_unop c) :=
{ lift := λ s, (hc.desc (cocone_unop_of_cone s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F.unop : J ⥤ C` into a colimit for `F : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cone_of_cocone_unop (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cone F.unop} (hc : is_limit c) :
  is_colimit (cocone_of_cone_unop c) :=
{ desc := λ s, (hc.lift (cone_unop_of_cocone s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (op j)
  end }

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a colimit, we can construct a limit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_limit_of_has_colimit_left_op (F : J ⥤ Cᵒᵖ) [has_colimit F.left_op] : has_limit F :=
has_limit.mk
{ cone := cone_of_cocone_left_op (colimit.cocone F.left_op),
  is_limit := is_limit_cone_of_cocone_left_op _ (colimit.is_colimit _) }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_limits_of_shape_op_of_has_colimits_of_shape [has_colimits_of_shape Jᵒᵖ C] :
  has_limits_of_shape J Cᵒᵖ :=
{ has_limit := λ F, has_limit_of_has_colimit_left_op F }

local attribute [instance] has_limits_of_shape_op_of_has_colimits_of_shape

/--
If `C` has colimits, we can construct limits for `Cᵒᵖ`.
-/
lemma has_limits_op_of_has_colimits [has_colimits C] : has_limits Cᵒᵖ := ⟨infer_instance⟩

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a limit, we can construct a colimit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_colimit_of_has_limit_left_op (F : J ⥤ Cᵒᵖ) [has_limit F.left_op] : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cone_left_op (limit.cone F.left_op),
  is_colimit := is_colimit_cocone_of_cone_left_op _ (limit.is_limit _) }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_colimits_of_shape_op_of_has_limits_of_shape [has_limits_of_shape Jᵒᵖ C] :
  has_colimits_of_shape J Cᵒᵖ :=
{ has_colimit := λ F, has_colimit_of_has_limit_left_op F }

local attribute [instance] has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has limits, we can construct colimits for `Cᵒᵖ`.
-/
lemma has_colimits_op_of_has_limits [has_limits C] : has_colimits Cᵒᵖ := ⟨infer_instance⟩

variables (X : Type v₁)
/--
If `C` has products indexed by `X`, then `Cᵒᵖ` has coproducts indexed by `X`.
-/
lemma has_coproducts_opposite [has_products_of_shape X C] :
  has_coproducts_of_shape X Cᵒᵖ :=
begin
  haveI : has_limits_of_shape (discrete X)ᵒᵖ C :=
    has_limits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

/--
If `C` has coproducts indexed by `X`, then `Cᵒᵖ` has products indexed by `X`.
-/
lemma has_products_opposite [has_coproducts_of_shape X C] :
  has_products_of_shape X Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape (discrete X)ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

lemma has_finite_coproducts_opposite [has_finite_products C] :
  has_finite_coproducts Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, begin
    resetI,
    haveI : has_limits_of_shape (discrete J)ᵒᵖ C :=
      has_limits_of_shape_of_equivalence (discrete.opposite J).symm,
    apply_instance,
  end }

lemma has_finite_products_opposite [has_finite_coproducts C] :
  has_finite_products Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, begin
    resetI,
    haveI : has_colimits_of_shape (discrete J)ᵒᵖ C :=
      has_colimits_of_shape_of_equivalence (discrete.opposite J).symm,
    apply_instance,
  end }

lemma has_equalizers_opposite [has_coequalizers C] : has_equalizers Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape walking_parallel_pair.{v₁}ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence walking_parallel_pair_op_equiv.{v₁},
  apply_instance
end

lemma has_coequalizers_opposite [has_equalizers C] : has_coequalizers Cᵒᵖ :=
begin
  haveI : has_limits_of_shape walking_parallel_pair.{v₁}ᵒᵖ C :=
    has_limits_of_shape_of_equivalence walking_parallel_pair_op_equiv.{v₁},
  apply_instance
end

lemma has_finite_colimits_opposite [has_finite_limits C] :
  has_finite_colimits Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, by { resetI, apply_instance, }, }

lemma has_finite_limits_opposite [has_finite_colimits C] :
  has_finite_limits Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, by { resetI, apply_instance, }, }

end category_theory.limits