import pseudo_normed_group.CLC
/-!

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

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

## Main definition

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

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

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

namespace category_theory

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

end category_theory

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

namespace SemiNormedGroup

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

namespace equalizer

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end equalizer
end SemiNormedGroup

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

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

namespace CLCTinv

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end CLCTinv

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

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

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

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

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

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

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

We take the equalizer of those two actions.

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

namespace CLCFPTinv₂

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

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

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

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

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

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

end CLCFPTinv₂

namespace CLCFPTinv

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

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

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

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

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

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

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

end CLCFPTinv

namespace breen_deligne

open CLCFPTinv

variables (M) {l m n}

namespace universal_map

variables (ϕ ψ : universal_map m n)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end universal_map

end breen_deligne

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


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

import category_theory.const

universes v w u -- declare the `v`'s first; see `category_theory.category` for an explanation

namespace category_theory

instance punit_category : small_category punit :=
{ hom  := λ X Y, punit,
  id   := λ _, punit.star,
  comp := λ _ _ _ _ _, punit.star }

namespace functor
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

/-- The constant functor. For `X : C`, `of.obj X` is the functor `punit ⥤ C`
  that maps `punit.star` to `X`. -/
def of : C ⥤ (punit.{w+1} ⥤ C) := const punit

namespace of
@[simp] lemma obj_obj (X : C) : (of.obj X).obj = λ _, X := rfl
@[simp] lemma obj_map (X : C) : (of.obj X).map = λ _ _ _, 𝟙 X := rfl
@[simp] lemma map_app {X Y : C} (f : X ⟶ Y) : (of.map f).app = λ _, f := rfl
end of

end functor

end category_theory


import mcl.defs
import mcl.rhl
import mcl.compute_list
import mcl.ts_updates
import syncablep
import mcl.syncablep
import mcl.lemmas
import .defs

open mcl
open mcl.mclk
open mcl.rhl
open parlang
open parlang.state
open parlang.thread_state

namespace assign_mcl
namespace proof2

notation m ` & ` n ` ::= ` v := memory.update m n v
notation s ` § ` f ` ⇂ ` ac := map_active_threads ac f s

lemma assign_rel' : mclp_rel eq p₁ p₂ eq := begin
    apply rel_mclk_to_mclp,

    apply skip_right.mpr,
    apply rhl.seq,
    swap,

    apply skip_left_after.mpr,
    apply skip_right.mpr,
    apply rhl.seq,
    swap,

    -- break it down into individual proofs
    apply add_skip_left.mpr,
    apply rhl.seq,
    swap,
    {
        apply shared_assign_right,
    },{
        apply shared_assign_right,
    }, {
        apply shared_assign_left,
    },
    apply shared_assign_left',
    intros _ _ _ _ _ _ h hs,
    cases h with m₁ h,
    cases h with m₂ h,
    simp only [map_map_active_threads],
    have : n₁ = n₂ := begin
        sorry
    end,
    subst this,
    have hseq : s₁ = s₂ := begin
        sorry
    end,

    -- the proof obligation in the form of a map thread on syncable is the simple version because we never consider threads to change active state (here all threads are always active)

    -- the two updates store indepedently because "a" ≠ "b"
    -- the two updates read indepedently because they both depend on the same state (AFAIK they could still be swaped because the state is fixed)
    apply exists.intro _,
    apply exists.intro _,

    -- split up the proof for the individual memories
    split, {
        have : thread_state.update_shared_vars_for_expr read_tid = id := by refl,
        rw this,
        have : thread_state.update_shared_vars_for_exprs v[read_tid] = id := by refl,
        rw this,
        have : thread_state.update_shared_vars_for_expr (read_tid + (expression.literal_int 1 (show type_of (sig.val "b") = type_of (sig.val "b"), by refl))) = id := by refl,
        rw this,
        simp,

        -- resolve get and update (the result should only be mcl_init, literals and memory (in case of loads))
        rw ← syncable_syncable',
        rw function.comp.assoc,
        rw ← ts_updates_nil (thread_state.tlocal_to_shared _ _ _ _ ∘ _),
        rw [ts_updates_store, ts_updates_compute, ts_updates_store],
        rw [← function.comp.right_id (compute _)],
        rw [ts_updates_compute],
        rw [function.comp.right_id],
        apply syncable'_store (show ((sig.val "a").type).dim = 1, by refl),
        {
            simp,
        }, {
            simp,
        }, {
            intros tid₁ tid₂ hneq,
            simp [vector.map_cons],
            repeat { rw vector.map_nil },
            rw initial_kernel_assertion_left_thread_state h,
            rw initial_kernel_assertion_left_thread_state h,
            simp,
            rw ← vector.eq_one',
            intro a,
            cases tid₁,
            cases tid₂,
            have : tid₁_val = tid₂_val := begin
                apply a,
            end,
            subst this,
            contradiction,
        },
        rw ts_updates_merge_computes_list,
        apply syncable'_store (show ((sig.val "b").type).dim = 1, by refl),
        {
            intro idx,
            have : "b" ≠ "a" := by intro; cases a,
            simp [this],
        }, {
            intro idx,
            have : "b" ≠ "a" := by intro; cases a,
            simp [this],
        }, {
            intros tid₁ tid₂ hneq,
            simp [vector.map_cons],
            repeat { rw vector.map_nil },
            rw initial_kernel_assertion_left_thread_state h,
            rw initial_kernel_assertion_left_thread_state h,
            simp,
            rw ← vector.eq_one',
            intro a,
            cases tid₁,
            cases tid₂,
            have : tid₁_val = tid₂_val := begin
                apply a,
            end,
            subst this,
            contradiction,
        },
        simp [append, list.append],
        apply syncable'_compute_list_syncable,
        exact h.left,
        sorry, --trivial from h
        sorry, --trivial from h
    },
    split, {
        have : thread_state.update_shared_vars_for_expr read_tid = id := by refl,
        rw this,
        have : thread_state.update_shared_vars_for_exprs v[read_tid] = id := by refl,
        rw this,
        have : thread_state.update_shared_vars_for_expr (read_tid + (expression.literal_int 1 (show type_of (sig.val "b") = type_of (sig.val "b"), by refl))) = id := by refl,
        rw this,
        simp,

        -- resolve get and update (the result should only be mcl_init, literals and memory (in case of loads))
        rw ← syncable_syncable',
        rw function.comp.assoc,
        rw ← ts_updates_nil (thread_state.tlocal_to_shared _ _ _ _ ∘ _),
        rw [ts_updates_store, ts_updates_compute, ts_updates_store],
        rw [← function.comp.right_id (compute _)],
        rw [ts_updates_compute],
        rw [function.comp.right_id],
        apply syncable'_store (show ((sig.val "b").type).dim = 1, by refl),
        {
            simp,
        }, {
            simp,
        }, {
            intros tid₁ tid₂ hneq,
            simp [vector.map_cons],
            repeat { rw vector.map_nil },
            rw h.right_thread_state,
            rw h.right_thread_state,
            simp,
            rw ← vector.eq_one',
            intro a,
            cases tid₁,
            cases tid₂,
            have : tid₁_val = tid₂_val := begin
                apply a,
            end,
            subst this,
            contradiction,
        },
        rw ts_updates_merge_computes_list,
        apply syncable'_store (show ((sig.val "a").type).dim = 1, by refl),
        {
            intro idx,
            have : "a" ≠ "b" := by intro; cases a,
            simp [this],
        }, {
            intro idx,
            have : "a" ≠ "b" := by intro; cases a,
            simp [this],
        }, {
            intros tid₁ tid₂ hneq,
            simp [vector.map_cons],
            repeat { rw vector.map_nil },
            rw h.right_thread_state,
            rw h.right_thread_state,
            simp,
            rw ← vector.eq_one',
            intro a,
            cases tid₁,
            cases tid₂,
            have : tid₁_val = tid₂_val := begin
                apply a,
            end,
            subst this,
            contradiction,
        },
        simp [append, list.append],
        apply syncable'_compute_list_syncable,
        exact h.right.left,
        sorry, --trivial from h
        sorry, --trivial from h
    }, {
        -- show post-condition
        simp [append, list.append],
        rw ts_update_compute_list,
        rw from_tlocal_comm,
        have := h.precondition,
        subst this,
        have := h.initial_state_eq,
        subst this,
        apply from_tlocal_eq,
        {
            intro tid,
            rw map_active_threads_nth_ac,
            rw map_active_threads_nth_ac,
            refl,
            sorry, -- trivial
            sorry, -- trivial
        },
        apply from_tlocal_eq,
        {
            intro tid,
            rw map_active_threads_nth_ac,
            rw map_active_threads_nth_ac,
            refl,
            sorry, -- trivial
            sorry, -- trivial
        },
        refl,
    }, {
        sorry, --trivial
    }
end

end proof2
end assign_mcl


import order

import lib.list

import etv

open order_dual

variables {α : Type*} [linear_order α] (C : config α)

