/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import topology.uniform_space.abstract_completion

/-!
# Hausdorff completions of uniform spaces

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

The goal is to construct a left-adjoint to the inclusion of complete Hausdorff uniform spaces
into all uniform spaces. Any uniform space `α` gets a completion `completion α` and a morphism
(ie. uniformly continuous map) `coe : α → completion α` which solves the universal
mapping problem of factorizing morphisms from `α` to any complete Hausdorff uniform space `β`.
It means any uniformly continuous `f : α → β` gives rise to a unique morphism
`completion.extension f : completion α → β` such that `f = completion.extension f ∘ coe`.
Actually `completion.extension f` is defined for all maps from `α` to `β` but it has the desired
properties only if `f` is uniformly continuous.

Beware that `coe` is not injective if `α` is not Hausdorff. But its image is always
dense. The adjoint functor acting on morphisms is then constructed by the usual abstract nonsense.
For every uniform spaces `α` and `β`, it turns `f : α → β` into a morphism
  `completion.map f : completion α → completion β`
such that
  `coe ∘ f = (completion.map f) ∘ coe`
provided `f` is uniformly continuous. This construction is compatible with composition.

In this file we introduce the following concepts:

* `Cauchy α` the uniform completion of the uniform space `α` (using Cauchy filters). These are not
  minimal filters.

* `completion α := quotient (separation_setoid (Cauchy α))` the Hausdorff completion.

## References

This formalization is mostly based on
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
From a slightly different perspective in order to reuse material in topology.uniform_space.basic.
-/

noncomputable theory
open filter set
universes u v w x

open_locale uniformity classical topology filter

/-- Space of Cauchy filters

