/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Adam Topaz
-/
import category_theory.functor.category
import category_theory.functor.fully_faithful
import category_theory.functor.reflects_isomorphisms

/-!
# Monads

We construct the categories of monads and comonads, and their forgetful functors to endofunctors.

(Note that these are the category theorist's monads, not the programmers monads.
For the translation, see the file `category_theory.monad.types`.)

For the fact that monads are "just" monoids in the category of endofunctors, see the file
`category_theory.monad.equiv_mon`.
-/

namespace category_theory
open category

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

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

/--
The data of a monad on C consists of an endofunctor T together with natural transformations
η : 𝟭 C ⟶ T and μ : T ⋙ T ⟶ T satisfying three equations:
- T μ_X ≫ μ_X = μ_(TX) ≫ μ_X (associativity)
- η_(TX) ≫ μ_X = 1_X (left unit)
- Tη_X ≫ μ_X = 1_X (right unit)
-/
structure monad extends C ⥤ C :=
(η' [] : 𝟭 _ ⟶ to_functor)
(μ' [] : to_functor ⋙ to_functor ⟶ to_functor)
(assoc' : ∀ X, to_functor.map (nat_trans.app μ' X) ≫ μ'.app _ = μ'.app _ ≫ μ'.app _ . obviously)
(left_unit' : ∀ X : C, η'.app (to_functor.obj X) ≫ μ'.app _ = 𝟙 _ . obviously)
(right_unit' : ∀ X : C, to_functor.map (η'.app X) ≫ μ'.app _ = 𝟙 _ . obviously)

/--
The data of a comonad on C consists of an endofunctor G together with natural transformations
ε : G ⟶ 𝟭 C and δ : G ⟶ G ⋙ G satisfying three equations:
- δ_X ≫ G δ_X = δ_X ≫ δ_(GX) (coassociativity)
- δ_X ≫ ε_(GX) = 1_X (left counit)
- δ_X ≫ G ε_X = 1_X (right counit)
-/
structure comonad extends C ⥤ C :=
(ε' [] : to_functor ⟶ 𝟭 _)
(δ' [] : to_functor ⟶ to_functor ⋙ to_functor)
(coassoc' : ∀ X, nat_trans.app δ' _ ≫ to_functor.map (δ'.app X) = δ'.app _ ≫ δ'.app _ . obviously)
(left_counit' : ∀ X : C, δ'.app X ≫ ε'.app (to_functor.obj X) = 𝟙 _ . obviously)
(right_counit' : ∀ X : C, δ'.app X ≫ to_functor.map (ε'.app X) = 𝟙 _ . obviously)

variables {C} (T : monad C) (G : comonad C)

instance coe_monad : has_coe (monad C) (C ⥤ C) := ⟨λ T, T.to_functor⟩
instance coe_comonad : has_coe (comonad C) (C ⥤ C) := ⟨λ G, G.to_functor⟩

@[simp] lemma monad_to_functor_eq_coe : T.to_functor = T := rfl
@[simp] lemma comonad_to_functor_eq_coe : G.to_functor = G := rfl

/-- The unit for the monad `T`. -/
def monad.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η'
/-- The multiplication for the monad `T`. -/
def monad.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ T := T.μ'

/-- The counit for the comonad `G`. -/
def comonad.ε : (G : C ⥤ C) ⟶ 𝟭 _  := G.ε'
/-- The comultiplication for the comonad `G`. -/
def comonad.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ G := G.δ'

/-- A custom simps projection for the functor part of a monad, as a coercion. -/
def monad.simps.coe := (T : C ⥤ C)
/-- A custom simps projection for the unit of a monad, in simp normal form. -/
def monad.simps.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η
/-- A custom simps projection for the multiplication of a monad, in simp normal form. -/
def monad.simps.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ (T : C ⥤ C) := T.μ

/-- A custom simps projection for the functor part of a comonad, as a coercion. -/
def comonad.simps.coe := (G : C ⥤ C)
/-- A custom simps projection for the counit of a comonad, in simp normal form. -/
def comonad.simps.ε : (G : C ⥤ C) ⟶ 𝟭 _ := G.ε
/-- A custom simps projection for the comultiplication of a comonad, in simp normal form. -/
def comonad.simps.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ (G : C ⥤ C) := G.δ

initialize_simps_projections category_theory.monad (to_functor → coe, η' → η, μ' → μ)
initialize_simps_projections category_theory.comonad (to_functor → coe, ε' → ε, δ' → δ)

@[reassoc]
lemma monad.assoc (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.μ.app X) ≫ T.μ.app _ = T.μ.app _ ≫ T.μ.app _ :=
T.assoc' X

@[simp, reassoc] lemma monad.left_unit (T : monad C) (X : C) :
  T.η.app ((T : C ⥤ C).obj X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.left_unit' X

@[simp, reassoc] lemma monad.right_unit (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.η.app X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.right_unit' X

@[reassoc]
lemma comonad.coassoc (G : comonad C) (X : C) :
  G.δ.app _ ≫ (G : C ⥤ C).map (G.δ.app X) = G.δ.app _ ≫ G.δ.app _ :=
G.coassoc' X

@[simp, reassoc] lemma comonad.left_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ G.ε.app ((G : C ⥤ C).obj X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.left_counit' X

@[simp, reassoc] lemma comonad.right_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ (G : C ⥤ C).map (G.ε.app X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.right_counit' X

/-- A morphism of monads is a natural transformation compatible with η and μ. -/
@[ext]
structure monad_hom (T₁ T₂ : monad C) extends nat_trans (T₁ : C ⥤ C) T₂ :=
(app_η' : ∀ X, T₁.η.app X ≫ app X = T₂.η.app X . obviously)
(app_μ' : ∀ X, T₁.μ.app X ≫ app X = ((T₁ : C ⥤ C).map (app X) ≫ app _) ≫ T₂.μ.app X . obviously)

/-- A morphism of comonads is a natural transformation compatible with ε and δ. -/
@[ext]
structure comonad_hom (M N : comonad C) extends nat_trans (M : C ⥤ C) N :=
(app_ε' : ∀ X, app X ≫ N.ε.app X = M.ε.app X . obviously)
(app_δ' : ∀ X, app X ≫ N.δ.app X = M.δ.app X ≫ app _ ≫ (N : C ⥤ C).map (app X) . obviously)

restate_axiom monad_hom.app_η'
restate_axiom monad_hom.app_μ'
attribute [simp, reassoc] monad_hom.app_η monad_hom.app_μ

restate_axiom comonad_hom.app_ε'
restate_axiom comonad_hom.app_δ'
attribute [simp, reassoc] comonad_hom.app_ε comonad_hom.app_δ

instance : category (monad C) :=
{ hom := monad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ _ _ _ f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance : category (comonad C) :=
{ hom := comonad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ M N L f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance {T : monad C} : inhabited (monad_hom T T) := ⟨𝟙 T⟩

@[simp]

instance {G : comonad C} : inhabited (comonad_hom G G) := ⟨𝟙 G⟩

@[simp] lemma comonad_hom.id_to_nat_trans (T : comonad C) :
  (𝟙 T : T ⟶ T).to_nat_trans = 𝟙 (T : C ⥤ C) :=
rfl
@[simp] lemma comp_to_nat_trans {T₁ T₂ T₃ : comonad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  (f ≫ g).to_nat_trans =
    ((f.to_nat_trans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.to_nat_trans : (T₁ : C ⥤ C) ⟶ T₃) :=
rfl

/-- Construct a monad isomorphism from a natural isomorphism of functors where the forward
direction is a monad morphism. -/
@[simps]
def monad_iso.mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_η' := f_η, app_μ' := f_μ },
  inv :=
  { to_nat_trans := f.inv,
    app_η' := λ X, by simp [←f_η],
    app_μ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_right f,
      simp only [nat_trans.naturality, iso.inv_hom_id_app, assoc, comp_id, f_μ,
        nat_trans.naturality_assoc, iso.inv_hom_id_app_assoc, ←functor.map_comp_assoc],
      simp,
    end } }

/-- Construct a comonad isomorphism from a natural isomorphism of functors where the forward
direction is a comonad morphism. -/
@[simps]
def comonad_iso.mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_ε' := f_ε, app_δ' := f_δ },
  inv :=
  { to_nat_trans := f.inv,
    app_ε' := λ X, by simp [←f_ε],
    app_δ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_left f,
      simp only [reassoc_of (f_δ X), iso.hom_inv_id_app_assoc, nat_trans.naturality_assoc],
      rw [←functor.map_comp, iso.hom_inv_id_app, functor.map_id],
      apply (comp_id _).symm
    end } }

variable (C)

/--
The forgetful functor from the category of monads to the category of endofunctors.
-/
@[simps]
def monad_to_functor : monad C ⥤ (C ⥤ C) :=
{ obj := λ T, T,
  map := λ M N f, f.to_nat_trans }

instance : faithful (monad_to_functor C) := {}.

@[simp]
lemma monad_to_functor_map_iso_monad_iso_mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  (monad_to_functor _).map_iso (monad_iso.mk f f_η f_μ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (monad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (monad_iso.mk (as_iso ((monad_to_functor C).map f)) f.app_η f.app_μ),
    ext; refl,
  end }

/--
The forgetful functor from the category of comonads to the category of endofunctors.
-/
@[simps]
def comonad_to_functor : comonad C ⥤ (C ⥤ C) :=
{ obj := λ G, G,
  map := λ M N f, f.to_nat_trans }

instance : faithful (comonad_to_functor C) := {}.

@[simp]
lemma comonad_to_functor_map_iso_comonad_iso_mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  (comonad_to_functor _).map_iso (comonad_iso.mk f f_ε f_δ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (comonad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (comonad_iso.mk (as_iso ((comonad_to_functor C).map f)) f.app_ε f.app_δ),
    ext; refl,
  end }

variable {C}

/--
An isomorphism of monads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def monad_iso.to_nat_iso {M N : monad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(monad_to_functor C).map_iso h

/--
An isomorphism of comonads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def comonad_iso.to_nat_iso {M N : comonad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(comonad_to_functor C).map_iso h

variable (C)

namespace monad

/-- The identity monad. -/
@[simps]
def id : monad C :=
{ to_functor := 𝟭 C,
  η' := 𝟙 (𝟭 C),
  μ' := 𝟙 (𝟭 C) }

instance : inhabited (monad C) := ⟨monad.id C⟩

end monad

namespace comonad

/-- The identity comonad. -/
@[simps]
def id : comonad C :=
{ to_functor := 𝟭 _,
  ε' := 𝟙 (𝟭 C),
  δ' := 𝟙 (𝟭 C) }

instance : inhabited (comonad C) := ⟨comonad.id C⟩

end comonad

end category_theory


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.multiset.nodup

/-!
# The cartesian product of multisets

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

namespace multiset

section pi
variables {α : Type*}
open function

/-- Given `δ : α → Type*`, `pi.empty δ` is the trivial dependent function out of the empty
multiset. -/
def pi.empty (δ : α → Sort*) : (Πa∈(0:multiset α), δ a) .

variables [decidable_eq α] {β : α → Type*} {δ : α → Sort*}

/-- Given `δ : α → Type*`, a multiset `m` and a term `a`, as well as a term `b : δ a` and a
function `f` such that `f a' : δ a'` for all `a'` in `m`, `pi.cons m a b f` is a function `g` such
that `g a'' : δ a''` for all `a''` in `a ::ₘ m`. -/
def pi.cons (m : multiset α) (a : α) (b : δ a) (f : Πa∈m, δ a) : Πa'∈a ::ₘ m, δ a' :=
λa' ha', if h : a' = a then eq.rec b h.symm else f a' $ (mem_cons.1 ha').resolve_left h

lemma pi.cons_same {m : multiset α} {a : α} {b : δ a} {f : Πa∈m, δ a} (h : a ∈ a ::ₘ m) :
  pi.cons m a b f a h = b :=
dif_pos rfl

lemma pi.cons_ne {m : multiset α} {a a' : α} {b : δ a} {f : Πa∈m, δ a}
  (h' : a' ∈ a ::ₘ m) (h : a' ≠ a) :
  pi.cons m a b f a' h' = f a' ((mem_cons.1 h').resolve_left h) :=
dif_neg h

lemma pi.cons_swap {a a' : α} {b : δ a} {b' : δ a'} {m : multiset α} {f : Πa∈m, δ a} (h : a ≠ a') :
  pi.cons (a' ::ₘ m) a b (pi.cons m a' b' f) == pi.cons (a ::ₘ m) a' b' (pi.cons m a b f) :=
begin
  apply hfunext rfl,
  rintro a'' _ rfl,
  refine hfunext (by rw [cons_swap]) (λ ha₁ ha₂ _, _),
  rcases ne_or_eq a'' a with h₁ | rfl,
  rcases eq_or_ne a'' a' with rfl | h₂,
  all_goals { simp [*, pi.cons_same, pi.cons_ne] },
end

/-- `pi m t` constructs the Cartesian product over `t` indexed by `m`. -/
def pi (m : multiset α) (t : Πa, multiset (β a)) : multiset (Πa∈m, β a) :=
m.rec_on {pi.empty β} (λa m (p : multiset (Πa∈m, β a)), (t a).bind $ λb, p.map $ pi.cons m a b)
begin
  intros a a' m n,
  by_cases eq : a = a',
  { subst eq },
  { simp [map_bind, bind_bind (t a') (t a)],
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b hb,
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b' hb',
    apply map_hcongr, { rw [cons_swap a a'] },
    intros f hf,
    exact pi.cons_swap eq }
end

@[simp] lemma pi_zero (t : Πa, multiset (β a)) : pi 0 t = {pi.empty β} := rfl

@[simp] lemma pi_cons (m : multiset α) (t : Πa, multiset (β a)) (a : α) :
  pi (a ::ₘ m) t = ((t a).bind $ λb, (pi m t).map $ pi.cons m a b) :=
rec_on_cons a m

lemma pi_cons_injective {a : α} {b : δ a} {s : multiset α} (hs : a ∉ s) :
  function.injective (pi.cons s a b) :=
assume f₁ f₂ eq, funext $ assume a', funext $ assume h',
have ne : a ≠ a', from assume h, hs $ h.symm ▸ h',
have a' ∈ a ::ₘ s, from mem_cons_of_mem h',
calc f₁ a' h' = pi.cons s a b f₁ a' this : by rw [pi.cons_ne this ne.symm]
  ... = pi.cons s a b f₂ a' this : by rw [eq]
  ... = f₂ a' h' : by rw [pi.cons_ne this ne.symm]

lemma card_pi (m : multiset α) (t : Πa, multiset (β a)) :
  card (pi m t) = prod (m.map $ λa, card (t a)) :=
multiset.induction_on m (by simp) (by simp [mul_comm] {contextual := tt})

protected lemma nodup.pi {s : multiset α} {t : Π a, multiset (β a)} :
  nodup s → (∀a∈s, nodup (t a)) → nodup (pi s t) :=
multiset.induction_on s (assume _ _, nodup_singleton _)
begin
  assume a s ih hs ht,
  have has : a ∉ s, by simp at hs; exact hs.1,
  have hs : nodup s, by simp at hs; exact hs.2,
  simp,
  refine ⟨λ b hb, (ih hs $ λ a' h', ht a' $ mem_cons_of_mem h').map (pi_cons_injective has), _⟩,
  refine (ht a $ mem_cons_self _ _).pairwise _,
  from assume b₁ hb₁ b₂ hb₂ neb, disjoint_map_map.2 (assume f hf g hg eq,
    have pi.cons s a b₁ f a (mem_cons_self _ _) = pi.cons s a b₂ g a (mem_cons_self _ _),
      by rw [eq],
    neb $ show b₁ = b₂, by rwa [pi.cons_same, pi.cons_same] at this)
end

@[simp]
lemma pi.cons_ext {m : multiset α} {a : α} (f : Π a' ∈ a ::ₘ m, δ a') :
  pi.cons m a (f _ (mem_cons_self _ _)) (λ a' ha', f a' (mem_cons_of_mem ha')) = f :=
begin
  ext a' h',
  by_cases a' = a,
  { subst h, rw [pi.cons_same] },
  { rw [pi.cons_ne _ h] }
end

lemma mem_pi (m : multiset α) (t : Πa, multiset (β a)) :
  ∀f:Πa∈m, β a, (f ∈ pi m t) ↔ (∀a (h : a ∈ m), f a h ∈ t a) :=
begin
  intro f,
  induction m using multiset.induction_on with a m ih,
  { simpa using show f = pi.empty β, by funext a ha; exact ha.elim },
  simp_rw [pi_cons, mem_bind, mem_map, ih],
  split,
  { rintro ⟨b, hb, f', hf', rfl⟩ a' ha',
    by_cases a' = a,
    { subst h, rwa [pi.cons_same] },
    { rw [pi.cons_ne _ h], apply hf' } },
  { intro hf,
    refine ⟨_, hf a (mem_cons_self _ _), _, λ a ha, hf a (mem_cons_of_mem ha), _⟩,
    rw pi.cons_ext }
end

end pi

end multiset


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module category_theory.adhesive
! leanprover-community/mathlib commit afff1f24a6b68d0077c9d63782a1d093e337758c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Extensive
import Mathbin.CategoryTheory.Limits.Shapes.KernelPair

/-!

# Adhesive categories

## Main definitions
- `category_theory.is_pushout.is_van_kampen`: A convenience formulation for a pushout being
  a van Kampen colimit.
- `category_theory.adhesive`: A category is adhesive if it has pushouts and pullbacks along
  monomorphisms, and such pushouts are van Kampen.

## Main Results
- `category_theory.type.adhesive`: The category of `Type` is adhesive.
- `category_theory.adhesive.is_pullback_of_is_pushout_of_mono_left`: In adhesive categories,
  pushouts along monomorphisms are pullbacks.
- `category_theory.adhesive.mono_of_is_pushout_of_mono_left`: In adhesive categories,
  monomorphisms are stable under pushouts.
- `category_theory.adhesive.to_regular_mono_category`: Monomorphisms in adhesive categories are
  regular (this implies that adhesive categories are balanced).

## TODO

Show that the following are adhesive:
- functor categories into adhesive categories
- the categories of sheaves over a site

## References
- https://ncatlab.org/nlab/show/adhesive+category
- [Stephen Lack and Paweł Sobociński, Adhesive Categories][adhesive2004]

-/

namespace CategoryTheory

open Limits

universe v' u' v u

variable {J : Type v'} [Category.{u'} J] {C : Type u} [Category.{v} C]

variable {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

-- This only makes sense when the original diagram is a pushout.
/-- A convenience formulation for a pushout being a van Kampen colimit.
See `is_pushout.is_van_kampen_iff` below. -/
@[nolint unused_arguments]
def IsPushout.IsVanKampen (H : IsPushout f g h i) : Prop :=
  ∀ ⦃W' X' Y' Z' : C⦄ (f' : W' ⟶ X') (g' : W' ⟶ Y') (h' : X' ⟶ Z') (i' : Y' ⟶ Z') (αW : W' ⟶ W)
    (αX : X' ⟶ X) (αY : Y' ⟶ Y) (αZ : Z' ⟶ Z) (hf : IsPullback f' αW αX f)
    (hg : IsPullback g' αW αY g) (hh : CommSq h' αX αZ h) (hi : CommSq i' αY αZ i)
    (w : CommSq f' g' h' i'), IsPushout f' g' h' i' ↔ IsPullback h' αX αZ h ∧ IsPullback i' αY αZ i
#align category_theory.is_pushout.is_van_kampen CategoryTheory.IsPushout.IsVanKampen

theorem IsPushout.IsVanKampen.flip {H : IsPushout f g h i} (H' : H.IsVanKampen) :
    H.flip.IsVanKampen := by
  introv W' hf hg hh hi w
  simpa only [is_pushout.flip_iff, is_pullback.flip_iff, and_comm'] using
    H' g' f' i' h' αW αY αX αZ hg hf hi hh w.flip
#align category_theory.is_pushout.is_van_kampen.flip CategoryTheory.IsPushout.IsVanKampen.flip

theorem IsPushout.isVanKampen_iff (H : IsPushout f g h i) :
    H.IsVanKampen ↔ IsVanKampenColimit (PushoutCocone.mk h i H.w) :=
  by
  constructor
  · intro H F' c' α fα eα hα
    refine'
      Iff.trans _
        ((H (F'.map walking_span.hom.fst) (F'.map walking_span.hom.snd) (c'.ι.app _) (c'.ι.app _)
              (α.app _) (α.app _) (α.app _) fα (by convert hα walking_span.hom.fst)
              (by convert hα walking_span.hom.snd) _ _ _).trans
          _)
    · have :
        F'.map walking_span.hom.fst ≫ c'.ι.app walking_span.left =
          F'.map walking_span.hom.snd ≫ c'.ι.app walking_span.right :=
        by simp only [cocone.w]
      rw [(is_colimit.equiv_of_nat_iso_of_iso (diagram_iso_span F') c' (pushout_cocone.mk _ _ this)
            _).nonempty_congr]
      · exact ⟨fun h => ⟨⟨this⟩, h⟩, fun h => h.2⟩
      · refine' cocones.ext (iso.refl c'.X) _
        rintro (_ | _ | _) <;> dsimp <;>
          simp only [c'.w, category.assoc, category.id_comp, category.comp_id]
    · exact ⟨nat_trans.congr_app eα.symm _⟩
    · exact ⟨nat_trans.congr_app eα.symm _⟩
    · exact ⟨by simp⟩
    constructor
    · rintro ⟨h₁, h₂⟩ (_ | _ | _)
      · rw [← c'.w walking_span.hom.fst]
        exact (hα walking_span.hom.fst).paste_horiz h₁
      exacts[h₁, h₂]
    · intro h
      exact ⟨h _, h _⟩
  · introv H W' hf hg hh hi w
    refine'
      Iff.trans _
        ((H w.cocone
              ⟨by
                rintro (_ | _ | _)
                exacts[αW, αX, αY], _⟩
              αZ _ _).trans
          _)
    rotate_left
    · rintro i _ (_ | _ | _)
      · dsimp
        simp only [Functor.map_id, category.comp_id, category.id_comp]
      exacts[hf.w, hg.w]
    · ext (_ | _ | _)
      · dsimp
        rw [pushout_cocone.condition_zero]
        erw [category.assoc, hh.w, hf.w_assoc]
      exacts[hh.w.symm, hi.w.symm]
    · rintro i _ (_ | _ | _)
      · dsimp
        simp_rw [Functor.map_id]
        exact is_pullback.of_horiz_is_iso ⟨by rw [category.comp_id, category.id_comp]⟩
      exacts[hf, hg]
    · constructor
      · intro h
        exact ⟨h walking_cospan.left, h walking_cospan.right⟩
      · rintro ⟨h₁, h₂⟩ (_ | _ | _)
        · dsimp
          rw [pushout_cocone.condition_zero]
          exact hf.paste_horiz h₁
        exacts[h₁, h₂]
    · exact ⟨fun h => h.2, fun h => ⟨_, h⟩⟩
#align category_theory.is_pushout.is_van_kampen_iff CategoryTheory.IsPushout.isVanKampen_iff

theorem is_coprod_iff_isPushout {X E Y YE : C} (c : BinaryCofan X E) (hc : IsColimit c) {f : X ⟶ Y}
    {iY : Y ⟶ YE} {fE : c.pt ⟶ YE} (H : CommSq f c.inl iY fE) :
    Nonempty (IsColimit (BinaryCofan.mk (c.inr ≫ fE) iY)) ↔ IsPushout f c.inl iY fE :=
  by
  constructor
  · rintro ⟨h⟩
    refine' ⟨H, ⟨limits.pushout_cocone.is_colimit_aux' _ _⟩⟩
    intro s
    dsimp
    refine' ⟨h.desc (binary_cofan.mk (c.inr ≫ s.inr) s.inl), h.fac _ ⟨walking_pair.right⟩, _, _⟩
    · apply binary_cofan.is_colimit.hom_ext hc
      · rw [← H.w_assoc]
        erw [h.fac _ ⟨walking_pair.right⟩]
        exact s.condition
      · rw [← category.assoc]
        exact h.fac _ ⟨walking_pair.left⟩
    · intro m e₁ e₂
      apply binary_cofan.is_colimit.hom_ext h
      · dsimp
        rw [category.assoc, e₂, eq_comm]
        exact h.fac _ ⟨walking_pair.left⟩
      · refine' e₁.trans (Eq.symm _)
        exact h.fac _ _
  · refine' fun H => ⟨_⟩
    fapply limits.binary_cofan.is_colimit_mk
    ·
      exact fun s =>
        H.is_colimit.desc
          (pushout_cocone.mk s.inr _ <|
            (hc.fac (binary_cofan.mk (f ≫ s.inr) s.inl) ⟨walking_pair.left⟩).symm)
    · intro s
      erw [category.assoc, H.is_colimit.fac _ walking_span.right, hc.fac]
      rfl
    · intro s
      exact H.is_colimit.fac _ walking_span.left
    · intro s m e₁ e₂
      apply pushout_cocone.is_colimit.hom_ext H.is_colimit
      · symm
        exact (H.is_colimit.fac _ walking_span.left).trans e₂.symm
      · erw [H.is_colimit.fac _ walking_span.right]
        apply binary_cofan.is_colimit.hom_ext hc
        · dsimp
          erw [hc.fac, ← H.w_assoc, e₂]
          rfl
        · refine' ((category.assoc _ _ _).symm.trans e₁).trans _
          symm
          exact hc.fac _ _
#align category_theory.is_coprod_iff_is_pushout CategoryTheory.is_coprod_iff_isPushout

theorem IsPushout.isVanKampen_inl {W E X Z : C} (c : BinaryCofan W E) [FinitaryExtensive C]
    [HasPullbacks C] (hc : IsColimit c) (f : W ⟶ X) (h : X ⟶ Z) (i : c.pt ⟶ Z)
    (H : IsPushout f c.inl h i) : H.IsVanKampen :=
  by
  obtain ⟨hc₁⟩ := (is_coprod_iff_is_pushout c hc H.1).mpr H
  introv W' hf hg hh hi w
  obtain ⟨hc₂⟩ :=
    ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen c hc)
          (binary_cofan.mk _ pullback.fst) _ _ _ hg.w.symm pullback.condition.symm).mpr
      ⟨hg, is_pullback.of_has_pullback αY c.inr⟩
  refine' (is_coprod_iff_is_pushout _ hc₂ w).symm.trans _
  refine'
    ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen _ hc₁)
          (binary_cofan.mk _ _) pullback.snd _ _ _ hh.w.symm).trans
      _
  · dsimp
    rw [← pullback.condition_assoc, category.assoc, hi.w]
  constructor
  · rintro ⟨hc₃, hc₄⟩
    refine' ⟨hc₄, _⟩
    let Y'' := pullback αZ i
    let cmp : Y' ⟶ Y'' := pullback.lift i' αY hi.w
    have e₁ : (g' ≫ cmp) ≫ pullback.snd = αW ≫ c.inl := by
      rw [category.assoc, pullback.lift_snd, hg.w]
    have e₂ : (pullback.fst ≫ cmp : pullback αY c.inr ⟶ _) ≫ pullback.snd = pullback.snd ≫ c.inr :=
      by rw [category.assoc, pullback.lift_snd, pullback.condition]
    obtain ⟨hc₄⟩ :=
      ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen c hc)
            (binary_cofan.mk _ _) αW _ _ e₁.symm e₂.symm).mpr
        ⟨_, _⟩
    · rw [← category.id_comp αZ, ← show cmp ≫ pullback.snd = αY from pullback.lift_snd _ _ _]
      apply is_pullback.paste_vert _ (is_pullback.of_has_pullback αZ i)
      have : cmp = (hc₂.cocone_point_unique_up_to_iso hc₄).Hom :=
        by
        apply binary_cofan.is_colimit.hom_ext hc₂
        exacts[(hc₂.comp_cocone_point_unique_up_to_iso_hom hc₄ ⟨walking_pair.left⟩).symm,
          (hc₂.comp_cocone_point_unique_up_to_iso_hom hc₄ ⟨walking_pair.right⟩).symm]
      rw [this]
      exact is_pullback.of_vert_is_iso ⟨by rw [← this, category.comp_id, pullback.lift_fst]⟩
    · apply is_pullback.of_right _ e₁ (is_pullback.of_has_pullback _ _)
      rw [category.assoc, pullback.lift_fst, ← H.w, ← w.w]
      exact hf.paste_horiz hc₄
    · apply is_pullback.of_right _ e₂ (is_pullback.of_has_pullback _ _)
      rw [category.assoc, pullback.lift_fst]
      exact hc₃
  · rintro ⟨hc₃, hc₄⟩
    exact ⟨(is_pullback.of_has_pullback αY c.inr).paste_horiz hc₄, hc₃⟩
#align category_theory.is_pushout.is_van_kampen_inl CategoryTheory.IsPushout.isVanKampen_inl

theorem IsPushout.IsVanKampen.isPullback_of_mono_left [Mono f] {H : IsPushout f g h i}
    (H' : H.IsVanKampen) : IsPullback f g h i :=
  ((H' (𝟙 _) g g (𝟙 Y) (𝟙 _) f (𝟙 _) i (IsKernelPair.id_of_mono f)
            (IsPullback.of_vert_isIso ⟨by simp⟩) H.1.flip ⟨rfl⟩ ⟨by simp⟩).mp
        (IsPushout.of_horiz_isIso ⟨by simp⟩)).1.flip
#align category_theory.is_pushout.is_van_kampen.is_pullback_of_mono_left CategoryTheory.IsPushout.IsVanKampen.isPullback_of_mono_left

theorem IsPushout.IsVanKampen.isPullback_of_mono_right [Mono g] {H : IsPushout f g h i}
    (H' : H.IsVanKampen) : IsPullback f g h i :=
  ((H' f (𝟙 _) (𝟙 _) f (𝟙 _) (𝟙 _) g h (IsPullback.of_vert_isIso ⟨by simp⟩)
          (IsKernelPair.id_of_mono g) ⟨rfl⟩ H.1 ⟨by simp⟩).mp
      (IsPushout.of_vert_isIso ⟨by simp⟩)).2
#align category_theory.is_pushout.is_van_kampen.is_pullback_of_mono_right CategoryTheory.IsPushout.IsVanKampen.isPullback_of_mono_right

theorem IsPushout.IsVanKampen.mono_of_mono_left [Mono f] {H : IsPushout f g h i}
    (H' : H.IsVanKampen) : Mono i :=
  IsKernelPair.mono_of_isIso_fst
    ((H' (𝟙 _) g g (𝟙 Y) (𝟙 _) f (𝟙 _) i (IsKernelPair.id_of_mono f)
            (IsPullback.of_vert_isIso ⟨by simp⟩) H.1.flip ⟨rfl⟩ ⟨by simp⟩).mp
        (IsPushout.of_horiz_isIso ⟨by simp⟩)).2
#align category_theory.is_pushout.is_van_kampen.mono_of_mono_left CategoryTheory.IsPushout.IsVanKampen.mono_of_mono_left

theorem IsPushout.IsVanKampen.mono_of_mono_right [Mono g] {H : IsPushout f g h i}
    (H' : H.IsVanKampen) : Mono h :=
  IsKernelPair.mono_of_isIso_fst
    ((H' f (𝟙 _) (𝟙 _) f (𝟙 _) (𝟙 _) g h (IsPullback.of_vert_isIso ⟨by simp⟩)
            (IsKernelPair.id_of_mono g) ⟨rfl⟩ H.1 ⟨by simp⟩).mp
        (IsPushout.of_vert_isIso ⟨by simp⟩)).1
#align category_theory.is_pushout.is_van_kampen.mono_of_mono_right CategoryTheory.IsPushout.IsVanKampen.mono_of_mono_right

/-- A category is adhesive if it has pushouts and pullbacks along monomorphisms,
and such pushouts are van Kampen. -/
class Adhesive (C : Type u) [Category.{v} C] : Prop where
  [hasPullback_of_mono_left : ∀ {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [Mono f], HasPullback f g]
  [hasPushout_of_mono_left : ∀ {X Y S : C} (f : S ⟶ X) (g : S ⟶ Y) [Mono f], HasPushout f g]
  van_kampen :
    ∀ {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z} [Mono f]
      (H : IsPushout f g h i), H.IsVanKampen
#align category_theory.adhesive CategoryTheory.Adhesive

attribute [instance] adhesive.has_pullback_of_mono_left adhesive.has_pushout_of_mono_left

theorem Adhesive.van_kampen' [Adhesive C] [Mono g] (H : IsPushout f g h i) : H.IsVanKampen :=
  (Adhesive.van_kampen H.flip).flip
#align category_theory.adhesive.van_kampen' CategoryTheory.Adhesive.van_kampen'

theorem Adhesive.isPullback_of_isPushout_of_mono_left [Adhesive C] (H : IsPushout f g h i)
    [Mono f] : IsPullback f g h i :=
  (Adhesive.van_kampen H).isPullback_of_mono_left
#align category_theory.adhesive.is_pullback_of_is_pushout_of_mono_left CategoryTheory.Adhesive.isPullback_of_isPushout_of_mono_left

theorem Adhesive.isPullback_of_isPushout_of_mono_right [Adhesive C] (H : IsPushout f g h i)
    [Mono g] : IsPullback f g h i :=
  (Adhesive.van_kampen' H).isPullback_of_mono_right
#align category_theory.adhesive.is_pullback_of_is_pushout_of_mono_right CategoryTheory.Adhesive.isPullback_of_isPushout_of_mono_right

theorem Adhesive.mono_of_isPushout_of_mono_left [Adhesive C] (H : IsPushout f g h i) [Mono f] :
    Mono i :=
  (Adhesive.van_kampen H).mono_of_mono_left
#align category_theory.adhesive.mono_of_is_pushout_of_mono_left CategoryTheory.Adhesive.mono_of_isPushout_of_mono_left

theorem Adhesive.mono_of_isPushout_of_mono_right [Adhesive C] (H : IsPushout f g h i) [Mono g] :
    Mono h :=
  (Adhesive.van_kampen' H).mono_of_mono_right
#align category_theory.adhesive.mono_of_is_pushout_of_mono_right CategoryTheory.Adhesive.mono_of_isPushout_of_mono_right

instance Type.adhesive : Adhesive (Type u) :=
  by
  constructor
  intros
  exact (is_pushout.is_van_kampen_inl _ (types.is_coprod_of_mono f) _ _ _ H.flip).flip
#align category_theory.type.adhesive CategoryTheory.Type.adhesive

noncomputable instance (priority := 100) Adhesive.toRegularMonoCategory [Adhesive C] :
    RegularMonoCategory C :=
  ⟨fun X Y f hf =>
    { z := pushout f f
      left := pushout.inl
      right := pushout.inr
      w := pushout.condition
      IsLimit :=
        (adhesive.is_pullback_of_is_pushout_of_mono_left
            (is_pushout.of_has_pushout f f)).isLimitFork }⟩
#align category_theory.adhesive.to_regular_mono_category CategoryTheory.Adhesive.toRegularMonoCategory

-- This then implies that adhesive categories are balanced
example [Adhesive C] : Balanced C :=
  inferInstance

end CategoryTheory


/-
Copyright (c) 2023 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import Mathlib.Tactic.SolveByElim

register_label_attr ineq_rules

register_label_attr ineq_extra

register_label_attr mod_rules

register_label_attr mod_extra

register_label_attr iff_rules

syntax (name := RelSyntax) "mod_subst" " [" term,* "] " : tactic
syntax (name := ExtraSyntax) "extra" : tactic

open Lean Mathlib Tactic

def RelConfig : SolveByElim.Config :=
{ transparency := .instances
  -- On applying a lemma or hypothesis successfully, don't backtrack
  failAtMaxDepth := false
  maxDepth := 50 }

def Lean.MVarId.Rel (attr : Name) (add : List Term) (m : MessageData)
    (disch : MVarId → MetaM (Option (List MVarId)) := fun _ => pure none)
    (proc : List MVarId → List MVarId → MetaM (Option (List MVarId)) := fun _ _ => pure none)
    (g : MVarId) :
    MetaM (List MVarId) := do
  let cfg : SolveByElim.Config := { RelConfig with discharge := disch, proc := proc }
  let [] ← SolveByElim.solveByElim.processSyntax cfg true false add [] #[mkIdent attr] [g]
    | throwError m
  return []


/-
We now introduce the applicative typeclass. Here
it is as copied mostly verbatim from Lean's library
(credit DeMoura and Ulrich).
-/

import .functor

namespace hidden

open function   -- for definition of "const" used at end of file
universes u v

/-
Now suppose that we want to generalize functors, which allow
for mapping of *one-argument* functions, such as inc, over
functorial values, to enable mapping of n-argument functions
over functorial values for any natural number, n.

As a special case, we have the usual functor mapping function,
which works as follows: (α → β) → f α → f β. In plain English,
it takes a pure one-argument function from (α → β) and applies
it to each value in the functorial value of type f α.

Now consider a function of type α → β → γ (think of addition
of nats, of type nat → nat → nat, for example). Here what we
will want is a mapping function that takes a pure function of
type α → β → γ then a functor of α values *then a functor of
β values* to produce a functor of γ values.

So suppose our pure function is nat addition and that we
want to map this two-argument function. We'll need a list
of natural numbers as first arguments. We'll map add over
it, but of course we won't get a list of resulting nats;
rather we'll get a list of partially evaluated functions.
-/

#reduce nat.add <$> [1,2,3] -- remember <$> is functor.map

/-
We will then want to apply each of these functions to each
of their second arguments.
-/

/-
Now consider mapping a pure function with three arguments.
We take our pure function, map it over the list of first
arguments, getting a list of partially evaluate functions
that expect two more arguments. We then want to apply each
of these to their second arguments in a second list to get
a list of further partially evaluate functions expecting
their last arguments. We apply them to their arguments in
the third list to finally get a list of the values of the
function applied to all of its arguments, which come from
the given lists.
-/

/-
So what we're seeing here is that once we bootstrap the
process given a pure function, what we've now got is a
situation in which we have a *list* of functions each of
which takes some number of arguments, and that many lists
of arguments.
-/

/-
Bootstrap
-/
class has_pure (f : Type u → Type v) :=
(pure {α : Type u} : α → f α)

/-
Apply next step. Given a context (list, tree, option)
of functions of type (α → β), *where β can itself be a
function type*, and given a context of argument values
(of type α), compute and return a corresponding context
of result values (of type β). Understand that if β is
itself a function type, then what's returned here is
"another collection of functions." The seq function is
thus a means to apply a context containing functions
to a context containing arguments to get a context of
results, each of which itself could be a function of
one fewer arguments.
-/
class has_seq (f : Type u → Type v) : Type (max (u+1) v) :=
(seq  : Π {α β : Type u}, f (α → β) → f α → f β)

-- infix notation for seq (** instead of * to not conflict)
infixl ` <**> `:60 := has_seq.seq

/-
And finally, the applicative functor typeclass. Note that
this typeclass (1) extends functor, thus inheriting its map
field; (2) it also extends has_pure and has_seq, as defined
just above, thus gaining pure and seq fields, each of the
requisite type.

Finally, note that we implement the "map" function once and
for all, for all instances of this typeclass. What does it
do? It takes a function of type α → β, uses pure to turn it
into a (singleton) container of functions, and then uses the
seq (<*>) operator to map this container of functions (x)
over a container of argument values (y).
-/
class applicative (f : Type u → Type v) extends functor f, has_pure f, has_seq f :=
(map       := λ _ _ x y, pure x <**> y)

/-
Note that it *extends* the functor typeclass. Look for the use of
its "map" function in the definition of the applicative functor's
"seq" functions, coming up next.
-/

/-
The "applicative option" instance implements function application
*with built-in failure propagation*.
-/

def pure_option {α : Type u} : α → option α
| a := some a

def seq_option : Π {α β : Type u}, option (α → β) → option α → option β
| α β none _ := none
| α β (some func) oa := functor.map func oa  -- Use's functor's option_map!

instance : has_pure option := ⟨ @pure_option ⟩
instance : has_seq option := ⟨ @seq_option ⟩
instance : applicative option := ⟨ ⟩

-- examples with one-argument functions
#reduce pure (nat.succ) <**> none
#reduce none <**> some 1
#reduce pure (nat.succ) <**> (some 1)
#eval pure (λ s, s++"!") <**> (some "Hello")

-- examples with multi-argument functions
#reduce pure (nat.mul) <**> some 3
#reduce pure (nat.mul) <**> some 3 <**> some 4
#reduce pure (nat.mul) <**> none <**> some 4
#reduce pure (nat.mul) <**> some 3 <**> none

/-
Think of "none" as indicating a failure to compute
a function argument. What we've thus produced here,
in the form of the (applicative option) instance is
a generalization of *function application,* where
a failure to produce the function to be applied, or
the failure to produce any of its arguments, yields
a failure return. In the case where the function and
all of its arguments are given, we just get ordinary
function application.

Another way to think about this is that <**> handles
any error propagation "under the hood", leaving us as
programmers with an notion of function application
that appears works pretty much as usual. This is an
example that shows how, by overloading applicative
for option we obtain a new programming abstraction:
of ordinary function application (on the surface)
but with additional effects handling (in this case
error handling) being taken care of under the hood.
-/

/-
The applicative list typeclass instance.

In the preceding example, we had either zero or one
functions in an option and zero or one arguments in
a second option. In the "normal" case, where both the
function and the argument are provided, we just apply
the function to the argument and return the result in
a "some _" option value.

Now we turn to (applicative list) type. Here the seq
operator will take a list of zero or more functions and
a list of zero or more arguments and will return a list
containing the values obtained by applying each function
in the function list to each value in the argument list.

The way to think about this is that we are implementing
a kind of non-deterministic, multi-valued computation.
-/

def pure_list {α : Type u} : α → list α | a := [a]
def seq_list : Π {α β : Type u}, list (α → β) → list α → list β
| α β list.nil _ := list.nil
| α β (hf::tf) l := list.append (functor.map hf l) (seq_list tf l)

instance : has_pure list := ⟨ @pure_list ⟩
instance : has_seq list := ⟨ @seq_list ⟩
instance : applicative list := ⟨ ⟩

-- tests with one-argument functions
#reduce seq_list [] [1,2,3] -- apply empty list of functions
#reduce [] <**> [1,2,3]      -- same thing using infix operator

#reduce seq_list [nat.succ] []
#reduce [nat.succ] <**> []

#reduce seq_list [nat.succ] [1,2,3]
#reduce [nat.succ] <**> [1,2,3]

#reduce seq_list (pure nat.succ) [1,2,3]
#reduce (pure nat.succ) <**> [1,2,3]

#reduce [nat.succ, nat.pred] <**> []
#reduce [nat.succ, nat.pred] <**> [1,2,3]

-- tests with two-argument functions!
#reduce (pure nat.add) <*> [1,2,3]
#reduce (pure nat.add) <**> [1,2,3] <**> [2,4,6]
#reduce [nat.add, nat.mul] <**> [1,2,3] <**> [2,4,6]

/-
In practice we usually don't explicitly apply lists of
multiple functions directly to argument lists. Rather,
again in practice, we're usually interesting in applying
a single function to mult-valued arguments, so we use
"pure" to lift the function value into the list context
and then everything else is done by <**>, which, as we
have just seen, does tend to produce lists of functions
as intermediate results that get "applied" by <**> to
downstream argument lists (multi-valued arguments).
-/

end hidden


import category_theory.preadditive.functor_category
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.filtered

import for_mathlib.homological_complex2
import for_mathlib.additive_functor

import breen_deligne.homotopy

noncomputable theory

open_locale big_operators

open category_theory category_theory.limits

namespace category_theory
namespace preadditive

variables {𝒜 : Type*} [category 𝒜] [has_zero_morphisms 𝒜] [has_finite_biproducts 𝒜]

-- move this
@[simps {fully_applied := ff}]
def Pow (n : ℕ) : 𝒜 ⥤ 𝒜 :=
{ obj := λ A, ⨁ (λ (i : fin n), A),
  map := λ A B f, biproduct.map (λ i, f),
  map_id' := λ A, by { ext i j, simp only [biproduct.ι_map, category.id_comp, category.comp_id], },
  map_comp' := λ A B C f g, by { ext i j, simp only [biproduct.ι_map_assoc, category.assoc], } }

-- move this
attribute [simps] comp_hom
.

instance (n : ℕ) {J : Type*} [category J] : preserves_colimits_of_shape J (Pow n : 𝒜 ⥤ 𝒜) :=
{ preserves_colimit := λ K,
  { preserves := λ c hc,
    { desc := λ s, biproduct.desc $ λ i,
        let t : cocone K :=
        { X := s.X,
          ι := { app := λ j, show K.obj j ⟶ (K ⋙ Pow n).obj j, from biproduct.ι _ i,
                naturality' := by intros X Y f;
                  simp only [functor.comp_map, Pow_map, biproduct.ι_map], } ≫ s.ι } in
        hc.desc t,
      fac' := begin
        intros, ext,
        simp only [Pow_map, functor.map_cocone_ι_app, biproduct.map_desc,
          is_colimit.fac, nat_trans.comp_app, biproduct.ι_desc],
      end,
      uniq' := begin
        intros, ext i,
        simp only [biproduct.ι_desc],
        let t : cocone K :=
        { X := s.X,
          ι := { app := λ j, show K.obj j ⟶ (K ⋙ Pow n).obj j, from biproduct.ι _ i,
                naturality' := by intros X Y f;
                  simp only [functor.comp_map, Pow_map, biproduct.ι_map], } ≫ s.ι },
        refine hc.uniq t (_ ≫ m) _,
        intro j,
        simp only [nat_trans.comp_app, ← w,
          functor.map_cocone_ι_app, Pow_map, biproduct.ι_map_assoc],
      end } } }

instance (n : ℕ) : preserves_colimits (Pow n : 𝒜 ⥤ 𝒜) :=
{ preserves_colimits_of_shape := λ J hJ, by apply_instance }

end preadditive
end category_theory

namespace homotopy

variables {ι 𝒜 : Type*} [category 𝒜] [preadditive 𝒜] {c : complex_shape ι}
variables {C D : homological_complex 𝒜 c} {f g : C ⟶ D}

@[simps]
def congr (h : homotopy f g) (f' g' : C ⟶ D) (hf : f = f') (hg : g = g') :
  homotopy f' g' :=
{ comm := by simpa only [hf, hg] using h.comm,
  .. h }

end homotopy

namespace breen_deligne

open category_theory.preadditive

variables (BD : data)
variables {𝒜 : Type*} [category 𝒜] [preadditive 𝒜] [has_finite_biproducts 𝒜]
variables (F : 𝒜 ⥤ 𝒜)

namespace basic_universal_map

variables {m n o : ℕ} (f : basic_universal_map m n) (g : basic_universal_map n o)

@[simps {fully_applied := ff}]
def eval_Pow : (Pow m : 𝒜 ⥤ 𝒜) ⟶ Pow n :=
{ app := λ A, biproduct.matrix (λ i j, f j i • 𝟙 A),
  naturality' := begin
    intros, ext i j,
    simp only [Pow_map, biproduct.ι_map_assoc, category.assoc, biproduct.matrix_π,
      biproduct.map_π, biproduct.ι_desc, biproduct.matrix_π_assoc, biproduct.ι_desc_assoc,
      comp_zsmul, zsmul_comp, category.comp_id, category.id_comp],
  end }

@[simp] lemma eval_Pow_comp : @eval_Pow 𝒜 _ _ _ _ _ (comp g f) = f.eval_Pow ≫ g.eval_Pow :=
begin
  ext A i j,
  simp only [eval_Pow_app, nat_trans.comp_app, category.assoc, biproduct.ι_map_assoc,
    biproduct.matrix_π, biproduct.ι_matrix_assoc, biproduct.lift_desc,
    biproduct.map_π, biproduct.ι_desc, biproduct.matrix_π_assoc, biproduct.ι_desc_assoc,
    comp_zsmul, zsmul_comp, category.comp_id, category.id_comp],
  simp only [comp, add_monoid_hom.mk'_apply, matrix.mul, matrix.dot_product,
    finset.sum_smul, mul_smul],
  rw [finset.sum_congr rfl],
  rintros j -,
  rw smul_comm,
end

end basic_universal_map

namespace universal_map

variables {m n o : ℕ} (f : universal_map m n) (g : universal_map n o)

/- Note: this definition is generalized in `eval1half.lean` for a functor
`F : A₁ ⥤ A₂`. This generalization is used in `apply_Pow.lean`. -/
def eval_Pow : universal_map m n →+ (Pow m ⋙ F ⟶ Pow n ⋙ F) :=
free_abelian_group.lift $ λ g : basic_universal_map m n, whisker_right g.eval_Pow F

lemma eval_Pow_of (g : basic_universal_map m n) :
  eval_Pow F (free_abelian_group.of g) = whisker_right g.eval_Pow F :=
free_abelian_group.lift.of _ _

@[simp] lemma eval_Pow_zero : eval_Pow F (0 : universal_map m n) = 0 :=
add_monoid_hom.map_zero _

lemma eval_Pow_zero_app (A : 𝒜) : (eval_Pow F (0 : universal_map m n)).app A = 0 :=
by rw [eval_Pow_zero, zero_app]

lemma eval_Pow_comp : eval_Pow F (universal_map.comp g f) = eval_Pow F f ≫ eval_Pow F g :=
begin
  rw [← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.comp_apply, eq_comm,
    ← category_theory.preadditive.comp_hom_apply_apply, ← add_monoid_hom.flip_apply,
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.flip_apply _ _ (eval_Pow F),
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply],
  congr' 2,
  clear f g,
  ext g f : 2,
  simp only [add_monoid_hom.comp_hom_apply_apply, add_monoid_hom.comp_apply,
    add_monoid_hom.flip_apply, category_theory.preadditive.comp_hom_apply_apply,
    comp_of, eval_Pow_of, whisker_right_comp, basic_universal_map.eval_Pow_comp],
end

lemma eval_Pow_comp_app (A : 𝒜) :
  (eval_Pow F (universal_map.comp g f)).app A = (eval_Pow F f).app A ≫ (eval_Pow F g).app A :=
by rw [eval_Pow_comp, nat_trans.comp_app]

@[simps {fully_applied := ff}]
def eval_Pow_functor : FreeMat ⥤ (𝒜 ⥤ 𝒜) :=
{ obj := λ n, Pow n ⋙ F,
  map := λ m n f, eval_Pow F f,
  map_id' := λ n,
  begin
    refine (eval_Pow_of F _).trans _,
    ext A : 2, dsimp,
    rw ← F.map_id, congr' 1,
    ext i j : 2,
    simp only [biproduct.ι_matrix, category.comp_id, biproduct.lift_π, basic_universal_map.id],
    rw biproduct.ι_π,
    split_ifs with hij,
    { cases hij, rw [matrix.one_apply_eq, one_smul, eq_to_hom_refl], },
    { rw [matrix.one_apply_ne, zero_smul], dsimp, rintro rfl, exact hij rfl }
  end,
  map_comp' := λ m n o f g, eval_Pow_comp F _ _ }

instance eval_Pow_functor_additive : (eval_Pow_functor F).additive :=
{ map_add' := λ m n f g, by { dsimp [eval_Pow], rw add_monoid_hom.map_add } }

end universal_map

namespace data

open universal_map

@[simps {fully_applied := ff}]
def eval_functor' : data ⥤ chain_complex (𝒜 ⥤ 𝒜) ℕ :=
(eval_Pow_functor F).map_homological_complex _

@[simps {fully_applied := ff}]
def eval_functor : data ⥤ 𝒜 ⥤ chain_complex 𝒜 ℕ :=
eval_functor' F ⋙ homological_complex.functor_eval.flip
.

-- generalize to arbitrary homological complexes
instance homological_complex.functor_eval_flip_preserves_colimits_of_shape
  (J : Type*) [category J] (F : chain_complex (𝒜 ⥤ 𝒜) ℕ)
  [∀ i, preserves_colimits_of_shape J (F.X i)] :
  preserves_colimits_of_shape J (homological_complex.functor_eval.flip.obj F) :=
{ preserves_colimit := λ K,
  { preserves := λ c hc,
    let t : Π (s : cocone (K ⋙ homological_complex.functor_eval.flip.obj F))
        (i : ℕ), cocone (K ⋙ F.X i) := λ s i,
    { X := s.X.X i,
      ι := { app := λ j, show (K ⋙ F.X i).obj j ⟶ s.X.X i, from (s.ι.app j).f i,
            naturality' := begin
              intros a b φ, have := s.ι.naturality φ, dsimp at this ⊢,
              simp only [category.comp_id] at this ⊢,
              rw ← this, refl
            end } },
      u : Π (s : cocone (K ⋙ homological_complex.functor_eval.flip.obj F))
        (i j : ℕ), cocone (K ⋙ F.X i) := λ s i j,
    { X := s.X.X j,
      ι := { app := λ k, show (K ⋙ F.X i).obj k ⟶ s.X.X j,
                         from (whisker_left K (F.d i j)).app k ≫ (s.ι.app k).f j,
            naturality' := begin
              intros a b φ, have := s.ι.naturality φ, dsimp at this ⊢,
              simp only [category.comp_id] at this ⊢,
              rw [← this, (F.d i j).naturality_assoc], refl,
            end } } in
    { desc := λ s,
      { f := λ i, (is_colimit_of_preserves (F.X i) hc).desc (t s i),
        comm' := begin
          intros i j h, dsimp,
          have := (is_colimit_of_preserves (F.X i) hc).uniq (u s i j),
          refine (this _ _).trans (this _ _).symm,
          { intros j', dsimp,
            erw [(is_colimit_of_preserves (F.X i) hc).fac_assoc],
            apply (s.ι.app j').comm, },
          { intros j', dsimp,
            rw nat_trans.naturality_assoc,
            erw [(is_colimit_of_preserves (F.X j) hc).fac], }
        end },
      fac' := by { intros, ext i, dsimp, erw [(is_colimit_of_preserves (F.X i) hc).fac], },
      uniq' := begin
        intros, ext i,
        exact (is_colimit_of_preserves (F.X i) hc).uniq (t s i) (m.f i)
          (λ j, homological_complex.congr_hom (w j) i),
      end, } } }

instance eval_functor_preserves_colimits_of_shape
  (BD : data) (J : Type*) [category J] [preserves_colimits_of_shape J F] :
  preserves_colimits_of_shape J ((eval_functor F).obj BD) :=
begin
  refine @homological_complex.functor_eval_flip_preserves_colimits_of_shape _ _ _ _ J _
    ((eval_functor' F).obj BD) (id _),
  intro i,
  show preserves_colimits_of_shape J (Pow (BD.X i) ⋙ F),
  apply_instance
end

instance eval_functor_preserves_filtered_colimits (BD : data) [preserves_filtered_colimits F] :
  preserves_filtered_colimits ((eval_functor F).obj BD) :=
{ preserves_filtered_colimits := by introsI; apply_instance }

-- @[simps]
-- def eval_functor.obj (M : 𝒜) : chain_complex 𝒜 ℕ :=
-- { X := λ n, (Pow (BD.X n) ⋙ F).obj M,
--   d := λ m n, (eval_Pow F (BD.d m n)).app M,
--   shape' := λ i j h, by rw [BD.shape i j h, universal_map.eval_Pow_zero_app],
--   d_comp_d' := λ i j k hij hjk, begin
--     rw [← universal_map.eval_Pow_comp_app],
--     have := BD.d_comp_d i j k,
--     convert universal_map.eval_Pow_zero_app _ _ using 3,
--   end }

-- @[simps {fully_applied := ff}]
-- def eval_functor : 𝒜 ⥤ chain_complex 𝒜 ℕ :=
-- { obj := eval_functor.obj BD F,
--   map := λ A B f,
--   { f := λ n, (Pow (BD.X n) ⋙ F).map f,
--     comm' := λ m n h, by simp only [eval_functor.obj_d, nat_trans.naturality] },
--   map_id' := λ A, by { ext n, exact category_theory.functor.map_id _ _ },
--   map_comp' := λ A B C f g, by { ext n, exact category_theory.functor.map_comp _ _ _ } }

-- @[simps {fully_applied := ff}]
-- def map_eval_functor {BD₁ BD₂ : data} (φ : BD₁ ⟶ BD₂) :
--   BD₁.eval_functor F ⟶ BD₂.eval_functor F :=
-- { app := λ A,
--   { f := λ i, (universal_map.eval_Pow F (φ.f i)).app A,
--     comm' := by { intros, dsimp only [eval_functor_obj, eval_functor.obj_d],
--       simp only [← nat_trans.comp_app, ← eval_Pow_comp F], congr' 2, apply φ.comm } },
--   naturality' := λ A B f, by { ext i : 2, apply nat_trans.naturality } }

end data

namespace package

open universal_map

variables (BD' : package) (A : 𝒜)

def eval_homotopy := (eval_Pow_functor F).map_homotopy BD'.homotopy

def eval_homotopy' (A : 𝒜) :=
(eval_Pow_functor F ⋙ (evaluation _ _).obj A).map_homotopy BD'.homotopy

local attribute [instance] has_binary_biproducts_of_finite_biproducts

@[simps]
def Biprod : 𝒜 ⥤ 𝒜 :=
{ obj := λ A, A ⊞ A,
  map := λ A B f, biprod.map f f,
  map_id' := λ A,
    by ext; simp only [biprod.inl_map, biprod.inr_map, category.id_comp, category.comp_id],
  map_comp' := λ A B C f g,
    by ext; simp only [biprod.inl_map_assoc, biprod.inr_map_assoc, category.assoc] }
.

@[simps {fully_applied := ff}]
def Biprod_iso_Pow_two_components (A : 𝒜) : A ⊞ A ≅ (Pow 2).obj A :=
{ hom := biprod.desc
    (biproduct.ι (λ i : fin 2, A) 0)
    (biproduct.ι (λ i : fin 2, A) 1),
  inv := biprod.lift (biproduct.π _ 0) (biproduct.π _ 1),
  hom_inv_id' := begin
    ext;
    simp only [biprod.lift_fst, biprod.lift_snd, biprod.inl_desc_assoc, biprod.inr_desc_assoc,
      biproduct.ι_π_self, category.assoc];
    erw category.id_comp;
    simp only [biprod.inl_fst, biprod.inl_snd, biprod.inr_fst, biprod.inr_snd];
    rw [biproduct.ι_π_ne]; dec_trivial
  end,
  inv_hom_id' := begin
    ext i j,
    erw [category.comp_id],
    simp only [add_comp, comp_add, biprod.lift_desc, category.assoc],
    fin_cases i with [0,1];
    rw [biproduct.ι_π_self_assoc, biproduct.ι_π_ne_assoc, zero_comp],
    swap 2, { dec_trivial },
    swap 3, { dec_trivial },
    { rw add_zero },
    { rw zero_add }
  end }
.

@[simps {fully_applied := ff}]
def Biprod_iso_Pow_two : (Biprod : 𝒜 ⥤ 𝒜) ≅ Pow 2 :=
nat_iso.of_components Biprod_iso_Pow_two_components $ λ A B f,
begin
  ext ⟨i⟩;
  simp only [biproduct.ι_map, Biprod_iso_Pow_two_components_hom, Biprod_map, Pow_map,
    biprod.inl_map_assoc, biprod.inl_desc_assoc, biprod.inr_map_assoc, biprod.inr_desc_assoc,
    biprod.inr_map, category.assoc, biprod.inr_desc],
end
.

@[simps]
def Pow_comp_Pow_components (m n : ℕ) (A : 𝒜) :
  (Pow n).obj ((Pow m).obj A) ≅ (Pow (m * n)).obj A :=
{ hom := biproduct.desc $ λ j, biproduct.desc $ λ i,
    biproduct.ι (λ i : fin _, A) (fin_prod_fin_equiv (i, j)),
  inv := biproduct.lift $ λ j, biproduct.lift $ λ i,
    biproduct.π (λ i : fin _, A) (fin_prod_fin_equiv (i, j)),
  hom_inv_id' := begin
    ext j i j' i' : 4,
    erw [biproduct.ι_desc_assoc, category.comp_id],
    simp only [biproduct.ι_desc_assoc, category.assoc, biproduct.lift_π],
    by_cases hj : j = j',
    { subst hj, rw [biproduct.ι_π_self_assoc],
      by_cases hi : i = i',
      { subst hi, rw [biproduct.ι_π_self, biproduct.ι_π_self] },
      { rw [biproduct.ι_π_ne, biproduct.ι_π_ne],
        { exact hi },
        { simpa only [equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff, eq_self_iff_true, ne.def] using hi, } } },
    { rw [biproduct.ι_π_ne, biproduct.ι_π_ne_assoc, zero_comp, comp_zero],
      { exact hj },
      { simp only [equiv.apply_eq_iff_eq, prod.mk.inj_iff, ne.def, hj, not_false_iff, and_false], } }
  end,
  inv_hom_id' := begin
    ext k k' : 2,
    erw [category.comp_id],
    simp only [category.assoc, biproduct.lift_desc, sum_comp, comp_sum],
    by_cases h : k = k',
    { subst h,
      rw [biproduct.ι_π_self,
        finset.sum_eq_single ((fin_prod_fin_equiv.symm k).snd : fin _),
        finset.sum_eq_single ((fin_prod_fin_equiv.symm k).fst : fin _)],
      { rw [prod.mk.eta, equiv.apply_symm_apply, biproduct.ι_π_self, biproduct.ι_π_self_assoc], },
      { rintro ⟨i⟩ - hi,
        rw [biproduct.ι_π_ne_assoc, zero_comp],
        dsimp [- fin_prod_fin_equiv_symm_apply],
        simp only [ne.def, ← equiv.symm_apply_eq, prod.ext_iff, not_and_distrib] at hi ⊢,
        exact or.inl (ne.symm hi) },
      { intro h, exact (h (finset.mem_univ _)).elim },
      { rintro ⟨j⟩ - hj,
        rw finset.sum_eq_zero,
        rintro ⟨i⟩ -,
        rw [biproduct.ι_π_ne_assoc, zero_comp],
        dsimp [- fin_prod_fin_equiv_symm_apply],
        simp only [ne.def, ← equiv.symm_apply_eq, prod.ext_iff, not_and_distrib] at hj ⊢,
        exact or.inr (ne.symm hj) },
      { intro h, exact (h (finset.mem_univ _)).elim } },
    { rw [biproduct.ι_π_ne, finset.sum_eq_zero],
      { rintro j -,
        rw [finset.sum_eq_zero],
        rintro i -,
        by_cases hk : k = fin_prod_fin_equiv (i,j),
        { subst hk,
          rw [biproduct.ι_π_self_assoc, biproduct.ι_π_ne],
          simpa only [ne.def] using h, },
        { rw [biproduct.ι_π_ne_assoc, zero_comp],
          dsimp [- fin_prod_fin_equiv_symm_apply],
          simpa only [ne.def] using h, } },
      { rw [ne.def], exact h } },
  end }
.

@[simps {fully_applied := ff}]
def Pow_comp_Pow (m n : ℕ) : (Pow m ⋙ Pow n : 𝒜 ⥤ 𝒜) ≅ Pow (m * n) :=
nat_iso.of_components (Pow_comp_Pow_components m n) $ λ A B f,
begin
  ext ⟨j⟩ ⟨i⟩ ⟨k⟩,
  simp only [biproduct.ι_map, Pow_comp_Pow_components_hom, Pow_map, functor.comp_map,
    biproduct.ι_map_assoc, category.assoc, biproduct.map_π, biproduct.ι_desc_assoc],
end
.

lemma _root_.free_abelian_group.eq_zero_induction
  {α M : Type*} [add_group M] (f : free_abelian_group α → M)
  (h1 : ∀ a, f (free_abelian_group.of a) = 0) (h2 : ∀ x y, f (x + y) = f x + f y) :
  ∀ x, f x = 0 :=
begin
  let F := add_monoid_hom.mk' f h2,
  have hF : ∀ x, F x = f x := λ _, rfl,
  intro x,
  refine free_abelian_group.induction_on x _ h1 _ _,
  { exact F.map_zero },
  { intros, show F _ = 0, rw [F.map_neg, hF, h1, neg_zero], },
  { intros x y hx hy, show F _ = 0, rw [F.map_add, hF, hF, hx, hy, add_zero], },
end

lemma aux' (m n : ℕ) (f : universal_map m n) :
  F.map ((Pow_comp_Pow 2 m).inv.app A ≫ (Pow m).map (Biprod_iso_Pow_two.inv.app A)) ≫
    ((eval_Pow_functor F).map f).app (Biprod.obj A) =
  ((eval_Pow_functor F).map ((mul 2) f)).app A ≫ F.map ((Pow_comp_Pow 2 n).inv.app A ≫
    (Pow n).map (Biprod_iso_Pow_two.inv.app A)) :=
begin
  rw [← sub_eq_zero],
  refine free_abelian_group.eq_zero_induction _ _ _ f; clear f,
  { intro f,
    rw [sub_eq_zero],
    dsimp only [eval_Pow_functor],
    rw [mul_of, eval_Pow_of, eval_Pow_of],
    dsimp only [whisker_right_app, basic_universal_map.eval_Pow_app],
    rw [← F.map_comp, ← F.map_comp],
    congr' 1,
    dsimp only [Pow_comp_Pow, Biprod_iso_Pow_two],
    erw [nat_iso.of_components_inv_app, nat_iso.of_components_inv_app,
      nat_iso.of_components_inv_app],
    dsimp only [Pow_comp_Pow_components_inv, Biprod_iso_Pow_two_components_inv, Pow_map],
    apply category_theory.limits.biproduct.hom_ext,
    rintro ⟨j⟩,
    apply category_theory.limits.biproduct.hom_ext',
    refine fin_prod_fin_equiv.forall_congr_left.mp _,
    rintro ⟨b, i⟩,
    rw [biproduct.lift_map, biproduct.lift_matrix, biproduct.lift_π, comp_sum,
      biproduct.lift_map, category.assoc, biproduct.ι_matrix_assoc, biproduct.lift_π],
    rw [finset.sum_eq_single i],
    { rw [category.assoc],
      ext;
      rw [category.assoc, category.assoc, comp_zsmul, zsmul_comp, comp_zsmul, comp_zsmul,
        category.comp_id, category.assoc, category.assoc];
      [rw biprod.lift_fst, rw biprod.lift_snd];
      rw [biproduct.lift_π, biproduct.lift_π, biproduct.lift_π,
        biproduct.ι_π, basic_universal_map.mul_apply, matrix.reindex_linear_equiv_apply,
        matrix.reindex_apply, matrix.submatrix_apply,
        matrix.kronecker_map, equiv.symm_apply_apply, equiv.symm_apply_apply];
      simp only [dite_eq_ite, equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff,
        eq_self_iff_true, eq_to_hom_refl, matrix.one_apply,
        ite_mul, ite_smul, one_mul, zero_mul, zero_smul, @eq_comm _ b, smul_ite, smul_zero];
      congr' 1, },
    { rintro i' - hi',
      rw [ne.def, eq_comm] at hi',
      rw [category.assoc],
      ext;
      rw [category.assoc, category.assoc, comp_zsmul, zsmul_comp, comp_zsmul, comp_zsmul,
        category.comp_id, zero_comp];
      [rw biprod.lift_fst, rw biprod.lift_snd];
      rw [biproduct.lift_π, biproduct.ι_π];
      simp only [dite_eq_ite, equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff,
        eq_self_iff_true, eq_to_hom_refl, equiv.ulift_symm_apply,
        eq_false_intro hi', and_false, if_false, smul_zero], },
    { intro h, exact (h (finset.mem_univ _)).elim } },
  { intros x y,
    simp only [add_monoid_hom.map_add, functor.map_add, comp_add, add_comp, nat_trans.app_add],
    abel }
end
.

@[simps {fully_applied := ff}]
def aux :
  (data.eval_functor F).obj ((data.mul 2).obj BD'.data) ≅
  Biprod ⋙ (data.eval_functor F).obj BD'.data :=
nat_iso.of_components (λ A,
  homological_complex.hom.iso_of_components (λ i, begin
      refine F.map_iso _,
      refine (Pow_comp_Pow 2 (BD'.data.X i)).symm.app A ≪≫ _,
      refine (Pow _).map_iso (Biprod_iso_Pow_two.symm.app A)
    end) $ λ i j hij, aux' F A (BD'.data.X i) (BD'.data.X j) (BD'.data.d i j)) $ λ A B f, begin
      ext i,
      dsimp only [data.eval_functor, data.eval_functor', eval_Pow, eval_Pow_functor_obj,
        functor.map_iso_hom, functor.comp_obj, functor.comp_map, functor.flip_obj_map,
        iso.trans_hom, iso.symm_hom, nat_iso.app_hom,
        functor.map_homological_complex_obj_X,
        homological_complex.functor_eval_map_app_f,
        homological_complex.comp_f,
        homological_complex.hom.iso_of_components_hom_f],
      rw [← F.map_comp, ← F.map_comp, ← category.assoc, nat_trans.naturality,
        category.assoc, category.assoc, functor.comp_map, ← functor.map_comp, ← functor.map_comp,
        nat_trans.naturality],
  end
.

-- move this up
lemma quux (n : ℕ) {N : ℕ} (k : fin N) (A : 𝒜) :
  (basic_universal_map.proj n k).eval_Pow.app A =
  biproduct.matrix (λ i j, if i = fin_prod_fin_equiv (k, j) then 𝟙 A else 0) :=
begin
  apply category_theory.limits.biproduct.hom_ext,
  rintro ⟨j⟩,
  apply category_theory.limits.biproduct.hom_ext',
  refine fin_prod_fin_equiv.forall_congr_left.mp _,
  rintro ⟨l, i⟩,
  dsimp only [basic_universal_map.eval_Pow_app],
  rw [biproduct.matrix_π, biproduct.matrix_π, biproduct.ι_desc, biproduct.ι_desc],
  dsimp only [basic_universal_map.proj, basic_universal_map.proj_aux,
    matrix.reindex_linear_equiv_apply, matrix.reindex_apply, matrix.submatrix,
    matrix.kronecker_map, matrix.of_apply],
  simp only [ite_mul, ite_smul, one_mul, one_smul, zero_mul, zero_smul, matrix.one_apply],
  rw [← ite_and],
  congr' 1,
  apply propext,
  rw [← equiv.symm_apply_eq, prod.ext_iff],
  apply and_congr iff.rfl,
  dsimp only [equiv.punit_prod_symm_apply],
  rw [eq_comm],
end
.

-- move this up
lemma eval_Pow_add {m n : ℕ} (f g : basic_universal_map m n) (A : 𝒜) :
  (f + g).eval_Pow.app A = f.eval_Pow.app A + g.eval_Pow.app A :=
begin
  dsimp [basic_universal_map.eval_Pow_app],
  ext ⟨i⟩ ⟨j⟩,
  simp only [biproduct.ι_matrix, biproduct.lift_π, comp_add, add_comp, add_zsmul],
end
.

def eval_functor_homotopy (A : 𝒜) : _root_.homotopy
  (((data.eval_functor F).obj BD'.data).map (biprod.fst + biprod.snd : A ⊞ A ⟶ A))
  (((data.eval_functor F).obj BD'.data).map (biprod.fst : A ⊞ A ⟶ A) +
    ((data.eval_functor F).obj BD'.data).map (biprod.snd : A ⊞ A ⟶ A)) :=
begin
  refine ((eval_homotopy' F BD' A).symm.comp_left ((aux F BD').inv.app A)).congr _ _ _ _,
  { ext i,
    rw [homological_complex.comp_f, aux_inv_app_f,
      functor.map_homological_complex_map_f, functor.comp_map, eval_Pow_functor_map,
      evaluation_obj_map, data.eval_functor_obj_map_f],
    dsimp only [data.sum, universal_map.sum],
    rw [eval_Pow_of, whisker_right_app, ← F.map_comp, fin.sum_univ_two,
      eval_Pow_add, quux, quux],
    congr' 1,
    apply category_theory.limits.biproduct.hom_ext', rintro m,
    rw [biproduct.ι_desc_assoc, biproduct.ι_map, category.assoc],
    apply category_theory.limits.biproduct.hom_ext, rintro n,
    rw [category.assoc],
    apply category_theory.limits.biprod.hom_ext';
    [rw [biprod.inl_desc_assoc], rw [biprod.inr_desc_assoc]];
    rw [category.assoc, biproduct.ι_desc_assoc, add_comp, comp_add,
      biproduct.matrix_π, biproduct.matrix_π, biproduct.ι_desc, biproduct.ι_desc,
      category.assoc, add_comp, comp_add];
    simp only [biprod.inl_fst_assoc, biprod.inl_snd_assoc,
      biprod.inr_fst_assoc, biprod.inr_snd_assoc, zero_comp, add_zero, zero_add,
      true_and, equiv.apply_eq_iff_eq, prod.mk.inj_iff, one_ne_zero,
      fin.zero_eq_one_iff, fin.one_eq_zero_iff, eq_self_iff_true, if_false, false_and],
      all_goals
      { by_cases hmn : m = n,
        { cases hmn, rw [if_pos rfl, biproduct.ι_π_self], },
        { rw [if_neg, biproduct.ι_π_ne]; [rw [ne.def], skip]; exact hmn } } },
  { ext i,
    rw [homological_complex.comp_f, aux_inv_app_f,
      functor.map_homological_complex_map_f, functor.comp_map, eval_Pow_functor_map,
      evaluation_obj_map,
      homological_complex.add_f_apply,
      data.eval_functor_obj_map_f, data.eval_functor_obj_map_f],
    dsimp only [data.proj, proj],
    rw [add_monoid_hom.map_sum, fin.sum_univ_two, eval_Pow_of, eval_Pow_of,
      nat_trans.app_add, whisker_right_app, whisker_right_app, comp_add,
      ← F.map_comp, ← F.map_comp, quux, quux],
    congr' 2;
    { apply category_theory.limits.biproduct.hom_ext, rintro n,
      rw [biproduct.map_π, category.assoc, biproduct.matrix_π],
      apply category_theory.limits.biproduct.hom_ext', rintro m,
      rw [biproduct.ι_desc_assoc, category.assoc],
      apply category_theory.limits.biprod.hom_ext';
      [rw [biprod.inl_desc_assoc], rw [biprod.inr_desc_assoc]],
      all_goals
      { rw [biproduct.ι_desc_assoc, biproduct.ι_desc];
        simp only [true_and, equiv.apply_eq_iff_eq, prod.mk.inj_iff, eq_self_iff_true];
        by_cases hmn : m = n,
        { cases hmn,
          simp only [biproduct.ι_π_self_assoc, eq_self_iff_true, if_true, if_false,
            biprod.inl_fst, biprod.inr_fst, biprod.inl_snd, biprod.inr_snd,
            zero_ne_one, one_ne_zero, false_and, fin.one_eq_zero_iff, fin.zero_eq_one_iff], },
        { rw biproduct.ι_π_ne_assoc, swap, { rw [ne.def], exact hmn },
          simp only [hmn, if_false, and_false, zero_comp, comp_zero] } } } }
end
.

end package

end breen_deligne


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebraic_topology.split_simplicial_object
import for_mathlib.dold_kan.degeneracies
import for_mathlib.dold_kan.functor_n

/-!

# Split simplicial objects in preadditive categories

In this file we define a functor `nondeg_complex : simplicial_object.split C ⥤ chain_complex C ℕ`
when `C` is a preadditive category with finite coproducts, and get an isomorphism
`to_karoubi_nondeg_complex_iso_N₁ : nondeg_complex ⋙ to_karoubi _ ≅ forget C ⋙ dold_kan.N₁`.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.category
  category_theory.preadditive category_theory.idempotents opposite
  algebraic_topology algebraic_topology.dold_kan

open_locale big_operators simplicial dold_kan

namespace simplicial_object

namespace splitting

variables {C : Type*} [category C] [has_finite_coproducts C]
  {X : simplicial_object C} (s : splitting X)

/-- The projection on a summand of the coproduct decomposition given
by a splitting of a simplicial object. -/
def π_summand [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  X.obj Δ ⟶ s.N A.1.unop.len :=
begin
  refine (s.iso Δ).inv ≫ sigma.desc (λ B, _),
  by_cases B = A,
  { exact eq_to_hom (by { subst h, refl, }), },
  { exact 0, },
end

@[simp, reassoc]
lemma ι_π_summand_eq_id [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  s.ι_summand A ≫ s.π_summand A = 𝟙 _ :=
begin
  dsimp [ι_summand, π_summand],
  simp only [summand, assoc, is_iso.hom_inv_id_assoc],
  erw [colimit.ι_desc, cofan.mk_ι_app],
  dsimp,
  simp only [eq_self_iff_true, if_true],
end

@[simp, reassoc]
lemma ι_π_summand_eq_zero [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A B : index_set Δ)
  (h : B ≠ A) : s.ι_summand A ≫ s.π_summand B = 0 :=
begin
  dsimp [ι_summand, π_summand],
  simp only [summand, assoc, is_iso.hom_inv_id_assoc],
  erw [colimit.ι_desc, cofan.mk_ι_app],
  apply dif_neg,
  exact h.symm,
end

variable [preadditive C]

lemma decomposition_id (Δ : simplex_categoryᵒᵖ) :
  𝟙 (X.obj Δ) = ∑ (A : index_set Δ), s.π_summand A ≫ s.ι_summand A :=
begin
  apply s.hom_ext',
  intro A,
  rw [comp_id, comp_sum, finset.sum_eq_single A, ι_π_summand_eq_id_assoc],
  { intros B h₁ h₂,
    rw [s.ι_π_summand_eq_zero_assoc _ _ h₂, zero_comp], },
  { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
end

@[simp, reassoc]
lemma σ_comp_π_summand_id_eq_zero {n : ℕ} (i : fin (n+1)) :
  X.σ i ≫ s.π_summand (index_set.id (op [n+1])) = 0 :=
begin
  apply s.hom_ext',
  intro A,
  dsimp only [simplicial_object.σ],
  rw [comp_zero, s.ι_summand_epi_naturality_assoc A (simplex_category.σ i).op,
    ι_π_summand_eq_zero],
  symmetry,
  change ¬ (A.epi_comp (simplex_category.σ i).op).eq_id,
  rw index_set.eq_id_iff_len_eq,
  have h := simplex_category.len_le_of_epi (infer_instance : epi A.e),
  dsimp at ⊢ h,
  linarith,
end

/-- If a simplicial object `X` in an additive category is split,
then `P_infty` vanishes on all the summands of `X _[n]` which do
not correspond to the identity of `[n]`. -/
lemma ι_summand_comp_P_infty_eq_zero {X : simplicial_object C}
  (s : simplicial_object.splitting X)
  {n : ℕ} (A : simplicial_object.splitting.index_set (op [n]))
  (hA : ¬ A.eq_id) :
  s.ι_summand A ≫ P_infty.f n = 0 :=
begin
  rw simplicial_object.splitting.index_set.eq_id_iff_mono at hA,
  rw [simplicial_object.splitting.ι_summand_eq, assoc,
    degeneracy_comp_P_infty X n A.e hA, comp_zero],
end

lemma comp_P_infty_eq_zero_iff {Z : C} {n : ℕ} (f : Z ⟶ X _[n]) :
  f ≫ P_infty.f n = 0 ↔ f ≫ s.π_summand (index_set.id (op [n])) = 0 :=
begin
  split,
  { intro h,
    cases n,
    { dsimp at h,
      rw [comp_id] at h,
      rw [h, zero_comp], },
    { have h' := f ≫= P_infty_f_add_Q_infty_f (n+1),
      dsimp at h',
      rw [comp_id, comp_add, h, zero_add] at h',
      rw [← h', assoc, Q_infty_f, decomposition_Q, preadditive.sum_comp,
        preadditive.comp_sum, finset.sum_eq_zero],
      intros i hi,
      simp only [assoc, σ_comp_π_summand_id_eq_zero, comp_zero], }, },
  { intro h,
    rw [← comp_id f, assoc, s.decomposition_id, preadditive.sum_comp,
      preadditive.comp_sum, fintype.sum_eq_zero],
    intro A,
    by_cases hA : A.eq_id,
    { dsimp at hA,
      subst hA,
      rw [assoc, reassoc_of h, zero_comp], },
    { simp only [assoc, s.ι_summand_comp_P_infty_eq_zero A hA, comp_zero], }, },
end

@[simp, reassoc]
lemma P_infty_comp_π_summand_id (n : ℕ) :
  P_infty.f n ≫ s.π_summand (index_set.id (op [n])) = s.π_summand (index_set.id (op [n])) :=
begin
  conv_rhs { rw ← id_comp (s.π_summand _), },
  symmetry,
  rw [← sub_eq_zero, ← sub_comp, ← comp_P_infty_eq_zero_iff, sub_comp, id_comp,
    P_infty_f_idem, sub_self],
end

@[simp, reassoc]
lemma π_summand_comp_ι_summand_comp_P_infty_eq_P_infty (n : ℕ) :
  s.π_summand (index_set.id (op [n])) ≫ s.ι_summand (index_set.id (op [n])) ≫ P_infty.f n =
    P_infty.f n :=
begin
  conv_rhs { rw ← id_comp (P_infty.f n), },
  erw [s.decomposition_id, preadditive.sum_comp],
  rw [fintype.sum_eq_single (index_set.id (op [n])), assoc],
  rintros A (hA : ¬A.eq_id),
  rw [assoc, s.ι_summand_comp_P_infty_eq_zero A hA, comp_zero],
end

/-- The differentials `s.d i j : s.N i ⟶ s.N j` on nondegenerate simplices of a split
simplicial object are induced by the differentials on the alternating face map complex. -/
@[simp]
def d (i j : ℕ) : s.N i ⟶ s.N j :=
s.ι_summand (index_set.id (op [i])) ≫ K[X].d i j ≫ s.π_summand (index_set.id (op [j]))

lemma ι_summand_comp_d_comp_π_summand_eq_zero (j k : ℕ) (A : index_set (op [j])) (hA : ¬A.eq_id) :
  s.ι_summand A ≫ K[X].d j k ≫ s.π_summand (index_set.id (op [k])) = 0 :=
begin
  rw A.eq_id_iff_mono at hA,
  rw [← assoc, ← s.comp_P_infty_eq_zero_iff, assoc, ← P_infty.comm j k, s.ι_summand_eq, assoc,
    degeneracy_comp_P_infty_assoc X j A.e hA, zero_comp, comp_zero],
end

/-- If `s` is a splitting of a simplicial object `X` in a preadditive category,
`s.nondeg_complex` is a chain complex which is given in degree `n` by
the nondegenerate `n`-simplices of `X`. -/
@[simps]
def nondeg_complex : chain_complex C ℕ :=
{ X := s.N,
  d := s.d,
  shape' := λ i j hij, by simp only [d, K[X].shape i j hij, zero_comp, comp_zero],
  d_comp_d' := λ i j k hij hjk, begin
    simp only [d, assoc],
    have eq : K[X].d i j ≫ 𝟙 (X.obj (op [j])) ≫ K[X].d j k ≫
      s.π_summand (index_set.id (op [k])) = 0 :=
      by erw [id_comp, homological_complex.d_comp_d_assoc, zero_comp],
    rw s.decomposition_id at eq,
    classical,
    rw [fintype.sum_eq_add_sum_compl (index_set.id (op [j])), add_comp, comp_add, assoc,
      preadditive.sum_comp, preadditive.comp_sum, finset.sum_eq_zero, add_zero] at eq, swap,
    { intros A hA,
      simp only [finset.mem_compl, finset.mem_singleton] at hA,
      simp only [assoc, ι_summand_comp_d_comp_π_summand_eq_zero _ _ _ _ hA, comp_zero], },
    rw [eq, comp_zero],
  end }

/-- The chain complex `s.nondeg_complex` attached to a splitting of a simplicial object `X`
becomes isomorphic to the normalized Moore complex `N₁.obj X` defined as a formal direct
factor in the category `karoubi (chain_complex C ℕ)`. -/
@[simps]
def to_karoubi_nondeg_complex_iso_N₁ : (to_karoubi _).obj s.nondeg_complex ≅ N₁.obj X :=
{ hom :=
  { f :=
    { f := λ n, s.ι_summand (index_set.id (op [n])) ≫ P_infty.f n,
      comm' := λ i j hij, begin
        dsimp,
        rw [assoc, assoc, assoc, π_summand_comp_ι_summand_comp_P_infty_eq_P_infty,
          homological_complex.hom.comm],
      end, },
    comm := by { ext n, dsimp, rw [id_comp, assoc, P_infty_f_idem], }, },
  inv :=
  { f :=
    { f := λ n, s.π_summand (index_set.id (op [n])),
      comm' := λ i j hij, begin
        dsimp,
        slice_rhs 1 1 { rw ← id_comp (K[X].d i j), },
        erw s.decomposition_id,
        rw [sum_comp, sum_comp, finset.sum_eq_single (index_set.id (op [i])), assoc, assoc],
        { intros A h hA,
          simp only [assoc, s.ι_summand_comp_d_comp_π_summand_eq_zero _ _ _ hA, comp_zero], },
        { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
      end, },
    comm := by { ext n, dsimp, simp only [comp_id, P_infty_comp_π_summand_id], }, },
  hom_inv_id' := begin
    ext n,
    simpa only [assoc, P_infty_comp_π_summand_id, karoubi.comp_f,
      homological_complex.comp_f, ι_π_summand_eq_id],
  end,
  inv_hom_id' := begin
    ext n,
    simp only [π_summand_comp_ι_summand_comp_P_infty_eq_P_infty, karoubi.comp_f,
      homological_complex.comp_f, N₁_obj_p, karoubi.id_eq],
  end, }

end splitting

namespace split

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

/-- The functor which sends a split simplicial object in a preadditive category to
the chain complex which consists of nondegenerate simplices. -/
@[simps]
def nondeg_complex_functor : split C ⥤ chain_complex C ℕ :=
{ obj := λ S, S.s.nondeg_complex,
  map := λ S₁ S₂ Φ,
  { f := Φ.f,
    comm' := λ i j hij, begin
      dsimp,
      erw [← ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [i])),
        ((alternating_face_map_complex C).map Φ.F).comm_assoc i j],
      simp only [assoc],
      congr' 2,
      apply S₁.s.hom_ext',
      intro A,
      dsimp [alternating_face_map_complex],
      erw ι_summand_naturality_symm_assoc Φ A,
      by_cases A.eq_id,
      { dsimp at h,
        subst h,
        simpa only [splitting.ι_π_summand_eq_id, comp_id, splitting.ι_π_summand_eq_id_assoc], },
      { have h' : splitting.index_set.id (op [j]) ≠ A := by { symmetry, exact h, },
        rw [S₁.s.ι_π_summand_eq_zero_assoc _ _ h', S₂.s.ι_π_summand_eq_zero _ _ h',
          zero_comp, comp_zero], },
    end }, }

/-- The natural isomorphism (in `karoubi (chain_complex C ℕ)`) between the chain complex
of nondegenerate simplices of a split simplicial object and the normalized Moore complex
defined as a formal direct factor of the alternating face map complex. -/
@[simps]
def to_karoubi_nondeg_complex_functor_iso_N₁ :
  nondeg_complex_functor ⋙ to_karoubi (chain_complex C ℕ) ≅ forget C ⋙ dold_kan.N₁ :=
nat_iso.of_components (λ S, S.s.to_karoubi_nondeg_complex_iso_N₁)
  (λ S₁ S₂ Φ, begin
    ext n,
    dsimp,
    simp only [karoubi.comp_f, to_karoubi_map_f, homological_complex.comp_f,
      nondeg_complex_functor_map_f, splitting.to_karoubi_nondeg_complex_iso_N₁_hom_f_f,
      N₁_map_f, alternating_face_map_complex.map_f, assoc, P_infty_f_idem_assoc],
    erw ← split.ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [n])),
    rw P_infty_f_naturality,
  end)

--@[simps]
--def nondeg_complex_functor_iso_forget_comp_normalized_Moore_complex {A : Type*} [category A] [abelian A] :
--  nondeg_complex_functor ≅ forget A ⋙ normalized_Moore_complex A :=
--(whiskering_right_to_karoubi_iso_equiv _ _).inv_fun
--  (to_karoubi_N'_iso_N₁
--    ≪≫ iso_whisker_left _ (N₁_iso_normalized_Moore_complex_comp_to_karoubi A))

end split

end simplicial_object


import Lean
import Mathlib.Tactic.RCases

import Verbose.Common

open Lean

open Lean.Parser.Tactic
open Lean Meta

def MaybeTypedIdent := Name × Option Syntax

open Lean Elab Tactic
open Option
open RCases

-- TODO: replace Syntax.missing by something smarter
def RCasesPattOfMaybeTypedIdent : MaybeTypedIdent → RCasesPatt
| (n, some pe) => RCasesPatt.typed Syntax.missing (RCasesPatt.one Syntax.missing  n) pe
| (n, none)    => RCasesPatt.one Syntax.missing n

def obtainTac (fact : Term) (news : Array MaybeTypedIdent) : TacticM Unit :=
do
  let orig_goal ← getMainGoal
  for new in news do
    checkName new.1
  let applied_fact_expr : Expr ← elabTerm fact none
  let news := Array.toList news
  match news with
  | [(name, stuff)] => do
    let type ← inferType applied_fact_expr
    if let some new := stuff then
      if not (← isDefEq (← elabTerm new type) type) then throwError "No way"
    let intermediate_goal ← assert orig_goal name type (← elabTerm fact none)
    let (_, new_goal) ← intro1P intermediate_goal
    replaceMainGoal [new_goal]
  | news =>
    let news_patt := news.map RCasesPattOfMaybeTypedIdent
    let new_goals ← rcases #[(none, fact)] (RCasesPatt.tuple Syntax.missing news_patt) (← getMainGoal)
    replaceMainGoal new_goals

declare_syntax_cat maybeTypedIdent
syntax ident : maybeTypedIdent
syntax "("ident ":" term")" : maybeTypedIdent

-- We could also use the less specific type `Syntax → MaybeTypedIdent`
def toMaybeTypedIdent : TSyntax `maybeTypedIdent → MaybeTypedIdent
| `(maybeTypedIdent| ($x:ident : $type:term)) => (x.getId, type)
| `(maybeTypedIdent| $x:ident) => (x.getId, none)
| _ => (Name.anonymous, none) -- This should never happen

declare_syntax_cat maybeApplied
syntax term : maybeApplied
syntax term "applied to" term : maybeApplied
syntax term "applied to [" term,* "]" : maybeApplied

def maybeAppliedToTerm : TSyntax `maybeApplied → MetaM Term
| `(maybeApplied| $e:term) => pure e
| `(maybeApplied| $e:term applied to $x:term) => `($e $x)
| `(maybeApplied| $e:term applied to [$args:term,*]) => `($e $args*)
| _ => pure ⟨Syntax.missing⟩ -- This should never happen

declare_syntax_cat newStuff
syntax maybeTypedIdent : newStuff
syntax maybeTypedIdent "such that" maybeTypedIdent,* : newStuff

def newStuffToArray : TSyntax `newStuff → Array MaybeTypedIdent
| `(newStuff| $x:maybeTypedIdent) => #[toMaybeTypedIdent x]
| `(newStuff| $x:maybeTypedIdent such that $news:maybeTypedIdent,*) =>
    #[toMaybeTypedIdent x] ++ (Array.map toMaybeTypedIdent news)
| _ => #[]

elab "By " e:maybeApplied "we get " colGt news:newStuff : tactic => do
obtainTac (← maybeAppliedToTerm e)  (newStuffToArray news)

example (P : Nat → Prop) (h : ∀ n, P n) : P 0 := by
  By h applied to 0 we get h₀
  exact h₀

example (P : Nat → Nat → Prop) (h : ∀ n k, P n (k+1)) : P 0 1 := by
  --rcases h 0 0 with (h₀ : P 0 0)
  By h applied to [0, 0] we get (h₀ : P 0 1)
  exact h₀

example (n : Nat) (h : ∃ k, n = 2*k) : True := by
  By h we get k such that (H : n = 2*k)
  trivial

example (n : Nat) (h : ∃ k, n = 2*k) : True := by
  By h we get k such that H
  trivial


import Lean
open Lean.SubExpr

def ps := [#[], #[0], #[1], #[0,1], #[1,0] , #[0,0], #[1,2,3]]
theorem Pos.roundtrip :
  true = ps.all fun x => x == (Pos.toArray <| Pos.ofArray <| x)
  := by native_decide

theorem Pos.append_roundtrip :
  true = (List.all
    (ps.bind fun p => ps.map fun q => (p,q))
    (fun (x,y) => (x ++ y) == (Pos.toArray <| (Pos.append (Pos.ofArray x) (Pos.ofArray y))))
  ) := by native_decide

theorem Pos.stringRoundtrip :
  true = ps.all (fun p =>
    let x := Pos.ofArray p
    some x == (Except.toOption $ Pos.fromString? $ Pos.toString $ x)
  ) := by native_decide

#eval Pos.toString Nat.zero


/-
Copyright (c) 2021 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Gabriel Ebner
-/
import Lean
import Mathlib.Tactic.Cache
import Mathlib.Tactic.RCases

open Tactic

namespace Mathlib.Tactic.Ext
open Lean Meta

def withExtHyps (struct : Name) (k : Array Expr → (x y : Expr) → Array (Name × Expr) → MetaM α) : MetaM α := do
  unless isStructure (← getEnv) struct do throwError "not a structure: {struct}"
  let structC ← mkConstWithLevelParams struct
  forallTelescope (← inferType structC) fun params _ => do
  withNewBinderInfos (params.map (·.fvarId!, BinderInfo.implicit)) do
  withLocalDeclD `x (mkAppN structC params) fun x => do
  withLocalDeclD `y (mkAppN structC params) fun y => do
    let mut hyps := #[]
    for field in getStructureFieldsFlattened (← getEnv) struct (includeSubobjectFields := false) do
      let x_f ← mkProjection x field
      let y_f ← mkProjection y field
      if ← isProof x_f then
        pure ()
      else if ← isDefEq (← inferType x_f) (← inferType y_f) then
        hyps := hyps.push (field, ← mkEq x_f y_f)
      else
        hyps := hyps.push (field, ← mkHEq x_f y_f)
    k params x y hyps

scoped elab "ext_type%" struct:ident : term => do
  withExtHyps (← resolveGlobalConstNoOverload struct) fun params x y hyps => do
    let mut ty ← mkEq x y
    for (f, h) in hyps.reverse do
      ty := mkForall f BinderInfo.default h ty
    mkForallFVars (params |>.push x |>.push y) ty

def mkIff (p q : Expr) : Expr := mkApp2 (mkConst ``Iff) p q

def mkAndN : List Expr → Expr
  | [] => mkConst ``True
  | [p] => p
  | [p, q] => mkAnd p q
  | p :: ps => mkAnd p (mkAndN ps)

scoped elab "ext_iff_type%" struct:ident : term => do
  withExtHyps (← resolveGlobalConstNoOverload struct) fun params x y hyps => do
    mkForallFVars (params |>.push x |>.push y) <|
      mkIff (← mkEq x y) <| mkAndN (hyps.map (·.2)).toList

elab "subst_eqs" : tactic =>
  open Elab.Tactic in
  liftMetaTactic1 fun mvarId => substEqs mvarId

scoped macro "ext_proof%" : term =>
  `(fun {..} {..} => by intros; subst_eqs; rfl)

syntax "split_ands" : tactic
macro_rules | `(tactic| split_ands) => `(tactic| skip)
macro_rules | `(tactic| split_ands) => `(tactic| refine And.intro ?_ ?_ <;> split_ands)

macro_rules | `(tactic| rfl) => `(tactic| exact HEq.rfl)

scoped macro "ext_iff_proof%" : term => `(fun {..} {..} =>
  ⟨fun _ => by subst_eqs; split_ands <;> rfl,
   fun _ => by (repeat cases ‹_ ∧ _›); subst_eqs; rfl⟩)

scoped macro "declareExtTheoremsFor" struct:ident : command => do
  let extName := mkIdent <| struct.getId.eraseMacroScopes.mkStr "ext"
  let extIffName := mkIdent <| struct.getId.eraseMacroScopes.mkStr "ext_iff"
  `(@[ext] protected theorem $extName:ident : ext_type% $struct:ident := ext_proof%
    protected theorem $extIffName:ident : ext_iff_type% $struct:ident := ext_iff_proof%)

open Elab.Command MonadRecDepth in
def liftCommandElabM (k : CommandElabM α) : AttrM α := do
  let (a, commandState) ←
    k.run { fileName := (← getEnv).mainModule.toString, fileMap := default } |>.run {
      env := ← getEnv, maxRecDepth := ← getMaxRecDepth,
      scopes := [{ header := "", opts := ← getOptions }]
    }
  modify fun coreState => { coreState with
    traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
    env := commandState.env
  }
  if let some err := commandState.messages.msgs.toArray.find?
      (·.severity matches MessageSeverity.error) then
    throwError err.data
  pure a

initialize extExtension : SimpleScopedEnvExtension (Name × Array DiscrTree.Key) (DiscrTree Name) ←
  registerSimpleScopedEnvExtension {
    name := `ext
    addEntry := fun dt (n, ks) => dt.insertCore ks n
    initial := {}
  }

def extAttribute : AttributeImpl where
  name := `ext
  descr := "Marks a lemma as extensionality lemma"
  add decl stx kind := do
    if isStructure (← getEnv) decl then
      liftCommandElabM do
        Elab.Command.elabCommand <|<- `(declareExtTheoremsFor $(mkIdent decl))
    else MetaM.run' do
      let declTy := (← getConstInfo decl).type
      let (xs, bis, declTy) ← withReducible <| forallMetaTelescopeReducing declTy
      if declTy.isAppOfArity ``Eq 3 && (declTy.getArg! 1).isMVar && (declTy.getArg! 2).isMVar then
        let ty := declTy.getArg! 0
        let key ←
          if (← withReducible <| whnf ty).isForall then
            pure #[DiscrTree.Key.star] -- FIXME: workaround
          else
            withReducible <| DiscrTree.mkPath ty
        extExtension.add (decl, key) kind
      else
        throwError "@[ext] attribute only applies to structures or lemmas proving x = y, got {declTy}"

initialize registerBuiltinAttribute extAttribute

def extLemmas (env : Environment) : DiscrTree Name :=
  extExtension.getState env

open Lean.Elab.Tactic in
elab "apply_ext_lemma" : tactic => do
  let tgt ← getMainTarget
  unless tgt.isAppOfArity ``Eq 3 do
    throwError "applyExtLemma only applies to equations, not{indentExpr tgt}"
  let ty := tgt.getArg! 0
  let s ← saveState
  for lem in ← (extLemmas (← getEnv)).getMatch ty do
    try
      liftMetaTactic (apply · (← mkConstWithFreshMVarLevels lem))
      return
    catch e =>
      s.restore
  throwError "no applicable extensionality lemma found for{indentExpr ty}"

scoped syntax "ext_or_skip" (ppSpace rintroPat)* : tactic
macro_rules | `(tactic| ext_or_skip) => `(tactic| skip)
macro_rules
| `(tactic| ext_or_skip $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; ext_or_skip $xs:rintroPat*)
macro_rules
| `(tactic| ext_or_skip $x:rintroPat $xs:rintroPat*) =>
  `(tactic| rintro $x:rintroPat; ext_or_skip $xs:rintroPat*)

-- TODO: support `ext : n`

syntax "ext" (colGt ppSpace rintroPat)* (" : " num)? : tactic
macro_rules
| `(tactic| ext) => do
  `(tactic| first | intro; ext | apply_ext_lemma; ext | skip)
macro_rules
| `(tactic| ext $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; ext_or_skip $xs:rintroPat*)

syntax "ext1" (colGt ppSpace rintroPat)* : tactic
macro_rules
| `(tactic| ext1 $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; rintro $xs:rintroPat*)

-- TODO
syntax "ext1?" (colGt ppSpace rintroPat)* : tactic
syntax "ext?" (colGt ppSpace rintroPat)* (" : " num)? : tactic


import temporal_logic.basic
import tactic.squeeze

universe variables u u₀ u₁ u₂

variables {α : Sort u₀} {β : Sort u₁} {γ : Sort u₂}

namespace temporal
open predicate

class postponable (p : cpred) : Prop :=
  (postpone : ◇p = p)
export postponable (postpone)

instance henceforth_persistent {p : cpred} : persistent (◻p) :=
by { constructor, simp only [temporal.henceforth_henceforth, eq_self_iff_true] with tl_simp }

instance persistent_not {p : cpred} [postponable p] : persistent (-p) :=
by { constructor, rw [← not_eventually, postpone p] }

instance leads_to_persistent {p q : cpred} : persistent (p ~> q) :=
by { constructor, simp only [tl_leads_to, is_persistent, eq_self_iff_true] }

instance and_persistent {p q : cpred} [persistent p] [persistent q]
: persistent (p ⋀ q) :=
by { constructor, simp only [henceforth_and, is_persistent, eq_self_iff_true], }

instance coe_persistent (p : Prop)
: persistent (p : cpred) :=
by { constructor, cases classical.prop_complete p ; subst p ;
     simp only [eq_self_iff_true, temporal.hence_false, predicate.coe_false,predicate.coe_true, eq_self_iff_true, temporal.hence_true] with tl_simp, }

instance false_persistent
: persistent (False : cpred) :=
by { constructor, simp only [eq_self_iff_true, temporal.hence_false] with tl_simp, }

instance forall_persistent {p : α → cpred} [∀ i, persistent (p i)]
: persistent (p_forall p) :=
by { constructor, simp only [henceforth_forall, is_persistent, eq_self_iff_true], }

instance exists_persistent {p : α → cpred} [∀ i, persistent (p i)]
: persistent (p_exists p) :=
by { constructor, apply mutual_entails,
     apply henceforth_str,
     apply p_exists_elim, intro, rw ← is_persistent (p x),
     mono, apply p_exists_intro, }

instance (p : cpred) : postponable (◇p) :=
by { constructor, simp only [eventually_eventually, temporal.eventually_eventually, eq_self_iff_true] }

instance postponable_not {p : cpred} [persistent p] : postponable (-p) :=
by { constructor, rw [← not_henceforth, is_persistent p] }

instance or_postponable {p q : cpred} [postponable p] [postponable q]
: postponable (p ⋁ q) :=
by { constructor, simp only [eventually_or, postpone, eq_self_iff_true], }

instance imp_postponable {p q : cpred} [persistent p] [postponable q]
: postponable (p ⟶ q) :=
by { simp only [p_imp_iff_p_not_p_or], apply_instance }

instance coe_postponable (p : Prop)
: postponable (p : cpred) :=
by { constructor, cases classical.prop_complete p ; subst p ; simp only [temporal.event_false, eq_self_iff_true, predicate.coe_false, predicate.coe_true, temporal.eventually_true, eq_self_iff_true] with tl_simp, }

instance forall_postponable (p : α → cpred) [∀ i, postponable (p i)]
: postponable (p_forall p) :=
⟨ begin
    apply mutual_entails,
    { rw [p_entails_of_fun],
      introv h, rw p_forall_to_fun, intro i,
      rw ← postpone (p i), revert h, apply p_impl_revert,
      revert Γ, change (_ ⟹ _),
      mono, rw [p_entails_of_fun],
      introv h, apply p_forall_revert h },
    apply eventually_weaken
  end ⟩

instance exists_postponable (p : α → cpred) [∀ i, postponable (p i)]
: postponable (p_exists p) :=
by constructor ; simp only [eventually_exists, postpone, eq_self_iff_true]

instance lifted₀_postponable (c : Prop) : postponable (lifted₀ c) :=
by { constructor, ext, simp only [lifted₀, eventually, iff_self, predicate.lifted₀, exists_const] }

instance lifted₀_persistent (c : Prop) : persistent (lifted₀ c) :=
by { constructor, ext, simp only [lifted₀, henceforth, forall_const, iff_self, predicate.lifted₀] }

instance True_postponable : postponable True :=
by { dunfold True, apply_instance }

instance True_persistent : persistent True :=
by { dunfold True, apply_instance }

instance False_postponable : postponable False :=
by { dunfold False, apply_instance }

instance False_persistent : persistent False :=
by { dunfold False, apply_instance }

-- instance not_forall_persistent {p : α → cpred} [∀ i, persistent (- p i)]
-- : persistent (- p_forall p) :=
-- by { constructor, squeeze_simp [p_not_p_forall], apply is_persistent }

inductive list_persistent : list cpred → Prop
 | nil_persistent : list_persistent []
 | cons_persistent (x : cpred) (xs : list $ cpred)
   [persistent x]
   (h : list_persistent xs)
 : list_persistent (x :: xs)

export list_persistent (nil_persistent)

def with_h_asms (Γ : cpred) : Π (xs : list (cpred)) (x : cpred), Prop
 | [] x := Γ ⊢ x
 | (x :: xs) y := Γ ⊢ x → with_h_asms xs y

lemma indirect_judgement (h p : pred' β)
  (H : ∀ Γ, Γ ⊢ h → Γ ⊢ p)
: h ⊢ p :=
by { apply H, lifted_pred keep, assumption }

lemma judgement_trans (p q r : pred' β)
  (h₀ : p ⊢ q)
  (h₁ : q ⊢ r)
: p ⊢ r :=
by { lifted_pred keep,
     apply h₁.apply,
     apply h₀.apply _ a }

@[trans]
lemma judgement_trans' {p q r : pred' β}
  (h₀ : p ⊢ q)
  (h₁ : q ⊢ r)
: p ⊢ r :=
judgement_trans _ _ _ h₀ h₁

lemma p_imp_postpone (Γ p q : cpred)
  [persistent Γ]
  [postponable q]
  (h : ctx_impl Γ p q)
: ctx_impl Γ (◇p) q :=
begin
  rw ← postpone q,
  mono,
end

lemma persistent_to_henceforth {p q : cpred}
  [persistent p]
  (h : p ⊢ q)
: p ⊢ ◻ q :=
by { rw ← is_persistent p,
     lifted_pred keep, intro i,
     apply h.apply _ (a i), }

lemma henceforth_deduction {Γ p q : cpred}
  (h : Γ ⊢ ◻(p ⟶ q))
: Γ ⊢ p → Γ ⊢ q :=
henceforth_str (p ⟶ q) Γ h

instance has_coe_to_fun_henceforth (Γ p q : cpred) : has_coe_to_fun (Γ ⊢ ◻(p ⟶ q)) :=
{ F := λ _, Γ ⊢ p → Γ ⊢ q
, coe :=  henceforth_deduction }

instance has_coe_to_fun_leads_to (Γ p q : cpred) : has_coe_to_fun (Γ ⊢ p ~> q) :=
temporal.has_coe_to_fun_henceforth _ _ _

end temporal


import M.Pluto.Language.Constant
import M.PlutusCore

namespace Pluto.Proof

open Pluto.Language
open PlutusCore (ByteString Data)

theorem show_constant_integer (i : Int) : toString (I ann i) = toString i :=
  rfl

theorem show_constant_bytestring (s : ByteString) : toString (S ann s) = "0x" ++ toString s :=
  rfl

theorem show_constant_text (t : String) : toString (T ann t) = "\"" ++ toString t ++ "\"" :=
  rfl

theorem show_constant_unit : toString (U ann ) = "()" :=
  rfl

theorem show_constant_true : toString (B ann true) = "True" :=
  rfl

theorem show_constant_false : toString (B ann false) = "False" :=
  rfl

theorem show_constant_data_integer : toString (D ann (Data.I i)) = "data " ++ toString i :=
  by simp [toString, showData]

theorem show_constant_data_bytestring : toString (D ann (Data.B b)) = "data " ++ ("0x" ++ toString b) :=
  by simp [toString, showData]

example : toString (I () 3                                           ) = "3"        := rfl

example : toString (S () $ ByteString.mk $ ByteArray.mk #[0xca, 0xfe]) = "0xcafe"   := rfl

example : toString (T () "test"                                      ) = "\"test\"" := rfl

example : toString (U ()                                             ) = "()"       := rfl

example : toString (B () true                                        ) = "True"     := rfl

example : toString (B () false                                       ) = "False"    := rfl

private def testData :=
  Data.List
    [
      Data.Map []
    , Data.Map [
        (Data.I 3, Data.List [])
      ]
    , Data.Map [
        (Data.B $ ByteString.mk $ ByteArray.mk #[0xca, 0xfe], Data.List [Data.I 2])
      ]
    , Data.Map [
        (Data.I 10, Data.I 20)
      , (Data.I 30, Data.I 40)
    ]
    , Data.Constr 2 [Data.I 9, Data.I (-10)]
    , Data.Constr 1 [Data.I (-11)]
    , Data.Constr 0 []
    ]

example : toString (D () testData) = "data [{},{3=[]},{0xcafe=[2]},{10=20,30=40},sigma2.[9,-10],sigma1.[-11],sigma0.[]]" :=
  by simp [toString, testData, showData, intercalateData, intercalateData']

end Pluto.Proof