/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.limits.creates
import category_theory.sites.sheafification

/-!

# Limits and colimits of sheaves

## Limits

We prove that the forgetful functor from `Sheaf J D` to presheaves creates limits.
If the target category `D` has limits (of a certain shape),
this then implies that `Sheaf J D` has limits of the same shape and that the forgetful
functor preserves these limits.

## Colimits

Given a diagram `F : K ⥤ Sheaf J D` of sheaves, and a colimit cocone on the level of presheaves,
we show that the cocone obtained by sheafifying the cocone point is a colimit cocone of sheaves.

This allows us to show that `Sheaf J D` has colimits (of a certain shape) as soon as `D` does.

-/
namespace category_theory
namespace Sheaf

open category_theory.limits
open opposite

section limits

universes w v u z
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]
variables {K : Type z} [small_category K]

noncomputable theory

section

/-- An auxiliary definition to be used below.

Whenever `E` is a cone of shape `K` of sheaves, and `S` is the multifork associated to a
covering `W` of an object `X`, with respect to the cone point `E.X`, this provides a cone of
shape `K` of objects in `D`, with cone point `S.X`.

See `is_limit_multifork_of_is_limit` for more on how this definition is used.
-/
def multifork_evaluation_cone (F : K ⥤ Sheaf J D)
  (E : cone (F ⋙ Sheaf_to_presheaf J D)) (X : C) (W : J.cover X) (S : multifork (W.index E.X)) :
  cone (F ⋙ Sheaf_to_presheaf J D ⋙ (evaluation Cᵒᵖ D).obj (op X)) :=
{ X := S.X,
  π :=
  { app := λ k, (presheaf.is_limit_of_is_sheaf J (F.obj k).1 W (F.obj k).2).lift $
      multifork.of_ι _ S.X (λ i, S.ι i ≫ (E.π.app k).app (op i.Y)) begin
        intros i,
        simp only [category.assoc],
        erw [← (E.π.app k).naturality, ← (E.π.app k).naturality],
        dsimp,
        simp only [← category.assoc],
        congr' 1,
        apply S.condition,
      end,
    naturality' := begin
      intros i j f,
      dsimp [presheaf.is_limit_of_is_sheaf],
      rw [category.id_comp],
      apply presheaf.is_sheaf.hom_ext (F.obj j).2 W,
      intros ii,
      rw [presheaf.is_sheaf.amalgamate_map, category.assoc, ← (F.map f).val.naturality,
        ← category.assoc, presheaf.is_sheaf.amalgamate_map],
      dsimp [multifork.of_ι],
      erw [category.assoc, ← E.w f],
      tidy,
    end } }

variables [has_limits_of_shape K D]

/-- If `E` is a cone of shape `K` of sheaves, which is a limit on the level of presheves,
this definition shows that the limit presheaf satisfies the multifork variant of the sheaf
condition, at a given covering `W`.

This is used below in `is_sheaf_of_is_limit` to show that the limit presheaf is indeed a sheaf.
-/
def is_limit_multifork_of_is_limit (F : K ⥤ Sheaf J D)
  (E : cone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_limit E) (X : C) (W : J.cover X) : is_limit (W.multifork E.X) :=
multifork.is_limit.mk _
(λ S, (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).lift $
  multifork_evaluation_cone F E X W S)
begin
  intros S i,
  apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op i.Y)) hE).hom_ext,
  intros k,
  dsimp [multifork.of_ι],
  erw [category.assoc, (E.π.app k).naturality],
  dsimp,
  rw ← category.assoc,
  erw (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac
    (multifork_evaluation_cone F E X W S),
  dsimp [multifork_evaluation_cone, presheaf.is_limit_of_is_sheaf],
  erw presheaf.is_sheaf.amalgamate_map,
  refl,
end
begin
  intros S m hm,
  apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).hom_ext,
  intros k,
  dsimp,
  erw (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac,
  apply presheaf.is_sheaf.hom_ext (F.obj k).2 W,
  intros i,
  erw presheaf.is_sheaf.amalgamate_map,
  dsimp [multifork.of_ι],
  change _ = S.ι i ≫ _,
  erw [← hm, category.assoc, ← (E.π.app k).naturality, category.assoc],
  refl,
end

/-- If `E` is a cone which is a limit on the level of presheaves,
then the limit presheaf is again a sheaf.

This is used to show that the forgetful functor from sheaves to presheaves creates limits.
-/
lemma is_sheaf_of_is_limit (F : K ⥤ Sheaf J D) (E : cone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_limit E) : presheaf.is_sheaf J E.X :=
begin
  rw presheaf.is_sheaf_iff_multifork,
  intros X S,
  exact ⟨is_limit_multifork_of_is_limit _ _ hE _ _⟩,
end

instance (F : K ⥤ Sheaf J D) : creates_limit F (Sheaf_to_presheaf J D) :=
creates_limit_of_reflects_iso $ λ E hE,
{ lifted_cone := ⟨⟨E.X, is_sheaf_of_is_limit _ _ hE⟩,
    ⟨λ t, ⟨E.π.app _⟩, λ u v e, Sheaf.hom.ext _ _ $ E.π.naturality _⟩⟩,
  valid_lift := cones.ext (eq_to_iso rfl) $ λ j, by { dsimp, simp },
  makes_limit :=
  { lift := λ S, ⟨hE.lift ((Sheaf_to_presheaf J D).map_cone S)⟩,
    fac' := λ S j, by { ext1, apply hE.fac ((Sheaf_to_presheaf J D).map_cone S) j },
    uniq' := λ S m hm, begin
      ext1,
      exact hE.uniq ((Sheaf_to_presheaf J D).map_cone S) m.val (λ j, congr_arg hom.val (hm j)),
    end } }

instance : creates_limits_of_shape K (Sheaf_to_presheaf J D) := {}

instance : has_limits_of_shape K (Sheaf J D) :=
has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (Sheaf_to_presheaf J D)

end

instance [has_limits D] : creates_limits (Sheaf_to_presheaf J D) := ⟨⟩

instance [has_limits D] : has_limits (Sheaf J D) :=
has_limits_of_has_limits_creates_limits (Sheaf_to_presheaf J D)

end limits

section colimits

universes w v u
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]
variables {K : Type (max v u)} [small_category K]
-- Now we need a handful of instances to obtain sheafification...
variables [concrete_category.{max v u} D]
variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
variables [preserves_limits (forget D)]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
variables [reflects_isomorphisms (forget D)]

/-- Construct a cocone by sheafifying a cocone point of a cocone `E` of presheaves
over a functor which factors through sheaves.
In `is_colimit_sheafify_cocone`, we show that this is a colimit cocone when `E` is a colimit. -/
@[simps]
def sheafify_cocone {F : K ⥤ Sheaf J D} (E : cocone (F ⋙ Sheaf_to_presheaf J D)) : cocone F :=
{ X := ⟨J.sheafify E.X, grothendieck_topology.plus.is_sheaf_plus_plus _ _⟩,
  ι :=
  { app := λ k, ⟨E.ι.app k ≫ J.to_sheafify E.X⟩,
    naturality' := λ i j f, by { ext1, dsimp, erw [category.comp_id, ← category.assoc, E.w f] } } }

/-- If `E` is a colimit cocone of presheaves, over a diagram factoring through sheaves,
then `sheafify_cocone E` is a colimit cocone. -/
@[simps]
def is_colimit_sheafify_cocone {F : K ⥤ Sheaf J D} (E : cocone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_colimit E) :
  is_colimit (sheafify_cocone E) :=
{ desc := λ S, ⟨J.sheafify_lift (hE.desc ((Sheaf_to_presheaf J D).map_cocone S)) S.X.2⟩,
  fac' := begin
    intros S j,
    ext1,
    dsimp [sheafify_cocone],
    erw [category.assoc, J.to_sheafify_sheafify_lift, hE.fac],
    refl,
  end,
  uniq' := begin
    intros S m hm,
    ext1,
    apply J.sheafify_lift_unique,
    apply hE.uniq ((Sheaf_to_presheaf J D).map_cocone S),
    intros j,
    dsimp,
    simpa only [← category.assoc, ← hm],
  end }

instance [has_colimits_of_shape K D] : has_colimits_of_shape K (Sheaf J D) :=
⟨λ F, has_colimit.mk ⟨sheafify_cocone (colimit.cocone _),
  is_colimit_sheafify_cocone _ (colimit.is_colimit _)⟩⟩

instance [has_colimits D] : has_colimits (Sheaf J D) := ⟨infer_instance⟩

end colimits

end Sheaf
end category_theory


class Refl.{U} {α : Type U} (R : α → α → Prop) : Prop :=
  refl (a : α) : R a a

class Symm.{U} {α : Type U} (R : α → α → Prop) : Prop :=
  symm {a b : α} : R a b → R b a

/--
  An example decl modifier (a doc comment).
-/
class abbrev PEquiv.{U} {α : Type U} (R : α → α → Prop) : Prop
  := Refl R, Symm R


import Mt.Thread

namespace Mt

variable {spec : Spec}
local instance : IsReservation spec.Reservation :=spec.is_reservation

/-- Describes a system of zero or more threads running in parallel

  Systems can be iterated one atomic step at a time by choosing
  one of its threads. They keep track of the number of threads
  which panicked during execution
-/
structure System (spec : Spec) where
  state   : spec.State
  threads : List (Thread spec)
  panics  : Nat

namespace System

def ThreadIndex (s : System spec) : Type :=Fin s.threads.length
def done (s : System spec) : Bool :=s.threads.length = 0

def iterate (s : System spec) : s.ThreadIndex -> System spec
  | thread_idx =>
    if (s.threads.get thread_idx).block_until s.state then
      match (s.threads.get thread_idx).iterate s.state with
        | Thread.IterationResult.Done state =>
          {
            state
            threads := s.threads.eraseIdx thread_idx.val
            panics := s.panics
          }
        | Thread.IterationResult.Panic state =>
          {
            state
            threads := s.threads.eraseIdx thread_idx.val
            panics := s.panics + 1
          }
        | Thread.IterationResult.Running state thread =>
          {
            state
            threads := s.threads.set thread_idx.val thread
            panics := s.panics
          }
    else
      s

theorem iterate_threads (s : System spec) (thread_idx : s.ThreadIndex)
  (blocked_until : (s.threads.get thread_idx).block_until s.state) :
  (s.iterate thread_idx).threads =
    match (s.threads.get thread_idx).iterate s.state with
      | Thread.IterationResult.Done .. => s.threads.eraseIdx thread_idx.val
      | Thread.IterationResult.Panic .. => s.threads.eraseIdx thread_idx.val
      | Thread.IterationResult.Running _ thread => s.threads.set thread_idx.val thread :=by
  rw [iterate]
  simp only [blocked_until, ite_true]
  cases h : Thread.iterate (List.get s.threads thread_idx) s.state <;> rfl

theorem iterate_panics (s : System spec) (thread_idx : s.ThreadIndex)
  (blocked_until : (s.threads.get thread_idx).block_until s.state) :
  (s.iterate thread_idx).panics =
    match (s.threads.get thread_idx).iterate s.state with
      | Thread.IterationResult.Done .. => s.panics
      | Thread.IterationResult.Panic .. => s.panics + 1
      | Thread.IterationResult.Running .. => s.panics :=by
  rw [iterate]
  simp only [blocked_until, ite_true]
  cases h : Thread.iterate (List.get s.threads thread_idx) s.state <;> rfl

inductive reduces_to : System spec -> System spec -> Prop where
| single {a b} (idx : a.ThreadIndex) (iteration : a.iterate idx = b) : reduces_to a b
| trans {a b c} (a_to_b : a.reduces_to b) (b_to_c : b.reduces_to c) : reduces_to a c

def reduces_to_or_eq (a b : System spec) : Prop :=a = b ∨ a.reduces_to b

theorem reduces_to_or_eq.refl (a : System spec) : a.reduces_to_or_eq a :=Or.inl rfl
theorem reduces_to_or_eq.trans {a b c : System spec} :
  a.reduces_to_or_eq b → b.reduces_to_or_eq c → a.reduces_to_or_eq c :=by
  intro ab bc
  cases ab <;> cases bc <;> rename_i h₁ h₂
  . rw [h₁, h₂] ; exact Or.inl rfl
  . rw [h₁] ; exact Or.inr h₂
  . rw [h₂.symm] ; exact Or.inr h₁
  . exact Or.inr <| h₁.trans h₂

end System

end Mt


import category_theory.triangulated.pretriangulated
import for_mathlib.homological_complex_shift
import for_mathlib.monoidal_category
import for_mathlib.int

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

-- Move + generalize!
@[simp]
lemma category_theory.discrete.associator_def (a b c : discrete ℤ) :
  α_ a b c = eq_to_iso (add_assoc a b c) := rfl

-- Move + generalize!
@[simp]
lemma category_theory.discrete.left_unitor_def (a : discrete ℤ) :
  λ_ a = eq_to_iso (zero_add _) := rfl

-- Move + generalize!
@[simp]
lemma category_theory.discrete.right_unitor_def (a : discrete ℤ) :
  ρ_ a = eq_to_iso (add_zero _) := rfl

namespace category_theory.triangulated
open category_theory.category

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

local attribute [instance, reducible] endofunctor_monoidal_category

namespace triangle

@[simps]
def triangle_shift_obj (T : triangle C) (i : ℤ) : triangle C :=
triangle.mk C
  (i.neg_one_pow • ((shift_functor _ i).map T.mor₁))
  (i.neg_one_pow • (((shift_functor _ i).map T.mor₂)))
  (i.neg_one_pow • ((shift_functor C i).map T.mor₃ ≫ (shift_comm _ _ _).hom))

@[simps]
def triangle_shift_map {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) :
  triangle_shift_obj C T₁ i ⟶ triangle_shift_obj C T₂ i :=
{ hom₁ := (shift_functor _ i).map f.hom₁,
  hom₂ := (shift_functor _ i).map f.hom₂,
  hom₃ := (shift_functor _ i).map f.hom₃,
  comm₁' := by { dsimp, simp only [functor.map_zsmul,
    preadditive.zsmul_comp, preadditive.comp_zsmul, ← functor.map_comp, f.comm₁] },
  comm₂' := by { dsimp, simp only [functor.map_zsmul,
    preadditive.zsmul_comp, preadditive.comp_zsmul, ← functor.map_comp, f.comm₂] },
  comm₃' := begin
    dsimp,
    simp only [functor.map_zsmul,
      preadditive.zsmul_comp, preadditive.comp_zsmul],
    congr' 1,
    simp only [ shift_comm_hom_comp, assoc, iso.cancel_iso_hom_right_assoc,
      ← functor.map_comp, f.comm₃],
  end }