lemma config.join_n2_n3_n2_ff
  (S : finset α) (cap4_free : ¬C.has_ncap 4 S)
  {n : ℕ} (x y : α)
  {P : list α} (hPx : C.ncup (n+2) (P ++ [x])) (Px_in_S : (P ++ [x]).in S)
  {Q : list α} (hxQy : C.ncup (n+3) (x :: Q ++ [y]))
  (xQy_in_S : (x :: Q ++ [y]).in S)
  {R : list α} (hyR : C.ncup (n+2) (y :: R)) (yR_in_S : (y :: R).in S)
  (label : C.label S) (sxy : ¬label.slope x y) :
  ∃ p q r s, C.has_interweaved_laced (n+3) S p q r s :=
begin
  have x_in_S : x ∈ S := by simp at xQy_in_S; tauto,
  have y_in_S : y ∈ S := by simp at xQy_in_S; tauto,
  have x_lt_y : x < y := by apply hxQy.head'_lt_last' x y; simp,

  have hP := hPx.init, simp at hP,
  have hQy := hxQy.tail, simp at hQy,
  rcases hP.init_append_last with ⟨P', a, eq_P, hP'⟩, subst eq_P,
  rcases hQy.cons_head_tail with ⟨b, Q', eq_Q, hQ'⟩,
  have eq_xQy : x :: Q ++ [y] = x :: (Q ++ [y]) := by simp,
  rw [eq_xQy, eq_Q] at *, clear eq_xQy,
  have a_in_S : a ∈ S := by simp at Px_in_S; tauto,
  have b_in_S : b ∈ S := by simp at xQy_in_S; tauto,

  have hR := hyR.tail, simp at hR,
  rcases hR.init_append_last with ⟨R', z, eq_R, hR'⟩,
  have xy_laced : C.has_laced (n+3) S x y := begin
    have hy : C.ncup 1 [y] := by simp,
    existsi [_, _, _, _, _, hPx, hxQy, hy],
    refine ⟨_, _, _⟩,
    split, assumption, split, assumption,
    simp, simp at xQy_in_S, tauto,
    simp, simp, rw ←eq_Q, simp,
  end,
  have xz_laced : C.has_laced (n+3) S x z := begin
    have hxyR : C.ncup (n+3) (x :: y :: R) := begin
      apply hyR.extend_left sxy; try {assumption}, simp,
    end,
    rw eq_R at hxyR,
    have hz : C.ncup 1 [z] := by simp,
    existsi [_, _, _, _, _, hPx, hxyR, hz],
    refine ⟨_, _, _⟩,
    split, assumption, rw eq_R at yR_in_S,
    simp, simp at yR_in_S, tauto,
    simp, simp,
  end,

  have a_lt_x : a < x :=
    by rw [config.ncup, config.cup] at hPx; simp at hPx; tauto,
  have x_lt_b : x < b :=
    by rw [config.ncup, config.cup] at hxQy; simp at hxQy; tauto,
  have y_lt_z : y < z := begin
    rw eq_R at hyR, apply hyR.head'_lt_last' y z,
    simp, simp,
  end,
  have a_lt_b : a < b := has_lt.lt.trans a_lt_x x_lt_b,
  by_cases sab : label.slope a b, swap,
  -- case ¬label.slope a b
  { have hQy := hxQy.tail, simp at hQy, rw ←eq_Q at hQy,
    have haQy : C.ncup (n+3) (a :: Q ++ [y]) := begin
      apply hQy.extend_left sab; try {assumption},
      simp, rw ←eq_Q at xQy_in_S, simp at xQy_in_S, tauto, simp,
      rw eq_Q, simp,
    end,
    have ha : C.ncup 1 [a] := by simp,
    have ay_laced : C.has_laced (n+3) S a y := begin
      existsi [_, _, _, _, _, ha, haQy, hyR],
      refine ⟨_, _, _⟩,
      simp, rw ←eq_Q at xQy_in_S, simp at xQy_in_S yR_in_S, tauto,
      rw nat.add_comm, simp,
    end,
    use [a, x, y, z], split,
    { split, assumption, split,
      exact le_of_lt x_lt_y, assumption },
    { tauto }, },
  -- case label.slope a b
  have b_lt_y : b < y := begin
    have hQy := hxQy.tail, simp at hQy,
    apply hQy.head'_lt_last' b y; simp,
    rw ←eq_Q, simp,
  end,
  have hP := hPx.init, simp at hP,
  have hPb : C.ncup (n+2) (P' ++ [a] ++ [b]) := begin
    apply hP.extend_right sab; try { assumption },
    simp; simp at Px_in_S; tauto,
    simp,
  end,
  by_cases sby : label.slope b y, swap,
  { have bz_laced : C.has_laced (n+3) S b z := begin
      have hbyR : C.ncup (n+3) (b :: y :: R) := begin
        apply hyR.extend_left sby; try {assumption}, simp,
      end,
      have hz : C.ncup 1 [z] := by simp,
      existsi [_, _, _, _, _, hPb, hbyR, hz], rw eq_R,
      refine ⟨_, _, _⟩,
      rw eq_R at yR_in_S, simp at Px_in_S yR_in_S, simp, tauto,
      simp, simp,
    end,
    use [x, b, y, z], split,
    split, assumption, split, apply le_of_lt, assumption, assumption,
    tauto, },
  { have hPby : C.ncup (n+3) (P' ++ [a] ++ [b] ++ [y]) := begin
      apply hPb.extend_right sby; try { assumption },
      simp; simp at Px_in_S; tauto, simp,
    end,
    have P_nnil : P' ++ [a] ≠ [] := by simp,
    rcases list.take_head P_nnil with ⟨w, P_, eq_P_⟩,
    rw eq_P_ at hPby,
    have wy_laced : C.has_laced (n+3) S w y := begin
      have hw : C.ncup 1 [w] := by simp,
      existsi [_, _, _, _, _, hw, hPby, hyR],
      refine ⟨_, _, _⟩,
      rw eq_P_ at Px_in_S, simp at yR_in_S Px_in_S, simp, tauto,
      rw nat.add_comm, simp,
    end,
    use [w, x, y, z], split, split,
    rw eq_P_ at hPx, apply hPx.head'_lt_last' w x; simp,
    split, exact le_of_lt x_lt_y, assumption, tauto, },
end

lemma config.join_n2_n3_n2_tt
  (S : finset α) (cap4_free : ¬C.has_ncap 4 S)
  {n : ℕ} (x y : α)
  {P : list α} (hPx : C.ncup (n+2) (P ++ [x])) (Px_in_S : (P ++ [x]).in S)
  {Q : list α} (hxQy : C.ncup (n+3) (x :: Q ++ [y]))
  (xQy_in_S : (x :: Q ++ [y]).in S)
  {R : list α} (hyR : C.ncup (n+2) (y :: R)) (yR_in_S : (y :: R).in S)
  (label : C.label S) (sxy : label.slope x y) :
  ∃ p q r s, C.has_interweaved_laced (n+3) S p q r s :=
begin
  have mirrored_goal : ∃ s r q p,
    C.mirror.has_interweaved_laced (n+3) S.mirror s r q p :=
  begin
    rw ←mirror.ncup at hPx hxQy hyR, simp at hPx hxQy hyR,
    rw ←mirror.has_ncap at cap4_free,
    rw ←list.mirror_in at Px_in_S xQy_in_S yR_in_S,
    simp [-list.cons_in, -list.append_in] at Px_in_S xQy_in_S yR_in_S,
    have syx := sxy, rw ←mirror_slope at syx,
    apply C.mirror.join_n2_n3_n2_ff
      _ _ (to_dual y) (to_dual x)
      hyR _ hxQy _ hPx _ label.mirror _; assumption,
  end,
  simp at mirrored_goal,
  rcases mirrored_goal with ⟨s, r, q, p, h⟩,
  rw mirror.has_interweaved_laced at h,
  use [p, q, r, s], exact h,
end

lemma config.join_n2_n3_n2 (S : finset α) {n : ℕ}
  (cap4_free : ¬C.has_ncap 4 S) (cup_free : ¬C.has_ncup (n+4) S)
  {cx : list α} (cx_ncup : C.ncup (n+2) cx) (cx_in_S : cx.in S)
  {c : list α} (c_ncup : C.ncup (n+3) c) (c_in_S : c.in S)
  {cy : list α} (cy_ncup : C.ncup (n+2) cy) (cy_in_S : cy.in S)
  (x : α) (hxcx : x ∈ cx.last') (hxc : x ∈ c.head')
  (y : α) (hyc : y ∈ c.last') (hycy : y ∈ cy.head') :
  ∃ p q r s, C.has_interweaved_laced (n+3) S p q r s :=
begin
  rcases c_ncup.take_head_last with ⟨x, Q, y, eq_Q, Q_ncup⟩,
  subst eq_Q, simp at hxc hyc, subst hxc, subst hyc,
  rcases cx_ncup.init_append_last with ⟨P, x, eq_P, P_ncup⟩,
  subst eq_P, simp at hxcx, subst hxcx,
  rcases cy_ncup.cons_head_tail with ⟨y, R, eq_R, R_ncup⟩,
  subst eq_R, simp at hycy, subst hycy,

  have label := cap4_free_label cap4_free,
  by_cases sxy : label.slope x y,
  { apply C.join_n2_n3_n2_tt S; try {assumption}, },
  { apply C.join_n2_n3_n2_ff S; try {assumption}, },
end


import for_mathlib.valuation_subring
import morphisms.proper
import algebraic_geometry.properties

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universes v u

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

open category_theory.morphism_property
open algebraic_geometry.morphism_property (topologically)

structure valuative_comm_sq {X Y : Scheme.{u}} (f : X ⟶ Y) :=
(R : Type.{u})
[hR : comm_ring R]
[hR₁ : is_domain R]
[hR₂ : valuation_ring R]
(K : Type.{u})
[hK : field K]
[hRK : algebra R K]
[hRK' : is_fraction_ring R K]
(i₁ : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X)
(i₂ : Scheme.Spec.obj (op $ CommRing.of R) ⟶ Y)
(comm_sq : comm_sq i₁ (Scheme.Spec.map (CommRing.of_hom $ algebra_map R K).op) f i₂)
.
def valuative_criterion.existence : morphism_property Scheme :=
λ X Y f, ∀ S : valuative_comm_sq f, S.comm_sq.has_lift

def valuative_criterion.uniqueness : morphism_property Scheme :=
λ X Y f, ∀ S : valuative_comm_sq f, subsingleton S.comm_sq.lift_struct

def valuative_criterion : morphism_property Scheme :=
λ X Y f, ∀ S : valuative_comm_sq f, nonempty (unique (S.comm_sq.lift_struct))

section existence

lemma valuative_criterion.existence.specializing_map (H : valuative_criterion.existence f) :
  specializing_map f.1.base :=
begin
  rintros x y (h : f.1.base x ⤳ y),
  let ϕ := Y.presheaf.stalk_specializes h ≫ PresheafedSpace.stalk_map f.1 x ≫ X.stalk_residue x,
  obtain ⟨A, hA, hA'⟩ := exists_factor_valuation_ring ϕ,
  let ϕ' := ϕ.cod_restrict A.to_subring hA,
  have : CommRing.of_hom ϕ' ≫ CommRing.of_hom (algebra_map ↥A ↥(X.residue_field x)) = ϕ,
  { ext, refl },
  obtain ⟨⟨H'⟩⟩ := H ⟨A, X.residue_field x, X.from_Spec_residue_field x,
    Scheme.Spec.map (CommRing.of_hom ϕ').op ≫ Y.from_Spec_stalk y, ⟨_⟩⟩,
  refine ⟨H'.l.1.base (local_ring.closed_point A), _, _⟩,
  { simp only [← functor.map_comp_assoc, ← op_comp, this, ϕ],
    erw op_comp,
    simp only [op_comp, functor.map_comp_assoc],
    erw Scheme.stalk_specializes_from_Spec_stalk h,
    rw [stalk_map_from_Spec_stalk, ← category.assoc], refl },
  { show local_ring A, by apply_instance },
  { change _ ⤳ _,
    conv_lhs { rw [← Scheme.from_Spec_residue_field_base x (⊥ : prime_spectrum $ X.residue_field x),
      ← (show _ = X.from_Spec_residue_field x, from H'.fac_left)] },
    refine specializes.map _ H'.l.1.base.2,
    apply_with local_ring.specializes_closed_point { instances := ff } },
  { rw [← Scheme.comp_val_base_apply, H'.fac_right],
    dsimp only,
    erw Scheme.comp_val_base_apply,
    convert Scheme.from_Spec_stalk_closed_point _,
    apply_with local_ring.comap_closed_point { instances := ff },
    exact hA' }
end

-- move me
lemma _root_.category_theory.functor.preimage_injective {C D} [category C] [category D]
  (F : C ⥤ D) [full F] {X Y : C} :
  function.injective (F.preimage : _ → (X ⟶ Y)) :=
λ f g e, by rw [← F.image_preimage f, ← F.image_preimage g, e]

lemma valuative_criterion.existence.of_specializing_map
  (H : universally (topologically @specializing_map) f) :
  valuative_criterion.existence f :=
begin
  rintros ⟨R, K, i₁, i₂, c⟩,
  resetI,
  let X' := pullback f i₂,
  let S := Scheme.Spec.obj (op $ CommRing.of R),
  let f' : X' ⟶ S := pullback.snd,
  let i₁' : _ ⟶ X' := pullback.lift i₁ _ c.1,
  let x' : X'.carrier := i₁'.1.base (show prime_spectrum K, from local_ring.closed_point _),
  let s' : S.carrier := (show prime_spectrum R, from local_ring.closed_point _),
  have hxs : f'.1.base x' ⤳ s' := local_ring.specializes_closed_point _,
  have hf' : specializing_map f'.1.base := H _ _ _ (is_pullback.of_has_pullback _ _).flip,
  obtain ⟨x, hx : _ ⤳ _, e⟩ := hf' hxs,
  let ϕ : CommRing.of R ⟶ X'.stalk x := structure_sheaf.to_stalk R s' ≫
    S.presheaf.stalk_specializes (specializes_of_eq e) ≫ PresheafedSpace.stalk_map f'.1 x,
  haveI : is_local_ring_hom ϕ := by apply is_local_ring_hom_comp,
  let ψ : X'.presheaf.stalk x ⟶ CommRing.of K :=
    X'.presheaf.stalk_specializes hx ≫ stalk_closed_point_to _ i₁',
  have hϕ : ϕ ≫ ψ = CommRing.of_hom (algebra_map R K),
  { simp only [ϕ, stalk_closed_point_to, category.assoc,
      ← PresheafedSpace.stalk_map.stalk_specializes_stalk_map_assoc,
      Top.presheaf.stalk_specializes_comp_assoc],
    slice_lhs 3 4 { erw ← PresheafedSpace.stalk_map.comp },
    have : i₁'.val ≫ f'.val = (Scheme.Spec.map (CommRing.of_hom (algebra_map R K)).op).1 :=
      congr_arg LocallyRingedSpace.hom.val (pullback.lift_snd i₁ _ c.1),
    erw [PresheafedSpace.stalk_map.congr_hom' _ _ this],
    simp only [category.assoc, Top.presheaf.stalk_specializes_comp_assoc],
    erw structure_sheaf.to_stalk_stalk_specializes_assoc,
    slice_lhs 1 2 { erw stalk_map_to_stalk },
    rw iso.comp_inv_eq,
    simp_rw category.assoc,
    erw structure_sheaf.to_stalk_comp_stalk_to_fiber_ring_hom,
    refl },
  have hψ := @bijective_range_restrict_comp_of_valuation_ring R (X'.presheaf.stalk x) K
    _ _ _ _ _ _ _ _ _ _ hϕ _,
  let ψ' : _ ⟶ CommRing.of R :=
    (ring_equiv.of_bijective _ hψ).symm.to_ring_hom.comp ψ.range_restrict,
  haveI : is_local_ring_hom ψ',
  { apply_with is_local_ring_hom_comp { instances := ff },
    { exact is_local_ring_hom_equiv (ring_equiv.of_bijective _ hψ).symm },
    { exact is_local_ring_hom_of_surjective _ ψ.range_restrict_surjective } },
  have hψ'' : ϕ ≫ ψ' = 𝟙 _,
  { ext1 y, exact (ring_equiv.of_bijective _ hψ).symm_apply_apply y },
  haveI : mono (CommRing.of_hom (algebra_map R K)),
  { apply functor.mono_of_mono_map (forget CommRing), rw mono_iff_injective,
    exact (is_fraction_ring.injective R K : _) },
  have hψ' : ψ' ≫ CommRing.of_hom (algebra_map R K) = ψ,
  { rw ← hϕ, apply ring_hom.ext, intro y,
    change ((ring_equiv.of_bijective _ hψ) $ (ring_equiv.of_bijective _ hψ).symm _).1 = _,
    rw ring_equiv.apply_symm_apply, refl },
  haveI : local_ring (CommRing.of R) := show local_ring R, by apply_instance,
  refine ⟨⟨⟨(Spec_to_equiv_of_local_ring (CommRing.of R) _).symm ⟨_, ψ', infer_instance⟩
    ≫ pullback.fst, _, _⟩⟩⟩,
  { dsimp only,
    transitivity i₁' ≫ pullback.fst, swap, { exact pullback.lift_fst _ _ _ },
    rw ← category.assoc, congr' 1,
    refine (functor.map_comp_assoc _ _ _ _).symm.trans _,
    dsimp only,
    rw [← op_comp, hψ', op_comp, functor.map_comp_assoc, Scheme.stalk_specializes_from_Spec_stalk],
    exact Spec_map_stalk_closed_point_to_from_stalk _ _ },
  { dsimp only,
    rw [category.assoc, pullback.condition, ← category.assoc],
    convert category.id_comp _,
    show (_ ≫ _) ≫ f' = 𝟙 _,
    apply Scheme.Spec.preimage_injective,
    rw ← cancel_epi (CommRing.of_hom (algebra_map R K)).op,
    apply Scheme.Spec.map_injective,
    simp only [functor.map_comp, op_comp, functor.image_preimage, category.assoc],
    rw [← functor.map_comp_assoc, ← op_comp, hψ', op_comp, functor.map_comp_assoc,
      Scheme.stalk_specializes_from_Spec_stalk_assoc],
    erw Spec_map_stalk_closed_point_to_from_stalk_assoc,
    rw [pullback.lift_snd, category.comp_id] }
end
.
lemma valuative_criterion.existence_stable_under_base_change :
  valuative_criterion.existence.stable_under_base_change :=
begin
  rintros X Y Y' S f g h k H hg ⟨R, K, i₄, i₂, c⟩,
  resetI,
  obtain ⟨⟨⟨l, hl₁, hl₂⟩⟩⟩ := hg ⟨R, K, i₄ ≫ h, i₂ ≫ f, ⟨_⟩⟩,
  obtain ⟨l', hl₃, hl₄⟩ := pullback_cone.is_limit.lift' H.is_limit l i₂ hl₂,
  refine ⟨⟨⟨l', _, hl₄⟩⟩⟩,
  apply pullback_cone.is_limit.hom_ext H.is_limit,
  { simp only [category.assoc, hl₃, hl₁], refl },
  { simp only [category.assoc, hl₄, c.w.symm], refl },
  { simp only [category.assoc, ← c.w_assoc, H.w] }
end

lemma valuative_criterion.existence_eq :
  valuative_criterion.existence = universally (topologically @specializing_map) :=
begin
  apply le_antisymm,
  { rw ← valuative_criterion.existence_stable_under_base_change.universally_eq,
    exact universally_mono (λ X Y f, valuative_criterion.existence.specializing_map f) },
  { exact λ X Y f, valuative_criterion.existence.of_specializing_map f }
end

lemma universally_closed_eq_valuative_criterion :
  @universally_closed = @quasi_compact ⊓ valuative_criterion.existence :=
by rw [valuative_criterion.existence_eq,
  universally_closed_eq_quasi_compact_and_universally_specializing]

lemma universally_closed_of_valuative_criterion [quasi_compact f]
  (hf : valuative_criterion.existence f) : universally_closed f :=
begin
  rw universally_closed_eq_valuative_criterion,
  exact ⟨infer_instance, hf⟩
end

end existence

section uniqueness

lemma separated_of_valuative_criterion [quasi_separated f]
  (hf : valuative_criterion.uniqueness f) : separated f :=
begin
  suffices : universally_closed (pullback.diagonal f),
  { constructor,
    apply is_closed_immersion.of_is_immersion,
    exactI (universally_closed.is_closed_map $ pullback.diagonal f).closed_range },
  apply universally_closed_of_valuative_criterion,
  rintro ⟨R, K, i₁, i₂, c⟩,
  resetI,
  have c' : comm_sq i₁ (Scheme.Spec.map (CommRing.of_hom (algebra_map R K)).op) f
    (i₂ ≫ pullback.fst ≫ f),
  { constructor, rw [← c.w_assoc, pullback.diagonal_fst_assoc] },
  have : i₂ ≫ pullback.fst = i₂ ≫ pullback.snd,
  { injection @@subsingleton.elim (hf ⟨R, K, i₁, i₂ ≫ pullback.fst ≫ f, c'⟩)
      ⟨i₂ ≫ pullback.fst, _, category.assoc _ _ _⟩ ⟨i₂ ≫ pullback.snd, _, _⟩; dsimp only,
    { rw [← c.w_assoc, pullback.diagonal_fst, category.comp_id] },
    { rw [← c.w_assoc, pullback.diagonal_snd, category.comp_id] },
    { rw [category.assoc, pullback.condition] } },
  refine ⟨⟨⟨i₂ ≫ pullback.fst, _, _⟩⟩⟩; dsimp only,
  { rw [← c.w_assoc, pullback.diagonal_fst, category.comp_id] },
  { apply pullback.hom_ext; simp only [category.assoc, pullback.diagonal_fst, pullback.diagonal_snd,
      category.comp_id, this] }
end

lemma separated.valuative_criterion [separated f] :
  valuative_criterion.uniqueness f :=
begin
  rintro ⟨R, K, i₁, i₂, c⟩,
  constructor,
  rintro ⟨l₁, hl₁, hl₁'⟩ ⟨l₂, hl₂, hl₂'⟩,
  ext1,
  dsimp only at *,
  let h := hl₁'.trans hl₂'.symm,
  have := is_closed_immersion_stable_under_base_change
    (pullback_fst_map_snd_is_pullback f f (pullback.diagonal f)
    (pullback.lift l₁ l₂ h)) infer_instance,
  haveI : is_iso (pullback.diagonal f ≫ pullback.snd),
  { rw [pullback.diagonal_snd], apply_instance },
  rw ← is_closed_immersion_respects_iso.cancel_right_is_iso _ pullback.snd at this,
  swap, { apply_instance },
  rw [pullback.lift_snd, category.comp_id] at this,
  let Z := pullback (pullback.diagonal f) (pullback.lift l₁ l₂ h),
  let g : Z ⟶ _ := pullback.snd,
  change is_closed_immersion g at this,
  resetI,
  haveI : is_affine Z := is_affine_of_affine g,
  have hg₂ := ((is_closed_immersion_over_affine_iff g).mp this).2,
  suffices : is_iso g,
  { resetI,
    refine (pullback.lift_fst l₁ l₂ h).symm.trans (eq.trans _ (pullback.lift_snd l₁ l₂ h)),
    rw [← cancel_epi g, ← pullback.condition_assoc, ← pullback.condition_assoc,
      pullback.diagonal_fst, pullback.diagonal_snd] },
  let l : Scheme.Spec.obj (op $ CommRing.of K) ⟶ Z :=
    pullback.lift i₁ (Scheme.Spec.map (CommRing.of_hom (algebra_map R K)).op) _,
  swap,
  { apply pullback.hom_ext; simp only [pullback.diagonal_fst, pullback.diagonal_snd,
      category.assoc, category.comp_id, pullback.lift_fst, pullback.lift_snd, hl₁, hl₂] },
  have hg : l ≫ g = Scheme.Spec.map (CommRing.of_hom (algebra_map R K)).op := pullback.lift_snd _ _ _,
  have hg₁ := ((morphism_property.injective_respects_iso _).arrow_mk_iso_iff
    (Γ_Spec_arrow_iso $ CommRing.of_hom $ algebra_map R K)).mp (is_fraction_ring.injective R K : _),
  rw [← hg, op_comp, functor.map_comp] at hg₁,
  rw is_iso_respects_iso.arrow_mk_iso_iff (Spec_Γ_arrow_iso_of_is_affine g),
  convert_to is_iso
    (Scheme.Spec.map (ring_equiv.of_bijective _ ⟨hg₁.of_comp, hg₂⟩).to_CommRing_iso.hom.op),
  apply_instance
end

lemma separated_eq_valuative_criterion :
  @separated = @quasi_separated ⊓ valuative_criterion.uniqueness :=
begin
  ext X Y f, split,
  { introI H, exact ⟨infer_instance, separated.valuative_criterion f⟩ },
  { rintro ⟨h₁, h₂⟩, exactI separated_of_valuative_criterion f h₂ }
end

end uniqueness

lemma valuative_criterion_eq :
  valuative_criterion = valuative_criterion.existence ⊓ valuative_criterion.uniqueness :=
begin
  ext X Y f,
  refine (forall_congr _).trans forall_and_distrib,
  intro S,
  split,
  { rintro ⟨h⟩, exactI ⟨⟨⟨h.1.1⟩⟩, infer_instance⟩ },
  { rintro ⟨⟨⟨h₁⟩⟩, _⟩, exactI ⟨⟨⟨h₁⟩, λ _, subsingleton.elim _ _⟩⟩ }
end

lemma proper_eq_valuative_criterion :
  @proper = @quasi_compact ⊓ @quasi_separated ⊓ @locally_of_finite_type ⊓ valuative_criterion :=
begin
  rw [proper_eq, valuative_criterion_eq, separated_eq_valuative_criterion,
    universally_closed_eq_valuative_criterion],
  simp_rw [inf_comm, inf_assoc, inf_left_comm],
  congr' 2,
  rw [inf_comm, inf_assoc]
end

end algebraic_geometry


import for_mathlib.category_theory.abelian.extensions
import for_mathlib.algebra.homology.double

noncomputable theory

open category_theory category_theory.limits category_theory.category derived_category

namespace homological_complex

variables {C ι : Type*} [category C] [has_zero_morphisms C] [has_zero_object C]
  (c : complex_shape ι) (n : ι) [decidable_eq ι]

end homological_complex

variables {C : Type*} [category C] [abelian C]

@[simps]
def category_theory.short_complex.short_exact.extension
  {S : short_complex C} (ex : S.short_exact) :
  category_theory.abelian.extension S.X₃ S.X₁ :=
{ X := S.X₂,
  i := S.f,
  p := S.g,
  w := S.zero,
  ex := begin
    refine (short_complex.short_exact.iff_of_iso _).1 ex,
    exact (short_complex.mk_iso (iso.refl _) (iso.refl _) (iso.refl _) (by tidy) (by tidy)),
  end, }

instance category_theory.preadditive.is_iso_neg {C : Type*} [category C] [preadditive C]
  {X Y : C} (f : X ⟶ Y) [is_iso f] : is_iso (-f) :=
by simpa only [iso.trans_hom, preadditive.mul_iso_hom, units.coe_neg_one, iso.refl_hom,
  neg_smul, one_zsmul, as_iso_hom, preadditive.neg_comp, id_comp]
  using is_iso.of_iso ((preadditive.mul_iso (-1 : units ℤ) (iso.refl X)).trans (as_iso f))

@[simp]
lemma category_theory.preadditive.neg_inv {C : Type*} [category C] [preadditive C]
  {X Y : C} (f : X ⟶ Y) [is_iso f] : inv (-f) = - inv f :=
by rw [← cancel_mono (-f), is_iso.inv_hom_id, preadditive.neg_comp,
  preadditive.comp_neg, neg_neg, is_iso.inv_hom_id]

open category_theory category_theory.limits category_theory.category derived_category

namespace category_theory.abelian

namespace extension

variables {A B : C} (e : extension A B)

def σ := cochain_complex.double.σ (neg_add_self 1) e.w
def ι := cochain_complex.double.ι (neg_add_self 1) e.p
def σ' := cochain_complex.double.σ' (neg_add_self 1) e.w
def π := cochain_complex.double.π (neg_add_self 1) e.i

def homotopy_πσ'_σι : homotopy (e.π ≫ e.σ') (-e.σ ≫ e.ι)  :=
cochain_complex.double.homotopy_πσ'_σι (neg_add_self 1) e.w

instance : quasi_iso e.σ :=
cochain_complex.double.quasi_iso_σ (neg_add_self 1) e.w e.ex

instance : quasi_iso e.σ' :=
cochain_complex.double.quasi_iso_σ' (neg_add_self 1) e.w e.ex

def δ' : (single_functor C 0).obj A ⟶ (single_functor C (-1)).obj B :=
-inv (Q.map e.σ) ≫ Q.map e.π

lemma δ'_eq : e.δ' = -inv (Q.map e.σ) ≫ Q.map e.π := rfl

lemma δ'_eq' : e.δ' = Q.map e.ι ≫ inv (Q.map e.σ') :=
by simp only [δ', ← cancel_epi (Q.map e.σ), ← cancel_mono (Q.map e.σ'), assoc,
  is_iso.hom_inv_id_assoc, preadditive.comp_neg, preadditive.neg_comp, is_iso.inv_hom_id,
  comp_id, ← Q.map_comp, derived_category.Q_map_eq_of_homotopy _ _ e.homotopy_πσ'_σι,
  functor.map_neg, neg_neg]

lemma δ_eq'' : e.δ' = (short_complex.short_exact.extension e.ex).δ' := rfl

def δ : (single_functor C 0).obj A ⟶ ((single_functor C 0).obj B)⟦(1 : ℤ)⟧ :=
e.δ' ≫ (single_functor_shift_iso C 0 1 (-1) (neg_add_self 1)).inv.app B

def triangle : pretriangulated.triangle (derived_category C) :=
pretriangulated.triangle.mk ((single_functor C 0).map e.i) ((single_functor C 0).map e.p) e.δ

@[simps]
def single_short_complex : short_complex (cochain_complex C ℤ) :=
short_complex.mk ((homological_complex.single C _ 0).map e.i)
  ((homological_complex.single C _ 0).map e.p)
  (by rw [← functor.map_comp, e.w, functor.map_zero])

lemma single_short_complex_short_exact : e.single_short_complex.short_exact :=
short_complex.short_exact.map_of_exact e.ex (homological_complex.single C (complex_shape.up ℤ) 0)

def iso_mapping_cone := cochain_complex.double_iso_mapping_cone e.i

lemma compatibility_mapping_cone_σ : e.σ = (cochain_complex.double_iso_mapping_cone e.i).hom ≫
  cochain_complex.from_mapping_cone_of_ses e.single_short_complex_short_exact :=
begin
  refine cochain_complex.from_double_ext (neg_add_self 1) _ _ _ _,
  { dsimp,
    simp only [σ, cochain_complex.from_mapping_cone_of_ses, single_short_complex_g,
      cochain_complex.double.σ_f₁, id_comp, cochain_complex.double.desc.f₁, assoc,
      zero_eq_neg, preadditive.is_iso.comp_left_eq_zero],
    erw [cochain_complex.mapping_cone.inl_desc_v, cochain_complex.hom_complex.cochain.zero_v,
      comp_zero], },
  { dsimp,
    simp only [σ, cochain_complex.from_mapping_cone_of_ses, single_short_complex_g,
      cochain_complex.double.σ_f₂, homological_complex.single_obj_X_self_inv,
      eq_to_hom_refl, comp_id, id_comp, cochain_complex.double.desc.f₂, assoc],
    erw [cochain_complex.mapping_cone.inr_desc_f],
    dsimp,
    simp only [eq_self_iff_true, comp_id, id_comp, if_true], },
end

open cochain_complex.hom_complex

lemma compatibility_mapping_cone_π :
  e.π = -(cochain_complex.double_iso_mapping_cone e.i).hom ≫
  cochain_complex.mapping_cone.δ ((homological_complex.single C _ 0).map e.i) ≫
  (cochain_complex.single_shift_iso C 0 1 (-1) (neg_add_self 1).symm).hom.app B :=
begin
  refine cochain_complex.to_single_ext _ _ (-1) _,
  simp only [π, cochain_complex.mapping_cone.δ, cochain_complex.double.π_f, eq_to_hom_refl,
    cochain_complex.double.desc.f₁, comp_id, homological_complex.single_obj_X_self_inv,
    id_comp, cochain_complex.double_iso_mapping_cone_hom, homological_complex.neg_f_apply,
    homological_complex.comp_f, cochain_complex.double.desc_f,
    cochain_complex.hom_complex.cocycle.hom_of_f,
    cochain_complex.hom_complex.cocycle.right_shift_coe,
    cochain_complex.mapping_cone.δ_as_cocycle_coe, assoc,
    cochain_complex.hom_complex.cochain.right_shift_v _ 1 0
      (zero_add 1).symm (-1) (-1) (by linarith) 0 (neg_add_self 1).symm, cochain.neg_v,
    preadditive.neg_comp, preadditive.comp_neg, neg_neg],
  erw cochain_complex.mapping_cone.inl_fst_assoc,
  dsimp [cochain_complex.double.X_iso₁, homological_complex.X_iso_of_eq, iso.refl,
    cochain_complex.single_shift_iso, cochain_complex.single_shift_iso_app],
  simp only [cochain_complex.lift_single_f, id_comp],
  erw [id_comp, id_comp],
  refl,
end

lemma δ_eq_triangle_of_ses_δ :
  e.δ = triangle_of_ses_δ e.single_short_complex_short_exact :=
begin
  dsimp [triangle_of_ses_δ, δ, δ', mapping_cone_triangle],
  simp only [← cancel_epi (Q.map (cochain_complex.from_mapping_cone_of_ses
    e.single_short_complex_short_exact)), is_iso.hom_inv_id_assoc,
    ← Q.map (cochain_complex.double_iso_mapping_cone e.i).hom,
    preadditive.neg_comp, preadditive.comp_neg,
    e.compatibility_mapping_cone_σ, functor.map_neg, Q.map_comp, preadditive.neg_inv,
    is_iso.inv_comp, neg_neg, assoc,
    ← cancel_epi (Q.map (cochain_complex.double_iso_mapping_cone e.i).hom), mapping_cone_δ,
    ← cancel_mono ((Q.comm_shift_iso (1 : ℤ)).inv.app ((homological_complex.single C _ 0).obj B)),
    iso.hom_inv_id_app, single_functor_shift_iso_inv_app, compatibility_mapping_cone_π],
    erw [← Q.map_comp, iso.hom_inv_id_app, Q.map_id],
    refl,
end

lemma triangle_iso : e.triangle ≅ triangle_of_ses e.single_short_complex_short_exact :=
pretriangulated.triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) (by tidy) (by tidy)
  (by { dsimp [triangle], simp only [category_theory.functor.map_id, comp_id,
    id_comp, δ_eq_triangle_of_ses_δ], })

lemma triangle_distinguished : e.triangle ∈ dist_triang (derived_category C) :=
pretriangulated.isomorphic_distinguished _ (triangle_of_ses_dist _) _ e.triangle_iso

lemma iso_of_triangle_map (e₁ e₂ : extension A B)
  (φ : e₁.triangle ⟶ e₂.triangle) (hφ₁ : φ.hom₁ = 𝟙 _) (hφ₃ : φ.hom₃ = 𝟙 _) : e₁ ≅ e₂ :=
as_iso begin
  have eq₁ := φ.comm₁,
  have eq₂ := φ.comm₂,
  dsimp only [triangle] at eq₁ eq₂,
  simp only [pretriangulated.triangle.mk_mor₁, hφ₁] at eq₁,
  erw id_comp at eq₁,
  simp only [pretriangulated.triangle.mk_mor₂, hφ₃] at eq₂,
  erw comp_id at eq₂,
  refine extension.hom.mk' ((single_functor C 0).preimage φ.hom₂) _ _,
  { apply (single_functor C 0).map_injective,
    rw [functor.map_comp, functor.image_preimage, eq₁], },
  { apply (single_functor C 0).map_injective,
    rw [functor.map_comp, functor.image_preimage, eq₂], },
end

section naturality

variables {S₁ S₂ : short_complex C} (φ : S₁ ⟶ S₂)
  (ex₁ : S₁.short_exact) (ex₂ : S₂.short_exact)

include φ ex₁ ex₂

@[reassoc]
lemma σ_naturality :
  ex₁.extension.σ ≫ (homological_complex.single C _ 0).map φ.τ₃ =
    cochain_complex.double.map (neg_add_self 1) S₁.f S₂.f φ.τ₁ φ.τ₂ φ.comm₁₂.symm ≫
      ex₂.extension.σ :=
begin
  refine cochain_complex.to_single_ext _ _ 0 _,
  { dsimp only [short_complex.short_exact.extension, extension.σ],
    simp only [homological_complex.comp_f, cochain_complex.double.σ_f₂,
      homological_complex.single_obj_X_self_inv, eq_to_hom_refl,
      comp_id, homological_complex.single_map_f_self, homological_complex.single_obj_X_self_hom,
      assoc, cochain_complex.double.map_f₂, iso.inv_hom_id_assoc, iso.cancel_iso_hom_left,
      φ.comm₂₃],
    erw id_comp, },
end

@[reassoc]
lemma π_naturality :
  ex₁.extension.π ≫ (homological_complex.single C _ (-1 : ℤ)).map φ.τ₁ =
    cochain_complex.double.map (neg_add_self 1) S₁.f S₂.f φ.τ₁ φ.τ₂ φ.comm₁₂.symm ≫
    ex₂.extension.π :=
begin
  refine cochain_complex.to_single_ext _ _ (-1) _,
  { dsimp only [short_complex.short_exact.extension, extension.π],
    simp only [homological_complex.comp_f, cochain_complex.double.π_f, eq_to_hom_refl,
      cochain_complex.double.desc.f₁, comp_id, homological_complex.single_map_f_self,
      homological_complex.single_obj_X_self_hom, homological_complex.single_obj_X_self_inv,
      cochain_complex.double.map_f₁, assoc, iso.inv_hom_id, iso.cancel_iso_hom_left],
    apply id_comp, },
end

@[reassoc]
lemma δ'_naturality :
  ex₁.extension.δ' ≫ (single_functor C (-1)).map φ.τ₁ =
    (single_functor C 0).map φ.τ₃ ≫ ex₂.extension.δ' :=
begin
  dsimp only [extension.δ', single_functor, functor.comp_map],
  have hσ := Q.congr_map (σ_naturality φ ex₁ ex₂),
  have hπ := Q.congr_map (π_naturality φ ex₁ ex₂),
  simp only [Q.map_comp, ← cancel_mono (inv (Q.map ex₂.extension.σ)), assoc,
    is_iso.hom_inv_id, comp_id] at hσ,
  simp only [Q.map_comp] at hπ,
  simp only [← cancel_epi (Q.map ex₁.extension.σ), assoc, is_iso.hom_inv_id_assoc,
    hπ, ← hσ, preadditive.comp_neg, preadditive.neg_comp],
end

@[reassoc]
lemma δ_naturality :
  ex₁.extension.δ ≫ ((single_functor C 0).map φ.τ₁)⟦1⟧' =
    (single_functor C 0).map φ.τ₃ ≫ ex₂.extension.δ :=
begin
  dsimp only [extension.triangle, pretriangulated.triangle.mk, extension.δ],
  simpa only [← δ'_naturality_assoc φ ex₁ ex₂, assoc, nat_trans.naturality],
end

@[simps]
def triangle_map : ex₁.extension.triangle ⟶ ex₂.extension.triangle :=
{ hom₁ := (single_functor C 0).map φ.τ₁,
  hom₂ := (single_functor C 0).map φ.τ₂,
  hom₃ := (single_functor C 0).map φ.τ₃,
  comm₁' := by simpa only [functor.map_comp] using (single_functor C 0).congr_map φ.comm₁₂.symm,
  comm₂' := by simpa only [functor.map_comp] using (single_functor C 0).congr_map φ.comm₂₃.symm,
  comm₃' := δ_naturality φ ex₁ ex₂, }

end naturality

end extension

namespace extensions

variables {A B : C} (e : extension A B)

def δ : extensions A B → ((single_functor C 0).obj A ⟶
  ((single_functor C 0).obj B)⟦(1 : ℤ)⟧) :=
quot.lift extension.δ begin
  rintros E₁ E₂ ⟨e⟩,
  have eq := extension.δ_naturality
    ((extension.to_short_exact_sequence_functor A B).map e.hom) E₁.ex E₂.ex,
  dsimp at eq,
  simpa only [category_theory.functor.map_id, id_comp, comp_id] using eq,
end

variable (C)

@[simps]
def δ_nat_trans : extensions_functor C ⟶
  ((single_functor C 0).op ⋙ (single_functor C 0 ⋙ shift_functor _ (1 : ℤ) ⋙ yoneda).flip).flip :=
{ app := λ B,
  { app := λ A, extensions.δ,
    naturality' := λ A₁ A₂ π, begin
      ext e,
      obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' e,
      have eq := extension.δ_naturality (E.pull_short_complex π.unop)
        ((E.pull π.unop).ex) E.ex,
      dsimp at eq,
      simpa only [category_theory.functor.map_id, comp_id] using eq,
    end, },
  naturality' := begin
    rintro B₁ B₂ ι,
    ext A e,
    obtain ⟨E, rfl⟩ := quotient.surjective_quotient_mk' e,
    have eq := extension.δ_naturality (E.push_short_complex ι) E.ex (E.push ι).ex,
    dsimp at eq,
    simpa only [category_theory.functor.map_id, id_comp] using eq.symm,
  end, }

variables {C}

lemma δ_nat_trans_surjective'
  (φ : (single_functor C 0).obj A ⟶ ((single_functor C 0).obj B)⟦(1 : ℤ)⟧) :
  ∃ (e : extension A B), φ = e.δ :=
begin
  obtain ⟨φ, rfl⟩ : ∃ (φ' : (single_functor C 0).obj A ⟶ (single_functor C (-1)).obj B),
    φ = φ' ≫ (single_functor_shift_iso C 0 1 (-1) (neg_add_self 1)).inv.app B,
  { refine ⟨φ ≫ (single_functor_shift_iso C 0 1 (-1) (neg_add_self 1)).hom.app B, _⟩,
    simp only [assoc, iso.hom_inv_id_app],
    erw comp_id, },
  suffices : ∃ (E' A' : C) (f' : A ⟶ A') (i' : B ⟶ E') (p' : E' ⟶ A') (w : i' ≫ p' = 0)
    (ex : (short_complex.mk _ _ w).short_exact),
      φ ≫ Q.map ex.extension.σ' = (single_functor C 0).map f' ≫ Q.map ex.extension.ι,
  { obtain ⟨E', A', f', i', p', w, ex, z⟩ := this,
    refine ⟨ex.extension.pull f', _⟩,
    have eq := extension.δ_naturality (ex.extension.pull_short_complex f')
      (ex.extension.pull f').ex ex.extension.ex,
    simp only [extension.pull_short_complex, category_theory.functor.map_id, comp_id] at eq,
    refine trans _ eq.symm,
    dsimp only [extension.δ],
    rw ← assoc,
    congr' 1,
    erw [extension.δ'_eq', ← cancel_mono (Q.map ex.extension.σ'), assoc, assoc, is_iso.inv_hom_id,
      comp_id],
    exact z, },
  haveI : cochain_complex.is_strictly_le ((homological_complex.single C
    (complex_shape.up ℤ) (-1)).obj B) 0 :=
      cochain_complex.is_strictly_le_of_le _ (-1) 0 (by linarith),
  obtain ⟨E', A', p', f, s, hs, eq⟩ : ∃ (B' E' : C) (i' : B' ⟶ E')
   (f : (homological_complex.single C _ 0).obj A ⟶ cochain_complex.double (neg_add_self 1) i')
   (s : (homological_complex.single C _ (-1)).obj B ⟶ cochain_complex.double (neg_add_self 1) i')
   (hs : quasi_iso s), by { haveI := hs, exact φ = Q.map f ≫ inv (Q.map s), },
  { obtain ⟨L', L'_le, L'_ge, f, s, hs, hφ⟩ :=
      left_factorisation_of_is_strictly_le_of_is_strictly_ge φ 0 (-1),
    haveI := L'_le,
    obtain ⟨E', A', p', ⟨e⟩⟩ := cochain_complex.exists_iso_double (neg_add_self 1) L',
    refine ⟨E', A', p', f ≫ e.hom, s ≫ e.hom, infer_instance, _⟩,
    simp only [hφ, Q.map_comp, is_iso.inv_comp, assoc, is_iso.hom_inv_id_assoc], },
  obtain ⟨f', rfl⟩ := cochain_complex.eq_single_to_double' f,
  obtain ⟨i', w, hs'⟩ := cochain_complex.eq_single_to_double s,
  refine ⟨E', A', f', i', p', w, _, _⟩,
  { simpa only [hs', cochain_complex.single_to_double_quasi_iso_iff] using hs, },
  { dsimp only [single_functor, functor.comp_map],
    rw ← Q.map_comp,
    haveI := hs,
    simp only [← cancel_mono (Q.map s), assoc, is_iso.inv_hom_id, comp_id, hs'] at eq,
    convert eq,
    refine cochain_complex.from_single_ext _ _ 0 _,
    dsimp [short_complex.short_exact.extension, extension.ι],
    simp only [eq_self_iff_true, comp_id, id_comp, if_true, cochain_complex.double.lift.f₂,
      cochain_complex.desc_single_f],
    erw id_comp, },
end

lemma _root_.category_theory.abelian.extension.δ_eq_iff (e₁ e₂ : extension A B) :
  (e₁.δ = e₂.δ) ↔ nonempty (e₁ ≅ e₂) :=
begin
  split,
  { intro h,
    obtain ⟨β, hβ₁, hβ₂⟩ := pretriangulated.complete_distinguished_triangle_morphism₂ _ _
      e₁.triangle_distinguished e₂.triangle_distinguished (𝟙 _) (𝟙 _)
      (by simpa only [category_theory.functor.map_id, comp_id, id_comp] using h),
    let γ : e₁.triangle ⟶ e₂.triangle :=
    { hom₁ := 𝟙 _,
      hom₂ := β,
      hom₃ := 𝟙 _, },
    exact ⟨extension.iso_of_triangle_map e₁ e₂ γ rfl rfl⟩, },
  { rintro ⟨h⟩,
    change extensions.δ (quot.mk _ e₁) = extensions.δ (quot.mk _ e₂),
    congr' 1,
    exact quot.sound ⟨h⟩, },
end

variables (A B)

lemma δ_nat_trans_bijective :
  function.bijective (@extensions.δ _ _ _ A B) :=
begin
  split,
  { rintros ⟨e₁⟩ ⟨e₂⟩ (h : e₁.δ = e₂.δ),
    rw extension.δ_eq_iff at h,
    exact quot.sound h, },
  { intro φ,
    obtain ⟨e, rfl⟩ := δ_nat_trans_surjective' φ,
    exact ⟨quotient.mk' e, rfl⟩, },
end

instance : is_iso (δ_nat_trans C) :=
begin
  haveI : ∀ (A : C), is_iso ((δ_nat_trans C).app A),
  { intro A,
    haveI : ∀ (B : Cᵒᵖ), is_iso (((δ_nat_trans C).app A).app B),
    { intro B,
      rw is_iso_iff_bijective,
      apply δ_nat_trans_bijective, },
    apply nat_iso.is_iso_of_is_iso_app, },
  apply nat_iso.is_iso_of_is_iso_app,
end

variable (C)

@[simps]
def δ_nat_iso := as_iso (δ_nat_trans C)

end extensions

namespace extension

variables (A B : C)

@[simp]
lemma trivial.δ : (trivial A B).δ = 0 :=
begin
  haveI : is_split_epi (abelian.extension.trivial A B).triangle.mor₂ := is_split_epi.mk'
  { section_ := Q.map ((homological_complex.single _ _ _).map biprod.inr),
    id' := begin
      erw [← functor.map_comp, ← functor.map_comp, biprod.inr_snd,
        category_theory.functor.map_id, category_theory.functor.map_id],
      refl,
    end, },
  simpa only [← cancel_epi (abelian.extension.trivial A B).triangle.mor₂, comp_zero]
    using pretriangulated.triangle.comp_zero₂₃ _ (trivial A B).triangle_distinguished,
end

variables {A B}

lemma δ_eq_zero_iff (e : extension A B) : e.δ = 0 ↔ nonempty (e ≅ trivial A B) :=
by simp only [← extension.δ_eq_iff, trivial.δ]

lemma δ_neq_zero_iff (e : extension A B) : e.δ ≠ 0 ↔ is_empty (e ≅ trivial A B) :=
by simpa only [not_nonempty_iff] using e.δ_eq_zero_iff.not

end extension

end category_theory.abelian


import dnf

namespace first_order

section quantifier_elimination

variables {L : language} (A : Type) (Γ : list (formula L)) {φ φ₁ φ₂ ψ : formula L} {p q : formula L}
variable [has_coe A (formula L)]

/- If a formula φ has has quantifier elimination in a theory -/
@[simp]
def equiv_qf (φ : formula L) := ∃ ψ : qf L, (A∣[] ⊢ φ) ↔ (A∣[] ⊢ (ψ : formula L))

def Eq_equiv_qf {A : Type} [has_coe A (formula L)] : ((A∣[] ⊢ p) ↔ (A∣[] ⊢ q)) → (equiv_qf A p → equiv_qf A q) := begin
   intros h₁ h₂,
   rcases h₂ with ⟨φ₃, h₃⟩,
   existsi φ₃,
   split,
   intro h₄,
   apply h₃.mp (h₁.mpr h₄),
   intro h₄,
   apply h₁.mp (h₃.mpr h₄),
end

/- If a theory Γ has quantifier elimination -/
@[simp]
def qe := ∀ (φ : formula L), equiv_qf A φ

/- If a theory Γ has quantifier elimination on conjunctions of literals with
   with a single existential quantifier -/
def qe_ecl1 := ∀ (φ : ecl1 L), equiv_qf A (φ : formula L)

/- If a theory Γ has quantifier elimination on disjunctions of conjunctions
   of literals with a single existential quantifier -/
def qe_edcl1 := ∀ (φ : edcl1 L), equiv_qf A (φ : formula L)

/- If a theory Γ has quantifier elimination on disjunctions of conjugations
   of literals with a single quantifier -/
@[simp]
def qe_qdcl1 := ∀ (φ : qdcl1 L), equiv_qf A (φ : formula L)

@[simp]
def qe_dnf := ∀ (φ : dnf L), equiv_qf A (φ : formula L)

/- If a theory Γ has quantifier elimination on quantifier free formulas -/
@[simp]
def qe_qf := ∀ (φ : qf L), equiv_qf A (φ : formula L)

/- All theories have quantifier elimination on quantifier free formulas -/
def for_all_qe_qf : @qe_qf L A _ := by { intros φ, existsi φ, refl }

/- If a theory has quantifier elimination on φ₁ φ₂ then it has quantifier
   elimination on (φ₁ or φ₂) -/
lemma equiv_qf_or_equiv_qf : equiv_qf A φ₁ → equiv_qf A φ₂ → equiv_qf A (φ₁ or φ₂) := begin
   intros h_φ₁ h_φ₂,
   rcases h_φ₁ with ⟨φ₁', h₁⟩,
   rcases h_φ₂ with ⟨φ₂', h₂⟩,
   apply Eq_equiv_qf (R_Eq_Or_ ⟨h₁.mpr, h₁.mp⟩ ⟨h₂.mpr, h₂.mp⟩),
   existsi (qf.o φ₁' φ₂'), refl,
end

lemma qe_ecl1_qe_edcl1 : (∀ x : ℕ, @var_not_free_in_axioms L x A _) → ((@qe_ecl1 L A _) → (@qe_edcl1 L A _)) := begin
   intros h h₁ φ,
   cases φ,
   {  existsi (φ : qf L), refl, },
   {  induction φ_ᾰ_1,
      rcases (h₁ (ecl1.ex φ_ᾰ φ_ᾰ_1)) with ⟨φ₂, h₂⟩,
      apply Eq_equiv_qf ⟨h₂.mpr, h₂.mp⟩,
      existsi φ₂, refl,
      rcases φ_ᾰ_1_ih_ᾰ with ⟨φ₂, h₂⟩,
      rcases φ_ᾰ_1_ih_ᾰ_1 with ⟨φ₃, h₃⟩,
      apply Eq_equiv_qf ⟨R_ (ExOrOut (h φ_ᾰ)), R_ (ExOrIn (h φ_ᾰ))⟩,
      apply Eq_equiv_qf (R_Eq_Or_ ⟨h₂.mpr, h₂.mp⟩ ⟨h₃.mpr, h₃.mp⟩),
      existsi qf.o φ₂ φ₃, refl,
   },
end

lemma qe_edcl1_qe_qdcl1 : (@qe_edcl1 L A _) → (@qe_qdcl1 L A _) := begin
   intros h₁ φ,
   induction φ,
   {  existsi (φ : qf L), refl, },
   {
      rcases (qf_equiv_dcl A (qf.n ↑φ_ᾰ_1)) with ⟨φ₂, h₂⟩,
      apply Eq_equiv_qf ⟨R_ Ex_To_All, R_ All_To_Ex⟩,
      apply Eq_equiv_qf
         (R_Eq_Not_ (R_Eq_Ex_ ⟨h₂.mpr, h₂.mp⟩)),
      rcases (h₁ (edcl1.ex φ_ᾰ φ₂)) with ⟨φ₃, h₃⟩,
      apply Eq_equiv_qf (R_Eq_Not_ ⟨h₃.mpr, h₃.mp⟩),
      existsi (qf.n φ₃), refl,
   },
   {  rcases (h₁ (edcl1.ex φ_ᾰ φ_ᾰ_1)) with ⟨φ₂, h₂⟩,
      apply Eq_equiv_qf ⟨h₂.mpr, h₂.mp⟩,
      existsi φ₂, refl,
   }
end

lemma qe_qdcl1_qe_dnf : (@qe_qdcl1 L A _) → (@qe_dnf L A _) := begin
   intros h₁ φ₁,
   induction φ₁,
   {  existsi (φ₁ : qf L), refl, },
   {  cases φ₁_ᾰ_1,
      {  rcases (h₁ (qdcl1.al φ₁_ᾰ φ₁_ᾰ_1)) with ⟨φ₂, h₂⟩,
         apply Eq_equiv_qf ⟨h₂.mpr, h₂.mp⟩,
         existsi φ₂, refl, },
      all_goals {  rcases φ₁_ih with ⟨φ₂, h₂⟩,
         apply Eq_equiv_qf (R_Eq_All_ ⟨h₂.mpr, h₂.mp⟩),
         rcases (qf_equiv_dcl A φ₂) with ⟨φ₃, h₃⟩,
         apply Eq_equiv_qf (R_Eq_All_ ⟨h₃.mpr, h₃.mp⟩),
         rcases (h₁ (qdcl1.al φ₁_ᾰ φ₃)) with ⟨φ₄, h₄⟩,
         apply Eq_equiv_qf ⟨h₄.mpr, h₄.mp⟩,
         existsi φ₄, refl,
      },
   },
   {  induction φ₁_ᾰ_1,
      {  rcases (h₁ (qdcl1.ex φ₁_ᾰ φ₁_ᾰ_1)) with ⟨φ₂, h₂⟩,
         apply Eq_equiv_qf ⟨h₂.mpr, h₂.mp⟩,
         existsi φ₂, refl, },
      all_goals {  rcases φ₁_ih with ⟨φ₂, h₂⟩,
         apply Eq_equiv_qf (R_Eq_Ex_ ⟨h₂.mpr, h₂.mp⟩),
         rcases (qf_equiv_dcl A φ₂) with ⟨φ₃, h₃⟩,
         apply Eq_equiv_qf (R_Eq_Ex_ ⟨h₃.mpr, h₃.mp⟩),
         rcases (h₁ (qdcl1.ex φ₁_ᾰ φ₃)) with ⟨φ₄, h₄⟩,
         apply Eq_equiv_qf ⟨h₄.mpr, h₄.mp⟩,
         existsi φ₄, refl,
      },
   }
end

/- If a theory has quantifer elimination on conjunctions of literals with
   a single existential quantifier, it has quantifier elimination -/
lemma qe_ecl1_qe : (∀ x : ℕ, @var_not_free_in_axioms L x A _) → ((@qe_ecl1 L A _) → (@qe L A _)) := begin
   intros h₁ h₂,
   have h_dnf : qe_dnf A :=
      by { apply qe_qdcl1_qe_dnf, apply qe_edcl1_qe_qdcl1,
           apply qe_ecl1_qe_edcl1 A h₁, assumption },
   intro φ₁,
   rcases (for_all_equiv_dnf A φ₁) with ⟨φ₂, h₂⟩,
   apply Eq_equiv_qf ⟨h₂.mpr, h₂.mp⟩,
   rcases (h_dnf φ₂) with ⟨φ₃, h₃⟩,
   apply Eq_equiv_qf ⟨h₃.mpr, h₃.mp⟩,
   existsi φ₃, refl,
end

/- Deciable sentences in a theory -/
--def decidable_sent (φ : sentence L) : Prop
--   := ((A∣[] ⊢ (φ : formula L)) ↔ (A∣Γ ⊢ F)) ∨ ((A∣[] ⊢ φ) ↔ (A∣Γ ⊢ T))

end quantifier_elimination

end first_order


import parlang

/- IDEA: try to remove the active map from the assertions -/

namespace parlang

open kernel

-- notation ac ` ⇃ ` c ` ◂ `  x:(foldr ` ◂ ` (h t, deactivate_threads c ac h) ac) := x
notation ac ` ⇃ ` c ` ◂ `  s := deactivate_threads c ac s

example {σ₁ ι₁ ι₂ : Type} {τ₁ : ι₁ → Type} {τ₂ : ι₂ → Type} [decidable_eq ι₁] [decidable_eq ι₂] :
{* λ n₁ s₁ ac₁ n₂ (s₂ : state n₂ (memory (λ (n: string), ℕ)) τ₂) ac₂, 0 < n₂ ∧ all_threads_active ac₂ *}
@kernel.compute ι₁ σ₁ τ₁ id ~> kernel.ite (λm, m.get "tid" = 1) (kernel.compute (λ m, m.update "x" 1)) (kernel.compute (λm, m.update "x" 0))
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, ∀ (h : 0 < n₂), (s₂.threads.nth ⟨0, h⟩).tlocal.get "x" = 1 *} := begin
    suffices : {* λ n₁ s₁ ac₁ n₂ (s₂ : state n₂ (memory (λ (n: string), ℕ)) τ₂) ac₂, 0 < n₂ ∧ (λac₂, all_threads_active ac₂) ac₂ *}
        @kernel.compute ι₁ σ₁ τ₁ id ~> kernel.ite (λm, m.get "tid" = 1) (kernel.compute (λ m, m.update "x" 1)) (kernel.compute (λm, m.update "x" 0))
    {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, (∀ (h : 0 < n₂), (s₂.threads.nth ⟨0, h⟩).tlocal.get "x" = 1) ∧ (λac₂, all_threads_active ac₂) ac₂ *},
    {
        apply consequence,
        exact this,
        simp,
        intros,
        exact ⟨a, a_1⟩,
        intros,
        exact (a.left) h,
    },
    apply ite_right,
    swap 7,
    exact (λn₁ s₁ ac₁ n₂ s₂ ac₂, ∀ (h : 0 < n₂), (s₂.threads.nth ⟨0, h⟩).tlocal.get "x" = 1),
    {
        intros,
        simp *,
    }, {
        intros,
        exact a,
    }, {
        intros,
        exact a,
    }, {
        intros,
        exact a h,
    }, {
        apply consequence_pre,
        apply compute_right,
        intros _ _ _ _ _ _ hp _,
        rw state.map_active_threads_nth_ac,
        refl,
        sorry,
    }, {
        apply consequence_pre,
        apply compute_right,
        intros _ _ _ _ _ _ hp _,
        rw ← state.map_active_threads_nth_inac,
        exact hp.left h,
        sorry,
    }
end

section

parameters (k : kernel bool (λ (s : string), ℕ))

def p₁ : program bool (λ (s : string), ℕ) :=
program.intro (λm, m.get "x") (
    compute (λ_, tt) ;;
    ite id (
        k
    ) (
        store (λ_, ⟨"a", 5⟩)
    )
)

def p₂ : program bool (λ (s : string), ℕ) :=
program.intro (λm, m.get "x") (
    compute (λ_, tt) ;;
    k
)

example : rel_hoare_program (λ_, ff) (λ_, ff) (λ m₁ m₂, eq m₁ m₂ ∧ 0 < m₁.get "x") p₁ p₂ eq := begin
    apply rel_kernel_to_program,
    apply single_step_left,
    swap,
    apply single_step_right,
    swap,
    {
        apply known_branch_left,
        swap,
        {
            apply consequence,
            apply rhl_eq,
            swap,
            {intros,
            cases a_1 with m₁,
            use m₁,
            use m₁,
            split,
            assumption,
            cases a,
            subst a_left,
            specialize a_right rfl,
            cases a_right,
            subst a_right_left,
            split,
            exact a_1_h,
            refl,},
            intros,
            have : (∀ (tid : fin n₁), id ((vector.nth (s₁.threads) tid).tlocal) = tt) ∧ n₁ = n₂ ∧ ∀ h : n₁ = n₂, s₁ = (by rw h; exact s₂) ∧ ac₁ = (by rw h; exact ac₂) := a,
            exact this.right,
        },
        intros,
        exact a.left tid,
    },
    apply compute_right,
    {
        apply consequence_pre,
        apply swap (compute_right _),
        {
            intros,
            use s₁,
            apply exec_skip,
        }, {
            intros _ _ _ _ _ _ h,
            simp[assertion_swap_side],
            cases h with m₁ h,
            cases h with m₂ h,
            cases h with h₁ h,
            cases h with h₂ h,
            cases h with h₃ h,
            cases h with h₄ h,
            cases h with h₅ h,
            cases h with h₆ h,
            cases h with h₇ h,
            cases h with h₈ h₉,
            split,
            {
                intro tid,
                rw state.map_active_threads_nth_ac,
                refl,
                apply all_threads_active_nth h₈,
            },
            split,
            {
                cases h₇,
                subst h₇_left,
                rw [h₃, ← h₄],
            },
            intro h',
            subst h',
            split, {
                rw eq.mpr.intro,
                unfold state.map_active_threads,
                simp,
                apply vector.eq_element_wise,
                intro i,
                simp,
                have : ac₁ = ac₂ := all_threads_active_eq h₈ h₉,
                subst this,
                rw h₆,
                rw h₅,
                cases h₇,
                subst h₇_left,
            }, {
                have : ac₁ = ac₂ := all_threads_active_eq h₈ h₉,
                exact this,
            }
        }
    }, {
        intros,
        exact a.right,
    }
end

end

end parlang