/-
Copyright (c) 2020 Bhavik Mehta, E. W. Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, E. W. Ayers
-/

import category_theory.sites.sieves
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.multiequalizer
import category_theory.category.preorder
import order.copy

/-!
# Grothendieck topologies

Definition and lemmas about Grothendieck topologies.
A Grothendieck topology for a category `C` is a set of sieves on each object `X` satisfying
certain closure conditions.

Alternate versions of the axioms (in arrow form) are also described.
Two explicit examples of Grothendieck topologies are given:
* The dense topology
* The atomic topology
as well as the complete lattice structure on Grothendieck topologies (which gives two additional
explicit topologies: the discrete and trivial topologies.)

A pretopology, or a basis for a topology is defined in `pretopology.lean`. The topology associated
to a topological space is defined in `spaces.lean`.

## Tags

Grothendieck topology, coverage, pretopology, site

## References

* [https://ncatlab.org/nlab/show/Grothendieck+topology][nlab]
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM91]

## Implementation notes

We use the definition of [nlab] and [MM91](Chapter III, Section 2), where Grothendieck topologies
are saturated collections of morphisms, rather than the notions of the Stacks project (00VG) and
the Elephant, in which topologies are allowed to be unsaturated, and are then completed.
TODO (BM): Add the definition from Stacks, as a pretopology, and complete to a topology.

This is so that we can produce a bijective correspondence between Grothendieck topologies on a
small category and Lawvere-Tierney topologies on its presheaf topos, as well as the equivalence
between Grothendieck topoi and left exact reflective subcategories of presheaf toposes.
-/

universes w v u
namespace category_theory

open category_theory category

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

/--
The definition of a Grothendieck topology: a set of sieves `J X` on each object `X` satisfying
three axioms:
1. For every object `X`, the maximal sieve is in `J X`.
2. If `S ∈ J X` then its pullback along any `h : Y ⟶ X` is in `J Y`.
3. If `S ∈ J X` and `R` is a sieve on `X`, then provided that the pullback of `R` along any arrow
   `f : Y ⟶ X` in `S` is in `J Y`, we have that `R` itself is in `J X`.

A sieve `S` on `X` is referred to as `J`-covering, (or just covering), if `S ∈ J X`.