@[simps]
def triangle_shift_functor (i : ℤ) : triangle C ⥤ triangle C :=
{ obj := λ T, triangle_shift_obj C T i,
  map := λ T₁ T₂ f, triangle_shift_map C f _,
  map_id' := begin
    intros T,
    ext,
    all_goals { dsimp, simp },
  end,
  map_comp' := begin
    intros T₁ T₂ T₃ f g,
    ext,
    all_goals { dsimp, simp },
  end, } .

variable {C}

@[simps]
def iso.of_components {T₁ T₂ : triangle C}
  (e₁ : T₁.obj₁ ≅ T₂.obj₁)
  (e₂ : T₁.obj₂ ≅ T₂.obj₂)
  (e₃ : T₁.obj₃ ≅ T₂.obj₃) (h₁ h₂ h₃) : T₁ ≅ T₂ :=
{ hom :=
  { hom₁ := e₁.hom,
    hom₂ := e₂.hom,
    hom₃ := e₃.hom,
    comm₁' := h₁,
    comm₂' := h₂,
    comm₃' := h₃ },
  inv :=
  { hom₁ := e₁.inv,
    hom₂ := e₂.inv,
    hom₃ := e₃.inv,
    comm₁' := by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, h₁],
    comm₂' := by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, h₂],
    comm₃' := by rw [← functor.map_iso_inv, iso.comp_inv_eq, category.assoc, iso.eq_inv_comp,
      functor.map_iso_hom, h₃], },
  hom_inv_id' := by ext; dsimp; simp,
  inv_hom_id' := by ext; dsimp; simp }
.

variable (C)

@[simps]
def triangle_shift_functor_ε : 𝟭 (triangulated.triangle C) ≅ triangle_shift_functor C 0 :=
nat_iso.of_components (λ T,
  iso.of_components
    (shift_zero _ _).symm
    (shift_zero _ _).symm
    (shift_zero _ _).symm
    begin
      convert ((shift_functor_zero _ _).inv.naturality _),
      dsimp only [triangle_shift_functor, triangle_shift_obj],
      simpa,
    end
    begin
      convert ((shift_functor_zero _ _).inv.naturality _),
      dsimp only [triangle_shift_functor, triangle_shift_obj],
      simpa,
    end
    begin
      dsimp,
      rw one_smul,
      rw ← nat_trans.naturality_assoc, dsimp [shift_comm],
      simp only [obj_ε_app, discrete.functor_map_id, nat_trans.id_app, ε_app_obj, assoc, id_comp],
      rw [← nat_trans.comp_app, ← nat_trans.comp_app],
      erw [monoidal_functor.μ_inv_hom_id_assoc, id_comp], refl,
    end)
  begin
    intros T₁ T₂ f, ext;
    { dsimp only [triangle_morphism.comp_hom₁, iso.of_components_hom_hom₁, triangle_shift_map_hom₁,
        triangle_morphism.comp_hom₂, iso.of_components_hom_hom₂, triangle_shift_map_hom₂,
        triangle_morphism.comp_hom₃, iso.of_components_hom_hom₃, triangle_shift_map_hom₃,
        functor.id_map, triangle_category_comp, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.ε_iso_hom, triangle_shift_functor_map],
      rw ← nat_trans.naturality _ _, refl },
  end
.

variables [∀ (i : ℤ), (shift_functor C i).additive]

@[reassoc]
lemma shift_comm_eq_eq_to_hom (X : C) (i j : ℤ) :
  (shift_add X i j).hom ≫ (shift_comm X i j).hom ≫ (shift_add X j i).inv =
  eq_to_hom (by { congr' 2, exact add_comm i j}) :=
begin
  dsimp [shift_add, shift_comm, opaque_eq_to_iso],
  simp, erw comp_id,
end

@[reassoc]
lemma shift_add_comp_eq_to_hom (X : C) (i j k : ℤ) (h : i + j = j + i) :
  (shift_add X (i+j) k).hom ≫
  eq_to_hom (by { congr' 3}) ≫
  (shift_add X (j+i) k).inv =
  eq_to_hom (by { congr' 3}) :=
begin
  dsimp [shift_add, opaque_eq_to_iso],
  induction h, dsimp, simpa,
end

@[reassoc]
lemma shift_add_comp_eq_to_hom' (X : C) (i j k : ℤ) (h : j + k = k + j) :
  (shift_add X i (j+k)).hom ≫
  eq_to_hom (by { congr' 3}) ≫
  (shift_add X i (k+j)).inv =
  eq_to_hom (by { congr' 3}) :=
begin
  dsimp [shift_add, opaque_eq_to_iso],
  induction h, dsimp, simpa,
end

lemma triangle_shift_functor_μ_aux (X : C) (i j : ℤ) :
  (shift_functor C j).map (shift_comm X 1 i).hom ≫
    (shift_comm ((shift_functor C i).obj X) 1 j).hom ≫
      (shift_functor C 1).map
        (shift_add X i j).inv =
  (shift_add ((shift_functor C 1).obj X) i j).inv ≫
    (shift_comm X 1 (i + j)).hom :=
begin
  dsimp [shift_add, shift_comm, opaque_eq_to_iso],
  simp only [eq_to_hom_map, eq_to_hom_app, functor.map_comp, obj_μ_app,
    category_theory.discrete.associator_def, eq_to_iso.inv,
    obj_μ_inv_app, eq_to_iso.hom, assoc, μ_inv_hom_app_assoc],
  congr' 2,
  simp only [← assoc], congr' 1, simp only [assoc],
  erw shift_add_comp_eq_to_hom_assoc,
  erw shift_add_comp_eq_to_hom'_assoc,
  simpa, exact add_comm _ _, exact add_comm _ _,
end

@[simps]
def triangle_shift_functor_μ (i j : ℤ) :
  triangle_shift_functor C i ⋙ triangle_shift_functor C j ≅
    triangle_shift_functor C (i + j) :=
nat_iso.of_components (λ T,
  iso.of_components
    (shift_add _ _ _).symm
    (shift_add _ _ _).symm
    (shift_add _ _ _).symm
    (begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₁),
      rw [functor.comp_map] at this,
      erw [this, mul_comm], refl,
    end)
    (begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₂),
      rw [functor.comp_map] at this,
      erw [this, mul_comm], refl,
    end)
    begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add,
        mul_comm j.neg_one_pow],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₃),
      dsimp [functor.comp_map] at this,
      erw [← reassoc_of this], clear this,
      simp only [functor.map_comp, assoc, obj_μ_app],
      congr' 2,
      --have := (shift_monoidal_functor C ℤ).to_lax_monoidal_functor.associativity i j 1,
      rw (shift_monoidal_functor C ℤ).map_associator_inv,
      dsimp,
      simp only [assoc, is_iso.inv_id, nat_trans.hcomp_app, comp_id, id_comp],
      slice_lhs 4 5
      { rw [← nat_trans.comp_app, is_iso.hom_inv_id,
          nat_trans.id_app] },
      erw id_comp,
      rw category_theory.nat_iso.is_iso_inv_app,
      --rw nat_trans.id_hcomp_app,
      dsimp,
      simp only [category_theory.functor.map_id, comp_id, assoc, is_iso.hom_inv_id_assoc],
      slice_lhs 4 5
      { rw [← nat_trans.comp_app, (shift_monoidal_functor C ℤ).μ_hom_inv_id,
          nat_trans.id_app] },
      erw comp_id, apply triangle_shift_functor_μ_aux,
    end)
  (begin
    intros T₁ T₂ f, ext;
    { dsimp only [triangle_morphism.comp_hom₁, iso.of_components_hom_hom₁, triangle_shift_map_hom₁,
        triangle_morphism.comp_hom₂, iso.of_components_hom_hom₂, triangle_shift_map_hom₂,
        triangle_morphism.comp_hom₃, iso.of_components_hom_hom₃, triangle_shift_map_hom₃,
        functor.id_map, triangle_category_comp, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.ε_iso_hom, triangle_shift_functor_map],
      rw ← nat_trans.naturality _ _, refl },
  end)
.

/-
def triangle_shift_core : shift_mk_core (triangle C) ℤ :=
{ F := triangle_shift_functor _,
  ε := triangle_shift_functor_ε _,
  μ := λ i j, triangle_shift_functor_μ _ _ _,
  associativity := begin
    intros i j k T, ext,
    { have := (shift_monoidal_functor C ℤ).to_lax_monoidal_functor.associativity i j k,
      apply_fun (λ α, α.app T.obj₁) at this,
      simp only [nat_trans.comp_app, obj_μ_app, assoc, μ_inv_hom_app_assoc, map_inv_hom_app,
        comp_id, functor.associator_hom_app, nat_trans.hcomp_app, nat_trans.id_app,
        category_theory.functor.map_id, id_comp] at this,
      erw [id_comp] at this,
      refine eq.trans _ this, clear this,
      dsimp, simp only [obj_μ_app, assoc],
      -- I don't like that `(eq_to_hom _).hom₁`.
      admit },
    admit,
    admit
  end,
  left_unitality := admit,
  right_unitality := admit }
-/

@[simps]
def map_triangle_shift_functor (m n : discrete ℤ) (f : m ⟶ n) :
  triangle_shift_functor C m ⟶ triangle_shift_functor C n :=
{ app := λ T,
  { hom₁ := eq_to_hom $ by rw discrete.eq_of_hom f,
    hom₂ := eq_to_hom $ by rw discrete.eq_of_hom f,
    hom₃ := eq_to_hom $ by rw discrete.eq_of_hom f,
    comm₁' := by { rcases f with ⟨⟨⟨⟩⟩⟩, simp only [eq_to_hom_refl, id_comp, comp_id], },
    comm₂' := by { rcases f with ⟨⟨⟨⟩⟩⟩, simp only [eq_to_hom_refl, id_comp, comp_id], },
    comm₃' := by { rcases f with ⟨⟨⟨⟩⟩⟩,
      dsimp, rw (shift_functor C (1 : ℤ)).map_id, simp only [comp_id, id_comp]} },
  naturality' := begin
    rcases f with ⟨⟨⟨⟩⟩⟩,
    rintros X Y g, ext;
    { dsimp, simp only [eq_to_hom_refl, id_comp, comp_id] },
  end } .

lemma associativity_aux (X : C) (a b c : discrete ℤ) :
(𝟙 ((shift_functor C c).obj ((shift_functor C b).obj ((shift_functor C a).obj X))) ≫
  (shift_functor C c).map (((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ a b).app X)) ≫
  ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ (a ⊗ b) c).app X ≫
  eq_to_hom (by { congr' 2, apply add_assoc }) =
  𝟙 ((shift_functor C c).obj
  ((shift_functor C b).obj ((shift_functor C a).obj X))) ≫ (((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ b c).app
  ((shift_functor C a).obj X) ≫ (shift_functor C (b + c)).map
  (𝟙 ((shift_functor C a).obj X))) ≫ ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ a
  (b ⊗ c)).app X :=
begin
  have := (shift_monoidal_functor C ℤ).associativity' a b c,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  erw comp_id,
  exact this
end

lemma left_unitality_aux (X : C) (a : discrete ℤ) : 𝟙 ((shift_functor C a).obj X) =
  (𝟙 ((shift_functor C a).obj X) ≫ (shift_functor C a).map
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.ε.app X)) ≫
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ
    (𝟙_ (discrete ℤ)) a).app X ≫ eq_to_hom (by { congr, exact zero_add a }) :=
begin
  have := (shift_monoidal_functor C ℤ).left_unitality' a,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  exact this
end

lemma right_unitality_aux (X : C) (a : discrete ℤ) : 𝟙 ((shift_functor C a).obj X) =
  ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.ε.app ((shift_functor C a).obj X) ≫
       (shift_functor C (𝟙_ (discrete ℤ))).map (𝟙 ((shift_functor C a).obj X))) ≫
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ a (𝟙_ (discrete ℤ))).app X ≫
    eq_to_hom (by { congr, apply add_zero }) :=
begin
  have := (shift_monoidal_functor C ℤ).right_unitality' a,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  erw comp_id,
  exact this
end

instance has_shift : has_shift (triangle C) ℤ := has_shift.mk $
{ obj := triangle_shift_functor _,
  map := λ m n f, map_triangle_shift_functor _ _ _ f,
  map_id' := λ X, by { ext; refl },
  map_comp' := λ X Y Z f g, by { ext; simp },
  ε := (triangle_shift_functor_ε _).hom,
  μ := λ m n, (triangle_shift_functor_μ _ m n).hom,
  μ_natural' := begin
    rintros m m' n n' ⟨⟨⟨⟩⟩⟩ ⟨⟨⟨⟩⟩⟩, ext;
    { dsimp, simp only [id_comp, comp_id, category_theory.functor.map_id] },
  end,
  associativity' := λ a b c, by ext; apply associativity_aux,
  left_unitality' := λ a, by ext; apply left_unitality_aux,
  right_unitality' := λ a, by ext; apply right_unitality_aux,
  ε_is_iso := infer_instance,
  μ_is_iso := infer_instance } .

@[simp]
lemma shift_obj₁ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₁ = T.obj₁⟦i⟧ := rfl

@[simp]
lemma shift_obj₂ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₂ = T.obj₂⟦i⟧ := rfl

@[simp]
lemma shift_obj₃ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₃ = T.obj₃⟦i⟧ := rfl

@[simp]
lemma shift_mor₁ (T : triangle C) (i : ℤ) : T⟦i⟧.mor₁ = i.neg_one_pow • T.mor₁⟦i⟧' := rfl

@[simp]
lemma shift_mor₂ (T : triangle C) (i : ℤ) : T⟦i⟧.mor₂ = i.neg_one_pow • T.mor₂⟦i⟧' := rfl

@[simp]
lemma shift_mor₃ (T : triangle C) (i : ℤ) :
  T⟦i⟧.mor₃ = i.neg_one_pow • (T.mor₃⟦i⟧' ≫ (shift_comm _ _ _).hom) := rfl

@[simp]
lemma shift_hom₁ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₁ = f.hom₁⟦i⟧' := rfl

@[simp]
lemma shift_hom₂ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₂ = f.hom₂⟦i⟧' := rfl

@[simp]
lemma shift_hom₃ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₃ = f.hom₃⟦i⟧' := rfl

end triangle

/-
instance {C : Type*} [category C] [preadditive C] (X Y : C) : has_neg (X ≅ Y) :=
⟨λ f,
{ hom := -f.hom,
  inv := -f.inv,
  hom_inv_id' := by simp only [comp_neg, neg_comp, iso.hom_inv_id, neg_neg],
  inv_hom_id' := by simp only [comp_neg, neg_comp, iso.inv_hom_id, neg_neg] }⟩

@[simp] lemma _root_.category_theory.neg_hom
   {C : Type*} [category C] [preadditive C] {X Y : C} (f : X ≅ Y) :
   (-f).hom = -(f.hom) := rfl

@[simp] lemma _root_.category_theory.neg_inv
   {C : Type*} [category C] [preadditive C] {X Y : C} (f : X ≅ Y) :
   (-f).inv = -(f.inv) := rfl
-/

namespace pretriangulated

@[simp] lemma shift_comm_self (X : C) (i : ℤ) : shift_comm X i i = iso.refl _ :=
begin
  ext,
  dsimp [shift_comm, opaque_eq_to_iso],
  simp only [discrete.functor_map_id, nat_trans.id_app, id_comp, μ_hom_inv_app],
  refl,
end

variables [has_zero_object C] [∀ (i : ℤ), (shift_functor C i).additive] [pretriangulated C]

lemma dist_triangle_iff_of_iso {T₁ T₂ : triangle C} (e : T₁ ≅ T₂) :
  (T₁ ∈ dist_triang C) ↔ (T₂ ∈ dist_triang C) :=
⟨λ h, isomorphic_distinguished _ h _ e.symm, λ h, isomorphic_distinguished _ h _ e⟩

lemma dist_triangle_rot_iff (T : triangle C) :
  (T.rotate ∈ dist_triang C) ↔ (T ∈ dist_triang C) :=
begin
  refine ⟨λ h, _, λ h, rot_of_dist_triangle _ _ h⟩,
  let e : T ≅ T.rotate.inv_rotate := rot_comp_inv_rot.app T,
  rw ← dist_triangle_iff_of_iso _ e.symm,
  exact inv_rot_of_dist_triangle _ _ h,
end

lemma shift_of_dist_triangle (T : triangle C) (hT : T ∈ dist_triang C) (i : ℤ) :
  T⟦i⟧ ∈ dist_triang C :=
begin
  induction i using int.induction_on_iff with i,
  { exact isomorphic_distinguished T hT _ (shift_zero _ _), },
  { suffices : T⟦(i+1 : ℤ)⟧ ≅ T⟦(i:ℤ)⟧.rotate.rotate.rotate,
    { dsimp,
      rw dist_triangle_iff_of_iso _ this,
      iterate 3 { rw dist_triangle_rot_iff }, },
    refine shift_add _ _ _ ≪≫ _,
    refine triangle.iso.of_components (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
    { dsimp, simp only [category.id_comp, category.comp_id, comp_neg, neg_one_smul], },
    { dsimp, simp only [category.id_comp, category.comp_id, neg_comp, neg_one_smul], },
    { dsimp, simp only [category.id_comp, category.comp_id, neg_comp, neg_one_smul],
      simp only [functor.map_comp, assoc, category_theory.functor.map_id, comp_id,
        functor.map_zsmul, preadditive.zsmul_comp, preadditive.comp_zsmul,
        shift_comm_self, iso.refl_hom], }, },
end

end pretriangulated

end category_theory.triangulated


import convex convex_body linalg measure touching_cone brunn_minkowski
  microid criticality pruning locally_linear arithmetic
  touching_cone_polytope
  analysis.convex.basic
  data.multiset.basic
  measure_theory.measure.measure_space
  topology.basic
  analysis.inner_product_space.pi_L2

open_locale pointwise
open_locale ennreal -- for ∞ notation
open_locale topological_space -- for 𝓝 notation

-- needed to get decidable_eq for sets!
open classical
local attribute [instance] prop_decidable

section definitions

variables (V : Type)
[inner_product_space ℝ V] [finite_dimensional ℝ V]

end definitions

section preparation_lemmas

variables {V : Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

noncomputable def TS_microid_measure {k : ℕ} (u : metric.sphere (0 : V) 1) (μ : microid_measure V k) :
submodule ℝ V :=
TS (microid_of_measure μ).val u.val
end preparation_lemmas

section default_reduction

variables {V : Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

def microid_pair (k : ℕ)
(u : metric.sphere (0 : V) 1) :=
(Σ μ : microid_measure V k,
{P : microid_generator_space V k // is_default_polytope μ u P})

def pair_to_default_body {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : convex_body V :=
convex_body_of_polytope (polytope_of_microid_generator pair.2.1)

def pair_to_measure {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair: microid_pair k u) : microid_measure V k := pair.1

noncomputable def pair_to_microid {k : ℕ}
{u : metric.sphere (0 : V) 1} :
microid_pair k u → convex_body V :=
microid_of_measure ∘ pair_to_measure

noncomputable def pair_to_default_measure {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : microid_measure V k :=
dirac_microid_measure pair.2.1

noncomputable def pair_to_TS {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : submodule ℝ V :=
TS (pair_to_microid pair).val u

noncomputable def reduce_pair {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : microid_pair k u :=
begin
  refine ⟨pair_to_default_measure pair, pair.2.1, _⟩,
  rcases pair.2.2 with ⟨h1, h2, h3⟩,
  refine ⟨h1, h2, _⟩,
  {
    simp only [pair_to_default_measure, microid_of_dirac_eq],
    simp only [body_of_poly_of_gen_eq],
    refine ⟨h3.1, _⟩,
    intros C hC,
    exact id,
  },
end

lemma reduced_microid_eq_default_body {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) :
(pair_to_microid (reduce_pair pair)) = pair_to_default_body pair :=
begin
  simp only [pair_to_microid, pair_to_TS, pair_to_measure, reduce_pair,
  pair_to_default_measure, microid_of_dirac_eq, pair_to_default_body,
  body_of_poly_of_gen_eq,
  function.comp_app, function.comp_app],
end

lemma nface_eq_self_of_vspan_mem_uperp {A : set V} {u : V}
(h : vector_span ℝ A ≤ vector_orth u) : normal_face A u = A :=
begin
  apply subset_antisymm,
  {
    apply normal_face_subset,
  },
  {
    intros a ha,
    simp only [mem_normal_face],
    refine ⟨ha, _⟩,
    intros b hb,
    have hab : a - b ∈ vector_orth u,
    {
      apply h,
      apply submodule.subset_span,
      exact ⟨a, b, ha, hb, rfl⟩,
    },
    simp only [vector_orth] at hab,
    replace hab := inner_left_of_mem_orthogonal_singleton _ hab,
    apply le_of_eq,
    symmetry,
    simpa only [inner_sub_left, sub_eq_zero] using hab,
  },
end

lemma span_reduced_microid_eq_TS (k : ℕ)
(u : metric.sphere (0 : V) 1) :
span_of_convex_body ∘ pair_to_microid ∘ (reduce_pair : microid_pair k u → microid_pair k u) =
pair_to_TS ∘ (reduce_pair : microid_pair k u → microid_pair k u) :=
begin
  funext pair,
  simp only [function.comp_app],
  simp only [reduced_microid_eq_default_body, pair_to_default_body, pair_to_TS],
  simp only [convex_body_of_polytope],
  have is_poly := (polytope_of_microid_generator pair.2.1).property,
  rw [TS_poly_eq_vspan_face is_poly],
  rcases pair.2.2 with ⟨h0, h1, h2, h3⟩,
  rw [←subtype.val_eq_coe, nface_eq_self_of_vspan_mem_uperp h1],
  simp only [span_of_convex_body],
end

lemma subset_diff {A : set V} (h : (0 : V) ∈ A) : A ⊆ diff A :=
begin
  intros v vA,
  refine ⟨v, 0, vA, h, _⟩,
  simp only [vsub_eq_sub, sub_zero],
end

lemma vspan_eq_span_of_mem_zero {A : set V} (h : (0 : V) ∈ A) :
vector_span ℝ A = submodule.span ℝ A :=
begin
  apply le_antisymm,
  {
    simp only [vector_span, submodule.span_le],
    rintro x ⟨a, b, ha, hb, rfl⟩,
    simp only [vsub_eq_sub, set_like.mem_coe],
    refine submodule.sub_mem _ _ _,
    all_goals {
      apply submodule.subset_span,
      assumption,
    },
  },
  {
    simp only [vector_span],
    apply submodule.span_mono,
    exact subset_diff h,
  },
end

lemma reduced_microid_subset_TS {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) :
(pair_to_microid (reduce_pair pair)).val ⊆ pair_to_TS (reduce_pair pair) :=
begin
  refine subset_trans submodule.subset_span
    (subset_of_eq (congr_arg coe _)),
  revert pair,
  have := function.funext_iff.mp (span_reduced_microid_eq_TS k u),
  convert this,
  ext,
  refine forall_congr _,
  simp only [function.comp_app, span_of_convex_body],
  intro pair,
  rw [reduced_microid_eq_default_body, pair_to_default_body,
    convex_body_of_polytope, subtype.val_eq_coe, subtype.coe_mk],
  rw [vspan_eq_span_of_mem_zero (pair.2.2.1)],
end

noncomputable def pair_to_default_space {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : submodule ℝ V :=
TS (pair_to_default_body pair).val u.val

lemma TS_reduce_eq_default_space {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) :
pair_to_TS (reduce_pair pair) = pair_to_default_space pair :=
begin
  simp only [pair_to_TS, pair_to_default_space, reduced_microid_eq_default_body],
  refl,
end

lemma reduced_default_body_eq {k : ℕ}{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) :
pair_to_default_body (reduce_pair pair) = pair_to_default_body pair :=
begin
  simp only [pair_to_default_body, reduce_pair],
end

lemma default_space_eq_TS_of_reduced {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) :
pair_to_default_space (reduce_pair pair) = pair_to_TS (reduce_pair pair) :=
begin
  simp only [pair_to_default_space, TS_reduce_eq_default_space, reduced_default_body_eq],
end

noncomputable def pair_to_space_pair {k : ℕ}
{u : metric.sphere (0 : V) 1}
(pair : microid_pair k u) : submodule ℝ V × submodule ℝ V :=
⟨pair_to_TS pair, pair_to_default_space pair⟩

lemma pair_to_space_pair_def {k : ℕ}
{u : metric.sphere (0 : V) 1} :
@pair_to_space_pair V _ _ k u = λ pair, ⟨pair_to_TS pair, pair_to_default_space pair⟩ :=
rfl

noncomputable def paircol_span {k : ℕ}
{u : metric.sphere (0 : V) 1}
(D : multiset (microid_pair k u)) : submodule ℝ V :=
(D.map pair_to_default_space).sum

lemma nonempty_prune_triple {k : ℕ} : nonempty (prune_triple V k) :=
begin
  refine ⟨⟨⟨0, _⟩, 0, 0⟩⟩,
  simp only [mem_closed_ball_zero_iff, norm_zero, zero_le_one],
end

lemma cuspiness_lipschitz {k : ℕ}
(tr : prune_triple V k)
(u v : V) :
|cuspiness' u tr - cuspiness' v tr| ≤ dist u v :=
begin
  simp only [cuspiness', ←sub_div, ←inner_sub_right, abs_div],
  simp only [←is_R_or_C.abs_to_real],
  refine le_trans (div_le_div_of_le_right
    (abs_inner_le_norm (prune_direction tr) (u - v)) _) _,
  {
    apply is_R_or_C.abs_nonneg,
  },
  {
    simp only [is_R_or_C.abs_to_real,
      abs_eq_self.mpr (norm_nonneg _)],
    apply div_le_of_nonneg_of_le_mul,
    {
      apply norm_nonneg,
    },
    {
      apply dist_nonneg,
    },
    {
      conv {to_lhs, rw [mul_comm]},
      apply mul_le_mul_of_nonneg_right _ (norm_nonneg _),
      simp only [←dist_eq_norm, subtype.dist_eq],
    },
  },
end

lemma support_locally_linear_of_cuspy {k : ℕ}
{G : microid_generator_space V k}
{u : metric.sphere (0 : V ) 1}
{ε : ℝ}
(εpos : ε > 0)
(h : ∀ tr : prune_triple V k,
valid_prune_triple tr u → (prune_triple_generator tr) = G → cuspiness u tr ≥ ε) :
supp_locally_linear (metric.ball u.val ε) (body_of_microid_generator G) :=
begin
  rw [normal_face_singleton_iff_locally_linear metric.is_open_ball],
  rcases generator_face_nonempty G u with ⟨m, hm⟩,
  refine ⟨G.val m, _⟩,
  intros v hv,
  simp only [body_of_microid_generator, convex_body.normal_face],
  simp only [normal_face_spanned_by_verts],
  convert convex_hull_singleton (G.val m),
  have lem : ∀ l : fin k.succ, G.val l ≠ G.val m →
    ⟪G.val m - G.val l, v⟫_ℝ > 0,
  {
    intros l hh,
    let tr : prune_triple V k := ⟨G, m, l⟩,
    have valid : valid_prune_triple tr u,
    {
      simp only [valid_prune_triple,
      prune_cusp, prune_cusp_index,
      prune_secondary, prune_secondary_index,
      prune_gen_fn, tr],
      split,
      {
        simp only [generator_face, finset.mem_coe, finset.mem_filter] at hm,
        exact hm.2,
      },
      {tauto},
    },
    have := h tr valid rfl,
    change cuspiness' u.val tr ≥ ε at this,
    replace : cuspiness' v tr > 0,
    {
      refine lt_of_lt_of_le _ (ge_sub_abs (cuspiness' v tr) (cuspiness' u.val tr)),
      refine lt_of_lt_of_le _ (sub_le_sub this (cuspiness_lipschitz _ _ _)),
      simpa only [metric.mem_ball, sub_pos] using hv,
    },
    {
      simp only [cuspiness', prune_direction,
        prune_cusp, prune_secondary,
        prune_cusp_index, prune_secondary_index,
        prune_gen_fn, tr] at this,
      exact dividend_pos this (norm_nonneg _),
    },
  },
  apply subset_antisymm,
  {
    intros x hx,
    simp only [set.mem_singleton_iff],
    simp only [generator_face, finset.mem_coe, finset.mem_filter] at hm,
    simp only [mem_normal_face] at hx,
    rcases hx.1 with ⟨l, hl, rfl⟩,
    by_contra hh,
    suffices c : ⟪G.val m - G.val l, v⟫_ℝ > 0,
    {
      simp only [inner_sub_left, gt_iff_lt, sub_pos] at c,
      replace hx := hx.2 (G.val m) (set.mem_range_self _),
      linarith,
    },
    {
      exact lem l hh,
    },
  },
  {
    simp only [set.singleton_subset_iff, mem_normal_face],
    refine ⟨set.mem_range_self _, _⟩,
    intros y hy,
    rcases hy with ⟨l, rfl⟩,
    by_cases hh : G.val l = G.val m,
    {
      simp only [hh],
      apply le_refl,
    },
    {
      apply le_of_lt,
      rw [←sub_pos, ←inner_sub_left],
      exact lem l hh,
    },
  },
end

/- lemma lemma_vspan_subset_span {A : set V} :
(vector_span ℝ A : set V) ⊆ submodule.span ℝ A :=
begin
  simp only [vector_span],
end -/

lemma zero_normal_face_eq (A : set V) :
normal_face A 0 = A :=
begin
  ext,
  simp only [normal_face, set.mem_set_of],
  split,
  {
    intro h,
    exact h.1,
  },
  {
    intro h,
    refine ⟨h, _⟩,
    simp only [inner_zero_right],
    intros y hy,
    apply le_refl,
  }
end

lemma orthogonal_projection_eq_zero_iff (E : submodule ℝ V) :
Eᗮ = 0 ↔ E = ⊤ :=
begin
  exact submodule.orthogonal_eq_bot_iff,
end

/- lemma normal_face_by_supp (K : convex_body V) (u : V) :
(normal_face K.val u) = { x : V | x ∈ K.val ∧ ⟪x, u⟫_ℝ = K.supp u } := sorry
 -/

lemma TS_zero_of_cuspy_generators {k : ℕ}
{μ : microid_measure V k}
{u : metric.sphere (0 : V) 1}
{ε : ℝ}
(εpos : ε > 0)
(h : ∀ (tr : prune_triple V k),
valid_prune_triple tr u → prune_triple_generator tr ∈ msupport μ → cuspiness u tr ≥ ε) :
TS_microid_measure u μ = 0 :=
begin
  suffices hε : metric.ball u.val ε ⊆ pre_touching_cone (microid_of_measure μ).val u,
  {
    have span_top : vector_span ℝ (pre_touching_cone (microid_of_measure μ).val u) = ⊤,
    {
      refine vector_span_top_of_ball_subset εpos hε,
    },
    have : pre_touching_cone (microid_of_measure μ).val u =
      touching_cone (microid_of_measure μ).val u,
    {
      refine touching_cone_unique_face _ _ _ _ _,
      {
        conv {
          congr, skip,
          rw [←zero_normal_face_eq (pre_touching_cone (microid_of_measure μ).val u)],
        },
        exact normal_face_is_face (pre_touching_cone_convex _ _) 0,
      },
      rw [relint_eq_int (vector_span_top_of_ball_subset εpos hε), mem_interior],
      exact ⟨metric.ball u.val ε, hε, metric.is_open_ball, metric.mem_ball_self εpos⟩,
    },
    simp only [TS_microid_measure, TS, orthogonal_projection_eq_zero_iff],
    rw [this] at hε,
    refine span_top_of_ball_subset εpos hε,
  },
  intros v hv,
  simp only [pre_touching_cone, outer_normal_cone, set.mem_set_of],
  suffices ll : supp_locally_linear (metric.ball u.val ε)
    (microid_of_measure μ),
  {
    rcases ll with ⟨x, ll⟩,
    rw [normal_face_singleton_iff_locally_linear_with (metric.is_open_ball)] at ll,
    simp only [convex_body.normal_face] at ll,
    rw [ll v hv, ll ↑u (metric.mem_ball_self εpos)],
  },
  {
    apply microid_supp_locally_linear_of_generators εpos,
    intros G hG,
    apply support_locally_linear_of_cuspy εpos,
    intros tr valid htrG,
    refine h tr valid _,
    rw [htrG],
    exact hG,
  },
end

lemma cuspiness_nonneg {k : ℕ}
{tr : prune_triple V k}
{u : metric.sphere (0 : V) 1}
(h : valid_prune_triple tr u) : cuspiness u tr ≥ 0 :=
begin
  simp only [valid_prune_triple] at h,
  simp only [cuspiness, prune_direction,
    prune_cusp, prune_cusp_index,
    prune_secondary, prune_secondary_index,
    prune_gen_fn] at h ⊢,
  apply div_nonneg,
  {
    simp only [inner_sub_left, sub_nonneg],
    tauto,
  },
  {apply norm_nonneg},
end

lemma exists_prune_triple_seq {k : ℕ}
{μ : microid_measure V k}
{u : metric.sphere (0 : V) 1}
(h : TS_microid_measure u μ ≠ 0) :
∃ t : ℕ → prune_triple V k,
(∀ n : ℕ, valid_prune_triple (t n) u) ∧
(∀ n : ℕ, prune_triple_generator (t n) ∈ msupport μ) ∧
filter.tendsto ((cuspiness u) ∘ t) filter.at_top (𝓝 (0 : ℝ)) :=
begin
  suffices hex : ∀ ε : ℝ,
  ∃ tr : prune_triple V k, ε > 0 →
  valid_prune_triple tr u ∧
  prune_triple_generator tr ∈ msupport μ ∧ cuspiness u tr < ε,
  {
    choose tℝ htℝ using hex,
    rcases exists_seq_strict_anti_tendsto (0 : ℝ)
      with ⟨ε, -, εpos, εtt⟩,
    let t := tℝ ∘ ε,
    refine ⟨t, _, _, _⟩,
    {
      intro n,
      exact (htℝ (ε n) (εpos n)).1,
    },
    {
      intro n,
      exact (htℝ (ε n) (εpos n)).2.1,
    },
    {
      have εtt' := tendsto_nhds_within_of_tendsto_nhds_of_eventually_within
        _ εtt (filter.eventually_of_forall εpos),
      have : filter.tendsto (cuspiness u ∘ tℝ) (𝓝[preorder.lt 0] 0) (𝓝 0),
      {
        simp only [filter.tendsto_iff_eventually],
        intros p ep,
        simp only [filter.has_basis.eventually_iff metric.nhds_basis_ball] at ep,
        simp only [filter.has_basis.eventually_iff metric.nhds_within_basis_ball,
          function.comp_app],
        rcases ep with ⟨i, ipos, hi⟩,
        refine ⟨i, ipos, _⟩,
        rintro x ⟨hx, xpos⟩,
        apply hi,
        simp only [real.ball_eq_Ioo] at hx ⊢,
        split,
        {
          simp only [zero_sub],
          refine lt_of_lt_of_le (neg_neg_of_pos ipos) _,
          apply cuspiness_nonneg,
          exact (htℝ x xpos).1,
        },
        {
          exact lt_trans (htℝ x xpos).2.2 hx.2,
        },
      },
      have := filter.tendsto.comp this εtt',
      rw [function.comp.assoc] at this,
      exact this,
    },
  },
  intros ε,
  by_cases εpos : ε > 0, rotate,
  {
    rcases nonempty_prune_triple with ⟨tr⟩,
    refine ⟨tr, _⟩,
    {
      intro h,
      contradiction,
    },
  },
  {
    by_contra hass,
    push_neg at hass,
    apply h,
    apply TS_zero_of_cuspy_generators εpos,
    intros tr valid htr,
    exact (hass tr).2 valid htr,
  },
end

lemma exists_pair {k : ℕ}
{μ : microid_measure V k}
{u : metric.sphere (0 : V) 1}
(h : TS_microid_measure u μ ≠ 0) :
∃ p : microid_pair k u,
pair_to_measure p = μ :=
begin
  rcases exists_prune_triple_seq h with ⟨t, valid, genμ, tt⟩,
  rcases pruning_lemma valid tt with ⟨G, hzm, hnz, hup, hcl⟩,
  refine ⟨⟨μ, G, _⟩, _⟩,
  {
    refine ⟨hzm, hup, _, _⟩,
    {
      rw [TS_poly_eq_vspan_face (polytope_of_microid_generator G).property u],
      rw [←subtype.val_eq_coe, nface_eq_self_of_vspan_mem_uperp hup],
      exact hnz,
    },
    {
      simp only [in_combinatorial_closure] at hcl,
      intros C hC hsupp,
      rw [body_of_poly_of_gen_eq] at hsupp,
      have := hcl C hC hsupp,
      rw [msupport_microid_eq_closure μ hC],
      refine set.mem_of_subset_of_mem _ this,
      apply closure_mono,
      intros v hv,
      simp only [set.mem_Union] at hv ⊢,
      rcases hv with ⟨K, ⟨nK, -, rfl⟩, vsupp⟩,
      refine ⟨prune_triple_generator (t nK), genμ nK, _⟩,
      simp only [function.comp_app] at vsupp,
      exact vsupp,
    },
  },
  {
    simp only [pair_to_measure],
  },
end

lemma nonzero_of_mem_of_semicritical
{Es : multiset (submodule ℝ V)}
(h : semicritical_spaces Es) :
∀ E : submodule ℝ V, E ∈ Es → E ≠ ⊥ :=
begin
  intros E hE,
  let S : multiset (submodule ℝ V) := {E},
  suffices hd : dim S.sum ≥ S.card,
  {
    by_contra,
    simp only [h, S] at hd,
    rw [multiset.sum_singleton E, multiset.card_singleton] at hd,
    rw [h] at hd,
    change finite_dimensional.finrank ℝ (⊥ : submodule ℝ V) ≥ 1 at hd,
    simp only [finrank_bot, gt_iff_lt, not_lt_zero'] at hd,
    linarith,
  },
  refine h S _,
  simp only [S, multiset.singleton_le],
  exact hE,
end

lemma exists_pair_multiset {k : ℕ}
(μs : multiset (microid_measure V k))
(u : metric.sphere (0 : V) 1)
(hTS : semicritical_spaces (μs.map (TS_microid_measure u))) :
∃ C : multiset (microid_pair k u),
C.map pair_to_measure = μs :=
begin
  induction μs using pauls_multiset_induction,
  {
    refine ⟨0, _⟩,
    simp only [multiset.map_zero],
  },
  {
    have hTS': semicritical_spaces (μs_C'.map (TS_microid_measure u)),
    {
      simp only [multiset.map_cons] at hTS,
      refine semicritical_of_le (multiset.le_cons_self _ _) hTS,
    },
    rcases μs_ᾰ hTS' with ⟨C', hC'⟩,
    have μs_a_nonzero : TS_microid_measure u μs_a ≠ ⊥,
    {
      refine nonzero_of_mem_of_semicritical hTS _ _,
      simp only [multiset.map_cons],
      exact multiset.mem_cons_self _ _,
    },
    rcases exists_pair μs_a_nonzero with ⟨E, hE⟩,
    refine ⟨E ::ₘ C', _⟩,
    simp only [hC', hE, multiset.map_cons],
  },
end

theorem matryoshka_reduction {k : ℕ}
{u : metric.sphere (0 : V) 1}
{D C : multiset (microid_pair k u)}
(hdim : dim V = (D + C).card + 1) :
u ∈ msupport (bm.area ((D.map pair_to_default_body) + C.map pair_to_microid)) →
u ∈ msupport (bm.area ((D + C).map pair_to_microid))
:=
begin
  revert C,
  induction D using pauls_multiset_induction,
  {
    intros C hdim hu,
    simpa only [multiset.map_zero, zero_add] using hu,
  },
  {
    intros C hdim hu,
    let C' := (reduce_pair D_a) ::ₘ C,
    have hdim' : dim V = (D_C' + C').card + 1,
    {
      simp only [C', multiset.card_add, multiset.card_cons] at hdim ⊢,
      rw [hdim],
      ring,
    },
    have goal' := D_ᾰ hdim',
    simp only [multiset.map_add, multiset.map_cons] at goal',
    rw [multiset.add_cons, ←multiset.cons_add] at goal',
    rw [reduced_microid_eq_default_body] at goal',
    simp only [multiset.map_add, multiset.map_cons] at hu,
    replace hu := goal' hu,
    clear D_ᾰ goal',
    simp only [multiset.cons_add, multiset.map_cons],
    rw [multiset.add_cons, ←multiset.map_add] at hu,
    have defp := D_a.2.2,
    refine defp.2.2.2 _ _ hu,
    simp only [multiset.card_map, multiset.card_add],
    simp only [multiset.card_add, multiset.card_cons] at hdim,
    rw [hdim],
    ring,
  },
end

end default_reduction

variables {V : Type}
[inner_product_space ℝ V] [finite_dimensional ℝ V]

lemma TS_microid_proj_eq_proj_TS_microid {k : ℕ}
(μ : microid_measure V k)
(E : submodule ℝ V)
(u : metric.sphere (0 : V) 1)
(uE : u.val ∈ E) :
TS_microid_measure (uncoe_sph E u uE) (project_microid_measure E μ) =
(TS_microid_measure u μ).map (proj E) :=
begin
  simp only [TS_microid_measure, uncoe_sph],
  rw [TS_orthogonal_projection _ uE, microid_proj_eq_proj_microid],
  simp only [proj_body, subtype.val_eq_coe],
  refl,
end

lemma TS_default_body_eq_TS_default_measure (k : ℕ)
(u : metric.sphere (0 : V) 1) (x : microid_pair k u) :
TS (pair_to_default_body x).val u.val = TS_microid_measure u (pair_to_default_measure x) :=
begin
  simp only [TS_microid_measure, pair_to_default_measure, pair_to_default_body,
    microid_of_dirac_eq, body_of_poly_of_gen_eq],
end

section blabb

lemma u_mem_sum_TS_orth
{k : ℕ}
{u : metric.sphere (0 : V) 1}
{E : submodule ℝ V}
(A : multiset (microid_pair k u))
(h : E = (A.map pair_to_TS).sum) :
u.val ∈ Eᗮ :=
begin
  revert E,
  induction A using pauls_multiset_induction,
  {
    intros E h,
    simp only [multiset.map_zero, multiset.sum_zero, submodule.zero_eq_bot] at h,
    simp only [h, submodule.bot_orthogonal_eq_top],
  },
  {
    intros E h,
    simp only [multiset.map_cons, multiset.sum_cons, submodule.add_eq_sup] at h,
    simp only [h],
    intros x hx,
    simp only [submodule.mem_sup] at hx,
    rcases hx with ⟨y, hy, z, hz, rfl⟩,
    simp only [inner_add_left],
    convert add_zero (0 : ℝ),
    {
      apply inner_left_of_mem_orthogonal_singleton,
      simp only [pair_to_TS] at hy,
      exact TS_le_uperp _ _ hy,
    },
    {
      exact A_ᾰ rfl z hz,
    },
  },
end

lemma semicritical_subprojection
{k : ℕ}
{u : metric.sphere (0 : V) 1}
(A B : multiset (microid_pair k u))
(E : submodule ℝ V)
(SP : multiset (microid_measure Eᗮ k))
(hAE : E = (A.map pair_to_TS).sum)
(hA2 : dim E = A.card)
(hB : semicritical_spaces ((A + B).map pair_to_TS))
(hSP : SP = B.map (project_microid_measure Eᗮ ∘ pair_to_measure)):
semicritical_spaces
(SP.map (TS_microid_measure (uncoe_sph Eᗮ u (u_mem_sum_TS_orth A hAE)))) :=
begin
  simp only [hSP],
  rw [multiset.map_map, map_lambda],
  simp only [function.comp_app, TS_microid_measure,
    microid_proj_eq_proj_microid, proj_body, uncoe_sph],
  simp only [←TS_orthogonal_projection],
  let C := A.map pair_to_TS,
  let D := B.map pair_to_TS,
  suffices hD : semicritical_spaces (D.map (λ W, W.map (proj Eᗮ))),
  {
    simpa only [D, multiset.map_map, map_lambda, function.comp_app] using hD,
  },
  simp only [multiset.map_add] at hB,
  change semicritical_spaces (C + D) at hB,
  refine semicritical_spaces_factorization _ _ _ hB,
  refine ⟨_, _⟩,
  {
    simpa only [C, multiset.card_map] using hA2,
  },
  {
    intros F hF,
    simp only [hAE],
    apply le_sum_multiset_of_mem,
    exact hF,
  },
end

end blabb

--set_option pp.implicit true
theorem matryoshka_principle {k : ℕ}
(n₀ : ℕ)
(n : ℕ)
(hn : n ≤ n₀)
(μs : multiset (microid_measure V k))
(u : metric.sphere (0 : V) 1)
--(hdim1 : n ≥ 1)
(hdim2 : dim V = n + 1)
(hdim3 : μs.card = n)
(hTS : semicritical_spaces (μs.map (TS_microid_measure u))) :
u ∈ msupport (bm.area (μs.map microid_of_measure)) :=
begin
  unfreezingI {
    induction n₀ with n₀ ih generalizing n μs V,
    {
      have : μs = 0,
      {
        rw [←multiset.card_eq_zero, hdim3],
        simpa only [le_zero_iff] using hn,
      },
      rw [this],
      simp only [multiset.empty_eq_zero, multiset.map_zero, bm.area_empty],
    },
    {
      by_cases hn' : n = 0,
      {
        have : μs = 0,
        {
          rw [←multiset.card_eq_zero, hdim3, hn'],
        },
        rw [this],
        simp only [multiset.map_zero, bm.area_empty],
      },
      rcases exists_pair_multiset μs u hTS with
        ⟨C, rfl⟩,
      let D := C.map pair_to_space_pair,
      let uperp := vector_orth u.val,
      have :=
      begin
        clear ih,
        refine semicritical_switching D uperp _ _ _ _ _,
        {
          simp only [D, multiset.card_map] at hdim3 ⊢,
          rw [hdim3],
          exact nat.pos_of_ne_zero hn',
        },
        {
          simpa only [multiset.map_map] using hTS,
        },
        {
          have dim_uperp : dim uperp = n,
          {
            suffices h : dim uperp + 1 = dim V,
            {
              rw [hdim2] at h,
              exact nat.add_right_cancel h,
            },
            {
              have : dim (submodule.span ℝ ({u} : set V)) = 1,
              {
                apply finrank_span_singleton,
                have := metric.mem_sphere.mp u.prop,
                have z_ne_o: 1 ≠ (0 : ℝ) := zero_ne_one.symm,
                rw [←this] at z_ne_o,
                apply dist_ne_zero.mp z_ne_o,
              },
              rw [←this],
              rw [nat.add_comm],
              refine dim_add_dim_orthogonal _,
            },
          },
          symmetry,
          simpa only [dim_uperp, multiset.card_map] using hdim3,
        },
        {
          clear hn hdim2 hdim3 hTS,
          intros x xD,
          rcases multiset.mem_map.mp xD with ⟨c, ⟨cC, rfl⟩⟩,
          simp only [pair_to_space_pair],
          split,
          {apply TS_le_uperp},
          {
            simp only [pair_to_default_space, pair_to_default_body, submodule.span_le],
            apply TS_le_uperp,
/-          simp only [polytope_to_convex_body],
            have is_default_poly := c.snd.2,
            exact is_default_poly.1, --simp only [is_default_polytope] at is_default_poly, -/
          },
        },
        {
          intros x xD,
          rcases multiset.mem_map.mp xD with ⟨c, ⟨cC, rfl⟩⟩,
          simp only [pair_to_space_pair, pair_to_default_space,
            pair_to_default_body, convex_body_of_polytope],
          have is_default_poly := c.snd.2,
          exact is_default_poly.2.2.1,
        },
      end,
      rcases this with ⟨A, B, h⟩,
      rcases h with ⟨hAB, hBD, h1, h2, h3⟩,
      rcases multiset_exists_of_le_map hBD with ⟨B', ⟨hB'C, rfl⟩⟩,
      rcases multiset_exists_of_le_map hAB with ⟨A', ⟨hA'B', rfl⟩⟩,
      /- let F := (B' - A').map pair_to_default_measure + (C - B').map pair_to_measure,
      let G := A'.map pair_to_default_measure,
      let E : submodule ℝ V := (A'.map pair_to_default_space).sum,
      have uE : u.val ∈ Eᗮ,
      {
        suffices h : E ≤ uperp,
        {
          simp only [submodule.mem_orthogonal],
          rintro x xE,
          apply inner_left_of_mem_orthogonal_singleton,
          exact h xE,
        },
        {
          refine sum_multiset_le _,
          rintro W hW,
          simp only [pair_to_default_space, multiset.mem_map] at hW,
          rcases hW with ⟨a, hA, rfl⟩,
          apply TS_le_uperp,
        },
      }, -/
      /- let pF := F.map (project_microid_measure Eᗮ),
      let n' := pF.card,
      have hn' : n' ≤ n₀,
      {
        simp only [n', pF, F, multiset.card_map, multiset.card_add
          --, multiset.card_add, multiset.card_sub, hA'B', hB'C
        ],
        rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
        rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
        simp only [add_tsub_cancel_left],
        simp only [multiset.card_map, multiset.card_add] at hdim3,
        calc t.card + tt.card = n - A'.card : _
      ...  ≤ n - 1 : _
      ...  ≤ n₀ : _,
        {
          rw [←hdim3],
          admit,
        },
        {
          apply nat.sub_le_sub_left n,
          apply nat.succ_le_of_lt,
          simpa only [multiset.card_map] using h3,
        },
        {
          norm_num,
          assumption,
        },
      },
      have EA' : dim E = A'.card,
      {
        apply le_antisymm,
        {admit},
        {
          simp only [multiset.map_map, pair_to_space_pair] at h1,
          rw [←multiset.card_map pair_to_default_space],
          --simp only [pair_to_default_space] at E,
          refine h1 _ _,
          refine le_trans _ (multiset.le_add_right _ _),
          simp only [function.comp_app],
          exact multiset.map_le_map hA'B',
        }
      },
      have hdim2' : dim Eᗮ = n' + 1,
      {
        apply le_antisymm,
        {
          suffices dimE : dim E ≥ n - n',
          {
            simp only [ge_iff_le, tsub_le_iff_right, eq_tsub_of_add_eq hdim2.symm] at dimE,
            rw [←dim_add_dim_orthogonal E, nat.add_assoc] at dimE,
            norm_num at dimE,
            exact dimE,
          },
          {
            rw [EA'],
            norm_num,
            simp only [hdim3.symm, multiset.card_map],
            simp only [pF, F, n', multiset.card_map, multiset.card_add],

            rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
            rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
            simp only [add_tsub_cancel_left, multiset.card_add],
            simp only [add_assoc],
          },
        },
        {
          suffices dimE : dim E ≤ n - n',
          {
            simp only [ge_iff_le, tsub_le_iff_right, eq_tsub_of_add_eq hdim2.symm] at dimE,
            rw [←dim_add_dim_orthogonal E, tsub_tsub] at dimE,
            admit,
          },
          {
            rw [multiset.map_map, pair_to_space_pair_def, multiset.card_map] at h2,
            rw [h2],
            rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
            rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
            simp only [add_tsub_cancel_left,
                       multiset.card_map, n', pF, F,
                       multiset.card_add,
                       hdim3.symm],
            generalizes [A'.card = A'c, t.card = tc, tt.card = ttc],
            rw [nat.add_assoc],
            simp only [add_tsub_cancel_right],
          },
        },
      },
      have hdim3' : pF.card = n' := rfl,
      let u' := uncoe_sph Eᗮ u uE, -/
      let A := A'.map reduce_pair,
      let B := (B' - A').map reduce_pair + (C - B'),
      let E := (A.map pair_to_TS).sum,
      let SP := B.map (project_microid_measure Eᗮ ∘ pair_to_measure),
      have sc_AB : semicritical_spaces ((A + B).map pair_to_TS),
      {
        have hA : A.map pair_to_TS = A'.map pair_to_default_space,
        {simp only [multiset.map_map, function.comp_app, TS_reduce_eq_default_space]},
        have hB : B.map pair_to_TS = (B' - A').map pair_to_default_space + (C - B').map pair_to_TS,
        {
          simp only [B, multiset.map_map, multiset.map_add, function.comp_app,
            TS_reduce_eq_default_space],
        },
        have hAB : (A + B).map pair_to_TS = B'.map pair_to_default_space + (C - B').map pair_to_TS,
        {
          rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
          rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
          simp only [A, B, add_tsub_cancel_left, multiset.map_map, multiset.map_add,
            function.comp_app, TS_reduce_eq_default_space, add_assoc],
        },
        rw [hAB],
        rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
        rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
        simp only [add_tsub_cancel_left] at hAB ⊢,
        simp only [D, pair_to_space_pair_def] at h1,
        simpa only [multiset.map_add, multiset.map_map, add_tsub_cancel_left,
          function.comp_app] using h1,
      },
      have dimE : dim E = A.card,
      {
        rw [multiset.card_map] at h2 ⊢,
        rw [←h2],
        suffices h : E = ((A'.map pair_to_space_pair).map prod.snd).sum,
        {rw [h]},
        {
          simp only [multiset.map_map, E, pair_to_space_pair_def,
            function.comp_app, TS_reduce_eq_default_space],
        },
      },
      have sc_sp := semicritical_subprojection A B E SP rfl dimE sc_AB rfl,
      have cardSP : A.card + SP.card = n,
      {
        simp only [multiset.card_map, map_add],
        rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
        rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
        simp only [add_tsub_cancel_left],
        simpa only [multiset.card_map, multiset.card_add, add_assoc] using hdim3,
      },
      have dimEp : dim Eᗮ = SP.card + 1,
      {
        have rn := dim_add_dim_orthogonal E,
        rw [hdim2, ←cardSP, dimE, add_assoc] at rn,
        zify at rn ⊢,
        exact add_left_cancel rn,
      },
      have cardSPle : SP.card ≤ n₀,
      {
        have cardAgt : A.card > 0 := by simpa only [multiset.card_map] using h3,
        rw [←cardSP] at hn,
        apply nat.le_of_lt_succ,
        refine nat.lt_of_lt_of_le _ hn,
        simpa only [lt_add_iff_pos_left] using cardAgt,
      },
      /- have Fsc : semicritical_spaces (pF.map (TS_microid_measure u')),
      {
        simp only [multiset.map_map, function.comp_app],
        simp only [u', TS_microid_proj_eq_proj_TS_microid _ Eᗮ u uE],
        let A := A'.map pair_to_default_space,
        let Z := (B' - A').map pair_to_default_space + (C - B').map pair_to_TS,
        have := semicritical_spaces_factorization
          A Z ⟨(_ : dim E = A.card), _⟩ _,
        {
          have : Z.map (λ W, W.map (proj Eᗮ)) = F.map (λ μ, (TS_microid_measure u μ).map (proj Eᗮ)),
          {
            simp only [Z, pair_to_default_space, pair_to_TS, multiset.map_add, multiset.map_map],
            rw [TS_default_body_eq_TS_default_measure k u],
          }
        }
      }, -/
      have finp := ih SP.card cardSPle SP _ dimEp rfl sc_sp,
      clear ih hTS hn hAB hBD h2 h3 h1 sc_sp,

      have hE : E ≤ ⊤ := le_top,
      let Am := A.map pair_to_microid,
      let Bm := B.map pair_to_microid,
      have vc : bm.is_vol_coll Am E,
      {
        split,
        {simpa only [multiset.card_map, Am] using dimE},
        {
          simp only [Am, multiset.map_map],
          intros K hK,
          rcases multiset.mem_map.mp hK with ⟨x, hx, rfl⟩,
          simp only [E],
          have : convex_body_subset (pair_to_TS (reduce_pair x)) ((pair_to_microid ∘ reduce_pair) x) :=
          begin
            apply reduced_microid_subset_TS,
          end,
          refine subset_trans this _,
          apply set_like.coe_subset_coe.mpr,
          refine le_sum_multiset_of_mem _,
          apply multiset.mem_map.mpr,
          refine ⟨reduce_pair x, _, rfl⟩,
          apply multiset.mem_map.mpr,
          exact ⟨x, hx, rfl⟩,
        },
      },
      have ac : bm.is_area_coll (Am + Bm),
      {
        change finite_dimensional.finrank ℝ V = (Am + Bm).card + 1,
        change dim V = (Am + Bm).card + 1,
        rw [hdim2],
        simp only [multiset.card_add, multiset.card_map, add_left_inj],
        rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
        rcases multiset.le_iff_exists_add.mp hB'C with ⟨tt, rfl⟩,
        rw [add_tsub_cancel_left],
        rw [add_tsub_cancel_left],
        rw [←add_assoc],
        symmetry,
        simp only [multiset.card_map, multiset.card_add] at hdim3,
        assumption,
      },
      have sc : semicritical_spaces (Am.map span_of_convex_body),
      {
        simp only [multiset.map_map, Am, A],
        rw [span_reduced_microid_eq_TS, ←multiset.map_map],
        have : A.map pair_to_TS ≤ (A + B).map pair_to_TS,
        {simp only [multiset.map_add, le_add_iff_nonneg_right, zero_le]},
        exact semicritical_of_le this sc_AB,
      },
      have heq := bm.factorize_area vc ac sc,
      have tmp : multiset.map microid_of_measure SP = proj_coll Eᗮ Bm,
      {
        simp only [SP, Bm, proj_coll, multiset.map_map, pair_to_microid],
        simp only [function.comp_app],
        simp only [proj_microid_of_measure Eᗮ], -- rw does not work because of lambda!
      },
      have finp' := set.mem_image_of_mem (coe_sph Eᗮ) finp,
      rw [tmp, ←heq, coe_uncoe_sph] at finp',

      have : Am + Bm = B'.map pair_to_default_body + (C - B').map pair_to_microid,
      {
        simp only [Am, Bm, A, B, multiset.map_add, multiset.map_map],
        rw [←add_assoc],
        congr,
        rw [←multiset.map_add],
        simp only [function.comp_app, reduced_microid_eq_default_body],
        rcases multiset.le_iff_exists_add.mp hA'B' with ⟨t, rfl⟩,
        simp only [add_tsub_cancel_left],
      },
      rw [this] at finp',
      have : dim V = C.card + 1,
      {
        symmetry,
        simpa only [multiset.card_map, hdim2, add_left_inj] using hdim3,
      },
      rcases multiset.le_iff_exists_add.mp hB'C with ⟨D, rfl⟩,
      rw [add_tsub_cancel_left] at finp',
      have := matryoshka_reduction this finp',
      simpa only [multiset.map_map, pair_to_microid] using this,
    },
  },
end


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

! This file was ported from Lean 3 source module algebraic_geometry.presheafed_space.has_colimits
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.PresheafedSpace
import Mathbin.Topology.Category.Top.Limits
import Mathbin.Topology.Sheaves.Limits

/-!
# `PresheafedSpace C` has colimits.

If `C` has limits, then the category `PresheafedSpace C` has colimits,
and the forgetful functor to `Top` preserves these colimits.

When restricted to a diagram where the underlying continuous maps are open embeddings,
this says that we can glue presheaved spaces.

Given a diagram `F : J ⥤ PresheafedSpace C`,
we first build the colimit of the underlying topological spaces,
as `colimit (F ⋙ PresheafedSpace.forget C)`. Call that colimit space `X`.

Our strategy is to push each of the presheaves `F.obj j`
forward along the continuous map `colimit.ι (F ⋙ PresheafedSpace.forget C) j` to `X`.
Since pushforward is functorial, we obtain a diagram `J ⥤ (presheaf C X)ᵒᵖ`
of presheaves on a single space `X`.
(Note that the arrows now point the other direction,
because this is the way `PresheafedSpace C` is set up.)

The limit of this diagram then constitutes the colimit presheaf.
-/

noncomputable section

universe v' u' v u

open CategoryTheory

open TopCat

open TopCat.Presheaf

open TopologicalSpace

open Opposite

open CategoryTheory.Category

open CategoryTheory.Limits

open CategoryTheory.Functor

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

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

namespace AlgebraicGeometry

namespace PresheafedSpace

attribute [local simp] eq_to_hom_map

attribute [local tidy] tactic.auto_cases_opens

@[simp]
theorem map_id_c_app (F : J ⥤ PresheafedSpace.{v} C) (j) (U) :
    (F.map (𝟙 j)).c.app (op U) =
      (Pushforward.id (F.obj j).Presheaf).inv.app (op U) ≫
        (pushforwardEq
                (by
                  simp
                  rfl)
                (F.obj j).Presheaf).Hom.app
          (op U) :=
  by
  cases U
  dsimp
  simp [PresheafedSpace.congr_app (F.map_id j)]
  rfl
#align algebraic_geometry.PresheafedSpace.map_id_c_app AlgebraicGeometry.PresheafedSpace.map_id_c_app

@[simp]
theorem map_comp_c_app (F : J ⥤ PresheafedSpace.{v} C) {j₁ j₂ j₃} (f : j₁ ⟶ j₂) (g : j₂ ⟶ j₃) (U) :
    (F.map (f ≫ g)).c.app (op U) =
      (F.map g).c.app (op U) ≫
        (pushforwardMap (F.map g).base (F.map f).c).app (op U) ≫
          (Pushforward.comp (F.obj j₁).Presheaf (F.map f).base (F.map g).base).inv.app (op U) ≫
            (pushforwardEq
                    (by
                      rw [F.map_comp]
                      rfl)
                    _).Hom.app
              _ :=
  by
  cases U
  dsimp
  simp only [PresheafedSpace.congr_app (F.map_comp f g)]
  dsimp; simp; dsimp; simp
#align algebraic_geometry.PresheafedSpace.map_comp_c_app AlgebraicGeometry.PresheafedSpace.map_comp_c_app

-- See note [dsimp, simp]
/-- Given a diagram of `PresheafedSpace C`s, its colimit is computed by pushing the sheaves onto
the colimit of the underlying spaces, and taking componentwise limit.
This is the componentwise diagram for an open set `U` of the colimit of the underlying spaces.
-/
@[simps]
def componentwiseDiagram (F : J ⥤ PresheafedSpace.{v} C) [HasColimit F]
    (U : Opens (Limits.colimit F).carrier) : Jᵒᵖ ⥤ C
    where
  obj j := (F.obj (unop j)).Presheaf.obj (op ((Opens.map (colimit.ι F (unop j)).base).obj U))
  map j k f :=
    (F.map f.unop).c.app _ ≫
      (F.obj (unop k)).Presheaf.map
        (eqToHom
          (by
            rw [← colimit.w F f.unop, comp_base]
            rfl))
  map_comp' i j k f g := by
    cases U
    dsimp
    simp_rw [map_comp_c_app, category.assoc]
    congr 1
    rw [TopCat.Presheaf.Pushforward.comp_inv_app, TopCat.Presheaf.pushforwardEq_hom_app,
      CategoryTheory.NatTrans.naturality_assoc, TopCat.Presheaf.pushforwardMap_app]
    congr 1
    rw [category.id_comp, ← (F.obj (unop k)).Presheaf.map_comp]
    erw [← (F.obj (unop k)).Presheaf.map_comp]
    congr
#align algebraic_geometry.PresheafedSpace.componentwise_diagram AlgebraicGeometry.PresheafedSpace.componentwiseDiagram

variable [HasColimitsOfShape J TopCat.{v}]

/-- Given a diagram of presheafed spaces,
we can push all the presheaves forward to the colimit `X` of the underlying topological spaces,
obtaining a diagram in `(presheaf C X)ᵒᵖ`.
-/
@[simps]
def pushforwardDiagramToColimit (F : J ⥤ PresheafedSpace.{v} C) :
    J ⥤ (Presheaf C (colimit (F ⋙ PresheafedSpace.forget C)))ᵒᵖ
    where
  obj j := op (colimit.ι (F ⋙ PresheafedSpace.forget C) j _* (F.obj j).Presheaf)
  map j j' f :=
    (pushforwardMap (colimit.ι (F ⋙ PresheafedSpace.forget C) j') (F.map f).c ≫
        (Pushforward.comp (F.obj j).Presheaf ((F ⋙ PresheafedSpace.forget C).map f)
              (colimit.ι (F ⋙ PresheafedSpace.forget C) j')).inv ≫
          (pushforwardEq (colimit.w (F ⋙ PresheafedSpace.forget C) f) (F.obj j).Presheaf).Hom).op
  map_id' j := by
    apply (op_equiv _ _).Injective
    ext U
    induction U using Opposite.rec
    cases U
    dsimp; simp; dsimp; simp
  map_comp' j₁ j₂ j₃ f g := by
    apply (op_equiv _ _).Injective
    ext U
    dsimp
    simp only [map_comp_c_app, id.def, eq_to_hom_op, pushforward_map_app, eq_to_hom_map, assoc,
      id_comp, pushforward.comp_inv_app, pushforward_eq_hom_app]
    dsimp
    simp only [eq_to_hom_trans, id_comp]
    congr 1
    -- The key fact is `(F.map f).c.congr`,
    -- which allows us in rewrite in the argument of `(F.map f).c.app`.
    rw [(F.map f).c.congr]
    -- Now we pick up the pieces. First, we say what we want to replace that open set by:
    pick_goal 3
    refine' op ((opens.map (colimit.ι (F ⋙ PresheafedSpace.forget C) j₂)).obj (unop U))
    -- Now we show the open sets are equal.
    swap
    · apply unop_injective
      rw [← opens.map_comp_obj]
      congr
      exact colimit.w (F ⋙ PresheafedSpace.forget C) g
    -- Finally, the original goal is now easy:
    swap
    · simp
      rfl
#align algebraic_geometry.PresheafedSpace.pushforward_diagram_to_colimit AlgebraicGeometry.PresheafedSpace.pushforwardDiagramToColimit

variable [∀ X : TopCat.{v}, HasLimitsOfShape Jᵒᵖ (X.Presheaf C)]

/-- Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
def colimit (F : J ⥤ PresheafedSpace.{v} C) : PresheafedSpace C
    where
  carrier := colimit (F ⋙ PresheafedSpace.forget C)
  Presheaf := limit (pushforwardDiagramToColimit F).leftOp
#align algebraic_geometry.PresheafedSpace.colimit AlgebraicGeometry.PresheafedSpace.colimit

@[simp]
theorem colimit_carrier (F : J ⥤ PresheafedSpace.{v} C) :
    (colimit F).carrier = Limits.colimit (F ⋙ PresheafedSpace.forget C) :=
  rfl
#align algebraic_geometry.PresheafedSpace.colimit_carrier AlgebraicGeometry.PresheafedSpace.colimit_carrier

@[simp]
theorem colimit_presheaf (F : J ⥤ PresheafedSpace.{v} C) :
    (colimit F).Presheaf = limit (pushforwardDiagramToColimit F).leftOp :=
  rfl
#align algebraic_geometry.PresheafedSpace.colimit_presheaf AlgebraicGeometry.PresheafedSpace.colimit_presheaf

/-- Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
@[simps]
def colimitCocone (F : J ⥤ PresheafedSpace.{v} C) : Cocone F
    where
  pt := colimit F
  ι :=
    { app := fun j =>
        { base := colimit.ι (F ⋙ PresheafedSpace.forget C) j
          c := limit.π _ (op j) }
      naturality' := fun j j' f => by
        fapply PresheafedSpace.ext
        · ext x
          exact colimit.w_apply (F ⋙ PresheafedSpace.forget C) f x
        · ext U
          induction U using Opposite.rec
          cases U
          dsimp
          simp only [PresheafedSpace.id_c_app, eq_to_hom_op, eq_to_hom_map, assoc,
            pushforward.comp_inv_app]
          rw [← congr_arg nat_trans.app (limit.w (pushforward_diagram_to_colimit F).leftOp f.op)]
          dsimp
          simp only [eq_to_hom_op, eq_to_hom_map, assoc, id_comp, pushforward.comp_inv_app]
          congr
          dsimp
          simp only [id_comp]
          simpa }
#align algebraic_geometry.PresheafedSpace.colimit_cocone AlgebraicGeometry.PresheafedSpace.colimitCocone

variable [HasLimitsOfShape Jᵒᵖ C]

namespace ColimitCoconeIsColimit

/-- Auxiliary definition for `PresheafedSpace.colimit_cocone_is_colimit`.
-/
def descCApp (F : J ⥤ PresheafedSpace.{v} C) (s : Cocone F) (U : (Opens ↥s.pt.carrier)ᵒᵖ) :
    s.pt.Presheaf.obj U ⟶
      (colimit.desc (F ⋙ PresheafedSpace.forget C) ((PresheafedSpace.forget C).mapCocone s) _*
            limit (pushforwardDiagramToColimit F).leftOp).obj
        U :=
  by
  refine'
    limit.lift _
        { pt := s.X.presheaf.obj U
          π :=
            { app := fun j => _
              naturality' := fun j j' f => _ } } ≫
      (limit_obj_iso_limit_comp_evaluation _ _).inv
  -- We still need to construct the `app` and `naturality'` fields omitted above.
  · refine' (s.ι.app (unop j)).c.app U ≫ (F.obj (unop j)).Presheaf.map (eq_to_hom _)
    dsimp
    rw [← opens.map_comp_obj]
    simp
  · rw [PresheafedSpace.congr_app (s.w f.unop).symm U]
    dsimp
    have w :=
      functor.congr_obj
        (congr_arg opens.map (colimit.ι_desc ((PresheafedSpace.forget C).mapCocone s) (unop j)))
        (unop U)
    simp only [opens.map_comp_obj_unop] at w
    replace w := congr_arg op w
    have w' := nat_trans.congr (F.map f.unop).c w
    rw [w']
    dsimp
    simp
    dsimp
    simp
#align algebraic_geometry.PresheafedSpace.colimit_cocone_is_colimit.desc_c_app AlgebraicGeometry.PresheafedSpace.ColimitCoconeIsColimit.descCApp

theorem desc_c_naturality (F : J ⥤ PresheafedSpace.{v} C) (s : Cocone F)
    {U V : (Opens ↥s.pt.carrier)ᵒᵖ} (i : U ⟶ V) :
    s.pt.Presheaf.map i ≫ descCApp F s V =
      descCApp F s U ≫
        (colimit.desc (F ⋙ forget C) ((forget C).mapCocone s) _* (colimitCocone F).pt.Presheaf).map
          i :=
  by
  dsimp [desc_c_app]
  ext
  simp only [limit.lift_π, nat_trans.naturality, limit.lift_π_assoc, eq_to_hom_map, assoc,
    pushforward_obj_map, nat_trans.naturality_assoc, op_map,
    limit_obj_iso_limit_comp_evaluation_inv_π_app_assoc,
    limit_obj_iso_limit_comp_evaluation_inv_π_app]
  dsimp
  have w :=
    functor.congr_hom
      (congr_arg opens.map (colimit.ι_desc ((PresheafedSpace.forget C).mapCocone s) (unop j)))
      i.unop
  simp only [opens.map_comp_map] at w
  replace w := congr_arg Quiver.Hom.op w
  rw [w]
  dsimp; simp
#align algebraic_geometry.PresheafedSpace.colimit_cocone_is_colimit.desc_c_naturality AlgebraicGeometry.PresheafedSpace.ColimitCoconeIsColimit.desc_c_naturality

/-- Auxiliary definition for `PresheafedSpace.colimit_cocone_is_colimit`.
-/
def desc (F : J ⥤ PresheafedSpace.{v} C) (s : Cocone F) : colimit F ⟶ s.pt
    where
  base := colimit.desc (F ⋙ PresheafedSpace.forget C) ((PresheafedSpace.forget C).mapCocone s)
  c :=
    { app := fun U => descCApp F s U
      naturality' := fun U V i => desc_c_naturality F s i }
#align algebraic_geometry.PresheafedSpace.colimit_cocone_is_colimit.desc AlgebraicGeometry.PresheafedSpace.ColimitCoconeIsColimit.desc

theorem desc_fac (F : J ⥤ PresheafedSpace.{v} C) (s : Cocone F) (j : J) :
    (colimitCocone F).ι.app j ≫ desc F s = s.ι.app j :=
  by
  fapply PresheafedSpace.ext
  · simp [desc]
  · ext
    dsimp [desc, desc_c_app]
    simpa
#align algebraic_geometry.PresheafedSpace.colimit_cocone_is_colimit.desc_fac AlgebraicGeometry.PresheafedSpace.ColimitCoconeIsColimit.desc_fac

end ColimitCoconeIsColimit

open ColimitCoconeIsColimit

/-- Auxiliary definition for `PresheafedSpace.has_colimits`.
-/
def colimitCoconeIsColimit (F : J ⥤ PresheafedSpace.{v} C) : IsColimit (colimitCocone F)
    where
  desc s := desc F s
  fac s := desc_fac F s
  uniq s m w :=
    by
    -- We need to use the identity on the continuous maps twice, so we prepare that first:
    have t :
      m.base =
        colimit.desc (F ⋙ PresheafedSpace.forget C) ((PresheafedSpace.forget C).mapCocone s) :=
      by
      apply CategoryTheory.Limits.colimit.hom_ext
      intro j
      apply ContinuousMap.ext
      intro x
      dsimp
      simp only [colimit.ι_desc_apply, map_cocone_ι_app]
      rw [← w j]
      simp
    fapply PresheafedSpace.ext
    -- could `ext` please not reorder goals?
    · exact t
    · ext (U j)
      dsimp [desc, desc_c_app]
      simp only [limit.lift_π, eq_to_hom_op, eq_to_hom_map, assoc,
        limit_obj_iso_limit_comp_evaluation_inv_π_app]
      rw [PresheafedSpace.congr_app (w (unop j)).symm U]
      dsimp
      have w := congr_arg op (functor.congr_obj (congr_arg opens.map t) (unop U))
      rw [nat_trans.congr (limit.π (pushforward_diagram_to_colimit F).leftOp j) w]
      simp
#align algebraic_geometry.PresheafedSpace.colimit_cocone_is_colimit AlgebraicGeometry.PresheafedSpace.colimitCoconeIsColimit

instance : HasColimitsOfShape J (PresheafedSpace.{v} C)
    where HasColimit F :=
    HasColimit.mk
      { Cocone := colimitCocone F
        IsColimit := colimitCoconeIsColimit F }

instance : PreservesColimitsOfShape J (PresheafedSpace.forget C)
    where PreservesColimit F :=
    preservesColimitOfPreservesColimitCocone (colimitCoconeIsColimit F)
      (by
        apply is_colimit.of_iso_colimit (colimit.is_colimit _)
        fapply cocones.ext
        · rfl
        · intro j
          dsimp
          simp)

/-- When `C` has limits, the category of presheaved spaces with values in `C` itself has colimits.
-/
instance [HasLimits C] : HasColimits (PresheafedSpace.{v} C)
    where HasColimitsOfShape J 𝒥 :=
    {
      HasColimit := fun F =>
        has_colimit.mk
          { Cocone := colimit_cocone F
            IsColimit := colimit_cocone_is_colimit F } }

/-- The underlying topological space of a colimit of presheaved spaces is
the colimit of the underlying topological spaces.
-/
instance forgetPreservesColimits [HasLimits C] : PreservesColimits (PresheafedSpace.forget C)
    where PreservesColimitsOfShape J 𝒥 :=
    {
      PreservesColimit := fun F =>
        preserves_colimit_of_preserves_colimit_cocone (colimit_cocone_is_colimit F)
          (by
            apply is_colimit.of_iso_colimit (colimit.is_colimit _)
            fapply cocones.ext
            · rfl
            · intro j
              dsimp
              simp) }
#align algebraic_geometry.PresheafedSpace.forget_preserves_colimits AlgebraicGeometry.PresheafedSpace.forgetPreservesColimits

/-- The components of the colimit of a diagram of `PresheafedSpace C` is obtained
via taking componentwise limits.
-/
def colimitPresheafObjIsoComponentwiseLimit (F : J ⥤ PresheafedSpace.{v} C) [HasColimit F]
    (U : Opens (Limits.colimit F).carrier) :
    (Limits.colimit F).Presheaf.obj (op U) ≅ limit (componentwiseDiagram F U) :=
  by
  refine'
    ((sheaf_iso_of_iso (colimit.iso_colimit_cocone ⟨_, colimit_cocone_is_colimit F⟩).symm).app
          (op U)).trans
      _
  refine' (limit_obj_iso_limit_comp_evaluation _ _).trans (limits.lim.map_iso _)
  fapply nat_iso.of_components
  · intro X
    refine' (F.obj (unop X)).Presheaf.mapIso (eq_to_iso _)
    simp only [functor.op_obj, unop_op, op_inj_iff, opens.map_coe, SetLike.ext'_iff,
      Set.preimage_preimage]
    simp_rw [← comp_app]
    congr 2
    exact ι_preserves_colimits_iso_inv (forget C) F (unop X)
  · intro X Y f
    change ((F.map f.unop).c.app _ ≫ _ ≫ _) ≫ (F.obj (unop Y)).Presheaf.map _ = _ ≫ _
    rw [TopCat.Presheaf.Pushforward.comp_inv_app]
    erw [category.id_comp]
    rw [category.assoc]
    erw [← (F.obj (unop Y)).Presheaf.map_comp, (F.map f.unop).c.naturality_assoc, ←
      (F.obj (unop Y)).Presheaf.map_comp]
    congr
#align algebraic_geometry.PresheafedSpace.colimit_presheaf_obj_iso_componentwise_limit AlgebraicGeometry.PresheafedSpace.colimitPresheafObjIsoComponentwiseLimit

@[simp]
theorem colimitPresheafObjIsoComponentwiseLimit_inv_ι_app (F : J ⥤ PresheafedSpace.{v} C)
    (U : Opens (Limits.colimit F).carrier) (j : J) :
    (colimitPresheafObjIsoComponentwiseLimit F U).inv ≫ (colimit.ι F j).c.app (op U) =
      limit.π _ (op j) :=
  by
  delta colimit_presheaf_obj_iso_componentwise_limit
  rw [iso.trans_inv, iso.trans_inv, iso.app_inv, sheaf_iso_of_iso_inv, pushforward_to_of_iso_app,
    congr_app (iso.symm_inv _)]
  simp_rw [category.assoc]
  rw [← functor.map_comp_assoc, nat_trans.naturality]
  erw [← comp_c_app_assoc]
  rw [congr_app (colimit.iso_colimit_cocone_ι_hom _ _)]
  simp_rw [category.assoc]
  erw [limit_obj_iso_limit_comp_evaluation_inv_π_app_assoc, lim_map_π_assoc]
  convert category.comp_id _
  erw [← (F.obj j).Presheaf.map_id]
  iterate 2 erw [← (F.obj j).Presheaf.map_comp]
  congr
#align algebraic_geometry.PresheafedSpace.colimit_presheaf_obj_iso_componentwise_limit_inv_ι_app AlgebraicGeometry.PresheafedSpace.colimitPresheafObjIsoComponentwiseLimit_inv_ι_app

@[simp]
theorem colimitPresheafObjIsoComponentwiseLimit_hom_π (F : J ⥤ PresheafedSpace.{v} C)
    (U : Opens (Limits.colimit F).carrier) (j : J) :
    (colimitPresheafObjIsoComponentwiseLimit F U).Hom ≫ limit.π _ (op j) =
      (colimit.ι F j).c.app (op U) :=
  by rw [← iso.eq_inv_comp, colimit_presheaf_obj_iso_componentwise_limit_inv_ι_app]
#align algebraic_geometry.PresheafedSpace.colimit_presheaf_obj_iso_componentwise_limit_hom_π AlgebraicGeometry.PresheafedSpace.colimitPresheafObjIsoComponentwiseLimit_hom_π

end PresheafedSpace

end AlgebraicGeometry


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

universes v u l

namespace Mathlib

/-!
# A Fubini theorem for categorical limits

We prove that $lim_{J × K} G = lim_J (lim_K G(j, -))$ for a functor `G : J × K ⥤ C`,
when all the appropriate limits exist.

We begin working with a functor `F : J ⥤ K ⥤ C`. We'll write `G : J × K ⥤ C` for the associated
"uncurried" functor.

In the first part, given a coherent family `D` of limit cones over the functors `F.obj j`,
and a cone `c` over `G`, we construct a cone over the cone points of `D`.
We then show that if `c` is a limit cone, the constructed cone is also a limit cone.

In the second part, we state the Fubini theorem in the setting where limits are
provided by suitable `has_limit` classes.

We construct
`limit_uncurry_iso_limit_comp_lim F : limit (uncurry.obj F) ≅ limit (F ⋙ lim)`
and give simp lemmas characterising it.
For convenience, we also provide
`limit_iso_limit_curry_comp_lim G : limit G ≅ limit ((curry.obj G) ⋙ lim)`
in terms of the uncurried functor.

## Future work

The dual statement.
-/

namespace category_theory.limits

/--
A structure carrying a diagram of cones over the the functors `F.obj j`.
-/
-- We could try introducing a "dependent functor type" to handle this?

structure diagram_of_cones {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C)
where
  obj : (j : J) → cone (functor.obj F j)
  map : {j j' : J} → (f : j ⟶ j') → functor.obj (cones.postcompose (functor.map F f)) (obj j) ⟶ obj j'
  id : autoParam (J → cone_morphism.hom (map 𝟙) = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp : autoParam
  (∀ {j₁ j₂ j₃ : J} (f : j₁ ⟶ j₂) (g : j₂ ⟶ j₃),
    cone_morphism.hom (map (f ≫ g)) = cone_morphism.hom (map f) ≫ cone_morphism.hom (map g))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/--
Extract the functor `J ⥤ C` consisting of the cone points and the maps between them,
from a `diagram_of_cones`.
-/
@[simp] theorem diagram_of_cones.cone_points_obj {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] {F : J ⥤ K ⥤ C} (D : diagram_of_cones F) (j : J) : functor.obj (diagram_of_cones.cone_points D) j = cone.X (diagram_of_cones.obj D j) :=
  Eq.refl (functor.obj (diagram_of_cones.cone_points D) j)

/--
Given a diagram `D` of limit cones over the `F.obj j`, and a cone over `uncurry.obj F`,
we can construct a cone over the diagram consisting of the cone points from `D`.
-/
def cone_of_cone_uncurry {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] {F : J ⥤ K ⥤ C} {D : diagram_of_cones F} (Q : (j : J) → is_limit (diagram_of_cones.obj D j)) (c : cone (functor.obj uncurry F)) : cone (diagram_of_cones.cone_points D) :=
  cone.mk (cone.X c)
    (nat_trans.mk
      fun (j : J) =>
        is_limit.lift (Q j) (cone.mk (cone.X c) (nat_trans.mk fun (k : K) => nat_trans.app (cone.π c) (j, k))))

/--
`cone_of_cone_uncurry Q c` is a limit cone when `c` is a limit cone.`
-/
def cone_of_cone_uncurry_is_limit {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] {F : J ⥤ K ⥤ C} {D : diagram_of_cones F} (Q : (j : J) → is_limit (diagram_of_cones.obj D j)) {c : cone (functor.obj uncurry F)} (P : is_limit c) : is_limit (cone_of_cone_uncurry Q c) :=
  is_limit.mk
    fun (s : cone (diagram_of_cones.cone_points D)) =>
      is_limit.lift P
        (cone.mk (cone.X s)
          (nat_trans.mk
            fun (p : J × K) =>
              nat_trans.app (cone.π s) (prod.fst p) ≫
                nat_trans.app (cone.π (diagram_of_cones.obj D (prod.fst p))) (prod.snd p)))

/--
Given a functor `F : J ⥤ K ⥤ C`, with all needed limits,
we can construct a diagram consisting of the limit cone over each functor `F.obj j`,
and the universal cone morphisms between these.
-/
def diagram_of_cones.mk_of_has_limits {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] : diagram_of_cones F :=
  diagram_of_cones.mk (fun (j : J) => limit.cone (functor.obj F j))
    fun (j j' : J) (f : j ⟶ j') => cone_morphism.mk (functor.map lim (functor.map F f))

-- Satisfying the inhabited linter.

protected instance diagram_of_cones_inhabited {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] : Inhabited (diagram_of_cones F) :=
  { default := diagram_of_cones.mk_of_has_limits F }

@[simp] theorem diagram_of_cones.mk_of_has_limits_cone_points {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] : diagram_of_cones.cone_points (diagram_of_cones.mk_of_has_limits F) = F ⋙ lim :=
  rfl

/--
The Fubini theorem for a functor `F : J ⥤ K ⥤ C`,
showing that the limit of `uncurry.obj F` can be computed as
the limit of the limits of the functors `F.obj j`.
-/
def limit_uncurry_iso_limit_comp_lim {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] [has_limit (functor.obj uncurry F)] [has_limit (F ⋙ lim)] : limit (functor.obj uncurry F) ≅ limit (F ⋙ lim) :=
  let c : cone (functor.obj uncurry F) := limit.cone (functor.obj uncurry F);
  let P : is_limit c := limit.is_limit (functor.obj uncurry F);
  let G : diagram_of_cones F := diagram_of_cones.mk_of_has_limits F;
  let Q : (j : J) → is_limit (diagram_of_cones.obj G j) := fun (j : J) => limit.is_limit (functor.obj F j);
  is_limit.cone_point_unique_up_to_iso (cone_of_cone_uncurry_is_limit Q P) (limit.is_limit (F ⋙ lim))

@[simp] theorem limit_uncurry_iso_limit_comp_lim_hom_π_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] [has_limit (functor.obj uncurry F)] [has_limit (F ⋙ lim)] {j : J} {k : K} : iso.hom (limit_uncurry_iso_limit_comp_lim F) ≫ limit.π (F ⋙ lim) j ≫ limit.π (functor.obj F j) k =
  limit.π (functor.obj uncurry F) (j, k) := sorry

@[simp] theorem limit_uncurry_iso_limit_comp_lim_inv_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (F : J ⥤ K ⥤ C) [has_limits_of_shape K C] [has_limit (functor.obj uncurry F)] [has_limit (F ⋙ lim)] {j : J} {k : K} : iso.inv (limit_uncurry_iso_limit_comp_lim F) ≫ limit.π (functor.obj uncurry F) (j, k) =
  limit.π (F ⋙ lim) j ≫ limit.π (functor.obj F j) k := sorry

/--
The Fubini theorem for a functor `G : J × K ⥤ C`,
showing that the limit of `G` can be computed as
the limit of the limits of the functors `G.obj (j, _)`.
-/
def limit_iso_limit_curry_comp_lim {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits_of_shape K C] [has_limit G] [has_limit (functor.obj curry G ⋙ lim)] : limit G ≅ limit (functor.obj curry G ⋙ lim) :=
  has_limit.iso_of_nat_iso (iso.app (equivalence.unit_iso (equivalence.symm currying)) G) ≪≫
    limit_uncurry_iso_limit_comp_lim (functor.obj curry G)

@[simp] theorem limit_iso_limit_curry_comp_lim_hom_π_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits_of_shape K C] [has_limit G] [has_limit (functor.obj curry G ⋙ lim)] {j : J} {k : K} : iso.hom (limit_iso_limit_curry_comp_lim G) ≫
    limit.π (functor.obj curry G ⋙ lim) j ≫ limit.π (functor.obj (functor.obj curry G) j) k =
  limit.π G (j, k) := sorry

@[simp] theorem limit_iso_limit_curry_comp_lim_inv_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits_of_shape K C] [has_limit G] [has_limit (functor.obj curry G ⋙ lim)] {j : J} {k : K} : iso.inv (limit_iso_limit_curry_comp_lim G) ≫ limit.π G (j, k) =
  limit.π (functor.obj curry G ⋙ lim) j ≫ limit.π (functor.obj (functor.obj curry G) j) k := sorry

/--
A variant of the Fubini theorem for a functor `G : J × K ⥤ C`,
showing that $\lim_k \lim_j G(j,k) ≅ \lim_j \lim_k G(j,k)$.
-/
def limit_curry_swap_comp_lim_iso_limit_curry_comp_lim {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits C] : limit (functor.obj curry (prod.swap K J ⋙ G) ⋙ lim) ≅ limit (functor.obj curry G ⋙ lim) :=
  (iso.symm (limit_iso_limit_curry_comp_lim (prod.swap K J ⋙ G)) ≪≫
      has_limit.iso_of_equivalence (prod.braiding K J) (iso.refl (equivalence.functor (prod.braiding K J) ⋙ G))) ≪≫
    limit_iso_limit_curry_comp_lim G

@[simp] theorem limit_curry_swap_comp_lim_iso_limit_curry_comp_lim_hom_π_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits C] {j : J} {k : K} : iso.hom (limit_curry_swap_comp_lim_iso_limit_curry_comp_lim G) ≫
    limit.π (functor.obj curry G ⋙ lim) j ≫ limit.π (functor.obj (functor.obj curry G) j) k =
  limit.π (functor.obj curry (prod.swap K J ⋙ G) ⋙ lim) k ≫
    limit.π (functor.obj (functor.obj curry (prod.swap K J ⋙ G)) k) j := sorry

@[simp] theorem limit_curry_swap_comp_lim_iso_limit_curry_comp_lim_inv_π_π {J : Type v} {K : Type v} [small_category J] [small_category K] {C : Type u} [category C] (G : J × K ⥤ C) [has_limits C] {j : J} {k : K} : iso.inv (limit_curry_swap_comp_lim_iso_limit_curry_comp_lim G) ≫
    limit.π (functor.obj curry (prod.swap K J ⋙ G) ⋙ lim) k ≫
      limit.π (functor.obj (functor.obj curry (prod.swap K J ⋙ G)) k) j =
  limit.π (functor.obj curry G ⋙ lim) j ≫ limit.π (functor.obj (functor.obj curry G) j) k := sorry