This is essentially the completion of a uniform space. The embeddings are the neighbourhood filters.
This space is not minimal, the separated uniform space (i.e. quotiented on the intersection of all
entourages) is necessary for this.
-/
def Cauchy (α : Type u) [uniform_space α] : Type u := { f : filter α // cauchy f }

namespace Cauchy

section
parameters {α : Type u} [uniform_space α]
variables {β : Type v} {γ : Type w}
variables [uniform_space β] [uniform_space γ]

/-- The pairs of Cauchy filters generated by a set. -/
def gen (s : set (α × α)) : set (Cauchy α × Cauchy α) :=
{p | s ∈ p.1.val ×ᶠ p.2.val }

lemma monotone_gen : monotone gen :=
monotone_set_of $ assume p, @filter.monotone_mem _ (p.1.val ×ᶠ p.2.val)

private lemma symm_gen : map prod.swap ((𝓤 α).lift' gen) ≤ (𝓤 α).lift' gen :=
calc map prod.swap ((𝓤 α).lift' gen) =
  (𝓤 α).lift' (λs:set (α×α), {p | s ∈ p.2.val ×ᶠ p.1.val }) :
  begin
    delta gen,
    simp [map_lift'_eq, monotone_set_of, filter.monotone_mem,
          function.comp, image_swap_eq_preimage_swap, -subtype.val_eq_coe]
  end
  ... ≤ (𝓤 α).lift' gen :
    uniformity_lift_le_swap
      (monotone_principal.comp (monotone_set_of $ assume p,
        @filter.monotone_mem _ (p.2.val ×ᶠ p.1.val)))
      begin
        have h := λ(p:Cauchy α×Cauchy α), @filter.prod_comm _ _ (p.2.val) (p.1.val),
        simp [function.comp, h, -subtype.val_eq_coe, mem_map'],
        exact le_rfl,
      end

private lemma comp_rel_gen_gen_subset_gen_comp_rel {s t : set (α×α)} : comp_rel (gen s) (gen t) ⊆
  (gen (comp_rel s t) : set (Cauchy α × Cauchy α)) :=
assume ⟨f, g⟩ ⟨h, h₁, h₂⟩,
let ⟨t₁, (ht₁ : t₁ ∈ f.val), t₂, (ht₂ : t₂ ∈ h.val), (h₁ : t₁ ×ˢ t₂ ⊆ s)⟩ :=
  mem_prod_iff.mp h₁ in
let ⟨t₃, (ht₃ : t₃ ∈ h.val), t₄, (ht₄ : t₄ ∈ g.val), (h₂ : t₃ ×ˢ t₄ ⊆ t)⟩ :=
  mem_prod_iff.mp h₂ in
have t₂ ∩ t₃ ∈ h.val,
  from inter_mem ht₂ ht₃,
let ⟨x, xt₂, xt₃⟩ :=
  h.property.left.nonempty_of_mem this in
(f.val ×ᶠ g.val).sets_of_superset
  (prod_mem_prod ht₁ ht₄)
  (assume ⟨a, b⟩ ⟨(ha : a ∈ t₁), (hb : b ∈ t₄)⟩,
    ⟨x,
      h₁ (show (a, x) ∈ t₁ ×ˢ t₂, from ⟨ha, xt₂⟩),
      h₂ (show (x, b) ∈ t₃ ×ˢ t₄, from ⟨xt₃, hb⟩)⟩)

private lemma comp_gen :
  ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) ≤ (𝓤 α).lift' gen :=
calc ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) =
    (𝓤 α).lift' (λs, comp_rel (gen s) (gen s)) :
  begin
    rw [lift'_lift'_assoc],
    exact monotone_gen,
    exact monotone_id.comp_rel monotone_id
  end
  ... ≤ (𝓤 α).lift' (λs, gen $ comp_rel s s) :
    lift'_mono' $ assume s hs, comp_rel_gen_gen_subset_gen_comp_rel
  ... = ((𝓤 α).lift' $ λs:set(α×α), comp_rel s s).lift' gen :
  begin
    rw [lift'_lift'_assoc],
    exact monotone_id.comp_rel monotone_id,
    exact monotone_gen
  end
  ... ≤ (𝓤 α).lift' gen : lift'_mono comp_le_uniformity le_rfl

instance : uniform_space (Cauchy α) :=
uniform_space.of_core
{ uniformity  := (𝓤 α).lift' gen,
  refl        := principal_le_lift'.2 $ λ s hs ⟨a, b⟩ (a_eq_b : a = b),
    a_eq_b ▸ a.property.right hs,
  symm        := symm_gen,
  comp        := comp_gen }

theorem mem_uniformity {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α, gen t ⊆ s :=
mem_lift'_sets monotone_gen

theorem mem_uniformity' {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α, ∀ f g : Cauchy α, t ∈ f.1 ×ᶠ g.1 → (f, g) ∈ s :=
mem_uniformity.trans $ bex_congr $ λ t h, prod.forall

/-- Embedding of `α` into its completion `Cauchy α` -/
def pure_cauchy (a : α) : Cauchy α :=
⟨pure a, cauchy_pure⟩

lemma uniform_inducing_pure_cauchy : uniform_inducing (pure_cauchy : α → Cauchy α) :=
⟨have (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) = id,
      from funext $ assume s, set.ext $ assume ⟨a₁, a₂⟩,
        by simp [preimage, gen, pure_cauchy, prod_principal_principal],
    calc comap (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ((𝓤 α).lift' gen)
          = (𝓤 α).lift'
              (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) :
        comap_lift'_eq
      ... = 𝓤 α : by simp [this]⟩

lemma uniform_embedding_pure_cauchy : uniform_embedding (pure_cauchy : α → Cauchy α) :=
{ inj := assume a₁ a₂ h, pure_injective $ subtype.ext_iff_val.1 h,
  ..uniform_inducing_pure_cauchy }

lemma dense_range_pure_cauchy : dense_range pure_cauchy :=
assume f,
have h_ex : ∀ s ∈ 𝓤 (Cauchy α), ∃y:α, (f, pure_cauchy y) ∈ s, from
  assume s hs,
  let ⟨t'', ht''₁, (ht''₂ : gen t'' ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
  let ⟨t', ht'₁, ht'₂⟩ := comp_mem_uniformity_sets ht''₁ in
  have t' ∈ f.val ×ᶠ f.val,
    from f.property.right ht'₁,
  let ⟨t, ht, (h : t ×ˢ t ⊆ t')⟩ := mem_prod_same_iff.mp this in
  let ⟨x, (hx : x ∈ t)⟩ := f.property.left.nonempty_of_mem ht in
  have t'' ∈ f.val ×ᶠ pure x,
    from mem_prod_iff.mpr ⟨t, ht, {y:α | (x, y) ∈ t'},
      h $ mk_mem_prod hx hx,
      assume ⟨a, b⟩ ⟨(h₁ : a ∈ t), (h₂ : (x, b) ∈ t')⟩,
        ht'₂ $ prod_mk_mem_comp_rel (@h (a, x) ⟨h₁, hx⟩) h₂⟩,
  ⟨x, ht''₂ $ by dsimp [gen]; exact this⟩,
begin
  simp only [closure_eq_cluster_pts, cluster_pt, nhds_eq_uniformity, lift'_inf_principal_eq,
    set.inter_comm _ (range pure_cauchy), mem_set_of_eq],
  exact (lift'_ne_bot_iff $ monotone_const.inter monotone_preimage).mpr
    (assume s hs,
      let ⟨y, hy⟩ := h_ex s hs in
      have pure_cauchy y ∈ range pure_cauchy ∩ {y : Cauchy α | (f, y) ∈ s},
        from ⟨mem_range_self y, hy⟩,
      ⟨_, this⟩)
end

lemma dense_inducing_pure_cauchy : dense_inducing pure_cauchy :=
uniform_inducing_pure_cauchy.dense_inducing dense_range_pure_cauchy

lemma dense_embedding_pure_cauchy : dense_embedding pure_cauchy :=
uniform_embedding_pure_cauchy.dense_embedding dense_range_pure_cauchy

lemma nonempty_Cauchy_iff : nonempty (Cauchy α) ↔ nonempty α :=
begin
  split ; rintro ⟨c⟩,
  { have := eq_univ_iff_forall.1 dense_embedding_pure_cauchy.to_dense_inducing.closure_range c,
    obtain ⟨_, ⟨_, a, _⟩⟩ := mem_closure_iff.1 this _ is_open_univ trivial,
    exact ⟨a⟩ },
  { exact ⟨pure_cauchy c⟩ }
end

section
set_option eqn_compiler.zeta true
instance : complete_space (Cauchy α) :=
complete_space_extension
  uniform_inducing_pure_cauchy
  dense_range_pure_cauchy $
  assume f hf,
  let f' : Cauchy α := ⟨f, hf⟩ in
  have map pure_cauchy f ≤ (𝓤 $ Cauchy α).lift' (preimage (prod.mk f')),
    from le_lift'.2 $ assume s hs,
    let ⟨t, ht₁, (ht₂ : gen t ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
    let ⟨t', ht', (h : t' ×ˢ t' ⊆ t)⟩ := mem_prod_same_iff.mp (hf.right ht₁) in
    have t' ⊆ { y : α | (f', pure_cauchy y) ∈ gen t },
      from assume x hx, (f ×ᶠ pure x).sets_of_superset (prod_mem_prod ht' hx) h,
    f.sets_of_superset ht' $ subset.trans this (preimage_mono ht₂),
  ⟨f', by simp [nhds_eq_uniformity]; assumption⟩
end

instance [inhabited α] : inhabited (Cauchy α) :=
⟨pure_cauchy default⟩

instance [h : nonempty α] : nonempty (Cauchy α) :=
h.rec_on $ assume a, nonempty.intro $ Cauchy.pure_cauchy a

section extend

/-- Extend a uniformly continuous function `α → β` to a function `Cauchy α → β`. Outputs junk when
`f` is not uniformly continuous. -/
def extend (f : α → β) : Cauchy α → β :=
if uniform_continuous f then
  dense_inducing_pure_cauchy.extend f
else
  λ x, f (nonempty_Cauchy_iff.1 ⟨x⟩).some

section separated_space
variables [separated_space β]

lemma extend_pure_cauchy {f : α → β} (hf : uniform_continuous f) (a : α) :
  extend f (pure_cauchy a) = f a :=
begin
  rw [extend, if_pos hf],
  exact uniformly_extend_of_ind uniform_inducing_pure_cauchy dense_range_pure_cauchy hf _
end

end separated_space

variables [_root_.complete_space β]

lemma uniform_continuous_extend {f : α → β} : uniform_continuous (extend f) :=
begin
  by_cases hf : uniform_continuous f,
  { rw [extend, if_pos hf],
    exact uniform_continuous_uniformly_extend uniform_inducing_pure_cauchy
      dense_range_pure_cauchy hf },
  { rw [extend, if_neg hf],
    exact uniform_continuous_of_const (assume a b, by congr) }
end

end extend

end

theorem Cauchy_eq {α : Type*} [inhabited α] [uniform_space α] [complete_space α]
  [separated_space α] {f g : Cauchy α} :
  Lim f.1 = Lim g.1 ↔ (f, g) ∈ separation_rel (Cauchy α) :=
begin
  split,
  { intros e s hs,
    rcases Cauchy.mem_uniformity'.1 hs with ⟨t, tu, ts⟩,
    apply ts,
    rcases comp_mem_uniformity_sets tu with ⟨d, du, dt⟩,
    refine mem_prod_iff.2
      ⟨_, f.2.le_nhds_Lim (mem_nhds_right (Lim f.1) du),
       _, g.2.le_nhds_Lim (mem_nhds_left (Lim g.1) du), λ x h, _⟩,
    cases x with a b, cases h with h₁ h₂,
    rw ← e at h₂,
    exact dt ⟨_, h₁, h₂⟩ },
  { intros H,
    refine separated_def.1 (by apply_instance) _ _ (λ t tu, _),
    rcases mem_uniformity_is_closed tu with ⟨d, du, dc, dt⟩,
    refine H {p | (Lim p.1.1, Lim p.2.1) ∈ t}
      (Cauchy.mem_uniformity'.2 ⟨d, du, λ f g h, _⟩),
    rcases mem_prod_iff.1 h with ⟨x, xf, y, yg, h⟩,
    have limc : ∀ (f : Cauchy α) (x ∈ f.1), Lim f.1 ∈ closure x,
    { intros f x xf,
      rw closure_eq_cluster_pts,
      exact f.2.1.mono
        (le_inf f.2.le_nhds_Lim (le_principal_iff.2 xf)) },
    have := dc.closure_subset_iff.2 h,
    rw closure_prod_eq at this,
    refine dt (this ⟨_, _⟩); dsimp; apply limc; assumption }
end

section
local attribute [instance] uniform_space.separation_setoid

lemma separated_pure_cauchy_injective {α : Type*} [uniform_space α] [s : separated_space α] :
  function.injective (λa:α, ⟦pure_cauchy a⟧) | a b h :=
separated_def.1 s _ _ $ assume s hs,
let ⟨t, ht, hts⟩ :=
  by rw [← (@uniform_embedding_pure_cauchy α _).comap_uniformity, filter.mem_comap] at hs;
    exact hs in
have (pure_cauchy a, pure_cauchy b) ∈ t, from quotient.exact h t ht,
@hts (a, b) this

end

end Cauchy

local attribute [instance] uniform_space.separation_setoid

open Cauchy set

namespace uniform_space
variables (α : Type*) [uniform_space α]
variables {β : Type*} [uniform_space β]
variables {γ : Type*} [uniform_space γ]

instance complete_space_separation [h : complete_space α] :
  complete_space (quotient (separation_setoid α)) :=
⟨assume f, assume hf : cauchy f,
  have cauchy (f.comap (λx, ⟦x⟧)), from
    hf.comap' comap_quotient_le_uniformity $ hf.left.comap_of_surj (surjective_quotient_mk _),
  let ⟨x, (hx : f.comap (λx, ⟦x⟧) ≤ 𝓝 x)⟩ := complete_space.complete this in
  ⟨⟦x⟧, (comap_le_comap_iff $ by simp).1
    (hx.trans $ map_le_iff_le_comap.1 continuous_quotient_mk.continuous_at)⟩⟩

/-- Hausdorff completion of `α` -/
def completion := quotient (separation_setoid $ Cauchy α)

namespace completion

instance [inhabited α] : inhabited (completion α) :=
quotient.inhabited (separation_setoid (Cauchy α))

@[priority 50]
instance : uniform_space (completion α) := separation_setoid.uniform_space

instance : complete_space (completion α) := uniform_space.complete_space_separation (Cauchy α)

instance : separated_space (completion α) := uniform_space.separated_separation

instance : t3_space (completion α) := separated_t3

/-- Automatic coercion from `α` to its completion. Not always injective. -/
instance : has_coe_t α (completion α) := ⟨quotient.mk ∘ pure_cauchy⟩ -- note [use has_coe_t]

protected lemma coe_eq : (coe : α → completion α) = quotient.mk ∘ pure_cauchy := rfl

lemma comap_coe_eq_uniformity :
  (𝓤 _).comap (λ(p:α×α), ((p.1 : completion α), (p.2 : completion α))) = 𝓤 α :=
begin
  have : (λx:α×α, ((x.1 : completion α), (x.2 : completion α))) =
    (λx:(Cauchy α)×(Cauchy α), (⟦x.1⟧, ⟦x.2⟧)) ∘ (λx:α×α, (pure_cauchy x.1, pure_cauchy x.2)),
  { ext ⟨a, b⟩; simp; refl },
  rw [this, ← filter.comap_comap],
  change filter.comap _ (filter.comap _ (𝓤 $ quotient $ separation_setoid $ Cauchy α)) = 𝓤 α,
  rw [comap_quotient_eq_uniformity, uniform_embedding_pure_cauchy.comap_uniformity]
end

lemma uniform_inducing_coe : uniform_inducing  (coe : α → completion α) :=
⟨comap_coe_eq_uniformity α⟩

variables {α}

lemma dense_range_coe : dense_range (coe : α → completion α) :=
dense_range_pure_cauchy.quotient

variables (α)

/-- The Haudorff completion as an abstract completion. -/
def cpkg {α : Type*} [uniform_space α] : abstract_completion α :=
{ space := completion α,
  coe := coe,
  uniform_struct := by apply_instance,
  complete := by apply_instance,
  separation := by apply_instance,
  uniform_inducing := completion.uniform_inducing_coe α,
  dense := completion.dense_range_coe }

instance abstract_completion.inhabited : inhabited (abstract_completion α) :=
⟨cpkg⟩

local attribute [instance]
abstract_completion.uniform_struct abstract_completion.complete abstract_completion.separation

lemma nonempty_completion_iff : nonempty (completion α) ↔ nonempty α :=
cpkg.dense.nonempty_iff.symm

lemma uniform_continuous_coe : uniform_continuous (coe : α → completion α) :=
cpkg.uniform_continuous_coe

lemma continuous_coe : continuous (coe : α → completion α) :=
cpkg.continuous_coe

lemma coe_injective [separated_space α] : function.injective (coe : α → completion α) :=
uniform_embedding.inj (uniform_embedding_coe _)

variable {α}

lemma dense_inducing_coe : dense_inducing (coe : α → completion α) :=
{ dense := dense_range_coe,
  ..(uniform_inducing_coe α).inducing }

/-- The uniform bijection between a complete space and its uniform completion. -/
def uniform_completion.complete_equiv_self [complete_space α] [separated_space α]:
  completion α ≃ᵤ α :=
abstract_completion.compare_equiv completion.cpkg abstract_completion.of_complete

open topological_space

instance separable_space_completion [separable_space α] : separable_space (completion α) :=
completion.dense_inducing_coe.separable_space

lemma dense_embedding_coe [separated_space α]: dense_embedding (coe : α → completion α) :=
{ inj := separated_pure_cauchy_injective,
  ..dense_inducing_coe }

lemma dense_range_coe₂ :
  dense_range (λx:α × β, ((x.1 : completion α), (x.2 : completion β))) :=
dense_range_coe.prod_map dense_range_coe

lemma dense_range_coe₃ :
  dense_range (λx:α × (β × γ),
    ((x.1 : completion α), ((x.2.1 : completion β), (x.2.2 : completion γ)))) :=
dense_range_coe.prod_map dense_range_coe₂

@[elab_as_eliminator]
lemma induction_on {p : completion α → Prop}
  (a : completion α) (hp : is_closed {a | p a}) (ih : ∀a:α, p a) : p a :=
is_closed_property dense_range_coe hp ih a

@[elab_as_eliminator]
lemma induction_on₂ {p : completion α → completion β → Prop}
  (a : completion α) (b : completion β)
  (hp : is_closed {x : completion α × completion β | p x.1 x.2})
  (ih : ∀(a:α) (b:β), p a b) : p a b :=
have ∀x : completion α × completion β, p x.1 x.2, from
  is_closed_property dense_range_coe₂ hp $ assume ⟨a, b⟩, ih a b,
this (a, b)

@[elab_as_eliminator]
lemma induction_on₃ {p : completion α → completion β → completion γ → Prop}
  (a : completion α) (b : completion β) (c : completion γ)
  (hp : is_closed {x : completion α × completion β × completion γ | p x.1 x.2.1 x.2.2})
  (ih : ∀(a:α) (b:β) (c:γ), p a b c) : p a b c :=
have ∀x : completion α × completion β × completion γ, p x.1 x.2.1 x.2.2, from
  is_closed_property dense_range_coe₃ hp $ assume ⟨a, b, c⟩, ih a b c,
this (a, b, c)

lemma ext {Y : Type*} [topological_space Y] [t2_space Y] {f g : completion α → Y}
  (hf : continuous f) (hg : continuous g) (h : ∀a:α, f a = g a) : f = g :=
cpkg.funext hf hg h

lemma ext' {Y : Type*} [topological_space Y] [t2_space Y] {f g : completion α → Y}
  (hf : continuous f) (hg : continuous g) (h : ∀a:α, f a = g a) (a : completion α) :
  f a = g a :=
congr_fun (ext hf hg h) a

section extension
variables {f : α → β}

/-- "Extension" to the completion. It is defined for any map `f` but
returns an arbitrary constant value if `f` is not uniformly continuous -/
protected def extension (f : α → β) : completion α → β :=
cpkg.extend f

section complete_space

variables [complete_space β]

lemma uniform_continuous_extension : uniform_continuous (completion.extension f) :=
cpkg.uniform_continuous_extend

lemma continuous_extension : continuous (completion.extension f) :=
cpkg.continuous_extend

end complete_space

@[simp] lemma extension_coe [separated_space β] (hf : uniform_continuous f) (a : α) :
  (completion.extension f) a = f a :=
cpkg.extend_coe hf a

variables [separated_space β] [complete_space β]

lemma extension_unique (hf : uniform_continuous f) {g : completion α → β}
  (hg : uniform_continuous g) (h : ∀ a : α, f a = g (a : completion α)) :
  completion.extension f = g :=
cpkg.extend_unique hf hg h

@[simp] lemma extension_comp_coe {f : completion α → β} (hf : uniform_continuous f) :
  completion.extension (f ∘ coe) = f :=
cpkg.extend_comp_coe hf
end extension

section map
variables {f : α → β}

/-- Completion functor acting on morphisms -/
protected def map (f : α → β) : completion α → completion β :=
cpkg.map cpkg f

lemma uniform_continuous_map : uniform_continuous (completion.map f) :=
cpkg.uniform_continuous_map cpkg f

lemma continuous_map : continuous (completion.map f) :=
cpkg.continuous_map cpkg f

@[simp] lemma map_coe (hf : uniform_continuous f) (a : α) : (completion.map f) a = f a :=
cpkg.map_coe cpkg hf a

lemma map_unique {f : α → β} {g : completion α → completion β}
  (hg : uniform_continuous g) (h : ∀a:α, ↑(f a) = g a) : completion.map f = g :=
cpkg.map_unique cpkg hg h

@[simp] lemma map_id : completion.map (@id α) = id :=
cpkg.map_id

lemma extension_map [complete_space γ] [separated_space γ] {f : β → γ} {g : α → β}
  (hf : uniform_continuous f) (hg : uniform_continuous g) :
  completion.extension f ∘ completion.map g = completion.extension (f ∘ g) :=
completion.ext (continuous_extension.comp continuous_map) continuous_extension $
  by intro a; simp only [hg, hf, hf.comp hg, (∘), map_coe, extension_coe]

lemma map_comp {g : β → γ} {f : α → β} (hg : uniform_continuous g) (hf : uniform_continuous f) :
  completion.map g ∘ completion.map f = completion.map (g ∘ f) :=
extension_map ((uniform_continuous_coe _).comp hg) hf

end map

/- In this section we construct isomorphisms between the completion of a uniform space and the
completion of its separation quotient -/
section separation_quotient_completion

/-- The isomorphism between the completion of a uniform space and the completion of its separation
quotient. -/
def completion_separation_quotient_equiv (α : Type u) [uniform_space α] :
  completion (separation_quotient α) ≃ completion α :=
begin
  refine ⟨completion.extension (separation_quotient.lift (coe : α → completion α)),
    completion.map quotient.mk, _, _⟩,
  { assume a,
    refine induction_on a (is_closed_eq (continuous_map.comp continuous_extension) continuous_id) _,
    rintros ⟨a⟩,
    show completion.map quotient.mk
      (completion.extension (separation_quotient.lift coe) ↑⟦a⟧) = ↑⟦a⟧,
    rw [extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α),
      completion.map_coe uniform_continuous_quotient_mk] ; apply_instance },
  { assume a,
    refine completion.induction_on a
      (is_closed_eq (continuous_extension.comp continuous_map) continuous_id) (λ a, _),
    rw [map_coe uniform_continuous_quotient_mk,
      extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α) _] ; apply_instance }
end

lemma uniform_continuous_completion_separation_quotient_equiv :
  uniform_continuous ⇑(completion_separation_quotient_equiv α) :=
uniform_continuous_extension

lemma uniform_continuous_completion_separation_quotient_equiv_symm :
  uniform_continuous ⇑(completion_separation_quotient_equiv α).symm :=
uniform_continuous_map

end separation_quotient_completion

section extension₂
variables (f : α → β → γ)
open function

/-- Extend a two variable map to the Hausdorff completions. -/
protected def extension₂ (f : α → β → γ) : completion α → completion β → γ :=
cpkg.extend₂ cpkg f

section separated_space
variables [separated_space γ] {f}

@[simp] lemma extension₂_coe_coe (hf : uniform_continuous₂ f) (a : α) (b : β) :
  completion.extension₂ f a b = f a b :=
cpkg.extension₂_coe_coe cpkg hf a b

end separated_space

variables [complete_space γ] (f)

lemma uniform_continuous_extension₂ : uniform_continuous₂ (completion.extension₂ f) :=
cpkg.uniform_continuous_extension₂ cpkg f

end extension₂

section map₂
open function

/-- Lift a two variable map to the Hausdorff completions. -/
protected def map₂ (f : α → β → γ) : completion α → completion β → completion γ :=
cpkg.map₂ cpkg cpkg f

lemma uniform_continuous_map₂ (f : α → β → γ) : uniform_continuous₂ (completion.map₂ f) :=
cpkg.uniform_continuous_map₂ cpkg cpkg f

lemma continuous_map₂ {δ} [topological_space δ] {f : α → β → γ}
  {a : δ → completion α} {b : δ → completion β} (ha : continuous a) (hb : continuous b) :
  continuous (λd:δ, completion.map₂ f (a d) (b d)) :=
cpkg.continuous_map₂ cpkg cpkg ha hb

lemma map₂_coe_coe (a : α) (b : β) (f : α → β → γ) (hf : uniform_continuous₂ f) :
  completion.map₂ f (a : completion α) (b : completion β) = f a b :=
cpkg.map₂_coe_coe cpkg cpkg a b f hf

end map₂
end completion
end uniform_space


-- WIP Trying to proove addBoth.sub, addBoth.sup
-- Verification that it suffices to have the lemma: beq_eq_eq

-- Tested with:
-- leanprover/lean4:nightly unchanged - Lean (version 4.0.0-nightly-2023-01-28, commit e37f209c1a2a, Release)

import Std.Data.AssocList
import Std.Data.List.Lemmas
-- import Std.Classes.BEq

namespace MWE8b

theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = if c then a else b := by cases c <;> rfl

theorem cond_decide {α} (p : Prop) [Decidable p] (t e : α) : cond (decide p) t e = if p then t else e := by
  by_cases p <;> simp [*]

-- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Problems.20simplifying.20.20conditions.20with.20hypotheses/near/324212540
@[simp] theorem beq_eq_eq [DecidableEq α] (x y : α) :
  (x == y) = decide (x = y) := rfl

abbrev Strings := List String

instance : Repr (Std.AssocList String Strings) where reprPrec s n := s.toList.repr n

def addDecl (s: Std.AssocList String Strings) (d: String) : Std.AssocList String Strings :=
match s.contains d with
| true => s
| false => .cons d [] s

theorem addDecl.added (s: Std.AssocList String Strings) (d: String): (addDecl s d).contains d
:= by
  simp [addDecl]
  split <;> simp
  next x heq => simp_all

theorem addDecl.cons (s: Std.AssocList String Strings) (d: String): (addDecl s d).isEmpty = false
:= by
  simp [addDecl]
  split <;> simp [List.isEmpty]
  . case h_1 x heq =>
    split <;> simp_all

theorem addDecl.after (s: Std.AssocList String Strings) (x y: String): s.contains x → (addDecl s y).contains x
:= by
  intro h
  simp [Std.AssocList.contains, addDecl] at h ⊢
  apply Exists.elim h
  split <;> simp_all
  done

def addSubSup: String → String → Std.AssocList String Strings → Std.AssocList String Strings
| sub, sup, .nil            => .cons sub [sup] .nil
| sub, sup, .cons a as tail => bif a = sub then .cons sub (as.insert sup) tail else .cons a as (addSubSup sub sup tail)

theorem addSubSup.sub (sub sup: String) (ss: Std.AssocList String Strings): (addSubSup sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addSubSup, cond_eq_ite]
    by_cases key = sub
    . case pos h =>
      simp [h]
    . case neg h =>
      simp [h]
      apply tail_ih

def addBoth (sub sup: String) (ss: Std.AssocList String Strings) : Std.AssocList String Strings :=
  let ss' := addDecl ss sup
  addSubSup sub sup ss'

theorem addBoth.sub_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case nil =>
    simp [addBoth, addDecl, addSubSup, cond_eq_ite]
    split <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addBoth, addDecl]
    by_cases key = sup <;> simp [*]
    . case pos =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup = sub <;> simp [*]
      . case neg h =>
        simp [addBoth, addDecl] at tail_ih
        split at tail_ih
        . case h_1 =>
          by_cases key = sub <;> simp [*]
        . case h_2 x heq =>
          by_cases key = sub <;> simp_all
          simp [addSubSup, cond_eq_ite, h] at tail_ih
          apply tail_ih
    . case neg h =>
      split <;> simp_all
      . case h_1 x heq =>
        -- Given the tactic state: (same as MWE8 addBoth.sub_eq path cons/neg/h_1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sub
        sorry

      . case h_2 x heq =>
        -- Given the tactic state: (same as MWE8 addBoth.sub_eq path cons/neg/h_2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sub
        sorry

theorem addBoth.sub_beq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case nil =>
    simp [addBoth, addDecl, addSubSup, cond_eq_ite]
    split <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addBoth, addDecl]
    by_cases key == sup <;> simp_all
    . case pos =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup == sub <;> simp [*]
      . case pos =>
        simp_all
      . case neg h =>
        simp [addBoth, addDecl] at tail_ih
        split at tail_ih
        . case h_1 =>
          by_cases key == sub <;> simp_all
        . case h_2 x heq =>
          by_cases key == sub <;> simp_all
          simp [addSubSup, cond_eq_ite, h] at tail_ih
          apply tail_ih
    . case neg h =>
      split <;> simp_all
      . case h_1 x heq =>
        -- Given the tactic state: (same as addBoth.sub_eq: path cons/neg/h_1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sub
        sorry

      . case h_2 x heq =>
        -- Given the tactic state: (same as addBoth.sub_eq: path cons/neg/h_2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sub
        sorry

theorem addBoth.sup_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sup
:= by
  simp [addBoth]
  simp [addDecl]
  induction ss <;> simp [*]
  . case nil =>
    simp [addSubSup, cond_eq_ite]
    by_cases sup = sub <;> simp [*]
  . case cons key value tail tail_ih =>
    simp [addDecl, cond_eq_ite]
    by_cases key = sup <;> simp [*]
    . case pos h1 =>
      simp [addSubSup, cond_eq_ite] at tail_ih ⊢
      by_cases sup = sub <;> simp [*]
    . case neg h1 =>
      let ⟨ x, hx, he ⟩ := tail_ih
      split <;> simp_all
      . case h_1 y heq =>
        -- Given the tactic state: (same as MWE8 addBoth.sup_eq path cons/neg/h_1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup tail)
        -- he: x.fst = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sup
        sorry

      . case h_2 y heq =>
        -- Given the tactic state: (same as MWE8 addBoth.sup_eq path cons/neg/h_2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail)) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail))
        -- he: x.fst = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sup
        sorry

theorem addBoth.sup_beq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sup
:= by
  simp [addBoth]
  simp [addDecl]
  induction ss <;> simp_all
  . case nil =>
    simp [addSubSup, cond_eq_ite]
    by_cases sup == sub <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addDecl, cond_eq_ite]
    by_cases key == sup <;> simp_all
    . case pos h1 =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup == sub <;> simp_all
    . case neg h1 =>
      let ⟨ x, hx, he ⟩ := tail_ih
      split <;> simp_all
      . case h_1 y heq =>
        -- Given the tactic state (same as addBoth.sup_eq: path cons/neg/h1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup tail)
        -- he: x.fst = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sup
        sorry

      . case h_2 y heq =>
        -- Given the tactic state: (same as addBoth.sup_eq: path cons/neg/h2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail)) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail))
        -- he: x.fst = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sup
        sorry

end MWE8b


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Logic

/--
An alternative constructor for `LawfulMonad` which has more
defaultable fields in the common case.
-/
theorem LawfulMonad.mk' (m : Type u → Type v) [Monad m]
    (id_map : ∀ {α} (x : m α), id <$> x = x)
    (pure_bind : ∀ {α β} (x : α) (f : α → m β), pure x >>= f = f x)
    (bind_assoc : ∀ {α β γ} (x : m α) (f : α → m β) (g : β → m γ),
      x >>= f >>= g = x >>= fun x => f x >>= g)
    (map_const : ∀ {α β} (x : α) (y : m β),
      Functor.mapConst x y = Function.const β x <$> y := by intros; rfl)
    (seqLeft_eq : ∀ {α β} (x : m α) (y : m β),
      x <* y = (x >>= fun a => y >>= fun _ => pure a) := by intros; rfl)
    (seqRight_eq : ∀ {α β} (x : m α) (y : m β), x *> y = (x >>= fun _ => y) := by intros; rfl)
    (bind_pure_comp : ∀ {α β} (f : α → β) (x : m α),
      x >>= (fun y => pure (f y)) = f <$> x := by intros; rfl)
    (bind_map : ∀ {α β} (f : m (α → β)) (x : m α), f >>= (. <$> x) = f <*> x := by intros; rfl)
    : LawfulMonad m :=
  have map_pure {α β} (g : α → β) (x : α) : g <$> (pure x : m α) = pure (g x) := by
    rw [← bind_pure_comp]; simp [pure_bind]
  { id_map, bind_pure_comp, bind_map, pure_bind, bind_assoc, map_pure,
    comp_map := by simp [← bind_pure_comp, bind_assoc, pure_bind]
    pure_seq := by intros; rw [← bind_map]; simp [pure_bind]
    seq_pure := by intros; rw [← bind_map]; simp [map_pure, bind_pure_comp]
    seq_assoc := by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind]
    map_const := funext fun x => funext (map_const x)
    seqLeft_eq := by simp [seqLeft_eq, ← bind_map, ← bind_pure_comp, pure_bind, bind_assoc]
    seqRight_eq := fun x y => by
      rw [seqRight_eq, ← bind_map, ← bind_pure_comp, bind_assoc]; simp [pure_bind, id_map] }

instance : LawfulMonad (Except ε) := LawfulMonad.mk'
  (id_map := fun x => by cases x <;> rfl)
  (pure_bind := fun a f => rfl)
  (bind_assoc := fun a f g => by cases a <;> rfl)

instance : LawfulApplicative (Except ε) := inferInstance
instance : LawfulFunctor (Except ε) := inferInstance

instance : LawfulMonad Option := LawfulMonad.mk'
  (id_map := fun x => by cases x <;> rfl)
  (pure_bind := fun x f => rfl)
  (bind_assoc := fun x f g => by cases x <;> rfl)
  (bind_pure_comp := fun f x => by cases x <;> rfl)

instance : LawfulApplicative Option := inferInstance
instance : LawfulFunctor Option := inferInstance

/-!
## SatisfiesM

The `SatisfiesM` predicate works over an arbitrary (lawful) monad / applicative / functor,
and enables Hoare-like reasoning over monadic expressions. For example, given a monadic
function `f : α → m β`, to say that the return value of `f` satisfies `Q` whenever
the input satisfies `P`, we write `∀ a, P a → SatisfiesM Q (f a)`.
-/

/--
`SatisfiesM p (x : m α)` lifts propositions over a monad. It asserts that `x` may as well
have the type `x : m {a // p a}`, because there exists some `m {a // p a}` whose image is `x`.
So `p` is the postcondition of the monadic value.
-/
def SatisfiesM {m : Type u → Type v} [Functor m] (p : α → Prop) (x : m α) : Prop :=
  ∃ x' : m {a // p a}, Subtype.val <$> x' = x

namespace SatisfiesM

/-- If `p` is always true, then every `x` satisfies it. -/
theorem of_true [Applicative m] [LawfulApplicative m] {x : m α}
    (h : ∀ a, p a) : SatisfiesM p x :=
  ⟨(fun a => ⟨a, h a⟩) <$> x, by simp [← comp_map, Function.comp]⟩

/--
If `p` is always true, then every `x` satisfies it.
(This is the strongest postcondition version of `of_true`.)
-/
protected theorem trivial [Applicative m] [LawfulApplicative m] {x : m α} :
  SatisfiesM (fun _ => True) x := of_true fun _ => trivial

/-- The `SatisfiesM p x` predicate is monotonic in `p`. -/
theorem imp [Functor m] [LawfulFunctor m] {x : m α}
    (h : SatisfiesM p x) (H : ∀ {a}, p a → q a) : SatisfiesM q x :=
  let ⟨x, h⟩ := h; ⟨(fun ⟨a, h⟩ => ⟨_, H h⟩) <$> x, by rw [← h, ← comp_map]; rfl⟩

/-- `SatisfiesM` distributes over `<$>`, general version. -/
protected theorem map [Functor m] [LawfulFunctor m] {x : m α}
    (hx : SatisfiesM p x) (hf : ∀ {a}, p a → q (f a)) : SatisfiesM q (f <$> x) := by
  let ⟨x', hx⟩ := hx
  refine ⟨(fun ⟨a, h⟩ => ⟨f a, hf h⟩) <$> x', ?_⟩
  rw [← hx]; simp [← comp_map, Function.comp]

/--
`SatisfiesM` distributes over `<$>`, strongest postcondition version.
(Use this for reasoning forward from assumptions.)
-/
theorem map_post [Functor m] [LawfulFunctor m] {x : m α}
    (hx : SatisfiesM p x) : SatisfiesM (fun b => ∃ a, p a ∧ b = f a) (f <$> x) :=
  hx.map fun h => ⟨_, h, rfl⟩

/--
`SatisfiesM` distributes over `<$>`, weakest precondition version.
(Use this for reasoning backward from the goal.)
-/
theorem map_pre [Functor m] [LawfulFunctor m] {x : m α}
    (hx : SatisfiesM (fun a => p (f a)) x) : SatisfiesM p (f <$> x) :=
  hx.map fun h => h

/-- `SatisfiesM` distributes over `mapConst`, general version. -/
protected theorem mapConst [Functor m] [LawfulFunctor m] {x : m α}
    (hx : SatisfiesM q x) (ha : ∀ {b}, q b → p a) : SatisfiesM p (Functor.mapConst a x) :=
  map_const (f := m) ▸ hx.map ha

/-- `SatisfiesM` distributes over `pure`, general version / weakest precondition version. -/
protected theorem pure [Applicative m] [LawfulApplicative m]
    (h : p a) : SatisfiesM (m := m) p (pure a) := ⟨pure ⟨_, h⟩, by simp⟩

/-- `SatisfiesM` distributes over `<*>`, general version. -/
protected theorem seq [Applicative m] [LawfulApplicative m] {x : m α}
    (hf : SatisfiesM p₁ f) (hx : SatisfiesM p₂ x)
    (H : ∀ {f a}, p₁ f → p₂ a → q (f a)) : SatisfiesM q (f <*> x) := by
  match f, x, hf, hx with | _, _, ⟨f, rfl⟩, ⟨x, rfl⟩ => ?_
  refine ⟨(fun ⟨a, h₁⟩ ⟨b, h₂⟩ => ⟨a b, H h₁ h₂⟩) <$> f <*> x, ?_⟩
  simp only [← pure_seq]; simp [SatisfiesM, seq_assoc]
  simp only [← pure_seq]; simp [seq_assoc, Function.comp]

/-- `SatisfiesM` distributes over `<*>`, strongest postcondition version. -/
protected theorem seq_post [Applicative m] [LawfulApplicative m] {x : m α}
    (hf : SatisfiesM p₁ f) (hx : SatisfiesM p₂ x) :
    SatisfiesM (fun c => ∃ f a, p₁ f ∧ p₂ a ∧ c = f a) (f <*> x) :=
  hf.seq hx fun  hf ha => ⟨_, _, hf, ha, rfl⟩

/--
`SatisfiesM` distributes over `<*>`, weakest precondition version 1.
(Use this when `x` and the goal are known and `f` is a subgoal.)
-/
protected theorem seq_pre [Applicative m] [LawfulApplicative m] {x : m α}
    (hf : SatisfiesM (fun f => ∀ {a}, p₂ a → q (f a)) f) (hx : SatisfiesM p₂ x) :
    SatisfiesM q (f <*> x) :=
  hf.seq hx fun hf ha => hf ha

/--
`SatisfiesM` distributes over `<*>`, weakest precondition version 2.
(Use this when `f` and the goal are known and `x` is a subgoal.)
-/
protected theorem seq_pre' [Applicative m] [LawfulApplicative m] {x : m α}
    (hf : SatisfiesM p₁ f) (hx : SatisfiesM (fun a => ∀ {f}, p₁ f → q (f a)) x) :
    SatisfiesM q (f <*> x) :=
  hf.seq hx fun hf ha => ha hf

/-- `SatisfiesM` distributes over `<*`, general version. -/
protected theorem seqLeft [Applicative m] [LawfulApplicative m] {x : m α}
    (hx : SatisfiesM p₁ x) (hy : SatisfiesM p₂ y)
    (H : ∀ {a b}, p₁ a → p₂ b → q a) : SatisfiesM q (x <* y) :=
  seqLeft_eq x y ▸ (hx.map fun h _ => H h).seq_pre hy

/-- `SatisfiesM` distributes over `*>`, general version. -/
protected theorem seqRight [Applicative m] [LawfulApplicative m] {x : m α}
    (hx : SatisfiesM p₁ x) (hy : SatisfiesM p₂ y)
    (H : ∀ {a b}, p₁ a → p₂ b → q b) : SatisfiesM q (x *> y) :=
  seqRight_eq x y ▸ (hx.map fun h _ => H h).seq_pre hy

/-- `SatisfiesM` distributes over `>>=`, general version. -/
protected theorem bind [Monad m] [LawfulMonad m] {f : α → m β}
    (hx : SatisfiesM p x) (hf : ∀ a, p a → SatisfiesM q (f a)) :
    SatisfiesM q (x >>= f) := by
  match x, hx with | _, ⟨x, rfl⟩ => ?_
  have g a ha := Classical.indefiniteDescription _ (hf a ha)
  refine ⟨x >>= fun ⟨a, h⟩ => g a h, ?_⟩
  simp [← bind_pure_comp]; congr; funext ⟨a, h⟩; simp [← (g a h).2, ← bind_pure_comp]

/-- `SatisfiesM` distributes over `>>=`, weakest precondition version. -/
protected theorem bind_pre [Monad m] [LawfulMonad m] {f : α → m β}
    (hx : SatisfiesM (fun a => SatisfiesM q (f a)) x) :
    SatisfiesM q (x >>= f) := hx.bind fun _ h => h

end SatisfiesM

@[simp] theorem SatisfiesM_Id_eq : SatisfiesM (m := Id) p x ↔ p x :=
  ⟨fun ⟨y, eq⟩ => eq ▸ y.2, fun h => ⟨⟨_, h⟩, rfl⟩⟩

@[simp] theorem SatisfiesM_Option_eq : SatisfiesM (m := Option) p x ↔ ∀ a, x = some a → p a :=
  ⟨by revert x; intro | some _, ⟨some ⟨_, h⟩, rfl⟩, _, rfl => exact h,
   fun h => match x with | some a => ⟨some ⟨a, h _ rfl⟩, rfl⟩ | none => ⟨none, rfl⟩⟩

@[simp] theorem SatisfiesM_Except_eq : SatisfiesM (m := Except ε) p x ↔ ∀ a, x = .ok a → p a :=
  ⟨by revert x; intro | .ok _, ⟨.ok ⟨_, h⟩, rfl⟩, _, rfl => exact h,
   fun h => match x with | .ok a => ⟨.ok ⟨a, h _ rfl⟩, rfl⟩ | .error e => ⟨.error e, rfl⟩⟩

@[simp] theorem SatisfiesM_ReaderT_eq [Monad m] :
    SatisfiesM (m := ReaderT ρ m) p x ↔ ∀ s, SatisfiesM p (x s) :=
  (exists_congr fun a => by exact ⟨fun eq _ => eq ▸ rfl, funext⟩).trans Classical.skolem.symm

theorem SatisfiesM_StateRefT_eq [Monad m] :
    SatisfiesM (m := StateRefT' ω σ m) p x ↔ ∀ s, SatisfiesM p (x s) := by simp

@[simp] theorem SatisfiesM_StateT_eq [Monad m] [LawfulMonad m] :
    SatisfiesM (m := StateT ρ m) (α := α) p x ↔ ∀ s, SatisfiesM (m := m) (p ·.1) (x s) := by
  refine .trans ⟨fun ⟨f, eq⟩ => eq ▸ ?_, fun ⟨f, h⟩ => ?_⟩ Classical.skolem.symm
  · refine ⟨fun s => (fun ⟨⟨a, h⟩, s'⟩ => ⟨⟨a, s'⟩, h⟩) <$> f s, fun s => ?_⟩
    rw [← comp_map, map_eq_pure_bind]; rfl
  · refine ⟨fun s => (fun ⟨⟨a, s'⟩, h⟩ => ⟨⟨a, h⟩, s'⟩) <$> f s, funext fun s => ?_⟩
    show _ >>= _ = _; simp [map_eq_pure_bind, ← h]

@[simp] theorem SatisfiesM_ExceptT_eq [Monad m] [LawfulMonad m] :
    SatisfiesM (m := ExceptT ρ m) (α := α) p x ↔ SatisfiesM (m := m) (∀ a, · = .ok a → p a) x := by
  refine ⟨fun ⟨f, eq⟩ => eq ▸ ?_, fun ⟨f, eq⟩ => eq ▸ ?_⟩
  · exists (fun | .ok ⟨a, h⟩ => ⟨.ok a, fun | _, rfl => h⟩ | .error e => ⟨.error e, fun.⟩) <$> f
    show _ = _ >>= _; rw [← comp_map, map_eq_pure_bind]; congr; funext a; cases a <;> rfl
  · exists ((fun | ⟨.ok a, h⟩ => .ok ⟨a, h _ rfl⟩ | ⟨.error e, _⟩ => .error e) <$> f : m _)
    show _ >>= _ = _; simp [← comp_map, map_eq_pure_bind]; congr; funext ⟨a, h⟩; cases a <;> rfl


import category_theory.path_category
import category_theory.quotient
import category_theory.groupoid
import algebra.group.defs
import algebra.hom.group
import algebra.hom.equiv
import data.set.lattice
import combinatorics.quiver.connected_component
import group_theory.subgroup.basic

/-
path_category == the free category of pats
quotient == quotienting morphisms by relations
algebra.hom.equiv to use ≃*
-/

open set
open classical function
local attribute [instance] prop_decidable

namespace category_theory

universes u v

variables {C : Type u}

instance groupoid.vertex_group [groupoid C] (c : C): group (c ⟶ c) :=
{ mul := λ (x y : c ⟶ c), x ≫ y
, mul_assoc := category.assoc --λ (x y z : c ⟶ c), by simp only [category.assoc]
, one := 𝟙 c
, one_mul := category.id_comp
, mul_one := category.comp_id
, inv := groupoid.inv
, mul_left_inv := groupoid.inv_comp }

@[simp] lemma groupoid.vertex_group.mul_eq_comp [groupoid C] (c : C) (γ δ : c ⟶ c) : γ * δ = γ ≫ δ := rfl
@[simp] lemma groupoid.vertex_group.inv_eq_inv [G : groupoid C] (c : C) (γ : c ⟶ c) : γ ⁻¹ = G.inv γ := rfl

def groupoid.vertex_group_isom_of_map [groupoid C] {c d : C} (f : c ⟶ d) :
  (c ⟶ c) ≃* (d ⟶ d) :=
begin
  refine_struct ⟨λ γ, (groupoid.inv f) ≫ γ ≫ f, λ δ, f ≫ δ ≫ (groupoid.inv f), _, _, _⟩,
  { rintro x,
    simp_rw [category.assoc, groupoid.comp_inv, category.comp_id,←category.assoc, groupoid.comp_inv, category.id_comp], },
  { rintro x,
    simp_rw [category.assoc, groupoid.inv_comp, ←category.assoc, groupoid.inv_comp,category.id_comp, category.comp_id], },
  { rintro x y,
    have : x ≫ y = x ≫ f ≫ (groupoid.inv f) ≫ y, by
    { congr, rw [←category.assoc,groupoid.comp_inv,category.id_comp], },
    simp [this,groupoid.vertex_group.mul_eq_comp,category.assoc], },
end

def groupoid.vertex_group_isom_of_path [groupoid C] (c d : C)  (p : quiver.path c d) : (c ⟶ c) ≃* (d ⟶ d) :=
begin
  induction p,
  { reflexivity },
  { apply p_ih.trans,  apply groupoid.vertex_group_isom_of_map, assumption, }
end

@[simp]
lemma groupoid.inv_inv [G : groupoid C] (c d : C) [p : c ⟶ d] : G.inv (G.inv p) = p :=
  calc G.inv (G.inv p) = (G.inv (G.inv p)) ≫ (𝟙 d) : by rw category.comp_id
                  ... = (G.inv (G.inv p)) ≫ (G.inv p ≫ p) : by rw ←groupoid.inv_comp
                  ... = (G.inv (G.inv p) ≫ G.inv p) ≫ p : by rw ←category.assoc
                  ... = (𝟙 c) ≫ p : by rw groupoid.inv_comp
                  ... = p : by rw category.id_comp

section
open quiver
instance [G : groupoid C] : has_reverse C := ⟨λ a b, G.inv⟩
end

namespace groupoid

section subgroupoid

variable (G : groupoid C)

@[ext]
structure subgroupoid :=
  (arrws : ∀ (c d : C), set (G.hom c d))
  (inv' : ∀ {c d} {p : G.hom c d} (hp : p ∈ arrws c d),
            groupoid.inv p ∈ arrws d c)
  (mul' : ∀ {c d e} {p} (hp : p ∈ arrws c d) {q} (hq : q ∈ arrws d e),
            p ≫ q ∈ arrws c e)

--instance: has_coe_to_fun (subgroupoid G) (λ S, Π (c d : C), set (G.hom c d)) := ⟨λ S, S.arrws⟩

variable {G}

lemma subgroupoid.nonempty_isotropy_to_mem_id (S :subgroupoid G) (c : C) :
  (S.arrws c c).nonempty → 𝟙 c ∈ S.arrws c c :=
begin
  rintro ⟨γ,hγ⟩,
  have : 𝟙 c = γ * (G.inv γ), by simp only [vertex_group.mul_eq_comp, comp_inv],
  rw this, apply S.mul', exact hγ, apply S.inv', exact hγ,
end

def subgroupoid.carrier (S :subgroupoid G) : set C := {c : C | (S.arrws c c).nonempty }

def subgroupoid.as_wide_quiver  (S : subgroupoid G) : quiver C := ⟨λ c d, subtype $ S.arrws c d⟩

def subgroupoid.coe  (S : subgroupoid G) : groupoid (S.carrier) :=
{ to_category :=
  { to_category_struct :=
    { to_quiver :=
      { hom := λ a b, S.arrws a.val b.val }
    , id := λ a, ⟨𝟙 a.val, by {apply subgroupoid.nonempty_isotropy_to_mem_id, use a.prop,}⟩
    , comp := λ a b c p q, ⟨p.val ≫ q.val, S.mul' p.prop q.prop⟩, }
  , id_comp' := λ a b ⟨p,hp⟩, by simp only [category.id_comp]
  , comp_id' := λ a b ⟨p,hp⟩, by simp only [category.comp_id]
  , assoc' := λ a b c d ⟨p,hp⟩ ⟨q,hq⟩ ⟨r,hr⟩, by simp only [category.assoc] }
, inv := λ a b p, ⟨G.inv p.val, S.inv' p.prop⟩
, inv_comp' := λ a b ⟨p,hp⟩, by simp only [inv_comp]
, comp_inv' := λ a b ⟨p,hp⟩, by simp only [comp_inv] }

def subgroupoid.vertex_subgroup (S : subgroupoid G) (c : C) (hc : c ∈ S.carrier) : subgroup (c ⟶ c) :=
⟨ S.arrws c c
, λ f g hf hg, S.mul' hf hg
, by {apply subgroupoid.nonempty_isotropy_to_mem_id, use hc,}
, λ f hf, S.inv' hf⟩

def is_subgroupoid (S T : subgroupoid G) : Prop :=
  ∀ {c d}, S.arrws c d ⊆ T.arrws c d

instance subgroupoid_le : has_le (subgroupoid G) := ⟨is_subgroupoid⟩

def le_refl (S : subgroupoid G) : S ≤ S :=
by {rintro c d p, exact id,}

def le_trans (R S T : subgroupoid G) : R ≤ S → S ≤ T → R ≤ T :=
by {rintro RS ST c d, exact (@RS c d).trans (@ST c d), }

def le_antisymm (R S : subgroupoid G) : R ≤ S → S ≤ R → R = S :=
by {rintro RS SR, ext c d p, exact ⟨(@RS c d p), (@SR c d p)⟩,}

instance : partial_order (subgroupoid G) :=
{ le := is_subgroupoid,
  le_refl := le_refl,
  le_trans := le_trans,
  le_antisymm := le_antisymm}

instance : has_top (subgroupoid G) := ⟨⟨(λ _ _, set.univ), by {rintros,trivial,}, by {rintros, trivial,}⟩⟩
instance : has_bot (subgroupoid G) := ⟨⟨(λ _ _, ∅), by {rintros, simpa using hp,}, by {rintros, simpa using hp,}⟩⟩

instance : has_inf (subgroupoid G) :=
⟨ λ S T,
  ⟨(λ c d, (S.arrws c d)∩(T.arrws c d))
  , by {rintros, exact ⟨S.inv' hp.1,T.inv' hp.2⟩}
  , by {rintros, exact ⟨S.mul' hp.1 hq.1, T.mul' hp.2 hq.2⟩}⟩⟩

instance : has_Inf (subgroupoid G) :=
⟨ λ s,
  ⟨(λ c d, set.Inter (λ (S : s), S.val.arrws c d))
  , by {rintros, rw set.mem_Inter, rintro S, apply S.val.inv', apply hp, simp, use [S.val, S.prop], refl,}
  , by {rintros, rw set.mem_Inter, rintro S, apply S.val.mul', apply hp, use [S.val,S.prop], apply hq, use [S.val,S.prop],}⟩⟩

instance : complete_lattice (subgroupoid G) :=
{ bot          := (⊥),
  bot_le       := λ S c d, by {apply empty_subset,},
  top          := (⊤),
  le_top       := λ S c d, by {apply subset_univ,},
  inf          := (⊓),
  le_inf       := λ R S T RS RT c d p pR, ⟨RS pR, RT pR⟩,
  inf_le_left  := λ R S c d p pRS, pRS.left,
  inf_le_right := λ R S c d p pRS, pRS.right,
  .. complete_lattice_of_Inf (subgroupoid G)
       ( by
        { dsimp only [Inf], rintro s, constructor,
          { rintro S Ss c d p hp,
            simp only [Inter_coe_set, mem_Inter] at hp,
            exact hp S Ss, },
          { rintro T Tl c d p pT,
            simp only [Inter_coe_set, mem_Inter],
            rintros S Ss, apply Tl, exact Ss, exact pT,}}) }

def discrete [decidable_eq C] : subgroupoid G :=
⟨ λ c d, if h : c = d then {h.rec_on (G.id c)} else ∅
, by
  { rintros c d p hp,
    by_cases h : d = c,
    { subst_vars,
      simp only [eq_self_iff_true, congr_arg_mpr_hom_right, eq_to_hom_refl, category.comp_id, dite_eq_ite, if_true, mem_singleton_iff] at hp ⊢,
      rw hp, apply inv_one, },
    { rw dif_neg (λ l : c = d, h l.symm) at hp, exact hp.elim, }, }
, by
  { rintros c d e p hp q hq,
    by_cases h : d = c,
    { by_cases k : e = d; subst_vars,
      { simp only [eq_self_iff_true, dite_eq_ite, if_true, mem_singleton_iff] at ⊢ hp hq,
        rw [hp, hq], simp only [category.comp_id], },
      { simp only [eq_self_iff_true, dite_eq_ite, if_true, mem_singleton_iff] at ⊢ hp hq,
        rw dif_neg (λ l : d = e, k l.symm) at hq, exact hq.elim, }, },
    { rw dif_neg (λ l : c = d, h l.symm) at hp, exact hp.elim, }
  }⟩

structure is_normal (S : subgroupoid G) : Prop :=
  (wide : ∀ c, (𝟙 c) ∈ (S.arrws c c))  -- S is "wide": all vertices of G are covered
  (conj_mem : ∀ {c d} (p : c ⟶ d) (γ : c ⟶ c) (hs : γ ∈ S.arrws c c), ((G.inv p) ≫ γ ≫ p) ∈ (S.arrws d d))

def is_normal.conjugation_eq (S : subgroupoid G) (Sn : is_normal S) {c d} (p : c ⟶ d) :
  set.bij_on (λ γ : c ⟶ c, (G.inv p) ≫ γ ≫ p) (S.arrws c c) (S.arrws d d) :=
begin
  split,
  { rintro γ γS, apply Sn.conj_mem, exact γS },
  split,
  { rintro γ₁ γ₁S γ₂ γ₂S h,
    simp only at h,
    let h' := p ≫=(h =≫ (G.inv p)),--category_theory.eq_whisker h (G.inv p),
    simp only [category.assoc, comp_inv, category.comp_id] at h',
    simp only [←category.assoc, comp_inv, category.id_comp] at h', exact h', }, -- what's the quickest way here?
  { rintro δ δS, use (p ≫ δ ≫ (G.inv p)), split,
    { have : p = G.inv (G.inv p), by {simp only [inv_inv],},
      nth_rewrite 0 this,
      apply Sn.conj_mem, exact δS, },
    { simp only [category.assoc, inv_comp, category.comp_id],
      simp only [←category.assoc, inv_comp, category.id_comp], }}
end

lemma top_is_normal : is_normal (⊤ : subgroupoid G) :=
begin
  split,
  { rintro c, trivial },
  { rintro c d p γ hγ, trivial,}
end

lemma Inf_is_normal (s : set $ subgroupoid G) (sn : ∀ S ∈ s, is_normal S) : is_normal (Inf s) :=
begin
  split,
  { rintro c, dsimp only [Inf], rintro _ ⟨⟨S,Ss⟩,rfl⟩, exact (sn S Ss).wide c,},
  { rintros c d p γ hγ, dsimp only [Inf], rintro _ ⟨⟨S,Ss⟩,rfl⟩, apply (sn S Ss).conj_mem p γ, apply hγ, use ⟨S,Ss⟩,}
end

lemma is_normal_vertex_subgroup (S : subgroupoid G) (Sn : is_normal S) (c : C) (cS : c ∈ S.carrier) : (S.vertex_subgroup c cS).normal :=
begin
  constructor,
  rintros x hx y,
  simp only [vertex_group.mul_eq_comp, vertex_group.inv_eq_inv, category.assoc],
  have : y = G.inv (G.inv y), by {simp only [inv_inv],},
  nth_rewrite 0 this,
  apply Sn.conj_mem, exact hx,
end

/- Following Higgins -/
structure is_strict_normal (S : subgroupoid G) extends is_normal S : Prop :=
(discrete : ∀ (c d : C), c ≠ d →  (S.arrws c d) = ∅)

variable (X : ∀ c d : C, set (G.hom c d))

-- Following Higgins, more or less
def generated : subgroupoid G := Inf { S : subgroupoid G | ∀ (c d : C), X c d ⊆ S.arrws c d }

def set_as_quiver (X : ∀ c d : C, set (G.hom c d)) : quiver C := ⟨λ (c d : C), subtype $ X c d⟩

-- better this way?
def word'  (X : ∀ c d : C, set (G.hom c d)) : C → C → Sort* :=
@quiver.path _ (@quiver.symmetrify_quiver C (set_as_quiver X))

def word'.val (X : ∀ c d : C, set (G.hom c d)) {c d : C} (w : word' X c d) : c ⟶ d :=
begin
  induction w with a b u y z,
  { exact 𝟙 c, },
  { cases y,
    { exact z ≫ y.val,},
    { exact z ≫ (G.inv y.val), }, },
end

--def word'.append : Π {c d e : C}, word' X c d → word' X d e → word' X c e := λ c d e u w, u.comp w
#print quiver.path.cons
def path.in : Π {c d : C} (p : quiver.path c d) (X : ∀ c d : C, set (G.hom c d)), Prop :=
begin
  rintro c d p X,
  induction p with one two three four,
  { exact true },
  { exact p_ih ∧ four ∈ X one two },
end

inductive word  (X : ∀ c d : C, set (G.hom c d)) : C → C → Sort*
| nil {c : C} : word c c
| cons_p {c d e : C} (p : X c d) (w : word d e) : word c e
| cons_n {c d e : C} (p : X d c) (w : word d e) : word c e

variable {X}

def word.val  : Π {c d : C}, word X c d → G.hom c d
| c .(c) (word.nil ) := (𝟙 c)
| _ _ (word.cons_p p w) := p.val ≫ w.val
| _ _ (word.cons_n p w) := (G.inv p.val) ≫ w.val

def word.letter {c d : C} (p : X c d) : word X c d := (word.cons_p p word.nil)

@[pattern]
def word.letter_p {c d : C} (p : X c d) : word X c d := word.letter p
@[pattern]
def word.letter_n {c d : C} (p : X c d) : word X d c := (word.cons_n p word.nil)

def word.append  : Π {c d e : C}, word X c d → word X d e → word X c e
| _ _ _ (word.nil) w := w
| _ _ _ (word.cons_p p u) w := word.cons_p p (u.append w)
| _ _ _ (word.cons_n p u) w := word.cons_n p (u.append w)

def word.reverse : Π {c d : C}, word X c d → word X d c
| _ _ (word.nil) := word.nil
| _ _ (word.cons_p p u) := (u.reverse.append (word.letter_n p))
| _ _ (word.cons_n p u) := (u.reverse.append (word.letter_p p))

def word.nonempty  : Π {c d : C}, word X c d → Prop
| _ _ (word.nil) := false
| _ _ _ := true

lemma word.nonempty_reverse  {c d : C} (p : word X c d) : p.nonempty → p.reverse.nonempty := sorry
lemma word.nonempty_append  {c d e : C} (p : word X c d) (q : word X d e) :
  p.nonempty ∨ q.nonempty → (p.append q).nonempty := sorry

lemma word.letter_p_val {c d : C} (p : X c d) : (word.letter_p p).val = p.val :=
begin
  dsimp [word.letter_p,word.letter,word.val],
  simp only [category.comp_id],
end

lemma word.letter_n_val {c d : C} (p : X c d) : (word.letter_n p).val = G.inv p.val :=
begin
  dsimp [word.letter_n,word.val],
  simp only [category.comp_id],
end

lemma word.nonempty_letter_p {c d : C} (p : X c d) : (word.letter_p p).nonempty := trivial
lemma word.nonempty_letter_n {c d : C} (p : X c d) : (word.letter_n p).nonempty := trivial

lemma word.append_val {c d e : C} (u : word X c d) (w : word X d e) :
  (u.append w).val = u.val ≫ w.val := sorry

lemma word.reverse_val {c d : C} (u : word X c d) :
  (u.reverse).val = G.inv u.val := sorry

variable (X)
include X
def generated' : subgroupoid G :=
begin
  fsplit,
  {rintros c d, apply set.image (λ (p : word X c d), p.val ) {p : word X c d | p.nonempty},},
  {rintros c d _ ⟨u,un,rfl⟩, simp, use u.reverse, split, apply word.nonempty_reverse, apply un, apply word.reverse_val, },
  {rintros c d e _ ⟨u,un,rfl⟩ _ ⟨w,wn,rfl⟩, simp, use u.append w, split, apply word.nonempty_append, use or.inl un, apply word.append_val, },
end

lemma generated'_contains : ∀ (c d : C), X c d ⊆ (generated' X).arrws c d :=
begin
  rintros c d p pX,
  dsimp only [generated'],
  simp only [mem_image],
  let w : word X c d := word.letter_p ⟨p,pX⟩,
  use w, split, simp, exact word.letter_p_val ⟨p,pX⟩,
end

lemma contains_generated'  (S : subgroupoid G) (hS : ∀ (c d : C), X c d ⊆ S.arrws c d) :
  Π {c d : C} (p : word X c d) (pn : p.nonempty), p.val ∈ S.arrws c d
| _ _ (word.letter_p p) _ := by {rw word.letter_p_val,apply hS, exact p.prop,}
| _ _ (word.letter_n p) _ := by {rw word.letter_n_val,apply S.inv',apply hS, exact p.prop,}
| _ _ (word.cons_p p (word.cons_p q u)) _ := by
{ apply S.mul',
  { apply hS, exact p.prop, },
  { apply contains_generated', trivial,} }
| _ _ (word.cons_p p (word.cons_n q u)) _ := by
{ apply S.mul',
  { apply hS, exact p.prop, },
  { apply contains_generated', trivial,} }
| _ _ (word.cons_n p (word.cons_p q u)) _ := by
{ apply S.mul',
  { apply S.inv', apply hS, exact p.prop, },
  { apply contains_generated', trivial,} }
| _ _ (word.cons_n p (word.cons_n q u)) _ := by
{ apply S.mul',
  { apply S.inv', apply hS, exact p.prop, },
  { apply contains_generated', trivial,} }

lemma generated_eq' : generated X = generated' X :=
begin
  apply le_antisymm,
  { have : ∀ (c d : C), X c d ⊆ (generated' X).arrws c d := generated'_contains X,
    exact @Inf_le _ _ { S : subgroupoid G | ∀ (c d : C), X c d ⊆ S.arrws c d } (generated' X) this,},
  { have : ∀ S : subgroupoid G, S ∈ { S : subgroupoid G | ∀ (c d : C), X c d ⊆ S.arrws c d} → (generated' X) ≤ S, by
    { rintro S hS, rintro c d _ ⟨w,h,rfl⟩, simp only, apply contains_generated' X S hS w h,},
    apply @le_Inf _ _ { S : subgroupoid G | ∀ (c d : C), X c d ⊆ S.arrws c d } (generated' X) this, }
end

def generated_on [decidable_eq C] (D : set C) : subgroupoid G := generated (λ c d, (X c d) ∪ (if h : c = d then by { rw h, exact {𝟙 d} } else ∅))

end subgroupoid

section strict_hom
/--
Higgins has his own version of normality and morphisms,
where normality has a condition that all arrows between distinct vertices disappear,
but I'm not sure this is the right way to look at it.
We'll do it here, and try for a more general approach afterwards (where we don't have this added condition on normal subgroupoids, _and_ morphisms can play with vertices)
-/

variables {C} (G H : groupoid C)

/- Following “Presentations of groupoids” by Higgins, p. 9, we call `strict_hom` the functors on underlying category being the identity on objects -/
structure strict_hom :=
( f   : Π {c d : C}, G.hom c d → H.hom c d)
( one : Π (c : C), f (𝟙 c) = 𝟙 c )
( mul : Π {c d e : C} (p : G.hom c d) (q : G.hom d e), f (p ≫ q) = (f p) ≫ (f q ))
( inv : Π {c d : C} (p : G.hom c d), f (G.inv p) = (H.inv $ f p) )

infixr ` →** `:25 := strict_hom

def strict_im (φ : G →** H) : subgroupoid H :=
⟨ λ c d, {p : H.hom c d | ∃ q : G.hom c d, p = φ.f q}
, by {rintros c d _ ⟨q,rfl⟩, rw ← φ.inv, simp only [mem_set_of_eq, exists_apply_eq_apply'],}
, by {rintros c d e _ ⟨p,rfl⟩ _ ⟨q,rfl⟩, rw ← φ.mul, simp only [mem_set_of_eq, exists_apply_eq_apply'],}⟩

variables {G H}

def strict_ker [decidable_eq C] (φ : G →** H) : subgroupoid G :=
⟨ λ c d, if h : c = d then eq.rec_on h {f : c ⟶ c | φ.f f = 𝟙 c} else ∅
, by
  { rintros c d p hp,
    by_cases h : d = c,
    { subst_vars, rw dif_pos (eq.refl d) at hp ⊢, simp only [mem_set_of_eq] at hp ⊢, rw φ.inv, rw hp, exact inv_one, },
    { rw dif_neg (λ l : c = d, h l.symm) at hp, finish, }}
, by
  { rintros c d e p hp q hq,
    by_cases h : d = c,
    { by_cases k : e = d,
      { subst_vars, rw dif_pos (eq.refl e) at hp hq ⊢, simp only [mem_set_of_eq] at hp hq ⊢, rw φ.mul, rw [hp,hq], exact mul_one (𝟙 e),},
      { subst_vars, rw dif_neg (λ l : d = e, k l.symm) at hq, finish,} },
    { rw dif_neg (λ l : c = d, h l.symm) at hp, finish, }}
⟩

--lemma normal_iff [decidable_eq C] (S : subgroupoid G) : is_strict_normal G S ↔ ∃ (H : groupoid C) (φ : G →** H), S = strict_ker φ := sorry

end strict_hom

section hom

variables (C) (D : Type*)
variables [G : groupoid C] [H : groupoid D]
variable [decidable_eq D]

def hom := @category_theory.functor C G.to_category D H.to_category
local infix `⥤i`:50 := hom

@[simp]
lemma functor.map_inv (φ : C ⥤i D) {c d : C} (f : c ⟶ d) :
  φ.map (G.inv f) = H.inv (φ.map f) :=
calc φ.map (G.inv f) = (φ.map $ G.inv f) ≫ (𝟙 $ φ.obj c) : by rw [category.comp_id]
                 ... = (φ.map $ G.inv f) ≫ ((φ.map f) ≫ (H.inv $ φ.map f)) : by rw [comp_inv]
                 ... = ((φ.map $ G.inv f) ≫ (φ.map f)) ≫ (H.inv $ φ.map f) : by rw [category.assoc]
                 ... = (φ.map $ G.inv f ≫ f) ≫ (H.inv $ φ.map f) : by rw [functor.map_comp']
                 ... = (H.inv $ φ.map f) : by rw [inv_comp,functor.map_id,category.id_comp]

def subgroupoid.map (φ : C ⥤i D) (φi : function.injective φ.obj) (S : subgroupoid G) : subgroupoid H :=
begin
  classical,
  fsplit,
  { rintros c d,
    by_cases h : (∃ a, φ.obj a = c) ∧ (∃ b, φ.obj b = d),
    { let a := h.left.some,
      let ac := h.left.some_spec,
      let b := h.right.some,
      let bd := h.right.some_spec,
      let := set.range (φ.map : (a ⟶ b) → ((φ.obj a) ⟶ (φ.obj b))),
      rw [ac,bd] at this, exact this, },
    { exact ∅, }, },
  { rintro c d p hp,
    by_cases h : (∃ a, φ.obj a = c) ∧ (∃ b, φ.obj b = d),
    { simp only at hp,
      rw dif_pos h at hp,
      simp only [eq_mp_eq_cast, cast_cast] at hp,
      simp only [eq_mp_eq_cast, cast_cast],
      rw dif_pos (and.intro h.right h.left),
      sorry, },
    { simp only at hp, rw dif_neg h at hp, exact hp.elim,},},
  { sorry, }
end

def subgroupoid.comap {C D : Type*} [G : groupoid C] [H : groupoid D] (φ : C ⥤i D) (S : subgroupoid H) : subgroupoid G :=
⟨ λ c d, {f : c ⟶ d | φ.map f ∈ S.arrws (φ.obj c) (φ.obj d)}
, by
  { rintros, simp only [mem_set_of_eq], rw functor.map_inv, apply S.inv', assumption, }
, by
  { rintros, simp only [mem_set_of_eq, functor.map_comp], apply S.mul'; assumption, }⟩

lemma subgroupoid.comap_mono {C D : Type*} [G : groupoid C] [H : groupoid D] (φ : C ⥤i D) (S T : subgroupoid H) :
  S ≤ T → subgroupoid.comap φ S ≤ subgroupoid.comap φ T :=
begin
  rintro ST,
  dsimp only [subgroupoid.comap],
  rintro c d p hp,
  exact ST hp,
end

lemma is_normal.preimage [G: groupoid C] (φ : C ⥤i D) {S : subgroupoid H} (Sn : is_normal S) : is_normal (subgroupoid.comap φ S) :=
begin
  dsimp only [subgroupoid.comap],
  split,
  { rintro c, simp only [mem_set_of_eq, functor.map_id], apply Sn.wide, },
  { rintros c d f γ hγ, simp only [mem_set_of_eq, functor.map_comp, functor.map_inv], apply Sn.conj_mem, exact hγ, },
end

def ker [G : groupoid C] [H : groupoid D] (φ : C ⥤i D) : subgroupoid G := subgroupoid.comap φ (discrete)

def mem_ker_iff  [G : groupoid C] [H : groupoid D] (φ : C ⥤i D) {c d : C} (f : c ⟶ d) :
  f ∈ (ker C D φ).arrws c d ↔ ∃ (h : φ.obj c = φ.obj d), φ.map f = h.rec_on (𝟙 $ φ.obj c) :=
begin
  dsimp only [ker, discrete,subgroupoid.comap],
  by_cases h : φ.obj c = φ.obj d,
  { simp only [dif_pos h, mem_singleton_iff, mem_set_of_eq],
    split,
    { rintro e, use h, exact e, },
    { rintro ⟨_,e⟩, exact e, }},
  { simp only [dif_neg h, mem_empty_eq, set_of_false, false_iff, not_exists],
    rintro e, exact (h e).elim, },
end

end hom

section quotient

def quot_v [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) :=
  (quot (λ (c d : C), (S.arrws c d).nonempty))

def quot_v.mk [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) (c : C) : quot_v S Sn:=
  (quot.mk (λ (c d : C), (S.arrws c d).nonempty) c)

def conj  [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) :
  (Σ (a b : C), a ⟶ b) → (Σ (a b : C), a ⟶ b) → Prop :=
begin
  rintros ⟨a,b,f⟩ ⟨c,d,g⟩,
  exact ∃ (α ∈ S.arrws a c) (β ∈ S.arrws d b), f = α ≫ g ≫ β
end

@[refl]
lemma conj.refl [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : ∀ F, conj S Sn F F :=
begin
  rintro ⟨a,b,f⟩,
  use [(𝟙 a), Sn.wide a, (𝟙 b), Sn.wide b],
  simp only [category.comp_id, category.id_comp],
end

@[symm]
lemma conj.symm [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : ∀ F G, conj S Sn F G → conj S Sn G F :=
begin
  rintros ⟨a,b,f⟩ ⟨c,d,g⟩ ⟨α,hα,β,hβ,rfl⟩,
  use [G.inv α, S.inv' hα, G.inv β, S.inv' hβ],
  simp only [category.assoc, comp_inv, category.comp_id],
  rw ←category.assoc,
  simp only [inv_comp, category.id_comp],
end

@[trans]
lemma conj.trans [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) :
  ∀ F G H, conj S Sn F G → conj S Sn G H → conj S Sn F H :=
begin
  rintros ⟨a₀,b₀,f₀⟩ ⟨a₁,b₁,f₁⟩ ⟨a₂,b₂,f₂⟩ ⟨α₀,hα₀,β₀,hβ₀,rfl⟩  ⟨α₁,hα₁,β₁,hβ₁,rfl⟩,
  use [α₀ ≫ α₁, S.mul' hα₀ hα₁, β₁ ≫ β₀, S.mul' hβ₁ hβ₀],
  simp only [category.assoc],
end

def quot_start [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : (quot $ conj S Sn) → (quot_v S Sn) :=
begin
  refine quot.lift _ _,
  { rintro ⟨a,b,f⟩, apply quot_v.mk, exact a,},
  { rintro ⟨a₀,b₀,f₀⟩ ⟨a₁,b₁,f₁⟩ ⟨α,hα,β,hβ,rfl⟩,simp,dsimp [quot_v.mk], apply quot.sound, exact ⟨α,hα⟩,}
end

def quot_end [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : (quot $ conj S Sn) → (quot_v S Sn) :=
begin
  refine quot.lift _ _,
  { rintro ⟨a,b,f⟩, apply quot_v.mk, exact b,},
  { rintro ⟨a₀,b₀,f₀⟩ ⟨a₁,b₁,f₁⟩ ⟨α,hα,β,hβ,rfl⟩,simp,dsimp [quot_v.mk], apply quot.sound, exact ⟨G.inv β,S.inv' hβ⟩,}
end

@[instance]
def quotient_quiver [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) :
  quiver (quot_v S Sn) := ⟨λc d, { F | quot_start S Sn F = c ∧ quot_end S Sn F = d }⟩

def quot_id'  [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : Π (c : quot_v S Sn),  (quot $ conj S Sn) :=
begin
  apply quot.lift, rotate,
  { rintro c,
    exact quot.mk (conj S Sn) ⟨c,c,𝟙 c⟩ },
  { rintros c d ⟨f,fS⟩,
    apply quot.sound,
    use [f,fS,G.inv f, S.inv' fS],
    simp only [category.id_comp, comp_inv], }
end

def quotient_id  [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : Π (c : quot_v S Sn),  c ⟶ c :=
λ c, ⟨ quot_id' S Sn c, by {dsimp only [quot_id',quot_start,quot_end,quot_v.mk], induction c, simp, simp,}⟩

def quot_id''  [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) : Π (c : quot_v S Sn),  c ⟶ c :=
begin
  refine λ c, c.rec_on _ _,
  { rintro c, dsimp only [quotient_quiver,quot_start,quot_end,quot_v.mk],
    use quot.mk (conj S Sn) ⟨c,c,𝟙 c⟩, split, simp only, simp only, },
  { rintros c d ⟨f,fS⟩,
    simp,
    have : quot.mk (λ (c d : C), (S.arrws c d).nonempty) c
         = quot.mk (λ (c d : C), (S.arrws c d).nonempty) d, by
    { apply quot.sound, constructor, use fS, },

    sorry, },
end

def quotient [G : groupoid C] (S : subgroupoid G) (Sn : is_normal S) :
  groupoid (quot (λ (c d : C), (S.arrws c d).nonempty)) :=
{ to_category :=
  { to_category_struct :=
    { to_quiver := quotient_quiver S Sn
    , id := quotient_id S Sn
    , comp := sorry }
  , id_comp' := sorry
  , comp_id' := sorry
  , assoc' := sorry }
, inv := sorry
, inv_comp' := sorry
, comp_inv' := sorry }

end quotient

end groupoid
end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.thin
import Mathlib.PostPort

universes v l u

namespace Mathlib

/-!
# Wide pullbacks

We define the category `wide_pullback_shape`, (resp. `wide_pushout_shape`) which is the category
obtained from a discrete category of type `J` by adjoining a terminal (resp. initial) element.
Limits of this shape are wide pullbacks (pushouts).
The convenience method `wide_cospan` (`wide_span`) constructs a functor from this category, hitting
the given morphisms.

We use `wide_pullback_shape` to define ordinary pullbacks (pushouts) by using `J := walking_pair`,
which allows easy proofs of some related lemmas.
Furthermore, wide pullbacks are used to show the existence of limits in the slice category.
Namely, if `C` has wide pullbacks then `C/B` has limits for any object `B` in `C`.

Typeclasses `has_wide_pullbacks` and `has_finite_wide_pullbacks` assert the existence of wide
pullbacks and finite wide pullbacks.
-/

namespace category_theory.limits

/-- A wide pullback shape for any type `J` can be written simply as `option J`. -/
def wide_pullback_shape (J : Type v) :=
  Option J

/-- A wide pushout shape for any type `J` can be written simply as `option J`. -/
def wide_pushout_shape (J : Type v) :=
  Option J

namespace wide_pullback_shape

/-- The type of arrows for the shape indexing a wide pullback. -/
inductive hom {J : Type v} : wide_pullback_shape J → wide_pullback_shape J → Type v
where
| id : (X : wide_pullback_shape J) → hom X X
| term : (j : J) → hom (some j) none

protected instance struct {J : Type v} : category_struct (wide_pullback_shape J) := sorry

protected instance hom.inhabited {J : Type v} : Inhabited (hom none none) :=
  { default := hom.id none }

protected instance subsingleton_hom {J : Type v} (j : wide_pullback_shape J) (j' : wide_pullback_shape J) : subsingleton (j ⟶ j') := sorry

protected instance category {J : Type v} : small_category (wide_pullback_shape J) :=
  thin_category

@[simp] theorem hom_id {J : Type v} (X : wide_pullback_shape J) : hom.id X = 𝟙 :=
  rfl

/--
Construct a functor out of the wide pullback shape given a J-indexed collection of arrows to a
fixed object.
-/
@[simp] theorem wide_cospan_map {J : Type v} {C : Type u} [category C] (B : C) (objs : J → C) (arrows : (j : J) → objs j ⟶ B) (X : wide_pullback_shape J) (Y : wide_pullback_shape J) (f : X ⟶ Y) : functor.map (wide_cospan B objs arrows) f =
  hom.cases_on f
    (fun (f_1 : wide_pullback_shape J) (H_1 : X = f_1) =>
      Eq._oldrec
        (fun (H_2 : Y = X) =>
          Eq._oldrec (fun (f : X ⟶ X) (H_3 : f == hom.id X) => Eq._oldrec 𝟙 (wide_cospan._proof_1 X f H_3))
            (wide_cospan._proof_2 X Y H_2) f)
        H_1)
    (fun (j : J) (H_1 : X = some j) =>
      Eq._oldrec
        (fun (f : some j ⟶ Y) (H_2 : Y = none) =>
          Eq._oldrec
            (fun (f : some j ⟶ none) (H_3 : f == hom.term j) => Eq._oldrec (arrows j) (wide_cospan._proof_3 j f H_3))
            (wide_cospan._proof_4 Y H_2) f)
        (wide_cospan._proof_5 X j H_1) f)
    (wide_cospan._proof_6 X) (wide_cospan._proof_7 Y) (wide_cospan._proof_8 X Y f) :=
  Eq.refl (functor.map (wide_cospan B objs arrows) f)

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_cospan` -/
def diagram_iso_wide_cospan {J : Type v} {C : Type u} [category C] (F : wide_pullback_shape J ⥤ C) : F ≅ wide_cospan (functor.obj F none) (fun (j : J) => functor.obj F (some j)) fun (j : J) => functor.map F (hom.term j) :=
  nat_iso.of_components (fun (j : wide_pullback_shape J) => eq_to_iso sorry) sorry

end wide_pullback_shape

namespace wide_pushout_shape

/-- The type of arrows for the shape indexing a wide psuhout. -/
inductive hom {J : Type v} : wide_pushout_shape J → wide_pushout_shape J → Type v
where
| id : (X : wide_pushout_shape J) → hom X X
| init : (j : J) → hom none (some j)

protected instance struct {J : Type v} : category_struct (wide_pushout_shape J) := sorry

protected instance hom.inhabited {J : Type v} : Inhabited (hom none none) :=
  { default := hom.id none }

protected instance subsingleton_hom {J : Type v} (j : wide_pushout_shape J) (j' : wide_pushout_shape J) : subsingleton (j ⟶ j') := sorry

protected instance category {J : Type v} : small_category (wide_pushout_shape J) :=
  thin_category

@[simp] theorem hom_id {J : Type v} (X : wide_pushout_shape J) : hom.id X = 𝟙 :=
  rfl

/--
Construct a functor out of the wide pushout shape given a J-indexed collection of arrows from a
fixed object.
-/
@[simp] theorem wide_span_map {J : Type v} {C : Type u} [category C] (B : C) (objs : J → C) (arrows : (j : J) → B ⟶ objs j) (X : wide_pushout_shape J) (Y : wide_pushout_shape J) (f : X ⟶ Y) : functor.map (wide_span B objs arrows) f =
  hom.cases_on f
    (fun (f_1 : wide_pushout_shape J) (H_1 : X = f_1) =>
      Eq._oldrec
        (fun (H_2 : Y = X) =>
          Eq._oldrec (fun (f : X ⟶ X) (H_3 : f == hom.id X) => Eq._oldrec 𝟙 (wide_span._proof_1 X f H_3))
            (wide_span._proof_2 X Y H_2) f)
        H_1)
    (fun (j : J) (H_1 : X = none) =>
      Eq._oldrec
        (fun (f : none ⟶ Y) (H_2 : Y = some j) =>
          Eq._oldrec
            (fun (f : none ⟶ some j) (H_3 : f == hom.init j) => Eq._oldrec (arrows j) (wide_span._proof_3 j f H_3))
            (wide_span._proof_4 Y j H_2) f)
        (wide_span._proof_5 X H_1) f)
    (wide_span._proof_6 X) (wide_span._proof_7 Y) (wide_span._proof_8 X Y f) :=
  Eq.refl (functor.map (wide_span B objs arrows) f)

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_span` -/
def diagram_iso_wide_span {J : Type v} {C : Type u} [category C] (F : wide_pushout_shape J ⥤ C) : F ≅ wide_span (functor.obj F none) (fun (j : J) => functor.obj F (some j)) fun (j : J) => functor.map F (hom.init j) :=
  nat_iso.of_components (fun (j : wide_pushout_shape J) => eq_to_iso sorry) sorry

end wide_pushout_shape

/-- `has_wide_pullbacks` represents a choice of wide pullback for every collection of morphisms -/
def has_wide_pullbacks (C : Type u) [category C] :=
  ∀ (J : Type v), has_limits_of_shape (wide_pullback_shape J) C

/-- `has_wide_pushouts` represents a choice of wide pushout for every collection of morphisms -/
def has_wide_pushouts (C : Type u) [category C] :=
  ∀ (J : Type v), has_colimits_of_shape (wide_pushout_shape J) C


import topology.paracompact
import data.real.basic
import data.nat.interval

import to_mathlib.data.set.basic
import to_mathlib.data.set.finite

open_locale topology
open set function

/-- We could generalise and replace `ι × ℝ` with a dependent family of types but it doesn't seem
worth it. Proof partly based on `refinement_of_locally_compact_sigma_compact_of_nhds_basis_set`. -/
lemma exists_countable_locally_finite_cover
  {ι X : Type*} [topological_space X] [t2_space X] [locally_compact_space X] [sigma_compact_space X]
  {c : ι → X} {W : ι → ℝ → set X} {B : ι → ℝ → set X} {p : ι → ℝ → Prop}
  (hc : surjective c)
  (hW₀ : ∀ i r, p i r → c i ∈ W i r)
  (hW₁ : ∀ i r, p i r → is_open (W i r))
  (hB : ∀ i, (𝓝 (c i)).has_basis (p i) (B i)) :
  ∃ (s : set (ι × ℝ)),
    s.countable ∧
    (∀ z ∈ s, ↿p z) ∧
    (⋃ z ∈ s, ↿W z) = univ ∧
    locally_finite (↿B ∘ (coe : s → ι × ℝ)) :=
begin
  let K' := compact_exhaustion.choice X,
  let K := K'.shiftr.shiftr,
  let C : ℕ → set X := λ n, K (n + 2) \ interior (K (n + 1)),
  let U : ℕ → set X := λ n, interior (K (n + 3)) \ K n,
  have hCU : ∀ n, C n ⊆ U n := λ n x hx,
    ⟨K.subset_interior_succ _ hx.1, mt (λ hx₃, K.subset_interior_succ _ hx₃) hx.2⟩,
  have hC : ∀ n, is_compact (C n) := λ n, (K.is_compact _).diff is_open_interior,
  have hC' : (⋃ n, C n) = univ,
  { refine set.univ_subset_iff.mp (λ x hx, mem_Union.mpr ⟨K'.find x, _⟩),
    simpa only [K'.find_shiftr]
      using diff_subset_diff_right interior_subset (K'.shiftr.mem_diff_shiftr_find x), },
  have hU : ∀ n, is_open (U n) := λ n,
    is_open_interior.sdiff $ is_compact.is_closed $ K.is_compact _,
  have hU' : ∀ n, { m | (U m ∩ U n).nonempty }.finite := λ n, by
  { suffices : {m | (U m ∩ U n).nonempty} ⊆ Icc (n-2) (n+2), { exact (finite_Icc _ _).subset this },
    rintros m ⟨x, ⟨⟨hx₁, hx₂⟩, ⟨hx₃, hx₄⟩⟩⟩,
    simp only [mem_Icc, tsub_le_iff_right],
    suffices : ∀ {a b : ℕ}, x ∉ K a → x ∈ interior (K b.succ) → a ≤ b,
    { exact ⟨this hx₄ hx₁, this hx₂ hx₃⟩, },
    intros a b ha hb,
    by_contra hab,
    replace hab : b + 1 ≤ a, { simpa using hab, },
    exact set.nonempty.ne_empty (⟨x, interior_subset hb, ha⟩ : (K b.succ \ K a).nonempty)
        (set.diff_eq_empty.mpr (K.subset hab)), },
  have hU'' : ∀ n x, x ∈ C n → U n ∈ 𝓝 x := λ n x hx,
    mem_nhds_iff.mpr ⟨U n, subset.rfl, hU n, hCU n hx⟩,
  have : ∀ n (x : C n), ∃ i r, ↑x ∈ W i r ∧ B i r ⊆ U n ∧ p i r,
  { rintros n ⟨x, hx⟩,
    obtain ⟨i, rfl⟩ := hc x,
    obtain ⟨r, hr₁, hr₂⟩ := (hB i).mem_iff.mp (hU'' n _ hx),
    exact ⟨i, r, hW₀ i r hr₁, hr₂, hr₁⟩, },
  choose i r h₁ h₂ h₃ using λ n, this n,
  let V : Π n, C n → set X := λ n x, W (i n x) (r n x),
  have hV₁ : ∀ n x, is_open (V n x) := λ n x, hW₁ _ _ (h₃ n x),
  have hV₂ : ∀ n, C n ⊆ ⋃ (x : C n), V n x := λ n x hx, mem_Union.mpr ⟨⟨x, hx⟩, h₁ _ _⟩,
  choose f hf using λ n, (hC n).elim_finite_subcover (V n) (hV₁ n) (hV₂ n),
  classical,
  let s : set (ι × ℝ) := ⋃ n, (f n).image (pi.prod (i n) (r n)),
  refine ⟨s, countable_Union (λ n, finset.countable_to_set _), λ z hz, _,
    set.univ_subset_iff.mp (λ x hx, _), λ x, _⟩,
  { simp only [pi.prod, mem_Union, finset.coe_image, mem_image, finset.mem_coe, set_coe.exists]
      at hz,
    obtain ⟨n, x, hx, -, rfl⟩ := hz,
    apply h₃, },
  { obtain ⟨n, hn⟩ := Union_eq_univ_iff.mp hC' x,
    specialize hf n hn,
    simp only [Union_coe_set, mem_Union, exists_prop] at hf,
    obtain ⟨y, hy₁, hy₂, hy₃⟩ := hf,
    simp only [pi.prod, mem_Union, finset.mem_coe, finset.mem_image, exists_prop, set_coe.exists,
      Union_exists, exists_and_distrib_right, prod.exists, prod.mk.inj_iff],
    exact ⟨i n ⟨y, hy₁⟩, r n ⟨y, hy₁⟩, ⟨n, y, hy₁, hy₂, rfl, rfl⟩, hy₃⟩, },
  { obtain ⟨n, hn⟩ := Union_eq_univ_iff.mp hC' x,
    refine ⟨U n, hU'' n x hn, _⟩,
    let P : ι × ℝ → Prop := λ z, (↿B (z : ι × ℝ) ∩ U n).nonempty,
    rw (equiv.set.sep s P).symm.set_finite_iff,
    simp only [s, P, set.Union_inter, sep_eq_inter_set_of],
    refine set.finite_Union' (λ m, set.to_finite _) (hU' n) (λ m hm, _),
    rw set.eq_empty_iff_forall_not_mem,
    intros z,
    simp only [pi.prod, finset.coe_image, mem_inter_iff, mem_image, finset.mem_coe, set_coe.exists,
      mem_set_of_eq, not_and, bex_imp_distrib, and_imp],
    rintros x hx₁ hx₂ rfl,
    rw set.not_nonempty_iff_eq_empty,
    have := set.inter_subset_inter_left (U n) (h₂ m ⟨x, hx₁⟩),
    rwa [set.not_nonempty_iff_eq_empty.mp hm, set.subset_empty_iff] at this, },
end


/-
Copyright (c) 2021 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import Lean

open Lean.Aesop.DefaultRules (splitAllHyps)
open Lean.Elab.Tactic

syntax (name := splitHyps) "splitHyps" : tactic

@[tactic splitHyps]
def evalSplitHyps : Tactic := λ _ => liftMetaTactic λ goal =>
  return [(← splitAllHyps goal).snd]

-- Note: the names of generated hypotheses are more or less arbitrary and should
-- not be relied upon.
set_option tactic.hygienic false

-- We can split product-like types.
example {P Q} (h : P ∧ Q) : Q ∧ P := by
  splitHyps
  exact ⟨h_2, h_1⟩

-- We can split product-like types under leading Π binders.
example {P Q : α → Prop} (h : ∀ x, P x ∧ Q x) (y) : Q y ∧ P y := by
  splitHyps
  exact ⟨h_2 y, h_1 y⟩

-- All product-like types from the standard library are supported (but not
-- arbitrary structures).
example {P : Type 1} {Q : Type 2} (h : P × Q) : PProd Q P := by
  splitHyps
  constructor; allGoals assumption

example {P : Prop} {Q : Type 1} (h : PProd P Q) : PProd Q P := by
  splitHyps
  constructor; allGoals assumption

example {P Q : Type 1} (h : MProd P Q) : Q × P := by
  splitHyps
  constructor; allGoals assumption

-- All sigma-like types from the standard library are supported.
example {X : Type} {P : X → Type} (h : Σ x, P x) : Σ x, P x := by
  splitHyps
  constructor; allGoals assumption

example {X : Prop} {P : X → Type 2} (h : Σ' x, P x) : Σ' x, P x := by
  splitHyps
  constructor; allGoals assumption

example {X : Type} {P : X → Prop} (h : ∃ x, P x) : ∃ x, P x := by
  splitHyps
  constructor; allGoals assumption

-- Sigma-like types can be split under Π binders as well, except for
-- Exists. (See note in the splitHyps code for why.) Also, splitting recurses
-- into nested products/existentials.
example {P : α → Type} {Q R : ∀ {a}, P a → Type}
    (h : ∀ a, Σ (y : P a), Q y × R y) (a) :
    Σ (y : P a), Q y × R y := by
  splitHyps
  exact ⟨h_1 a, h a, h_3 a⟩


import classes.context_free.basics.toolbox
import utilities.list_utils

variables {T : Type}

def lift_symbol {N₀ N : Type} (lift_N : N₀ → N) : symbol T N₀ → symbol T N
| (symbol.terminal t)    := symbol.terminal t
| (symbol.nonterminal n) := symbol.nonterminal (lift_N n)

def sink_symbol {N₀ N : Type} (sink_N : N → option N₀) : symbol T N → option (symbol T N₀)
| (symbol.terminal t)    := some (symbol.terminal t)
| (symbol.nonterminal n) := option.map symbol.nonterminal (sink_N n)

def lift_string {N₀ N : Type} (lift_N : N₀ → N) :
  list (symbol T N₀) → list (symbol T N) :=
list.map (lift_symbol lift_N)

def sink_string {N₀ N : Type} (sink_N : N → option N₀) :
  list (symbol T N) → list (symbol T N₀) :=
list.filter_map (sink_symbol sink_N)

def lift_rule {N₀ N : Type} (lift_N : N₀ → N) :
  N₀ × (list (symbol T N₀)) → N × (list (symbol T N)) :=
λ r, (lift_N r.fst, lift_string lift_N r.snd)

structure lifted_grammar :=
(g₀ g : CF_grammar T)
(lift_nt : g₀.nt → g.nt)
(lift_inj : function.injective lift_nt)
(corresponding_rules : ∀ r : g₀.nt × list (symbol T g₀.nt),
  r ∈ g₀.rules →
    lift_rule lift_nt r ∈ g.rules
)
(sink_nt : g.nt → option g₀.nt)
(sink_inj : ∀ x y, sink_nt x = sink_nt y →
  x = y  ∨  sink_nt x = none
)
(preimage_of_rules : ∀ r : g.nt × list (symbol T g.nt),
  (r ∈ g.rules ∧ ∃ n₀ : g₀.nt, lift_nt n₀ = r.fst) →
    (∃ r₀ ∈ g₀.rules, lift_rule lift_nt r₀ = r)
)
(lift_nt_sink : ∀ n₀ : g₀.nt, sink_nt (lift_nt n₀) = some n₀)

private lemma lifted_grammar_inverse (lg : @lifted_grammar T) :
  ∀ x : lg.g.nt,
    (∃ val, lg.sink_nt x = some val) →
      option.map lg.lift_nt (lg.sink_nt x) = x :=
begin
  intros x h,
  cases h with valu ass,
  rw ass,
  rw option.map_some',
  apply congr_arg,
  symmetry,
  by_contradiction,
  have inje := lg.sink_inj x (lg.lift_nt valu),
  rw lg.lift_nt_sink at inje,
  cases inje ass with case_valu case_none,
  {
    exact h case_valu,
  },
  rw ass at case_none,
  exact option.no_confusion case_none,
end

private lemma lift_tran {lg : lifted_grammar} {w₁ w₂ : list (symbol T lg.g₀.nt)}
    (hyp : CF_transforms lg.g₀ w₁ w₂) :
  CF_transforms lg.g (lift_string lg.lift_nt w₁) (lift_string lg.lift_nt w₂) :=
begin
  rcases hyp with ⟨r, rin, u, v, bef, aft⟩,
  use lift_rule lg.lift_nt r,
  split,
  {
    exact lg.corresponding_rules r rin,
  },
  use lift_string lg.lift_nt u,
  use lift_string lg.lift_nt v,
  split,
  {
    have lift_bef := congr_arg (lift_string lg.lift_nt) bef,
    unfold lift_string at *,
    rw list.map_append_append at lift_bef,
    convert lift_bef,
  },
  {
    have lift_aft := congr_arg (lift_string lg.lift_nt) aft,
    unfold lift_string at *,
    rw list.map_append_append at lift_aft,
    exact lift_aft,
  },
end

lemma lift_deri {lg : lifted_grammar} {w₁ w₂ : list (symbol T lg.g₀.nt)}
    (hyp : CF_derives lg.g₀ w₁ w₂) :
  CF_derives lg.g (lift_string lg.lift_nt w₁) (lift_string lg.lift_nt w₂) :=
begin
  induction hyp with x y trash orig ih,
  {
    apply CF_deri_self,
  },
  apply CF_deri_of_deri_tran,
  {
    exact ih,
  },
  exact lift_tran orig,
end

def good_letter {lg : @lifted_grammar T} : symbol T lg.g.nt → Prop
| (symbol.terminal t)    := true
| (symbol.nonterminal n) := (∃ n₀ : lg.g₀.nt, lg.sink_nt n = n₀)

def good_string {lg : @lifted_grammar T} (s : list (symbol T lg.g.nt)) :=
∀ a ∈ s, good_letter a

private lemma sink_tran {lg : lifted_grammar} {w₁ w₂ : list (symbol T lg.g.nt)}
    (hyp : CF_transforms lg.g w₁ w₂)
    (ok_input : good_string w₁) :
  CF_transforms lg.g₀ (sink_string lg.sink_nt w₁) (sink_string lg.sink_nt w₂) :=
begin
  rcases hyp with ⟨r, rin, u, v, bef, aft⟩,

  rcases lg.preimage_of_rules r (by {
    split,
    {
      exact rin,
    },
    rw bef at ok_input,
    have good_matched_nonterminal : good_letter (symbol.nonterminal r.fst),
    {
      specialize ok_input (symbol.nonterminal r.fst),
      finish,
    },
    change ∃ n₀ : lg.g₀.nt, lg.sink_nt r.fst = some n₀ at good_matched_nonterminal,
    cases good_matched_nonterminal with n₀ hn₀,
    use n₀,
    have almost := congr_arg (option.map lg.lift_nt) hn₀,
    rw lifted_grammar_inverse lg r.fst ⟨n₀, hn₀⟩ at almost,
    rw option.map_some' at almost,
    apply option.some_injective,
    exact almost.symm,
  }) with ⟨p, pin, preimage⟩,

  use p,
  split,
  {
    exact pin,
  },
  use sink_string lg.sink_nt u,
  use sink_string lg.sink_nt v,
  have correct_inverse : sink_symbol lg.sink_nt ∘ lift_symbol lg.lift_nt = option.some,
  {
    ext1,
    cases x,
    {
      refl,
    },
    rw function.comp_app,
    unfold lift_symbol,
    unfold sink_symbol,
    rw lg.lift_nt_sink,
    apply option.map_some',
  },
  split,
  {
    have sink_bef := congr_arg (sink_string lg.sink_nt) bef,
    unfold sink_string at *,
    rw list.filter_map_append_append at sink_bef,
    convert sink_bef,
    rw ←preimage,
    unfold lift_rule,
    dsimp only,
    change
      [symbol.nonterminal p.fst] =
      list.filter_map (sink_symbol lg.sink_nt)
        (list.map (lift_symbol lg.lift_nt) [symbol.nonterminal p.fst]),
    rw list.filter_map_map,
    rw correct_inverse,
    rw list.filter_map_some,
  },
  {
    have sink_aft := congr_arg (sink_string lg.sink_nt) aft,
    unfold sink_string at *,
    rw list.filter_map_append_append at sink_aft,
    convert sink_aft,
    rw ←preimage,
    unfold lift_rule,
    dsimp only,
    unfold lift_string,
    rw list.filter_map_map,
    rw correct_inverse,
    rw list.filter_map_some,
  },
end

lemma sink_deri (lg : lifted_grammar) (w₁ w₂ : list (symbol T lg.g.nt))
    (hyp : CF_derives lg.g w₁ w₂)
    (ok_input : good_string w₁) :
  CF_derives lg.g₀ (sink_string lg.sink_nt w₁) (sink_string lg.sink_nt w₂)
  ∧ good_string w₂ :=
begin
  induction hyp with x y trash orig ih,
  {
    split,
    {
      apply CF_deri_self,
    },
    {
      exact ok_input,
    },
  },
  split,
  {
    apply CF_deri_of_deri_tran,
    {
      exact ih.left,
    },
    exact sink_tran orig ih.right,
  },
  {
    intros a in_y,
    have ihr := ih.right a,
    rcases orig with ⟨r, in_rules, u, y, bef, aft⟩,
    rw bef at ihr,
    rw list.mem_append at ihr,
    rw aft at in_y,
    rw list.mem_append at in_y,
    cases in_y,
    rw list.mem_append at in_y,
    cases in_y,
    {
      apply ihr,
      rw list.mem_append,
      left,
      left,
      exact in_y,
    },
    {
      have exn₀ : ∃ (n₀ : lg.g₀.nt), lg.lift_nt n₀ = r.fst,
      {
        by_cases lg.sink_nt r.fst = none,
        {
          exfalso,
          have ruu : symbol.nonterminal r.fst ∈ x,
          {
            rw bef,
            rw list.mem_append,
            left,
            rw list.mem_append,
            right,
            apply list.mem_cons_self,
          },
          have glruf : good_letter (symbol.nonterminal r.fst),
          {
            exact ih.right (symbol.nonterminal r.fst) ruu,
          },
          unfold good_letter at glruf,
          rw h at glruf,
          cases glruf with n₀ imposs,
          exact option.no_confusion imposs,
        },
        cases (option.ne_none_iff_exists'.mp h) with x ex,
        use x,
        have gix := lifted_grammar_inverse lg r.fst ⟨x, ex⟩,
        rw ex at gix,
        rw option.map_some' at gix,
        apply option.some_injective,
        exact gix,
      },
      rcases lg.preimage_of_rules r ⟨in_rules, exn₀⟩ with ⟨r₀, in0, lif⟩,
      rw ←lif at in_y,
      unfold lift_rule at in_y,
      dsimp only at in_y,
      unfold lift_string at in_y,
      rw list.mem_map at in_y,
      rcases in_y with ⟨s, s_in_rulsnd, symbol_letter⟩,
      rw ←symbol_letter,
      cases s,
      {
        unfold lift_symbol,
      },
      unfold lift_symbol,
      unfold good_letter,
      use s,
      exact lg.lift_nt_sink s,
    },
    {
      apply ihr,
      right,
      exact in_y,
    },
  },
end

meta def five_steps : tactic unit := `[
  apply congr_fun,
  apply congr_arg,
  ext1,
  cases x;
  refl
]

variables {g₁ g₂ : CF_grammar T}

/-- similar to `lift_symbol (option.some ∘ sum.inl)` -/
def sTN_of_sTN₁ : (symbol T g₁.nt) → (symbol T (option (g₁.nt ⊕ g₂.nt)))
| (symbol.terminal st) := (symbol.terminal st)
| (symbol.nonterminal snt) := (symbol.nonterminal (some (sum.inl snt)))

/-- similar to `lift_symbol (option.some ∘ sum.inr)` -/
def sTN_of_sTN₂ : (symbol T g₂.nt) → (symbol T (option (g₁.nt ⊕ g₂.nt)))
| (symbol.terminal st) := (symbol.terminal st)
| (symbol.nonterminal snt) := (symbol.nonterminal (some (sum.inr snt)))

/-- similar to `lift_string (option.some ∘ sum.inl)` -/
def lsTN_of_lsTN₁ : list (symbol T g₁.nt) → list (symbol T (option (g₁.nt ⊕ g₂.nt))) :=
list.map sTN_of_sTN₁

/-- similar to `lift_string (option.some ∘ sum.inr)` -/
def lsTN_of_lsTN₂ : list (symbol T g₂.nt) → list (symbol T (option (g₁.nt ⊕ g₂.nt))) :=
list.map sTN_of_sTN₂

/-- similar to `lift_rule (option.some ∘ sum.inl)` -/
def rule_of_rule₁ (r : g₁.nt × (list (symbol T g₁.nt))) :
  ((option (g₁.nt ⊕ g₂.nt)) × (list (symbol T (option (g₁.nt ⊕ g₂.nt))))) :=
(some (sum.inl (prod.fst r)), lsTN_of_lsTN₁ (prod.snd r))

/-- similar to `lift_rule (option.some ∘ sum.inr)` -/
def rule_of_rule₂ (r : g₂.nt × (list (symbol T g₂.nt))) :
  ((option (g₁.nt ⊕ g₂.nt)) × (list (symbol T (option (g₁.nt ⊕ g₂.nt))))) :=
(some (sum.inr (prod.fst r)), lsTN_of_lsTN₂ (prod.snd r))


import M40001.M40001_4
import data.equiv.basic

namespace M40001

-- set_option pp.notation false

lemma left_inv_iff_lem (X : Type*) :
  ∀ r s : ↥{R : bin_rel X | equivalence R}, (∀ x y : X, r.1 x y ↔ s.1 x y) ↔ s = r :=
begin
  intros r s,
  split,
    {intro h,
    cases r, cases s,
    rw subtype.ext,
    dsimp,
    ext, from (h x x_1).symm,
    },
    {intros h x y,
    rw h
    }
end

def tricky (X : Type*) : {R : bin_rel X | equivalence R} ≃ {A : set (set X) | partition A} :=
{ to_fun := λ r, ⟨{a : set X | ∃ s : X, a = cls r.1 s}, equiv_relation_partition r.1 r.2⟩,
  inv_fun := λ a, ⟨rs a.1, partition_equiv_relation a.1 a.2 ⟩,
  left_inv :=
begin
    intro r,
    rcases r.2 with ⟨rrefl, ⟨rsymm, rtran⟩⟩,
    rw ←left_inv_iff_lem,
    intros x y,
    split,
      {intro h, simp,
      use cls r.val x,
      split,
        {use x},
        {split, apply rrefl, from h
        },
      },
      {intro h, simp at h,
      rcases h with ⟨B, ⟨⟨z, hb⟩, ⟨xB, yB⟩⟩⟩,
      unfold cls at hb,
      have h1 : r.val x z, by {apply rsymm, rw hb at xB, rwa set.mem_set_of_eq at xB},
      have h2 : r.val z y, by {rw hb at yB, rwa set.mem_set_of_eq at yB},
      from rtran x z y ⟨h1, h2⟩
      }
end,
  right_inv :=
begin
  unfold function.right_inverse,
  unfold function.left_inverse,
  intro b, simp,
  unfold cls,
  rw subtype.ext,
  ext,
  split,
    {rintro ⟨s, h⟩,
    rw h,
    have h1 : equivalence (rs (b.val)) := partition_equiv_relation b.val b.2,
    have h2 : ∀ x y : X, rs (b.val) x y = ∃ B ∈ b.val, x ∈ B ∧ y ∈ B, by {intros x y, refl},
    sorry
    },
  sorry
end
}

end M40001


import for_mathlib.algebra.homology.mapping_cone
import for_mathlib.algebra.homology.homological_complex_biprod
import category_theory.localization.predicate

noncomputable theory

open category_theory category_theory.limits category_theory.category

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

namespace cochain_complex

open hom_complex

variables {K L : cochain_complex C ℤ}

variable (K)

def cylinder : cochain_complex C ℤ :=
mapping_cone (homological_complex.biprod.lift (𝟙 K) (-𝟙 K))

namespace cylinder

variable {K}

def inl : K ⟶ cylinder K :=
homological_complex.biprod.inl ≫ mapping_cone.inr _

def inr : K ⟶ cylinder K :=
homological_complex.biprod.inr ≫ mapping_cone.inr _

variable (K)

def homotopy_inl_inr : homotopy (inl : K ⟶ _) inr :=
begin
  refine mapping_cone.lift_homotopy _ _ _ (cochain.of_hom (𝟙 K)) 0 _ _,
  { ext p q hpq,
    simp only [cocycle.δ_cochain_of_hom, neg_zero, zero_add,
      cochain.zero_cochain_comp, cochain.of_hom_v, inl, inr,
      homological_complex.comp_f, homological_complex.biprod.inl_f, assoc,
      homological_complex.biprod.inr_f,
      mapping_cone.inr_fst, comp_zero], },
  { ext1 p,
    simp only [cochain.comp_zero_cochain, cochain.of_hom_v, δ_zero, cochain.id_comp,
      zero_add, cochain.add_v, homological_complex.biprod.lift_f, homological_complex.id_f,
      homological_complex.neg_f_apply, inl, inr, homological_complex.comp_f,
      homological_complex.biprod.inl_f, assoc, mapping_cone.inr_snd, comp_id, homological_complex.biprod.inr_f],
    ext,
    { simp only [add_zero, biprod.inl_fst, preadditive.add_comp,
        biprod.lift_fst, biprod.inr_fst], },
    { simp only [biprod.inl_snd, preadditive.add_comp, biprod.lift_snd,
        biprod.inr_snd, add_left_neg], }, },
end

variable {K}

def desc (f₁ f₂ : K ⟶ L) (h : homotopy f₁ f₂) : cylinder K ⟶ L :=
mapping_cone.desc _ (cochain.of_homotopy h) (homological_complex.biprod.desc f₁ f₂) begin
  simp only [δ_cochain_of_homotopy, homological_complex.biprod.lift_desc, id_comp,
    preadditive.neg_comp],
  ext,
  simp only [cochain.sub_v, cochain.of_hom_v, homological_complex.add_f_apply,
    homological_complex.neg_f_apply],
  abel,
end

@[simp, reassoc]
lemma inl_desc (f₁ f₂ : K ⟶ L) (h : homotopy f₁ f₂) :
  inl ≫ desc f₁ f₂ h = f₁ :=
by simp only [desc, inl, assoc, mapping_cone.inr_desc, homological_complex.biprod.inl_desc]

@[simp, reassoc]
lemma inr_desc (f₁ f₂ : K ⟶ L) (h : homotopy f₁ f₂) :
  inr ≫ desc f₁ f₂ h = f₂ :=
by simp only [desc, inr, assoc, mapping_cone.inr_desc, homological_complex.biprod.inr_desc]

@[simp]
def π : cylinder K ⟶ K :=
desc _ _ (homotopy.refl (𝟙 K))

variable (K)

@[protected]
def homotopy_equiv : homotopy_equiv (cylinder K) K :=
{ hom := π,
  inv := inl,
  homotopy_hom_inv_id := begin
    refine mapping_cone.desc_homotopy _ _ _ 0
      ((cochain.of_hom homological_complex.biprod.snd).comp
        (mapping_cone.inl _) (zero_add _).symm) _ _,
    { ext1,
      dsimp [desc],
      simp only [zero_add, cochain.of_hom_comp, cochain.comp_zero_cochain, cochain.of_hom_v,
        mapping_cone.inl_desc_v_assoc, cochain.mk_v, zero_comp, δ_zero, cochain.zero_v,
        cochain.zero_cochain_comp, homological_complex.biprod.lift_f, homological_complex.id_f,
        homological_complex.neg_f_apply, homological_complex.biprod.snd_f, biprod.lift_snd_assoc,
        preadditive.neg_comp, id_comp],
      erw [homological_complex.id_f, comp_id, add_left_neg], },
    { erw [comp_id, mapping_cone.cochain_ext' _ _ (zero_add 1).symm],
      dsimp [desc, inl],
      split,
      { simp only [cochain.of_hom_comp, cochain.comp_assoc_of_second_is_zero_cochain,
          add_zero, mapping_cone.inr_comp_fst, cochain.comp_zero, add_left_neg,
          δ_comp_of_first_is_zero_cochain, mapping_cone.δ_inl, cocycle.δ_cochain_of_hom,
          cochain.zero_comp, smul_zero, cochain.add_comp], },
      { ext1,
        simp only [add_zero, cochain.of_hom_comp, cochain.comp_assoc_of_third_is_zero_cochain,
          mapping_cone.inr_comp_snd, cochain.comp_id, cochain.comp_zero_cochain,
          cochain.of_hom_v, homological_complex.biprod.inl_f, mapping_cone.inr_desc_f_assoc,
          homological_complex.biprod.desc_f, homological_complex.id_f, add_left_neg,
          δ_comp_of_first_is_zero_cochain, mapping_cone.δ_inl, cocycle.δ_cochain_of_hom,
          cochain.zero_comp, smul_zero, cochain.add_comp, cochain.add_v,
          homological_complex.biprod.snd_f, homological_complex.biprod.lift_f,
          homological_complex.neg_f_apply],
        ext1,
        { dsimp,
          simp only [biprod.inl_desc_assoc, id_comp, preadditive.comp_add,
            biprod.inl_snd_assoc, zero_comp, comp_id, zero_add], },
        { dsimp,
          ext1,
          { simp only [biprod.inr_desc_assoc, id_comp, biprod.inl_fst, preadditive.comp_add,
              biprod.inr_snd_assoc, comp_id, preadditive.add_comp, biprod.lift_fst,
              biprod.inr_fst, add_zero], },
          { simp only [biprod.inr_desc_assoc, id_comp, biprod.inl_snd, preadditive.comp_add,
              biprod.inr_snd_assoc, comp_id, preadditive.add_comp, biprod.lift_snd,
              biprod.inr_snd, add_left_neg], }, }, }, },
  end,
  homotopy_inv_hom_id := homotopy.of_eq (by rw [π, inl_desc]), }

end cylinder

variable (C)

def homotopy_equivalences : morphism_property (cochain_complex C ℤ) :=
λ K L φ, ∃ (h : homotopy_equiv K L), φ = h.hom

variable {C}

lemma homotopy_equivalences_is_inverted_by_iff {D : Type*} [category D]
  (F : cochain_complex C ℤ ⥤ D) :
  (homotopy_equivalences C).is_inverted_by F ↔
    ∀ (K L : cochain_complex C ℤ) (f₁ f₂ : K ⟶ L)
      (h : homotopy f₁ f₂), F.map f₁ = F.map f₂ :=
begin
  split,
  { intros hF K L f₁ f₂ h,
    haveI : is_iso (F.map cylinder.π) := hF _ ⟨cylinder.homotopy_equiv K, rfl⟩,
    have eq : F.map (cylinder.inl : K ⟶ _) = F.map cylinder.inr,
    { simp only [← cancel_mono (F.map (cylinder.π : _ ⟶ K)),
        ← F.map_comp, cylinder.π, cylinder.inl_desc, cylinder.inr_desc], },
    simpa only [← F.map_comp, cylinder.inl_desc, cylinder.inr_desc]
      using eq =≫ F.map (cylinder.desc _ _ h), },
  { rintros hF K L _ ⟨e, rfl⟩,
    exact ⟨⟨F.map e.inv,
      by simpa only [← F.map_comp, ← F.map_id]  using hF _ _ _ _ e.homotopy_hom_inv_id,
      by simpa only [← F.map_comp, ← F.map_id]  using hF _ _ _ _ e.homotopy_inv_hom_id⟩⟩, },
end

end cochain_complex

namespace homotopy_category

variable (C)

lemma localization_strict_universal_property (D : Type*) [category D] :
  localization.strict_universal_property_fixed_target (quotient C (complex_shape.up ℤ))
    (cochain_complex.homotopy_equivalences C) D :=
{ inverts := begin
    rw cochain_complex.homotopy_equivalences_is_inverted_by_iff,
    exact λ K L, eq_of_homotopy,
  end,
  lift := λ F hF, category_theory.quotient.lift _ F (begin
    rintros K L f₁ f₂ ⟨h⟩,
    rw cochain_complex.homotopy_equivalences_is_inverted_by_iff at hF,
    exact hF _ _ _ _ h,
  end),
  fac := λ F hF, quotient.lift_spec _ _ _,
  uniq := λ F₁ F₂ h, begin
    rw [quotient.lift_unique _ _ _ F₁ rfl, quotient.lift_unique _ _ _ F₂ h.symm],
    { refl, },
    { rintros K L f₁ f₂ ⟨h⟩,
      dsimp,
      rw eq_of_homotopy _ _ h, },
  end, }

instance is_localization :
  (homotopy_category.quotient C (complex_shape.up ℤ)).is_localization
    (cochain_complex.homotopy_equivalences C) :=
functor.is_localization.mk' _ _ (localization_strict_universal_property _ _)
  (localization_strict_universal_property _ _)

end homotopy_category