See https://stacks.math.columbia.edu/tag/00Z4, or [nlab], or [MM92] Chapter III, Section 2,
Definition 1.
-/
structure grothendieck_topology :=
(sieves : Π (X : C), set (sieve X))
(top_mem' : ∀ X, ⊤ ∈ sieves X)
(pullback_stable' : ∀ ⦃X Y : C⦄ ⦃S : sieve X⦄ (f : Y ⟶ X), S ∈ sieves X → S.pullback f ∈ sieves Y)
(transitive' : ∀ ⦃X⦄ ⦃S : sieve X⦄ (hS : S ∈ sieves X) (R : sieve X),
              (∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → R.pullback f ∈ sieves Y) → R ∈ sieves X)

namespace grothendieck_topology

instance : has_coe_to_fun (grothendieck_topology C) (λ _, Π X : C, set (sieve X)) := ⟨sieves⟩

variables {C} {X Y : C} {S R : sieve X}
variables (J : grothendieck_topology C)

/--
An extensionality lemma in terms of the coercion to a pi-type.
We prove this explicitly rather than deriving it so that it is in terms of the coercion rather than
the projection `.sieves`.
-/
@[ext]
lemma ext {J₁ J₂ : grothendieck_topology C} (h : (J₁ : Π (X : C), set (sieve X)) = J₂) : J₁ = J₂ :=
by { cases J₁, cases J₂, congr, apply h }

@[simp] lemma mem_sieves_iff_coe : S ∈ J.sieves X ↔ S ∈ J X := iff.rfl

-- Also known as the maximality axiom.
@[simp] lemma top_mem (X : C) : ⊤ ∈ J X := J.top_mem' X
-- Also known as the stability axiom.
@[simp] lemma pullback_stable (f : Y ⟶ X) (hS : S ∈ J X) : S.pullback f ∈ J Y :=
J.pullback_stable' f hS
lemma transitive (hS : S ∈ J X) (R : sieve X)
  (h : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → R.pullback f ∈ J Y) :
  R ∈ J X :=
J.transitive' hS R h

lemma covering_of_eq_top : S = ⊤ → S ∈ J X := λ h, h.symm ▸ J.top_mem X

/--
If `S` is a subset of `R`, and `S` is covering, then `R` is covering as well.

See https://stacks.math.columbia.edu/tag/00Z5 (2), or discussion after [MM92] Chapter III,
Section 2, Definition 1.
-/
lemma superset_covering (Hss : S ≤ R) (sjx : S ∈ J X) : R ∈ J X :=
begin
  apply J.transitive sjx R (λ Y f hf, _),
  apply covering_of_eq_top,
  rw [← top_le_iff, ← S.pullback_eq_top_of_mem hf],
  apply sieve.pullback_monotone _ Hss,
end

/--
The intersection of two covering sieves is covering.

See https://stacks.math.columbia.edu/tag/00Z5 (1), or [MM92] Chapter III,
Section 2, Definition 1 (iv).
-/
lemma intersection_covering (rj : R ∈ J X) (sj : S ∈ J X) : R ⊓ S ∈ J X :=
begin
  apply J.transitive rj _ (λ Y f Hf, _),
  rw [sieve.pullback_inter, R.pullback_eq_top_of_mem Hf],
  simp [sj],
end

@[simp]
lemma intersection_covering_iff : R ⊓ S ∈ J X ↔ R ∈ J X ∧ S ∈ J X :=
⟨λ h, ⟨J.superset_covering inf_le_left h, J.superset_covering inf_le_right h⟩,
 λ t, intersection_covering _ t.1 t.2⟩

/--
The sieve `S` on `X` `J`-covers an arrow `f` to `X` if `S.pullback f ∈ J Y`.
This definition is an alternate way of presenting a Grothendieck topology.
-/
def covers (S : sieve X) (f : Y ⟶ X) : Prop := S.pullback f ∈ J Y

lemma covers_iff (S : sieve X) (f : Y ⟶ X) : J.covers S f ↔ S.pullback f ∈ J Y :=
iff.rfl

lemma covering_iff_covers_id (S : sieve X) : S ∈ J X ↔ J.covers S (𝟙 X) :=
by simp [covers_iff]

/-- The maximality axiom in 'arrow' form: Any arrow `f` in `S` is covered by `S`. -/
lemma arrow_max (f : Y ⟶ X) (S : sieve X) (hf : S f) : J.covers S f :=
begin
  rw [covers, (sieve.pullback_eq_top_iff_mem f).1 hf],
  apply J.top_mem,
end

/-- The stability axiom in 'arrow' form: If `S` covers `f` then `S` covers `g ≫ f` for any `g`. -/
lemma arrow_stable (f : Y ⟶ X) (S : sieve X) (h : J.covers S f) {Z : C} (g : Z ⟶ Y) :
  J.covers S (g ≫ f) :=
begin
  rw covers_iff at h ⊢,
  simp [h, sieve.pullback_comp],
end

/--
The transitivity axiom in 'arrow' form: If `S` covers `f` and every arrow in `S` is covered by
`R`, then `R` covers `f`.
-/
lemma arrow_trans (f : Y ⟶ X) (S R : sieve X) (h : J.covers S f) :
  (∀ {Z : C} (g : Z ⟶ X), S g → J.covers R g) → J.covers R f :=
begin
  intro k,
  apply J.transitive h,
  intros Z g hg,
  rw ← sieve.pullback_comp,
  apply k (g ≫ f) hg,
end

lemma arrow_intersect (f : Y ⟶ X) (S R : sieve X) (hS : J.covers S f) (hR : J.covers R f) :
  J.covers (S ⊓ R) f :=
by simpa [covers_iff] using and.intro hS hR

variable (C)
/--
The trivial Grothendieck topology, in which only the maximal sieve is covering. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See [MM92] Chapter III, Section 2, example (a), or
https://en.wikipedia.org/wiki/Grothendieck_topology#The_discrete_and_indiscrete_topologies
-/
def trivial : grothendieck_topology C :=
{ sieves := λ X, {⊤},
  top_mem' := λ X, rfl,
  pullback_stable' := λ X Y S f hf,
  begin
    rw set.mem_singleton_iff at ⊢ hf,
    simp [hf],
  end,
  transitive' := λ X S hS R hR,
  begin
    rw [set.mem_singleton_iff, ← sieve.id_mem_iff_eq_top] at hS,
    simpa using hR hS,
  end }

/--
The discrete Grothendieck topology, in which every sieve is covering.

See https://en.wikipedia.org/wiki/Grothendieck_topology#The_discrete_and_indiscrete_topologies.
-/
def discrete : grothendieck_topology C :=
{ sieves := λ X, set.univ,
  top_mem' := by simp,
  pullback_stable' := λ X Y f, by simp,
  transitive' := by simp }
variable {C}

lemma trivial_covering : S ∈ trivial C X ↔ S = ⊤ := set.mem_singleton_iff

/-- See https://stacks.math.columbia.edu/tag/00Z6 -/
instance : has_le (grothendieck_topology C) :=
{ le := λ J₁ J₂, (J₁ : Π (X : C), set (sieve X)) ≤ (J₂ : Π (X : C), set (sieve X)) }

lemma le_def {J₁ J₂ : grothendieck_topology C} :
  J₁ ≤ J₂ ↔ (J₁ : Π (X : C), set (sieve X)) ≤ J₂ := iff.rfl

/-- See https://stacks.math.columbia.edu/tag/00Z6 -/
instance : partial_order (grothendieck_topology C) :=
{ le_refl := λ J₁, le_def.mpr (le_refl _),
  le_trans := λ J₁ J₂ J₃ h₁₂ h₂₃, le_def.mpr (le_trans h₁₂ h₂₃),
  le_antisymm := λ J₁ J₂ h₁₂ h₂₁, grothendieck_topology.ext (le_antisymm h₁₂ h₂₁),
  ..grothendieck_topology.has_le }

/-- See https://stacks.math.columbia.edu/tag/00Z7 -/
instance : has_Inf (grothendieck_topology C) :=
{ Inf := λ T,
  { sieves := Inf (sieves '' T),
    top_mem' :=
    begin
      rintro X S ⟨⟨_, J, hJ, rfl⟩, rfl⟩,
      simp,
    end,
    pullback_stable' :=
    begin
      rintro X Y S hS f _ ⟨⟨_, J, hJ, rfl⟩, rfl⟩,
      apply J.pullback_stable _ (f _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩),
    end,
    transitive' :=
    begin
      rintro X S hS R h _ ⟨⟨_, J, hJ, rfl⟩, rfl⟩,
      apply J.transitive (hS _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩) _ (λ Y f hf, h hf _ ⟨⟨_, _, hJ, rfl⟩, rfl⟩),
    end } }

/-- See https://stacks.math.columbia.edu/tag/00Z7 -/
lemma is_glb_Inf (s : set (grothendieck_topology C)) : is_glb s (Inf s) :=
begin
  refine @is_glb.of_image _ _ _ _ sieves _ _ _ _,
  { intros, refl },
  { exact is_glb_Inf _ },
end

/--
Construct a complete lattice from the `Inf`, but make the trivial and discrete topologies
definitionally equal to the bottom and top respectively.
-/
instance : complete_lattice (grothendieck_topology C) :=
complete_lattice.copy
(complete_lattice_of_Inf _ is_glb_Inf)
_ rfl
(discrete C)
(begin
  apply le_antisymm,
  { exact @complete_lattice.le_top _ (complete_lattice_of_Inf _ is_glb_Inf) (discrete C) },
  { intros X S hS,
    apply set.mem_univ },
end)
(trivial C)
(begin
  apply le_antisymm,
  { intros X S hS,
    rw trivial_covering at hS,
    apply covering_of_eq_top _ hS },
  { refine @complete_lattice.bot_le _ (complete_lattice_of_Inf _ is_glb_Inf) (trivial C) },
end)
_ rfl
_ rfl
_ rfl
Inf rfl

instance : inhabited (grothendieck_topology C) := ⟨⊤⟩

@[simp] lemma trivial_eq_bot : trivial C = ⊥ := rfl
@[simp] lemma discrete_eq_top : discrete C = ⊤ := rfl

@[simp] lemma bot_covering : S ∈ (⊥ : grothendieck_topology C) X ↔ S = ⊤ := trivial_covering
@[simp] lemma top_covering : S ∈ (⊤ : grothendieck_topology C) X := ⟨⟩

lemma bot_covers (S : sieve X) (f : Y ⟶ X) :
  (⊥ : grothendieck_topology C).covers S f ↔ S f :=
by rw [covers_iff, bot_covering, ← sieve.pullback_eq_top_iff_mem]

@[simp] lemma top_covers (S : sieve X) (f : Y ⟶ X) : (⊤ : grothendieck_topology C).covers S f :=
by simp [covers_iff]

/--
The dense Grothendieck topology.

See https://ncatlab.org/nlab/show/dense+topology, or [MM92] Chapter III, Section 2, example (e).
-/
def dense : grothendieck_topology C :=
{ sieves := λ X S, ∀ {Y : C} (f : Y ⟶ X), ∃ Z (g : Z ⟶ Y), S (g ≫ f),
  top_mem' := λ X Y f, ⟨Y, 𝟙 Y, ⟨⟩⟩,
  pullback_stable' :=
  begin
    intros X Y S h H Z f,
    rcases H (f ≫ h) with ⟨W, g, H'⟩,
    exact ⟨W, g, by simpa⟩,
  end,
  transitive' :=
  begin
    intros X S H₁ R H₂ Y f,
    rcases H₁ f with ⟨Z, g, H₃⟩,
    rcases H₂ H₃ (𝟙 Z) with ⟨W, h, H₄⟩,
    exact ⟨W, (h ≫ g), by simpa using H₄⟩,
  end }

lemma dense_covering : S ∈ dense X ↔ ∀ {Y} (f : Y ⟶ X), ∃ Z (g : Z ⟶ Y), S (g ≫ f) :=
iff.rfl

/--
A category satisfies the right Ore condition if any span can be completed to a commutative square.
NB. Any category with pullbacks obviously satisfies the right Ore condition, see
`right_ore_of_pullbacks`.
-/
def right_ore_condition (C : Type u) [category.{v} C] : Prop :=
∀ {X Y Z : C} (yx : Y ⟶ X) (zx : Z ⟶ X), ∃ W (wy : W ⟶ Y) (wz : W ⟶ Z), wy ≫ yx = wz ≫ zx

lemma right_ore_of_pullbacks [limits.has_pullbacks C] : right_ore_condition C :=
λ X Y Z yx zx, ⟨_, _, _, limits.pullback.condition⟩

/--
The atomic Grothendieck topology: a sieve is covering iff it is nonempty.
For the pullback stability condition, we need the right Ore condition to hold.

See https://ncatlab.org/nlab/show/atomic+site, or [MM92] Chapter III, Section 2, example (f).
-/
def atomic (hro : right_ore_condition C) : grothendieck_topology C :=
{ sieves := λ X S, ∃ Y (f : Y ⟶ X), S f,
  top_mem' := λ X, ⟨_, 𝟙 _, ⟨⟩⟩,
  pullback_stable' :=
  begin
    rintros X Y S h ⟨Z, f, hf⟩,
    rcases hro h f with ⟨W, g, k, comm⟩,
    refine ⟨_, g, _⟩,
    simp [comm, hf],
  end,
  transitive' :=
  begin
    rintros X S ⟨Y, f, hf⟩ R h,
    rcases h hf with ⟨Z, g, hg⟩,
    exact ⟨_, _, hg⟩,
  end }

/-- `J.cover X` denotes the poset of covers of `X` with respect to the
Grothendieck topology `J`. -/
@[derive preorder]
def cover (X : C) := { S : sieve X // S ∈ J X }

namespace cover

variables {J}

instance : has_coe (J.cover X) (sieve X) := ⟨λ S, S.1⟩

instance : has_coe_to_fun (J.cover X) (λ S, Π ⦃Y⦄ (f : Y ⟶ X), Prop) :=
⟨λ S Y f, (S : sieve X) f⟩

@[simp]
lemma coe_fun_coe (S : J.cover X) (f : Y ⟶ X) : (S : sieve X) f = S f := rfl

lemma condition (S : J.cover X) : (S : sieve X) ∈ J X := S.2

@[ext]
lemma ext (S T : J.cover X) (h : ∀ ⦃Y⦄ (f : Y ⟶ X), S f ↔ T f) : S = T :=
subtype.ext $ sieve.ext h

instance : order_top (J.cover X) :=
{ top := ⟨⊤, J.top_mem _⟩,
  le_top := λ S Y f h, by tauto,
  ..(infer_instance : preorder _) }

instance : semilattice_inf (J.cover X) :=
{ inf := λ S T, ⟨S ⊓ T, J.intersection_covering S.condition T.condition⟩,
  le_antisymm := λ S T h1 h2, ext _ _ $ λ Y f, ⟨h1 _, h2 _⟩,
  inf_le_left := λ S T Y f hf, hf.1,
  inf_le_right := λ S T Y f hf, hf.2,
  le_inf := λ S T W h1 h2 Y f h, ⟨h1 _ h, h2 _ h⟩,
  ..(infer_instance : preorder _) }

instance : inhabited (J.cover X) := ⟨⊤⟩

/-- An auxiliary structure, used to define `S.index` in `plus.lean`. -/
@[nolint has_inhabited_instance, ext]
structure arrow (S : J.cover X) :=
(Y : C)
(f : Y ⟶ X)
(hf : S f)

/-- An auxiliary structure, used to define `S.index` in `plus.lean`. -/
@[nolint has_inhabited_instance, ext]
structure relation (S : J.cover X) :=
(Y₁ Y₂ Z : C)
(g₁ : Z ⟶ Y₁)
(g₂ : Z ⟶ Y₂)
(f₁ : Y₁ ⟶ X)
(f₂ : Y₂ ⟶ X)
(h₁ : S f₁)
(h₂ : S f₂)
(w : g₁ ≫ f₁ = g₂ ≫ f₂)

/-- Map a `arrow` along a refinement `S ⟶ T`. -/
@[simps]
def arrow.map {S T : J.cover X} (I : S.arrow) (f : S ⟶ T) : T.arrow :=
⟨I.Y, I.f, f.le _ I.hf⟩

/-- Map a `relation` along a refinement `S ⟶ T`. -/
@[simps]
def relation.map {S T : J.cover X} (I : S.relation) (f : S ⟶ T) : T.relation :=
⟨_, _, _, I.g₁, I.g₂, I.f₁, I.f₂, f.le _ I.h₁, f.le _ I.h₂, I.w⟩

/-- The first `arrow` associated to a `relation`.
Used in defining `index` in `plus.lean`. -/
@[simps]
def relation.fst {S : J.cover X} (I : S.relation) : S.arrow :=
⟨I.Y₁, I.f₁, I.h₁⟩

/-- The second `arrow` associated to a `relation`.
Used in defining `index` in `plus.lean`. -/
@[simps]
def relation.snd {S : J.cover X} (I : S.relation) : S.arrow :=
⟨I.Y₂, I.f₂, I.h₂⟩

@[simp]
lemma relation.map_fst {S T : J.cover X} (I : S.relation) (f : S ⟶ T) :
   I.fst.map f = (I.map f).fst := rfl

@[simp]
lemma relation.map_snd {S T : J.cover X} (I : S.relation) (f : S ⟶ T) :
  I.snd.map f = (I.map f).snd := rfl

/-- Pull back a cover along a morphism. -/
def pullback (S : J.cover X) (f : Y ⟶ X) : J.cover Y :=
⟨sieve.pullback f S, J.pullback_stable _ S.condition⟩

/-- An arrow of `S.pullback f` gives rise to an arrow of `S`. -/
@[simps]
def arrow.base {f : Y ⟶ X} {S : J.cover X} (I : (S.pullback f).arrow) : S.arrow :=
⟨I.Y, I.f ≫ f, I.hf⟩

/-- A relation of `S.pullback f` gives rise to a relation of `S`. -/
@[simps]
def relation.base {f : Y ⟶ X} {S : J.cover X} (I : (S.pullback f).relation) : S.relation :=
⟨_, _, _, I.g₁, I.g₂, I.f₁ ≫ f, I.f₂≫ f, I.h₁, I.h₂, by simp [reassoc_of I.w]⟩

@[simp]
lemma relation.base_fst {f : Y ⟶ X} {S : J.cover X} (I : (S.pullback f).relation) :
 I.fst.base = I.base.fst := rfl

@[simp]
lemma relation.base_snd {f : Y ⟶ X} {S : J.cover X} (I : (S.pullback f).relation) :
 I.snd.base = I.base.snd := rfl

@[simp]
lemma coe_pullback {Z : C} (f : Y ⟶ X) (g : Z ⟶ Y) (S : J.cover X) :
  (S.pullback f) g ↔ S (g ≫ f) := iff.rfl

/-- The isomorphism between `S` and the pullback of `S` w.r.t. the identity. -/
def pullback_id (S : J.cover X) : S.pullback (𝟙 X) ≅ S :=
eq_to_iso $ cover.ext _ _ $ λ Y f, by simp

/-- Pulling back with respect to a composition is the composition of the pullbacks. -/
def pullback_comp {X Y Z : C} (S : J.cover X) (f : Z ⟶ Y) (g : Y ⟶ X) :
  S.pullback (f ≫ g) ≅ (S.pullback g).pullback f :=
eq_to_iso $ cover.ext _ _ $ λ Y f, by simp

/-- Combine a family of covers over a cover. -/
def bind {X : C} (S : J.cover X) (T : Π (I : S.arrow), J.cover I.Y) : J.cover X :=
⟨sieve.bind S (λ Y f hf, T ⟨Y, f, hf⟩), J.bind_covering S.condition (λ _ _ _, (T _).condition)⟩

/-- The canonical moprhism from `S.bind T` to `T`. -/
def bind_to_base {X : C} (S : J.cover X) (T : Π (I : S.arrow), J.cover I.Y) : S.bind T ⟶ S :=
hom_of_le $ by { rintro Y f ⟨Z,e1,e2,h1,h2,h3⟩, rw ← h3, apply sieve.downward_closed, exact h1 }

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the object `B`. -/
noncomputable def arrow.middle {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : C :=
I.hf.some

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `A ⟶ B`. -/
noncomputable def arrow.to_middle_hom {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : I.Y ⟶ I.middle :=
I.hf.some_spec.some

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `B ⟶ X`. -/
noncomputable def arrow.from_middle_hom {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : I.middle ⟶ X :=
I.hf.some_spec.some_spec.some

lemma arrow.from_middle_condition {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : S I.from_middle_hom :=
I.hf.some_spec.some_spec.some_spec.some

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `B ⟶ X`, as an arrow. -/
noncomputable
def arrow.from_middle {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : S.arrow := ⟨_, I.from_middle_hom, I.from_middle_condition⟩

lemma arrow.to_middle_condition {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : (T I.from_middle) I.to_middle_hom :=
I.hf.some_spec.some_spec.some_spec.some_spec.1

/-- An arrow in bind has the form `A ⟶ B ⟶ X` where `A ⟶ B` is an arrow in `T I` for some `I`.
 and `B ⟶ X` is an arrow of `S`. This is the hom `A ⟶ B`, as an arrow. -/
noncomputable
def arrow.to_middle {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : (T I.from_middle).arrow := ⟨_, I.to_middle_hom, I.to_middle_condition⟩

lemma arrow.middle_spec {X : C} {S : J.cover X} {T : Π (I : S.arrow), J.cover I.Y}
  (I : (S.bind T).arrow) : I.to_middle_hom ≫ I.from_middle_hom = I.f :=
I.hf.some_spec.some_spec.some_spec.some_spec.2

-- This is used extensively in `plus.lean`, etc.
-- We place this definition here as it will be used in `sheaf.lean` as well.
/-- To every `S : J.cover X` and presheaf `P`, associate a `multicospan_index`. -/
def index {D : Type w} [category.{max v u} D] (S : J.cover X) (P : Cᵒᵖ ⥤ D) :
  limits.multicospan_index D :=
{ L := S.arrow,
  R := S.relation,
  fst_to := λ I, I.fst,
  snd_to := λ I, I.snd,
  left := λ I, P.obj (opposite.op I.Y),
  right := λ I, P.obj (opposite.op I.Z),
  fst := λ I, P.map I.g₁.op,
  snd := λ I, P.map I.g₂.op }

/-- The natural multifork associated to `S : J.cover X` for a presheaf `P`.
Saying that this multifork is a limit is essentially equivalent to the sheaf condition at the
given object for the given covering sieve. See `sheaf.lean` for an equivalent sheaf condition
using this.
-/
abbreviation multifork {D : Type w} [category.{max v u} D] (S : J.cover X) (P : Cᵒᵖ ⥤ D) :
  limits.multifork (S.index P) :=
limits.multifork.of_ι _ (P.obj (opposite.op X)) (λ I, P.map I.f.op) begin
  intros I,
  dsimp [index],
  simp only [← P.map_comp, ← op_comp, I.w]
end

/-- The canonical map from `P.obj (op X)` to the multiequalizer associated to a covering sieve,
assuming such a multiequalizer exists. This will be used in `sheaf.lean` to provide an equivalent
sheaf condition in terms of multiequalizers. -/
noncomputable
abbreviation to_multiequalizer {D : Type w} [category.{max v u} D] (S : J.cover X) (P : Cᵒᵖ ⥤ D)
  [limits.has_multiequalizer (S.index P)] :
P.obj (opposite.op X) ⟶ limits.multiequalizer (S.index P) :=
limits.multiequalizer.lift _ _ (λ I, P.map I.f.op) begin
  intros I,
  dsimp only [index, relation.fst, relation.snd],
  simp only [← P.map_comp, ← op_comp, I.w],
end

end cover

/-- Pull back a cover along a morphism. -/
@[simps obj]
def pullback (f : Y ⟶ X) : J.cover X ⥤ J.cover Y :=
{ obj := λ S, S.pullback f,
  map := λ S T f, (sieve.pullback_monotone _ f.le).hom }

/-- Pulling back along the identity is naturally isomorphic to the identity functor. -/
def pullback_id (X : C) : J.pullback (𝟙 X) ≅ 𝟭 _ :=
nat_iso.of_components (λ S, S.pullback_id) $ by tidy

/-- Pulling back along a composition is naturally isomorphic to
the composition of the pullbacks. -/
def pullback_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  J.pullback (f ≫ g) ≅ J.pullback g ⋙ J.pullback f :=
nat_iso.of_components (λ S, S.pullback_comp f g) $ by tidy

end grothendieck_topology

end category_theory


-- import Lib.Tactic

namespace Option

def traverse [Applicative m] (f : α → m β) : Option α → m (Option β)
| none => pure none
| some x => some <$> f x

attribute [simp] map_id
-- theorem map_id : Option.map (@id α) = id := rfl

theorem map_comp {f : α → β} {g : β → γ} :
  Option.map (g ∘ f) = Option.map g ∘ Option.map f :=
by funext x ; cases x <;> rfl

@[simp]
theorem map_some {f : α → β} : Option.map f (some x) = some (f x) := rfl

@[simp]
theorem map_none {f : α → β} : Option.map f none = none := rfl

end Option

namespace OptionT

theorem ext {x y : OptionT m α} : x.run = y.run → x = y := id

@[simp]
theorem run_mk {m : Type u → Type v} (x : m (Option α)) :
  OptionT.run (OptionT.mk x) = x := rfl

variable [Monad m] [LawfulMonad m]

@[simp]
theorem run_map (f : α → β) (x : OptionT m α) :
  (f <$> x).run = Option.map f <$> x.run := by
simp [(.<$>.), OptionT.bind, map_eq_pure_bind]
apply congrArg; funext a; cases a <;> rfl

@[simp]
theorem run_pure (x : α) :
  (pure x : OptionT m α).run = pure (some x) := rfl

@[simp]
theorem run_bind (f : α → OptionT m β) (x : OptionT m α) :
  (x.bind f).run = x.run >>= λ x =>
    match x with
    | none => pure none
    | some y => f y |>.run
:= by
simp [OptionT.bind]; apply congrArg; funext a
cases a <;> rfl

@[simp]
theorem run_bind' (f : α → OptionT m β) (x : OptionT m α) :
  (x >>= f).run = x.run >>= λ x =>
    match x with
    | none => pure none
    | some y => f y |>.run
:= run_bind f x

@[simp]
theorem run_seq (f : OptionT m (α → β)) (x : OptionT m α) :
  (f <*> x).run = f.run >>= λ a =>
    match a with
    | none => pure none
    | some a => Option.map a <$> x.run
:= by
simp [Seq.seq, map_eq_pure_bind]
simp; apply congrArg; funext a; cases a
case none => rfl
case some =>
  simp [map_eq_pure_bind]
  apply congrArg; funext a; cases a <;> rfl

instance : LawfulMonad (OptionT m) where
  map_const := by intros; funext a; rfl
  id_map x := by
    apply OptionT.ext; simp [Option.map_id]
  comp_map f g x := by
    apply OptionT.ext; simp [Option.map_comp, comp_map]
  pure_bind x f := OptionT.ext <| by simp
  seqLeft_eq x y := OptionT.ext <| by
    simp [SeqLeft.seqLeft, map_eq_pure_bind]
    apply congrArg; funext a; cases a <;> simp
    apply congrArg; funext a; cases a <;> simp <;> rfl
  seqRight_eq x y := OptionT.ext <| by
    simp [SeqRight.seqRight, map_eq_pure_bind]
    apply congrArg; funext a; cases a <;> simp [← map_eq_pure_bind]
  pure_seq g x := OptionT.ext <| by simp
  map_pure g x := OptionT.ext <| by simp
  seq_pure g x := OptionT.ext <| by
    simp [map_eq_pure_bind]
    apply congrArg; funext a; cases a <;> simp
  seq_assoc x g h := OptionT.ext <| by
    simp [map_eq_pure_bind]
    apply congrArg; funext a; cases a <;> simp
    apply congrArg; funext a; cases a <;> simp [Option.map_comp]
  bind_pure_comp f x := OptionT.ext <| by
    simp [map_eq_pure_bind]
    apply congrArg; funext a; cases a <;> simp
  bind_map f x := OptionT.ext <| by
    simp
    apply congrArg; funext a; cases a <;> simp
  bind_assoc x f g := OptionT.ext <| by
    simp
    apply congrArg; funext a; cases a <;> simp

end OptionT


import .sqe .wf

open list

lemma atom.unify_dvd (m d i k ks) :
  k ≠ 0 → atom.unify m (atom.dvd d i (k::ks)) =
 (let m' := has_div.div m k in
  atom.dvd (m' * d) (m' * i) (1 :: list.map (λ x, m' * x) ks)) :=
begin intro hne, cases k, exfalso, apply hne, repeat {refl} end

lemma atom.unify_ndvd (m d i k ks) :
  k ≠ 0 → atom.unify m (atom.ndvd d i (k::ks)) =
 (let m' := has_div.div m k in
  atom.ndvd (m' * d) (m' * i) (1 :: list.map (λ x, m' * x) ks)) :=
begin intro hne, cases k, exfalso, apply hne, repeat {refl} end

lemma wf_inf_minus :
  ∀ {p : formula}, formula.wf p → formula.wf (inf_minus p)
| ⊤' h := by trivial
| ⊥' h := by trivial
| (A' a) h :=
  begin
    cases a; try {trivial}, cases a_a_1 with z zs,
    simp [inf_minus], rw inf_minus_le_eq,
    apply ite.rec; intro h, trivial,
    apply ite.rec; intro h; trivial
  end
| (p ∧' q) h :=
  begin
    cases h with h1 h2, apply cases_and_o; try {trivial};
    try {apply wf_inf_minus, assumption},
    constructor; {apply wf_inf_minus, assumption}
  end
| (p ∨' q) h :=
  begin
    cases h with h1 h2, apply cases_or_o; try {trivial};
    try {apply wf_inf_minus, assumption},
    constructor; {apply wf_inf_minus, assumption}
  end
| (¬' p) h := by assumption
| (∃' p) h := by assumption

lemma wf_asubst :
  ∀ a : atom, atom.wf a → ∀ i ks, atom.wf (asubst i ks a) :=
begin
  intro a, cases a with i ks d i ks d i ks;
  intros h i' ks'; cases ks with k ks; trivial
end

lemma wf_subst (i ks) :
  ∀ p, formula.wf p → formula.wf (subst i ks p)
| ⊤' h := by unfold subst
| ⊥' h := by unfold subst
| (A' a) h :=
  begin
    unfold subst, unfold formula.map,
    unfold formula.wf, apply wf_asubst _ h
  end
| (p ∧' q) h :=
  begin
    cases h with hp hq, apply and.intro;
    apply wf_subst; assumption
  end
| (p ∨' q) h :=
  begin
    cases h with hp hq, apply and.intro;
    apply wf_subst; assumption
  end
| (¬' p) h := wf_subst p h
| (∃' p) h := by unfold subst

lemma atom.wf_unify (z : znum) (hne : z ≠ 0) :
  ∀ (a : atom), atom.wf a → (head_coeff a ∣ z ∨ head_coeff a = 0)
  → atom.wf (atom.unify z a)
| (atom.le i ks) ha1 ha2 :=
  begin cases ks with k ks, trivial, cases k with m m; trivial end
| (atom.dvd d i ks) ha1 ha2 :=
  begin
    cases ks with k ks, trivial,
    cases (classical.em (k = 0)) with hk hk,
    subst hk, trivial, cases ha2 with ha2 ha2,
    rewrite atom.unify_dvd, simp,
    apply znum.mul_nonzero, unfold head_coeff at ha2,
    apply znum.div_nonzero, apply hne, apply ha2,
    apply ha1, apply hk, exfalso, apply hk ha2
  end
| (atom.ndvd d i ks) ha1 ha2 :=
  begin
    cases ks with k ks, trivial,
    cases (classical.em (k = 0)) with hk hk,
    subst hk, trivial, cases ha2 with ha2 ha2,
    rewrite atom.unify_ndvd, simp,
    apply znum.mul_nonzero, unfold head_coeff at ha2,
    apply znum.div_nonzero, apply hne, apply ha2,
    apply ha1, apply hk, exfalso, apply hk ha2
  end

meta def formula.wf_map_hco_of_formula.wf_tac :=
 `[unfold formula.map, unfold formula.wf,
   cases hn with hnp hnq, unfold formula.atoms at hnz,
   rewrite list.forall_mem_append at hnz,
   cases hnz with hnzp hnzq, apply and.intro;
   apply formula.wf_map_hco_of_formula.wf; assumption]

lemma formula.wf_map_hco_of_formula.wf {z : znum} (hz : z ≠ 0) :
  ∀ {p : formula}, (formula.wf p)
  → (∀ a ∈ p.atoms, has_dvd.dvd (head_coeff a) z ∨ head_coeff a = 0)
  → formula.wf (p.map (atom.unify z))
| ⊤' hn hnz := by unfold formula.map
| ⊥' hn hnz := by unfold formula.map
| (A' a) hn hnz :=
  begin
    unfold formula.map, unfold formula.wf, unfold formula.wf at hn,
    apply atom.wf_unify z hz _ hn, apply hnz,
    unfold formula.atoms, simp,
  end
| (p ∧' q) hn hnz := by formula.wf_map_hco_of_formula.wf_tac
| (p ∨' q) hn hnz := by formula.wf_map_hco_of_formula.wf_tac
| (¬' p) hp hpz :=
  begin
    unfold formula.map, unfold formula.wf,
    apply @formula.wf_map_hco_of_formula.wf p hp hpz,
  end
| (∃' p) hn hnz := by unfold formula.map

lemma formula.wf_hcso :
  ∀ {φ : formula}, formula.wf φ → formula.wf (φ.unify) :=
begin
  intros p hp, unfold formula.unify, unfold formula.wf,
  have hne : znum.lcms (list.map head_coeff (p.atoms_dep_0)) ≠ 0,
  { apply znum.nonzero_of_pos, apply znum.lcms_pos,
    apply @forall_mem_map _ _ head_coeff (λ (z : znum), z ≠ 0),
    unfold formula.atoms_dep_0, intros a ha, apply list.of_mem_filter ha },
  { apply and.intro,
    { intro hc, apply hne hc },
    { apply formula.wf_map_hco_of_formula.wf hne hp,
     intros a ha, apply or_of_not_imp_right,
     intro haz, apply znum.dvd_lcms,
     rewrite list.mem_map, existsi a, apply and.intro,
     unfold formula.atoms_dep_0, apply list.mem_filter_of_mem,
     apply ha, apply haz, refl } }
end

lemma wf_sqe_core :
  ∀ {φ : formula}, formula.wf φ → formula.wf (sqe_core φ) :=
begin
  intros p hp, simp [sqe_core],
  apply wf_or_o, apply wf_disj,
  { apply forall_mem_map,
    intros z hz, apply wf_subst,
    apply wf_inf_minus, apply hp },
  { apply wf_disj, apply forall_mem_map,
    intros zzs hzzs, apply wf_disj,
    apply forall_mem_map, intros z hz,
    apply wf_subst, apply hp }
end

lemma wf_sqe :
  ∀ (φ : formula), formula.wf φ → formula.wf (sqe φ) :=
begin
  intros p hp, apply wf_sqe_core,
  apply formula.wf_hcso hp
end


open Lean

syntax (name := myintro) "intros" sepBy(ident, ",") : tactic

macro_rules (kind := myintro)
| `(tactic| intros $x,*) => pure $ mkNode `Lean.Parser.Tactic.intros #[mkAtom "intros", mkNullNode x]

theorem tst1 {p q : Prop} : p → q → p :=
by {
  intros h1, h2;
  assumption
}

theorem tst2 {p q : Prop} : p → q → p :=
by {
  intros h1; -- the builtin and myintro overlap here.
  intros h2; -- the builtin and myintro overlap here.
  assumption
}

theorem tst3 {p q : Prop} : p → q → p :=
by {
  intros h1 h2;
  assumption
}


import linear_algebra.affine_space.affine_equiv
import algebra.direct_sum
import linear_algebra.direct_sum_module

universes u
variables
(K : Type u)
[field K]
[inhabited K]

#check smul_eq_zero
#check smul_eq_zero.mp
#check sub_smul

/-
Export affine_space (vec K) (pt K) := aff_pt_torsor K,
with vector_space K (vec K) = semimodule K (vec K).
-/
open_locale big_operators
open direct_sum
open_locale direct_sum

--notation `⨁`α, β  := direct_sum α β

/-
Objects
-/

-- 1-D *affine* K pt and vec objects rep'd by 2-D linear K tuples
@[ext]
structure pt extends K × K := (inv : fst = 1)
/-
What about for 3d?
-/
@[ext]
structure pt3 extends K × K × K × K := (inv : fst = 1)
/-
what about for pt n
-/
@[ext] ptn extends K × K × K × ...?
/-
Trying to define this type
-/
def get_K_n_type : nat → Type u
| 0 := K
| (nat.succ n) := K × (get_K_n_type n)
/-
The resulting type, Type u, of course, can refer to an affine vector OR any other type in the same universe
-/

def get_K_n_type_no_head : nat → Type u
| 0 := punit
| (nat.succ n) := K × (get_K_n_type_no_head n)

/-
what should this definition even be?
-/
structure pt_K_n_struct : Type (u+1) :=
  (n : ℕ)
  (inner : K × Type)

/-
How can we use any of this?

get_K_n_type is Type u, it could be an affine vector or a structure modeling an umbrella
-/

def pt_K_n_struct.coords (s : pt_K_n_struct K) : (get_K_n_type K s.n) :=
  begin
    --impossible to write this function
  end

/-
Direct Sum
-/
variables (n : nat )

def helpme : multiset K := ⟦[1,2,3]⟧

def hel_ : multiset (fin n)  := ⟦[⟨1,sorry⟩]⟧
/-
def direct_sum.lmk (R : Type u) [semiring R] (ι : Type v) [dec_ι : decidable_eq ι] (M : ι → Type w) [Π (i : ι), add_comm_monoid (M i)] [Π (i : ι), module R (M i)] (s : finset ι) :
(Π (i : ↥↑s), M i.val) →ₗ[R] ⨁ (i : ι), M i
-/

/-

def direct_sum.mk {ι : Type v} [dec_ι : decidable_eq ι] (β : ι → Type w) [Π (i : ι), add_comm_monoid (β i)] (s : finset ι) :
(Π (i : ↥↑s), β i.val) →+ ⨁ (i : ι), β i
-/

#check finset

def map_ : fin n → Type u := λn_, K
instance allmnd : Π (i : fin n), add_comm_monoid ((λ (i : fin n), map_ K n i) i) := sorry
instance allmod : Π (i : fin n), semimodule K ((λ (i : fin n), map_ K n i) i) := sorry
def muln_ : multiset (fin n)  := ⟦[⟨1,sorry⟩]⟧

def fins_ : finset (fin n) := ⟨(muln_ n), sorry⟩
variables (a : fin n → K) (b: Π (i : (↑(fins_ n) : set (fin n))), map_ K n i.val)

def dsumcommg : ⨁ (i : fin n), map_ K n i := direct_sum.mk (map_ K n) (fins_ n) b
def dsummod : ⨁ (i : fin n), map_ K n i := direct_sum.lmk K (fin n) (map_ K n) (fins_ n) b

#check (md1 K n) b

#check direct_sum.lmk K (fin n) (map_ K n) (fins_ n)

def md2 := direct_sum.lmk K (fin n) (map_ K n) (fins_ n)

lemma b :  direct_sum _ (map_ K n) = (⨁i, (map_ K n) i) := rfl

def type_of_dsum : Type u := @direct_sum (fin n) (map_ K n) begin
  intros,
  let k := (map_ K n i),
  let h0 : k = K := rfl,
  let h1 : (map_ K n i) = K := rfl,
  rw h1,
  by apply_instance
end

variables (x y : direct_sum (fin n) (map_ K n) ) (p : fin n)

def xt : direct_sum _ (map_ K n) :=

def tt : (⨁(fin n), (map_ K n)) := x

def dsakl  : map_ K n p := x p

variables (k : K)

def dsssaaak := k•x

--example : (x p) = K :=

@[class]
structure  test :=
  (t : Π (i : fin n), add_comm_monoid ((λ (i : fin n), map_ K n i) i))

def ppt [Π (i : fin n), add_comm_monoid ((λ (i : fin n), map_ K n i) i)] : _ := ⨁i, (map_ K n) i

#check ppt K n

variables (z : ppt K n) (j : fin n)

#check quot
#check setoid.r

def tester : map_ K n j := λ j : fin n, (z : (⨁i, (map_ K n))) j

abbreviation pts [Π (i : fin n), add_comm_monoid ((λ (i : fin n), map_ K n i) i)] := ⨁i, (map_ K n) i

universes v w u₁

variables (ι : Type v) [dec_ι : decidable_eq ι] (β : ι → Type w)


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import algebra.group algebra.group_power
import data.equiv data.fintype data.list.basic data.quot
import group_theory.subgroup

universes u v w

variables {α : Type u}

lemma list.append_eq_has_append {L₁ L₂ : list α} : list.append L₁ L₂ = L₁ ++ L₂ := rfl

lemma list.infix_cons {L₁ L₂ : list α} {x : α} : L₁ <:+: L₂ → L₁ <:+: x :: L₂ :=
λ ⟨LP, LS, H⟩, ⟨x :: LP, LS, eq.rec_on H rfl⟩

local attribute [simp] list.append_eq_has_append

namespace is_group_hom

variables {β : Type v} [group α] [group β]
variables (f : α → β) [is_group_hom f]

instance range_subgroup : is_subgroup (set.range f) :=
@set.image_univ _ _ f ▸ is_group_hom.image_subgroup f set.univ

end is_group_hom

namespace free_group

/-- Predicate asserting that word `w₁` can be reduced
to `w₂` in one step, i.e. there are words `w₃ w₄`
and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
inductive red.step : list (α × bool) → list (α × bool) → Prop
| bnot {L₁ L₂ x b} : red.step (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂)

/-- Reflexive-transitive closure of red.step -/
inductive red : list (α × bool) → list (α × bool) → Prop
| refl {L} : red L L
| step_trans {L₁ L₂ L₃} (H : free_group.red.step L₁ L₂) :
    red L₂ L₃ → red L₁ L₃

attribute [simp] red.step.bnot
attribute [refl] red.refl

variables {L L₁ L₂ L₃ L₄ : list (α × bool)}

theorem red.trans.aux (H12 : red L₁ L₂) : ∀ {L₃}, red L₂ L₃ → red L₁ L₃ :=
red.rec_on H12 (λ _ _, id) $ λ _ _ _ H1 H2 ih L₃ H23,
red.step_trans H1 $ ih H23

@[trans] theorem red.trans (H12 : red L₁ L₂) (H23 : red L₂ L₃) : red L₁ L₃ :=
red.trans.aux H12 H23

@[simp] lemma red.step.bnot_rev {x b} : red.step (L₁ ++ (x, bnot b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
by cases b; from step.bnot

theorem red.step.length : ∀ {L₁ L₂ : list (α × bool)}, red.step L₁ L₂ → L₂.length + 2 = L₁.length
| _ _ (@red.step.bnot _ L1 L2 x b) := by rw [list.length_append, list.length_append]; refl

theorem red.sizeof : ∀ {L₁ L₂ : list (α × bool)}, red.step L₁ L₂ → L₂.sizeof < L₁.sizeof
| _ _ (@red.step.bnot _ L1 L2 x b) :=
  begin
    induction L1 with hd tl ih,
    case list.nil
    { dsimp [list.sizeof],
      have H : 1 + sizeof (x, b) + (1 + sizeof (x, bnot b) + list.sizeof L2)
        = (list.sizeof L2 + 1) + (sizeof (x, b) + sizeof (x, bnot b) + 1),
      { ac_refl },
      rw H,
      exact nat.le_add_right _ _ },
    case list.cons
    { dsimp [list.sizeof],
      exact nat.add_lt_add_left ih _ }
  end

theorem red.of_step (H : red.step L₁ L₂) : red L₁ L₂ :=
red.step_trans H red.refl

@[simp] lemma red.bnot {x b} : red (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂) :=
red.step_trans red.step.bnot red.refl

@[simp] lemma red.step.cons_bnot {x b} : red.step ((x, b) :: (x, bnot b) :: L) L :=
@red.step.bnot _ [] _ _ _

@[simp] lemma red.cons_bnot {x b} : red ((x, b) :: (x, bnot b) :: L) L :=
@red.bnot _ [] _ _ _

@[simp] lemma red.cons_bnot_rev {x b} : red ((x, bnot b) :: (x, b) :: L) L :=
red.of_step $ @red.step.bnot_rev _ [] _ _ _

theorem red.step.append_left : ∀ {L₁ L₂ L₃ : list (α × bool)},
  red.step L₂ L₃ → red.step (L₁ ++ L₂) (L₁ ++ L₃)
| _ _ _ red.step.bnot := by rw [← list.append_assoc, ← list.append_assoc]; constructor

theorem red.step.append_right : ∀ {L₁ L₂ L₃ : list (α × bool)},
  red.step L₁ L₂ → red.step (L₁ ++ L₃) (L₂ ++ L₃)
| _ _ _ red.step.bnot := by simp

theorem red.step.cons {x} (H : red.step L₁ L₂) : red.step (x :: L₁) (x :: L₂) :=
@red.step.append_left _ [x] _ _ H

theorem red.append : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red L₁ L₃ → red L₂ L₄ → red (L₁ ++ L₂) (L₃ ++ L₄)
| _ _ _ _ red.refl red.refl := red.refl
| _ _ _ _ red.refl (red.step_trans H3 H4) :=
  have _ := red.sizeof H3,
  red.step_trans (red.step.append_left H3) (red.append red.refl H4)
| _ _ _ _ (red.step_trans H1 H2) H3 :=
  have _ := red.sizeof H1,
  red.step_trans (red.step.append_right H1) (red.append H2 H3)

theorem red.cons {x} (H : red L₁ L₂) : red (x :: L₁) (x :: L₂) :=
@red.append _ [x] _ _ _ red.refl H

theorem red.of_cons {x} : red (x :: L₁) (x :: L₂) → red L₁ L₂ :=
begin
  generalize H1 : (x :: L₁ : list _) = L1,
  generalize H2 : (x :: L₂ : list _) = L2,
  intro H,
  induction H with L3 L3 L4 L5 H3 H4 ih generalizing x L₁ L₂,
  case red.refl
  { subst H1; injections; subst_vars },
  case red.step_trans
  { cases H3 with L6 L7 x1 b1,
    subst_vars,
    cases L6 with hd tl,
    case list.nil
    { injection H1 with H5 H6,
      substs H5 H6,
      clear H1 H3,
      transitivity,
      { exact red.cons H4 },
      { simp } },
    case list.cons
    { injection H1 with H5 H6,
      substs H5 H6,
      exact red.trans red.bnot (ih rfl rfl) } }
end

@[simp] lemma red.cons_iff {x} : red (x :: L₁) (x :: L₂) ↔ red L₁ L₂ :=
⟨red.of_cons, red.cons⟩

theorem red.length (H : red L₁ L₂) : ∃ n, L₁.length = L₂.length + 2 * n :=
red.rec_on H (λ _, ⟨0, rfl⟩) $ λ _ _ _ H1 H2 ⟨n, ih⟩,
⟨nat.succ n, red.step.length H1 ▸ ih.symm ▸ rfl⟩

theorem red.antisymm (H : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ :=
red.rec_on H (λ _ _, rfl) $ λ L1 L2 L3 H1 H2 ih H21,
let ⟨n, hn⟩ := red.length (red.trans H2 H21) in
have H3 : list.length L2 = list.length L2 + 2 + 2 * n,
  from (red.step.length H1).symm ▸ hn,
have H4 : list.length L2 + 0 = list.length L2 + (2 * n + 2),
  by simpa using H3,
nat.no_confusion $ nat.add_left_cancel H4

theorem red.step.church_rosser.aux2 : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)} {x1 b1 x2 b2},
  L₁ ++ (x1, b1) :: (x1, bnot b1) :: L₂ = L₃ ++ (x2, b2) :: (x2, bnot b2) :: L₄ →
  L₁ ++ L₂ = L₃ ++ L₄ ∨ ∃ L₅, red.step (L₁ ++ L₂) L₅ ∧ red.step (L₃ ++ L₄) L₅
| []        _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []        _ [(x3,b3)] _ _ _ _ _ H := by injections; subst_vars; simp
| [(x3,b3)] _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []                     _ ((x3,b3)::(x4,b4)::tl) _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.bnot, red.step.cons_bnot⟩
| ((x3,b3)::(x4,b4)::tl) _ []                     _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.cons_bnot, red.step.bnot⟩
| ((x3,b3)::tl) _ ((x4,b4)::tl2) _ _ _ _ _ H :=
  let ⟨H1, H2⟩ := list.cons.inj H in
  match red.step.church_rosser.aux2 H2 with
    | or.inl H3 := or.inl $ by simp [H1, H3]
    | or.inr ⟨L₅, H3, H4⟩ := or.inr
      ⟨_, red.step.cons H3, by simpa [H1] using red.step.cons H4⟩
  end

theorem red.step.church_rosser.aux : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red.step L₁ L₃ → red.step L₂ L₄ → L₁ = L₂ →
  L₃ = L₄ ∨ ∃ L₅, red.step L₃ L₅ ∧ red.step L₄ L₅
| _ _ _ _ red.step.bnot red.step.bnot H := red.step.church_rosser.aux2 H

theorem red.step.church_rosser (H12 : red.step L₁ L₂) (H13 : red.step L₁ L₃) :
  L₂ = L₃ ∨ ∃ L₄, red.step L₂ L₄ ∧ red.step L₃ L₄ :=
red.step.church_rosser.aux H12 H13 rfl

theorem church_rosser_1 : ∀ {L₁ L₂ L₃ : list (α × bool)},
  red.step L₁ L₂ → red L₁ L₃ →
  red L₂ L₃ ∨ ∃ L₄, red L₂ L₄ ∧ step L₃ L₄
| _ _ _ H12 red.refl := or.inr ⟨_, red.refl, H12⟩
| _ _ _ H12 (red.step_trans H1 H2) :=
  have _ := red.sizeof H1,
  match red.step.church_rosser H12 H1 with
    | or.inl H3 := or.inl $ H3.symm ▸ H2
    | or.inr ⟨L1, H3, H4⟩ := match church_rosser_1 H4 H2 with
      | or.inl H5 := or.inl $ red.step_trans H3 H5
      | or.inr ⟨L2, H5, H6⟩ := or.inr $ ⟨L2, red.step_trans H3 H5, H6⟩
      end
  end

/-- Church-Rosser theorem for word reduction:
If `w1 w2 w3` are words such that `w1` reduces to
`w2` and `w3` respectively, then there is a word
`w4` such that `w2` and `w3` reduce to `w4` respectively. -/
theorem church_rosser : ∀ {L₁ L₂ L₃ : list (α × bool)},
  red L₁ L₂ → red L₁ L₃ → ∃ L₄, red L₂ L₄ ∧ red L₃ L₄
| _ _ _ red.refl H23 := ⟨_, H23, red.refl⟩
| _ _ _ (red.step_trans H1 H2) H23 :=
  have _ := red.sizeof H1,
  match church_rosser_1 H1 H23 with
    | or.inl H3 := church_rosser H2 H3
    | or.inr ⟨L7, H3, H4⟩ :=
        let ⟨L8, H5, H6⟩ := church_rosser H2 H3 in
        ⟨L8, H5, red.step_trans H4 H6⟩
  end

end free_group

variable α

/-- The free group over a type, i.e. the words formed
by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group : Type u :=
quot $ @free_group.red.step α

namespace free_group

variables {α} {L L₁ L₂ L₃ L₄ : list (α × bool)}

def mk (L) : free_group α := quot.mk red.step L

@[simp] lemma quot_mk_eq_mk : quot.mk red.step L = mk L := rfl

@[simp] lemma quot_lift_mk (β : Type*) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift f H (mk L) = f L := rfl

@[simp] lemma quot_lift_on_mk (β : Type*) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift_on (mk L) f H = f L := rfl

def inv : list (α × bool) → list (α × bool) :=
λ L, (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse

theorem red.step.inv (H : red.step L₁ L₂) : red.step (inv L₁) (inv L₂) :=
by cases H; simp [inv]

instance : group (free_group α) :=
{ mul := λ x y, quot.lift_on x
    (λ L₁, quot.lift_on y
       (λ L₂, mk $ L₁ ++ L₂)
       (λ L₂ L₃ H, quot.sound $ red.step.append_left H))
    (λ L₁ L₂ H, quot.induction_on y $
       λ L₃, quot.sound $ red.step.append_right H),
  mul_assoc := λ x y z, quot.induction_on x $ λ L₁,
    quot.induction_on y $ λ L₂, quot.induction_on z $ λ L₃, by simp,
  one := mk [],
  one_mul := λ x, quot.induction_on x $ λ L, rfl,
  mul_one := λ x, quot.induction_on x $ λ L, by simp [(*)],
  inv := λ x, quot.lift_on x
    (λ L, mk $ inv L)
    (λ L₁ L₂ H, quot.sound $ red.step.inv H),
  mul_left_inv := λ x, quot.induction_on x $ λ L,
    list.rec_on L rfl $ λ ⟨x, b⟩ tl ih, eq.trans
      (quot.sound $ by simp [inv]) ih }

@[simp] lemma mul_mk : mk L₁ * mk L₂ = mk (L₁ ++ L₂) := rfl

/-- The canonical injection from the type to the free
group over that type by sending each element to
the equivalence class of the letter that is the element. -/
def of (x : α) : free_group α :=
mk [(x, tt)]

theorem red.step.eqv_gen_of_red (H : red L₁ L₂) : eqv_gen red.step L₁ L₂ :=
red.rec_on H (λ _, eqv_gen.refl _) $ λ _ _ _ H1 _ ih,
eqv_gen.trans _ _ _ (eqv_gen.rel _ _ H1) ih

theorem red.step.exact (H : mk L₁ = mk L₂) :
  ∃ L₃, red L₁ L₃ ∧ red L₂ L₃ :=
eqv_gen.rec_on (quot.exact red.step H)
  (λ L1 L2 H12, ⟨L2, red.of_step H12, red.refl⟩)
  (λ L, ⟨L, red.refl, red.refl⟩)
  (λ L1 L2 H12 ⟨L3, H13, H23⟩, ⟨L3, H23, H13⟩)
  (λ L1 L2 L3 H12 H13 ⟨L4, H14, H24⟩ ⟨L5, H25, H35⟩,
     let ⟨L6, H46, H56⟩ := church_rosser H24 H25 in
     ⟨L6, red.trans H14 H46, red.trans H35 H56⟩)

theorem red.step.sound (L₃) (H13 : red L₁ L₃) (H23 : red L₂ L₃) :
  mk L₁ = mk L₂ :=
quot.eqv_gen_sound $ eqv_gen.trans _ _ _
  (red.step.eqv_gen_of_red H13)
  (eqv_gen.symm _ _ $ red.step.eqv_gen_of_red H23)

theorem red.nil.aux : ∀ {L₁ L₂ : list (α × bool)},
  red L₁ L₂ → L₁ = [] → [] = L₂
| _ _ red.refl                                        H := H.symm
| _ _ (red.step_trans (@red.step.bnot _ [] _ _ _) H2) H := list.no_confusion H

/-- The empty word `[]` only reduces to itself. -/
theorem red.nil (H : red [] L) : [] = L :=
red.nil.aux H rfl

theorem red.singleton.aux : ∀ {L₁ L₂ : list (α × bool)} {x},
  red L₁ L₂ → L₁ = [x] → [x] = L₂
| _ _ _ red.refl                                         H := H.symm
| _ _ _ (red.step_trans (@red.step.bnot _ [] _ _ _) H2)  H :=
  list.no_confusion (list.cons.inj H).2
| _ _ _ (red.step_trans (@red.step.bnot _ [x] _ _ _) H2) H :=
  list.no_confusion (list.cons.inj H).2

/-- A letter only reduces to itself. -/
theorem red.singleton {x} (H : red [x] L₁) : [x] = L₁ :=
red.singleton.aux H rfl

/-- The canonical injection from the type to
the free group is an injection. -/
theorem of.inj {x y : α} (H : of x = of y) : x = y :=
let ⟨L₁, hx, hy⟩ := red.step.exact H in
have H1 : _ := (red.singleton hx).trans (red.singleton hy).symm,
by injections

theorem red.step.sublist (H : red.step L₁ L₂) : L₂ <+ L₁ :=
by cases H; simp; constructor; constructor; refl

/-- If `w₁ w₂` are words such that `w₁` reduces to
`w₂`, then `w₂` is a sublist of `w₁`. -/
theorem red.sublist (H : red L₁ L₂) : L₂ <+ L₁ :=
red.rec_on H list.sublist.refl $ λ _ _ _ H1 H2 ih,
list.sublist.trans ih $ red.step.sublist H1

theorem red.inv_of_red_nil.aux {x b} (H : red L₁ L₂) :
  ∀ {L}, L₁ = ((x, b) :: L) → L₂ = [] → red L [(x, bnot b)] :=
red.rec_on H (by cc) $ λ L3 L4 L5 H34,
red.step.cases_on H34 $ λ L6 L7 x1 b1,
list.cases_on L6
  (λ H45 ih L H7 H5, by injections; subst_vars; simpa)
  (λ ⟨x2, b2⟩ tl H45 ih L H7 H5, by injections; subst_vars;
     from red.step_trans red.step.bnot (ih rfl H5))

/-- If `x` is a letter and `w` is a word such that `xw`
reduces to the empty word, then `w` reduecs to `x⁻¹` -/
theorem red.inv_of_red_nil {x b} (H : red ((x, b) :: L) []) :
  red L [(x, bnot b)] :=
red.inv_of_red_nil.aux H rfl rfl

theorem red.inv_of_red_of_ne.aux {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2)) (H2 : red L₁ L₂) :
  ∀ {L₃}, L₁ = (x1, b1) :: L₃ → L₂ = (x2, b2) :: L₄ →
  red L₃ ((x1, bnot b1) :: L₂) :=
red.rec_on H2 (by cc) $ λ L5 L6 L7 H56,
red.step.cases_on H56 $ λ L8 L9 x b,
list.cases_on L8
  (λ H67 ih L₃ H6 H7, by injections; subst_vars; simpa)
  (λ ⟨x, b⟩ tl H67 ih L₃ H6 H7, by injections; subst_vars;
    from red.step_trans red.step.bnot (ih rfl H7))

/-- If `x` and `y` are distinct letters and `w₁ w₂` are
words such that `xw₁` reduces to `yw₂`, then `w₁` reduces to `x⁻¹yw₂`. -/
theorem red.inv_of_red_of_ne {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2))
  (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) :
  red L₁ ((x1, bnot b1) :: (x2, b2) :: L₂) :=
red.inv_of_red_of_ne.aux H1 H2 rfl rfl

section to_group

variables {β : Type v} [group β] (f : α → β) {x y : free_group α}

def to_group.aux : list (α × bool) → β :=
λ L, list.prod $ L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹

theorem red.step.to_group {f : α → β} (H : red.step L₁ L₂) :
  to_group.aux f L₁ = to_group.aux f L₂ :=
by cases H with _ _ _ b; cases b; simp [to_group.aux]

theorem red.to_group {f : α → β} (H : red L₁ L₂) :
  to_group.aux f L₁ = to_group.aux f L₂ :=
red.rec_on H (λ _, rfl) $ λ _ _ _ H1 H2 ih,
eq.trans (by cases H1 with _ _ _ b; cases b; simp [to_group.aux]) ih

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
def to_group : free_group α → β :=
quot.lift (to_group.aux f) $ λ L₁ L₂ H, red.step.to_group H

variable {f}

@[simp] lemma to_group.mk : to_group f (mk L) =
  list.prod (L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹) :=
rfl

@[simp] lemma to_group.of {x} : to_group f (of x) = f x :=
one_mul _

instance to_group.is_group_hom : is_group_hom (to_group f) :=
⟨λ x y, quot.induction_on x $ λ L₁, quot.induction_on y $ λ L₂, by simp⟩

@[simp] lemma to_group.mul : to_group f (x * y) = to_group f x * to_group f y :=
is_group_hom.mul _ _ _

@[simp] lemma to_group.one : to_group f 1 = 1 :=
is_group_hom.one _

@[simp] lemma to_group.inv : to_group f x⁻¹ = (to_group f x)⁻¹ :=
is_group_hom.inv _ _

theorem to_group.unique (g : free_group α → β) [is_group_hom g]
  (hg : ∀ x, g (of x) = f x) {x} :
  g x = to_group f x :=
quot.induction_on x $ λ L, list.rec_on L (is_group_hom.one g) $
λ ⟨x, b⟩ t (ih : g (mk t) = _), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = to_group f (mk ((x, ff) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux])
  (show g (of x * mk t) = to_group f (mk ((x, tt) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux])

theorem to_group.of_eq (x : free_group α) : to_group of x = x :=
eq.symm $ to_group.unique id (λ x, rfl)

theorem to_group.range_subset {s : set β} [is_subgroup s] (H : set.range f ⊆ s) :
  set.range (to_group f) ⊆ s :=
λ y ⟨x, H1⟩, H1 ▸ (quot.induction_on x $ λ L,
list.rec_on L (is_submonoid.one_mem s) $ λ ⟨x, b⟩ tl ih,
bool.rec_on b
  (by simp at ih ⊢; from is_submonoid.mul_mem
    (is_subgroup.inv_mem $ H ⟨x, rfl⟩) ih)
  (by simp at ih ⊢; from is_submonoid.mul_mem (H ⟨x, rfl⟩) ih))

theorem to_group.range_eq_closure :
  set.range (to_group f) = group.closure (set.range f) :=
set.subset.antisymm
  (to_group.range_subset group.subset_closure)
  (group.closure_subset $ λ y ⟨x, hx⟩, ⟨of x, by simpa⟩)

end to_group

section map

variables {β : Type v} (f : α → β) {x y : free_group α}

def map.aux (L : list (α × bool)) : list (β × bool) :=
L.map $ λ x, (f x.1, x.2)

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map (x : free_group α) : free_group β :=
x.lift_on (λ L, mk $ map.aux f L) $
λ L₁ L₂ H, quot.sound $ by cases H; simp [map.aux]

instance map.is_group_hom : is_group_hom (map f) :=
⟨λ x y, quot.induction_on x $ λ L₁, quot.induction_on y $ λ L₂,
by simp [map, map.aux]⟩

variable {f}

@[simp] lemma map.mk : map f (mk L) = mk (L.map (λ x, (f x.1, x.2))) :=
rfl

@[simp] lemma map.id : map id x = x :=
have H1 : (λ (x : α × bool), x) = id := rfl,
quot.induction_on x $ λ L, by simp [H1]

@[simp] lemma map.id' : map (λ z, z) x = x := map.id

theorem map.comp {γ : Type w} {f : α → β} {g : β → γ} {x} :
  map g (map f x) = map (g ∘ f) x :=
quot.induction_on x $ λ L, by simp

@[simp] lemma map.of {x} : map f (of x) = of (f x) := rfl

@[simp] lemma map.mul : map f (x * y) = map f x * map f y :=
is_group_hom.mul _ x y

@[simp] lemma map.one : map f 1 = 1 :=
is_group_hom.one _

@[simp] lemma map.inv : map f x⁻¹ = (map f x)⁻¹ :=
is_group_hom.inv _ x

theorem map.unique (g : free_group α → free_group β) [is_group_hom g]
  (hg : ∀ x, g (of x) = of (f x)) {x} :
  g x = map f x :=
quot.induction_on x $ λ L, list.rec_on L (is_group_hom.one g) $
λ ⟨x, b⟩ t (ih : g (mk t) = map f (mk t)), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = map f ((of x)⁻¹ * mk t),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih])
  (show g (of x * mk t) = map f (of x * mk t),
     by simp [is_group_hom.mul g, hg, ih])

/-- Equivalent types give rise to equivalent free groups. -/
def free_group_congr {α β} (e : α ≃ β) : free_group α ≃ free_group β :=
⟨map e, map e.symm,
 λ x, by simp [function.comp, map.comp],
 λ x, by simp [function.comp, map.comp]⟩

theorem map_eq_to_group : map f x = to_group (of ∘ f) x :=
eq.symm $ map.unique _ $ λ x, by simp

end map

section prod

variables [group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod : α :=
to_group id x

variables {x y}

@[simp] lemma prod_mk :
  prod (mk L) = list.prod (L.map $ λ x, cond x.2 x.1 x.1⁻¹) :=
rfl

@[simp] lemma prod.of {x : α} : prod (of x) = x :=
to_group.of

instance prod.is_group_hom : is_group_hom (@prod α _) :=
to_group.is_group_hom

@[simp] lemma prod.mul : prod (x * y) = prod x * prod y :=
to_group.mul

@[simp] lemma prod.one : prod (1:free_group α) = 1 :=
to_group.one

@[simp] lemma prod.inv : prod x⁻¹ = (prod x)⁻¹ :=
to_group.inv

lemma prod.unique (g : free_group α → α) [is_group_hom g]
  (hg : ∀ x, g (of x) = x) {x} :
  g x = prod x :=
to_group.unique g hg

end prod

theorem to_group_eq_prod_map {β : Type v} [group β] {f : α → β} {x} :
  to_group f x = prod (map f x) :=
eq.symm $ to_group.unique (prod ∘ map f) $ λ _, by simp

section sum

variables [add_group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum : α :=
@prod (multiplicative _) _ x

variables {x y}

@[simp] lemma sum_mk :
  sum (mk L) = list.sum (L.map $ λ x, cond x.2 x.1 (-x.1)) :=
rfl

@[simp] lemma sum.of {x : α} : sum (of x) = x :=
prod.of

instance sum.is_group_hom : is_group_hom (@sum α _) :=
prod.is_group_hom

@[simp] lemma sum.sum : sum (x * y) = sum x + sum y :=
prod.mul

@[simp] lemma sum.one : sum (1:free_group α) = 0 :=
prod.one

@[simp] lemma sum.inv : sum x⁻¹ = -sum x :=
prod.inv

end sum

def free_group_empty_equiv_unit : free_group empty ≃ unit :=
{ to_fun    := λ _, (),
  inv_fun   := λ _, 1,
  left_inv  := λ x, quot.induction_on x $ λ L,
    match L with [] := rfl end,
  right_inv := λ ⟨⟩, rfl }

def free_group_unit_equiv_int : free_group unit ≃ int :=
{ to_fun    := λ x, sum $ map (λ _, 1) x,
  inv_fun   := λ x, of () ^ x,
  left_inv  := λ x, quot.induction_on x $ λ L, list.rec_on L rfl $
    λ ⟨⟨⟩, b⟩ tl ih, by cases b; simp [gpow_add] at ih ⊢; rw ih; refl,
  right_inv := λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [gpow_add, ih])
    (λ i ih, by simp at ih; simp [gpow_add, ih]) }

section reduce

variable [decidable_eq α]

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce (L : list (α × bool)) : list (α × bool) :=
list.rec_on L [] $ λ hd1 tl1 ih,
list.cases_on ih [hd1] $ λ hd2 tl2,
if hd1.1 = hd2.1 ∧ hd1.2 = bnot hd2.2 then tl2
else hd1 :: hd2 :: tl2

@[simp] lemma reduce.cons (x) : reduce (x :: L) =
  list.cases_on (reduce L) [x] (λ hd tl,
  if x.1 = hd.1 ∧ x.2 = bnot hd.2 then tl
  else x :: hd :: tl) := rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red : red L (reduce L) :=
begin
  induction L with hd1 tl1 ih,
  case list.nil
  { refl },
  case list.cons
  { dsimp,
    revert ih,
    generalize htl : reduce tl1 = TL,
    intro ih,
    cases TL with hd2 tl2,
    case list.nil
    { exact red.cons ih },
    case list.cons
    { dsimp,
      by_cases h : hd1.fst = hd2.fst ∧ hd1.snd = bnot (hd2.snd),
      { rw [if_pos h],
        transitivity,
        { exact red.cons ih },
        { cases hd1, cases hd2, cases h,
          dsimp at *, subst_vars,
          simp } },
      { rw [if_neg h],
        exact red.cons ih } } }
end

theorem reduce.not {p : Prop} : ∀ {L₁ L₂ L₃ : list (α × bool)} {x b}, reduce L₁ =L₂ ++ (x, b) :: (x, bnot b) :: L₃ → p
| [] L2 L3 _ _ := λ h, by cases L2; injections
| ((x,b)::L1) L2 L3 x' b' := begin
  dsimp,
  cases r : reduce L1,
  { dsimp, intro h,
    have := congr_arg list.length h,
    simp [-add_comm] at this,
    exact absurd this dec_trivial },
  cases hd with y c,
  by_cases x = y ∧ b = bnot c; simp [h]; intro H,
  { rw H at r,
    exact @reduce.not L1 ((y,c)::L2) L3 x' b' r },
  rcases L2 with _|⟨a, L2⟩,
  { injections, subst_vars,
    simp at h, cc },
  { refine @reduce.not L1 L2 L3 x' b' _,
    injection H with _ H,
    rw [r, H], refl }
end

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min (H : red (reduce L₁) L₂) : reduce L₁ = L₂ :=
begin
  revert H,
  generalize h1 : reduce L₁ = L,
  intro H,
  induction H with L1 L1 L2 L3 H1 H2 ih,
  case red.refl
  { refl },
  case red.step_trans
  { cases H1 with L4 L5 x b,
    exact reduce.not h1 }
end

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem : reduce (reduce L) = reduce L :=
eq.symm $ reduce.min reduce.red

theorem reduce.step.eq (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := church_rosser reduce.red (red.step_trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red (H : red L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := church_rosser reduce.red (red.trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, H13, H23⟩ := red.step.exact H in
(reduce.eq_of_red H13).trans (reduce.eq_of_red H23).symm

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
red.step.sound (reduce L₂) (H ▸ reduce.red) (reduce.red)

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self : mk (reduce L) = mk L :=
reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev (H : red L₁ L₂) : red L₂ (reduce L₁) :=
(reduce.eq_of_red H).symm ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word : free_group α → list (α × bool) :=
quot.lift reduce $ λ L₁ L₂ H, reduce.step.eq H

def to_word.mk {x : free_group α} : mk (to_word x) = x :=
quot.induction_on x $ λ L₁, reduce.self

def to_word.inj (x y : free_group α) : to_word x = to_word y → x = y :=
quot.induction_on x $ λ L₁, quot.induction_on y $ λ L₂, reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser (H12 : red L₁ L₂) (H13 : red L₁ L₃) :
  { L₄ // red L₂ L₄ ∧ red L₃ L₄ } :=
⟨reduce L₁, reduce.rev H12, reduce.rev H13⟩

instance : decidable_eq (free_group α) :=
function.injective.decidable_eq to_word.inj

instance red.decidable_rel : decidable_rel (@red α)
| [] [] := is_true red.refl
| [] (hd2::tl2) := is_false $ λ H,
  list.no_confusion $ red.nil H
| ((x,b)::tl) [] := match red.decidable_rel tl [(x, bnot b)] with
  | is_true H  := is_true $ red.trans (red.cons H) $
    red.of_step $ @red.step.bnot _ [] [] _ _
  | is_false H := is_false $ λ H2, H $ red.inv_of_red_nil H2
  end
| ((x1,b1)::tl1) ((x2,b2)::tl2) := if h : (x1, b1) = (x2, b2)
  then match red.decidable_rel tl1 tl2 with
    | is_true H  := is_true $ h ▸ red.cons H
    | is_false H := is_false $ λ H2, H $ h ▸ red.of_cons $ H2
    end
  else match red.decidable_rel tl1 ((x1,bnot b1)::(x2,b2)::tl2) with
    | is_true H  := is_true $ red.trans (red.cons H) $ red.cons_bnot
    | is_false H := is_false $ λ H2, H $ red.inv_of_red_of_ne h H2
    end

/-- A list containing every word that `w₁` reduces to. -/
def red.enum (L₁ : list (α × bool)) : list (list (α × bool)) :=
list.filter (λ L₂, red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
list.of_mem_filter H

theorem red.enum.complete (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
list.mem_filter_of_mem (list.mem_sublists.2 $ red.sublist H) H

instance : fintype { L₂ // red L₁ L₂ } :=
fintype.subtype (list.to_finset $ red.enum L₁) $
λ L₂, ⟨λ H, red.enum.sound $ list.mem_to_finset.1 H,
  λ H, list.mem_to_finset.2 $ red.enum.complete H⟩

end reduce

end free_group


example : x ≠ y → x ∉ [y] :=
  fun hne hin =>
    match hin with
    | .head _ => hne rfl

example : x ≠ y → x ∉ [y] :=
  fun hne (.head _) => hne rfl


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.punit
import category_theory.structured_arrow
import category_theory.is_connected
import category_theory.limits.yoneda
import category_theory.limits.types

/-!
# Cofinal functors

A functor `F : C ⥤ D` is cofinal if for every `d : D`,
the comma category of morphisms `d ⟶ F.obj c` is connected.

We prove the following three statements are equivalent:
1. `F : C ⥤ D` is cofinal.
2. Every functor `G : D ⥤ E` has a colimit if and only if `F ⋙ G` does,
   and these colimits are isomorphic via `colimit.pre G F`.
3. `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`.

Starting at 1. we show (in `cocones_equiv`) that
the categories of cocones over `G : D ⥤ E` and over `F ⋙ G` are equivalent.
(In fact, via an equivalence which does not change the cocone point.)
This readily implies 2., as `comp_has_colimit`, `has_colimit_of_comp`, and `colimit_iso`.

From 2. we can specialize to `G = coyoneda.obj (op d)` to obtain 3., as `colimit_comp_coyoneda_iso`.

From 3., we prove 1. directly in `cofinal_of_colimit_comp_coyoneda_iso_punit`.

We also show these conditions imply:
4. Every functor `H : Dᵒᵖ ⥤ E` has a limit if and only if `F.op ⋙ H` does,
   and these limits are isomorphic via `limit.pre H F.op`.

## Naming
There is some discrepancy in the literature about naming; some say 'final' instead of 'cofinal'.
The explanation for this is that the 'co' prefix here is *not* the usual category-theoretic one
indicating duality, but rather indicating the sense of "along with".

While the trend seems to be towards using 'final', for now we go with the bulk of the literature
and use 'cofinal'.

## References
* https://stacks.math.columbia.edu/tag/09WN
* https://ncatlab.org/nlab/show/final+functor
* Borceux, Handbook of Categorical Algebra I, Section 2.11.
  (Note he reverses the roles of definition and main result relative to here!)
-/

noncomputable theory

universes v u

namespace category_theory

open opposite
open category_theory.limits

variables {C : Type v} [small_category C]
variables {D : Type v} [small_category D]

/--
A functor `F : C ⥤ D` is cofinal if for every `d : D`, the comma category of morphisms `d ⟶ F.obj c`
is connected.

See https://stacks.math.columbia.edu/tag/04E6
-/
class cofinal (F : C ⥤ D) : Prop :=
(out (d : D) : is_connected (structured_arrow d F))

attribute [instance] cofinal.out

namespace cofinal

variables (F : C ⥤ D) [cofinal F]

instance (d : D) : nonempty (structured_arrow d F) := is_connected.is_nonempty

variables {E : Type u} [category.{v} E] (G : D ⥤ E)

/--
When `F : C ⥤ D` is cofinal, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `d ⟶ F.obj (lift F d)`.
-/
def lift (d : D) : C :=
(classical.arbitrary (structured_arrow d F)).right

/--
When `F : C ⥤ D` is cofinal, we denote by `hom_to_lift` an arbitrary choice of morphism
`d ⟶ F.obj (lift F d)`.
-/
def hom_to_lift (d : D) : d ⟶ F.obj (lift F d) :=
(classical.arbitrary (structured_arrow d F)).hom

/--
We provide an induction principle for reasoning about `lift` and `hom_to_lift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `hom_to_lift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : d ⟶ F.obj X₀` below),
and to show that how to transport such a construction
*both* directions along a morphism between such choices.
-/
lemma induction {d : D} (Z : Π (X : C) (k : d ⟶ F.obj X), Prop)
  (h₁ : Π X₁ X₂ (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
    (k₁ ≫ F.map f = k₂) → Z X₁ k₁ → Z X₂ k₂)
  (h₂ : Π X₁ X₂ (k₁ : d ⟶ F.obj X₁) (k₂ : d ⟶ F.obj X₂) (f : X₁ ⟶ X₂),
    (k₁ ≫ F.map f = k₂) → Z X₂ k₂ → Z X₁ k₁)
  {X₀ : C} {k₀ : d ⟶ F.obj X₀} (z : Z X₀ k₀) : Z (lift F d) (hom_to_lift F d) :=
begin
  apply nonempty.some,
  apply @is_preconnected_induction _ _ _
    (λ (Y : structured_arrow d F), Z Y.right Y.hom) _ _ { right := X₀, hom := k₀, } z,
  { intros j₁ j₂ f a, fapply h₁ _ _ _ _ f.right _ a, convert f.w.symm, dsimp, simp, },
  { intros j₁ j₂ f a, fapply h₂ _ _ _ _ f.right _ a, convert f.w.symm, dsimp, simp, },
end

variables {F G}

/--
Given a cocone over `F ⋙ G`, we can construct a `cocone G` with the same cocone point.
-/
@[simps]
def extend_cocone : cocone (F ⋙ G) ⥤ cocone G :=
{ obj := λ c,
  { X := c.X,
    ι :=
    { app := λ X, G.map (hom_to_lift F X) ≫ c.ι.app (lift F X),
      naturality' := λ X Y f,
      begin
        dsimp, simp,
        -- This would be true if we'd chosen `lift F X` to be `lift F Y`
        -- and `hom_to_lift F X` to be `f ≫ hom_to_lift F Y`.
        apply induction F
          (λ Z k, G.map f ≫ G.map (hom_to_lift F Y) ≫ c.ι.app (lift F Y) = G.map k ≫ c.ι.app Z),
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, category.assoc, ←functor.comp_map, c.w, z], },
        { intros Z₁ Z₂ k₁ k₂ g a z,
        rw [←a, functor.map_comp, category.assoc, ←functor.comp_map, c.w] at z,
        rw z, },
        { rw [←functor.map_comp_assoc], },
      end } },
  map := λ X Y f,
  { hom := f.hom, } }

@[simp]
lemma colimit_cocone_comp_aux (s : cocone (F ⋙ G)) (j : C) :
  G.map (hom_to_lift F (F.obj j)) ≫ s.ι.app (lift F (F.obj j)) =
    s.ι.app j :=
begin
  -- This point is that this would be true if we took `lift (F.obj j)` to just be `j`
  -- and `hom_to_lift (F.obj j)` to be `𝟙 (F.obj j)`.
  apply induction F (λ X k, G.map k ≫ s.ι.app X = (s.ι.app j : _)),
  { intros j₁ j₂ k₁ k₂ f w h, rw ←w, rw ← s.w f at h, simpa using h, },
  { intros j₁ j₂ k₁ k₂ f w h, rw ←w at h, rw ← s.w f, simpa using h, },
  { exact s.w (𝟙 _), },
end

variables {H : Dᵒᵖ ⥤ E}

/-- An auxilliary construction for `extend_cone`, moving `op` around. -/
@[simps]
def extend_cone_cone_to_cocone {F : C ⥤ D} {H : Dᵒᵖ ⥤ E} (c : cone (F.op ⋙ H)) :
  cocone (F ⋙ H.right_op) :=
{ X := op c.X,
  ι :=
  { app := λ j, (c.π.app (op j)).op,
    naturality' := λ j j' f,
    begin apply quiver.hom.unop_inj, dsimp, simp only [category.id_comp], exact c.w f.op, end }}

/-- An auxilliary construction for `extend_cone`, moving `op` around. -/
@[simps]
def extend_cone_cocone_to_cone (c : cocone H.right_op) : cone H :=
{ X := unop c.X,
  π :=
  { app := λ j, (c.ι.app (unop j)).unop,
    naturality' := λ j j' f,
    begin
      apply quiver.hom.op_inj,
      dsimp,
      simp only [category.comp_id],
      exact (c.w f.unop).symm,
    end }}

/--
Given a cone over `F.op ⋙ H`, we can construct a `cone H` with the same cone point.
-/
@[simps]
def extend_cone : cone (F.op ⋙ H) ⥤ cone H :=
{ obj := λ c, extend_cone_cocone_to_cone (extend_cocone.obj (extend_cone_cone_to_cocone c)),
  map := λ X Y f, { hom := f.hom, } }

@[simp]
lemma limit_cone_comp_aux (s : cone (F.op ⋙ H)) (j : Cᵒᵖ) :
  s.π.app (op (lift F (F.obj (unop j)))) ≫ H.map (hom_to_lift F (F.obj (unop j))).op =
    s.π.app j :=
begin
  apply quiver.hom.op_inj,
  exact colimit_cocone_comp_aux (extend_cone_cone_to_cocone s) (unop j)
end

variables (F G H)

/--
If `F` is cofinal,
the category of cocones on `F ⋙ G` is equivalent to the category of cocones on `G`,
for any `G : D ⥤ E`.
-/
@[simps]
def cocones_equiv : cocone (F ⋙ G) ≌ cocone G :=
{ functor := extend_cocone,
  inverse := cocones.whiskering F,
  unit_iso := nat_iso.of_components (λ c, cocones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cocones.ext (iso.refl _) (by tidy)) (by tidy), }.

/--
If `F` is cofinal,
the category of cones on `F.op ⋙ H` is equivalent to the category of cones on `H`,
for any `H : Dᵒᵖ ⥤ E`.
-/
@[simps]
def cones_equiv : cone (F.op ⋙ H) ≌ cone H :=
{ functor := extend_cone,
  inverse := cones.whiskering F.op,
  unit_iso := nat_iso.of_components (λ c, cones.ext (iso.refl _) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ c, cones.ext (iso.refl _) (by tidy)) (by tidy), }.
-- We could have done this purely formally in terms of `cocones_equiv`,
-- without having defined `extend_cone` at all,
-- but it comes at the cost of moving a *lot* of opposites around:
-- (((cones.functoriality_equivalence _ (op_op_equivalence E)).symm.trans
--   ((((cocone_equivalence_op_cone_op _).symm.trans
--     (cocones_equiv F (unop_unop _ ⋙ H.op))).trans
--     (cocone_equivalence_op_cone_op _)).unop)).trans
--   (cones.functoriality_equivalence _ (op_op_equivalence E))).trans
--   (cones.postcompose_equivalence (nat_iso.of_components (λ X, iso.refl _) (by tidy) :
--     H ≅ (unop_unop D ⋙ H.op).op ⋙ (op_op_equivalence E).functor)).symm

variables {G H}

/--
When `F : C ⥤ D` is cofinal, and `t : cocone G` for some `G : D ⥤ E`,
`t.whisker F` is a colimit cocone exactly when `t` is.
-/
def is_colimit_whisker_equiv (t : cocone G) : is_colimit (t.whisker F) ≃ is_colimit t :=
is_colimit.of_cocone_equiv (cocones_equiv F G).symm

/--
When `F : C ⥤ D` is cofinal, and `t : cone H` for some `H : Dᵒᵖ ⥤ E`,
`t.whisker F.op` is a limit cone exactly when `t` is.
-/
def is_limit_whisker_equiv (t : cone H) : is_limit (t.whisker F.op) ≃ is_limit t :=
is_limit.of_cone_equiv (cones_equiv F H).symm

/--
When `F` is cofinal, and `t : cocone (F ⋙ G)`,
`extend_cocone.obj t` is a colimit coconne exactly when `t` is.
-/
def is_colimit_extend_cocone_equiv (t : cocone (F ⋙ G)) :
  is_colimit (extend_cocone.obj t) ≃ is_colimit t :=
is_colimit.of_cocone_equiv (cocones_equiv F G)

/--
When `F` is cofinal, and `t : cone (F.op ⋙ H)`,
`extend_cone.obj t` is a limit conne exactly when `t` is.
-/
def is_limit_extend_cone_equiv (t : cone (F.op ⋙ H)) :
  is_limit (extend_cone.obj t) ≃ is_limit t :=
is_limit.of_cone_equiv (cones_equiv F H)

/-- Given a colimit cocone over `G : D ⥤ E` we can construct a colimit cocone over `F ⋙ G`. -/
@[simps]
def colimit_cocone_comp (t : colimit_cocone G) :
  colimit_cocone (F ⋙ G) :=
{ cocone := _,
  is_colimit := (is_colimit_whisker_equiv F _).symm (t.is_colimit) }

/-- Given a limit cone over `H : Dᵒᵖ ⥤ E` we can construct a limit cone over `F.op ⋙ H`. -/
@[simps]
def limit_cone_comp (t : limit_cone H) :
  limit_cone (F.op ⋙ H) :=
{ cone := _,
  is_limit := (is_limit_whisker_equiv F _).symm (t.is_limit) }

@[priority 100]
instance comp_has_colimit [has_colimit G] :
  has_colimit (F ⋙ G) :=
has_colimit.mk (colimit_cocone_comp F (get_colimit_cocone G))

@[priority 100]
instance comp_has_limit [has_limit H] :
  has_limit (F.op ⋙ H) :=
has_limit.mk (limit_cone_comp F (get_limit_cone H))

lemma colimit_pre_is_iso_aux {t : cocone G} (P : is_colimit t) :
  ((is_colimit_whisker_equiv F _).symm P).desc (t.whisker F) = 𝟙 t.X :=
begin
  dsimp [is_colimit_whisker_equiv],
  apply P.hom_ext,
  intro j,
  dsimp, simp, dsimp, simp, -- See library note [dsimp, simp].
end

instance colimit_pre_is_iso [has_colimit G] :
  is_iso (colimit.pre G F) :=
begin
  rw colimit.pre_eq (colimit_cocone_comp F (get_colimit_cocone G)) (get_colimit_cocone G),
  erw colimit_pre_is_iso_aux,
  dsimp,
  apply_instance,
end

lemma limit_pre_is_iso_aux {t : cone H} (P : is_limit t) :
  ((is_limit_whisker_equiv F _).symm P).lift (t.whisker F.op) = 𝟙 t.X :=
begin
  dsimp [is_limit_whisker_equiv],
  apply P.hom_ext,
  intro j,
  simp, refl,
end

instance limit_pre_is_iso [has_limit H] :
  is_iso (limit.pre H F.op) :=
begin
  rw limit.pre_eq (limit_cone_comp F (get_limit_cone H)) (get_limit_cone H),
  erw limit_pre_is_iso_aux,
  dsimp,
  apply_instance,
end

section
variables (G H)

/--
When `F : C ⥤ D` is cofinal, and `G : D ⥤ E` has a colimit, then `F ⋙ G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso [has_colimit G] : colimit (F ⋙ G) ≅ colimit G := as_iso (colimit.pre G F)

/--
When `F : C ⥤ D` is cofinal, and `H : Dᵒᵖ ⥤ E` has a limit, then `F.op ⋙ H` has a limit also and
`limit (F.op ⋙ H) ≅ limit H`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso [has_limit H] : limit (F.op ⋙ H) ≅ limit H := (as_iso (limit.pre H F.op)).symm

end

/-- Given a colimit cocone over `F ⋙ G` we can construct a colimit cocone over `G`. -/
@[simps]
def colimit_cocone_of_comp (t : colimit_cocone (F ⋙ G)) :
  colimit_cocone G :=
{ cocone := extend_cocone.obj t.cocone,
  is_colimit := (is_colimit_extend_cocone_equiv F _).symm (t.is_colimit), }

/-- Given a limit cone over `F.op ⋙ H` we can construct a limit cone over `H`. -/
@[simps]
def limit_cone_of_comp (t : limit_cone (F.op ⋙ H)) :
  limit_cone H :=
{ cone := extend_cone.obj t.cone,
  is_limit := (is_limit_extend_cone_equiv F _).symm (t.is_limit), }

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_colimit`.)
-/
lemma has_colimit_of_comp [has_colimit (F ⋙ G)] :
  has_colimit G :=
has_colimit.mk (colimit_cocone_of_comp F (get_colimit_cocone (F ⋙ G)))

/--
When `F` is cofinal, and `F.op ⋙ H` has a limit, then `H` has a limit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_limit`.)
-/
lemma has_limit_of_comp [has_limit (F.op ⋙ H)] :
  has_limit H :=
has_limit.mk (limit_cone_of_comp F (get_limit_cone (F.op ⋙ H)))

section
local attribute [instance] has_colimit_of_comp has_limit_of_comp

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso' [has_colimit (F ⋙ G)] : colimit (F ⋙ G) ≅ colimit G := as_iso (colimit.pre G F)

/--
When `F` is cofinal, and `F.op ⋙ H` has a limit, then `H` has a limit also and
`limit (F.op ⋙ H) ≅ limit H`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso' [has_limit (F.op ⋙ H)] : limit (F.op ⋙ H) ≅ limit H :=
(as_iso (limit.pre H F.op)).symm

end

/--
If the universal morphism `colimit (F ⋙ coyoneda.obj (op d)) ⟶ colimit (coyoneda.obj (op d))`
is an isomorphism (as it always is when `F` is cofinal),
then `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`
(simply because `colimit (coyoneda.obj (op d)) ≅ punit`).
-/
def colimit_comp_coyoneda_iso (d : D) [is_iso (colimit.pre (coyoneda.obj (op d)) F)] :
  colimit (F ⋙ coyoneda.obj (op d)) ≅ punit :=
as_iso (colimit.pre (coyoneda.obj (op d)) F) ≪≫ coyoneda.colimit_coyoneda_iso (op d)

lemma zigzag_of_eqv_gen_quot_rel {F : C ⥤ D} {d : D} {f₁ f₂ : Σ X, d ⟶ F.obj X}
  (t : eqv_gen (types.quot.rel (F ⋙ coyoneda.obj (op d))) f₁ f₂) :
  zigzag (structured_arrow.mk f₁.2) (structured_arrow.mk f₂.2) :=
begin
  induction t,
  case eqv_gen.rel : x y r
  { obtain ⟨f, w⟩ := r,
    fconstructor,
    swap 2, fconstructor,
    left, fsplit,
    exact { right := f, } },
  case eqv_gen.refl
  { fconstructor, },
  case eqv_gen.symm : x y h ih
  { apply zigzag_symmetric,
    exact ih, },
  case eqv_gen.trans : x y z h₁ h₂ ih₁ ih₂
  { apply relation.refl_trans_gen.trans,
    exact ih₁, exact ih₂, }
end

/--
If `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit` for all `d : D`, then `F` is cofinal.
-/
lemma cofinal_of_colimit_comp_coyoneda_iso_punit
  (I : Π d, colimit (F ⋙ coyoneda.obj (op d)) ≅ punit) : cofinal F :=
⟨λ d, begin
  haveI : nonempty (structured_arrow d F) := by
  { have := (I d).inv punit.star,
    obtain ⟨j, y, rfl⟩ := limits.types.jointly_surjective' this,
    exact ⟨structured_arrow.mk y⟩, },
  apply zigzag_is_connected,
  rintros ⟨⟨⟩,X₁,f₁⟩ ⟨⟨⟩,X₂,f₂⟩,
  dsimp at *,
  let y₁ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₁ f₁,
  let y₂ := colimit.ι (F ⋙ coyoneda.obj (op d)) X₂ f₂,
  have e : y₁ = y₂,
  { apply (I d).to_equiv.injective, ext, },
  have t := types.colimit_eq e,
  clear e y₁ y₂,
  exact zigzag_of_eqv_gen_quot_rel t,
end⟩

end cofinal

end category_theory


import data.matrix.notation

import for_mathlib.short_exact_sequence

noncomputable theory

open category_theory
open category_theory.limits

universes v u

namespace homological_complex

variables (C : Type u) [category.{v} C] [abelian C]
variables {ι : Type*} {c : complex_shape ι}

abbreviation Fst : chain_complex (short_exact_sequence C) ℕ ⥤
  homological_complex C (complex_shape.down ℕ) :=
(short_exact_sequence.Fst C).map_homological_complex _

abbreviation Snd : chain_complex (short_exact_sequence C) ℕ ⥤
  homological_complex C (complex_shape.down ℕ) :=
(short_exact_sequence.Snd C).map_homological_complex _

abbreviation Trd : chain_complex (short_exact_sequence C) ℕ ⥤
  homological_complex C (complex_shape.down ℕ) :=
(short_exact_sequence.Trd C).map_homological_complex _

abbreviation Fst_Snd : Fst C ⟶ Snd C :=
nat_trans.map_homological_complex (short_exact_sequence.f_nat C) _

abbreviation Snd_Trd : Snd C ⟶ Trd C :=
nat_trans.map_homological_complex (short_exact_sequence.g_nat C) _

variables {C}

variables (A : chain_complex (short_exact_sequence C) ℕ)

instance Fst_Snd_mono (n : ℕ) : mono (((Fst_Snd C).app A).f n) := (A.X n).mono'

instance Snd_Trd_epi (n : ℕ) : epi (((Snd_Trd C).app A).f n) := (A.X n).epi'

lemma Fst_Snd_Trd_exact (n : ℕ) : exact (((Fst_Snd C).app A).f n) (((Snd_Trd C).app A).f n) :=
(A.X n).exact'

end homological_complex


import category_theory.shift

noncomputable theory

namespace category_theory

open category

variables {C D E : Type*} {A : Type*} [category C] [category D] [category E]
  [add_monoid A] [has_shift C A] [has_shift D A] [has_shift E A]

variable (C)

def shift_functor_add' (a b c : A) (h : c = a + b) :
  shift_functor C c ≅ shift_functor C a ⋙ shift_functor C b :=
eq_to_iso (by rw h) ≪≫ shift_functor_add C a b

lemma shift_functor_add'_eq_shift_functor_add (a b : A) :
  shift_functor_add' C a b (a+b) rfl = shift_functor_add C a b :=
begin
  ext1,
  apply id_comp,
end

namespace functor

variables {C}  {F : C ⥤ D} {G : D ⥤ E} {a : A}
  (hF : shift_functor C a ⋙ F ≅ F ⋙ shift_functor D a)
  (hG : shift_functor D a ⋙ G ≅ G ⋙ shift_functor E a)

def comm_shift_comp :
  shift_functor C a ⋙ (F ⋙ G) ≅ (F ⋙ G) ⋙ shift_functor E a :=
(functor.associator _ _ _).symm ≪≫
  iso_whisker_right hF G ≪≫
  functor.associator _ _ _ ≪≫
  iso_whisker_left F hG ≪≫ (functor.associator _ _ _).symm

@[simp]
lemma comm_shift_comp_hom_app (X : C) :
  (comm_shift_comp hF hG).hom.app X = G.map (hF.hom.app X) ≫ hG.hom.app (F.obj X) :=
begin
  dsimp [comm_shift_comp],
  simp only [comp_id, id_comp],
end

@[simp]
lemma comm_shift_comp_inv_app (X : C) :
  (comm_shift_comp hF hG).inv.app X = hG.inv.app (F.obj X) ≫ G.map (hF.inv.app X) :=
begin
  dsimp [comm_shift_comp],
  simp only [comp_id, id_comp],
end

end functor

lemma shift_functor_comp_shift_functor_neg_eq_add'_comp_zero
  {G : Type*} [add_group G] [has_shift C G] (n : G) (X : C) :
  (shift_functor_comp_shift_functor_neg C n).hom.app X =
    (shift_functor_add' C n (-n) 0 (add_neg_self n).symm).inv.app X ≫
      (shift_functor_zero C G).hom.app X :=
by simpa only [shift_functor_add', eq_to_hom_map, unit_of_tensor_iso_unit_hom_app,
  eq_to_iso.hom, iso.trans_inv, nat_trans.comp_app, assoc]

end category_theory