import for_mathlib.algebra.homology.trunc
import for_mathlib.category_theory.localization.shift

noncomputable theory

open category_theory category_theory.category category_theory.limits
open_locale zero_object

namespace category_theory

instance ess_surj_comp {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃] (F : C₁ ⥤ C₂)
  [ess_surj F] (G : C₂ ⥤ C₃) [ess_surj G] : ess_surj (F ⋙ G) :=
⟨λ Z, ⟨_, ⟨G.map_iso (F.obj_obj_preimage_iso (G.obj_preimage Z)) ≪≫ G.obj_obj_preimage_iso Z⟩⟩⟩

instance ess_surj_Q {C : Type*} [category C] (W : morphism_property C) :
  ess_surj (W.Q) :=
localization.ess_surj W.Q W

lemma full_of_comp_ess_surj {C D E : Type*} [category C] [category D] [category E]
  (F : C ⥤ D) (G : D ⥤ E) [ess_surj F]
  (h : ∀ (X Y : C), function.surjective (λ (f : F.obj X ⟶ F.obj Y), G.map f)) : full G :=
G.full_of_surjective (λ K₁ K₂ f, begin
  let K'₁ := F.obj_preimage K₁,
  let K'₂ := F.obj_preimage K₂,
  let e₁ : F.obj K'₁ ≅ K₁ := F.obj_obj_preimage_iso K₁,
  let e₂ : F.obj K'₂ ≅ K₂ := F.obj_obj_preimage_iso K₂,
  obtain ⟨f', hf'⟩ := h K'₁ K'₂ (G.map e₁.hom ≫ f ≫ G.map e₂.inv),
  dsimp at hf',
  refine ⟨e₁.inv ≫ f' ≫ e₂.hom, _⟩,
  simp only [G.map_comp, hf', assoc],
  rw [← G.map_comp, e₂.inv_hom_id, G.map_id, comp_id, ← G.map_comp_assoc, e₁.inv_hom_id, G.map_id,
    id_comp],
end)

lemma faithful_of_comp_ess_surj {C D E : Type*} [category C] [category D] [category E]
  (F : C ⥤ D) (G : D ⥤ E) [ess_surj F]
  (h : ∀ (X Y : C), function.injective (λ (f : F.obj X ⟶ F.obj Y), G.map f)) : faithful G :=
⟨λ K₁ K₂ f₁ f₂ hf, begin
  let K'₁ := F.obj_preimage K₁,
  let K'₂ := F.obj_preimage K₂,
  let e₁ : F.obj K'₁ ≅ K₁ := F.obj_obj_preimage_iso K₁,
  let e₂ : F.obj K'₂ ≅ K₂ := F.obj_obj_preimage_iso K₂,
  rw [← cancel_mono e₂.inv, ← cancel_epi e₁.hom],
  apply h,
  dsimp,
  simp only [hf, functor.map_comp],
end⟩

end category_theory

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

namespace derived_category

instance zero_is_le (n : ℤ) : (0 : derived_category C).is_le n :=
⟨λ i hi, is_zero.of_iso (is_zero_zero _)
  (derived_category.homology_functor C i).map_zero_object⟩

instance zero_is_ge (n : ℤ) : (0 : derived_category C).is_ge n :=
⟨λ i hi, is_zero.of_iso (is_zero_zero _)
  (derived_category.homology_functor C i).map_zero_object⟩

def is_plus (K : derived_category C) : Prop := ∃ (n : ℤ), K.is_ge n

def is_minus (K : derived_category C) : Prop := ∃ (n : ℤ), K.is_le n

variable (C)
open category_theory.triangulated

instance plus_is_triangulated_subcategory :
  is_triangulated_subcategory (λ (K : derived_category C), K.is_plus) :=
{ zero := ⟨0, infer_instance⟩,
  shift := begin
    rintros K k ⟨n, hn⟩,
    haveI := hn,
    exact ⟨n-k, shift_is_ge K n k (n-k) (by linarith)⟩,
  end,
  ext₂ := begin
    rintros T hT ⟨n₁, hn₁⟩ ⟨n₃, hn₃⟩,
    exact ⟨min n₁ n₃,
      ⟨λ n hn, short_complex.exact.is_zero_of_both_zeros (homology_sequence.ex₂ hT n)
        (is_zero.eq_of_src (hn₁.is_zero' _ (lt_of_lt_of_le hn (min_le_left n₁ n₃))) _ _)
        (is_zero.eq_of_tgt (hn₃.is_zero' _ (lt_of_lt_of_le hn (min_le_right n₁ n₃))) _ _)⟩⟩,
  end, }

abbreviation plus := full_subcategory (λ (K : derived_category C), K.is_plus)
abbreviation minus := full_subcategory (λ (K : derived_category C), K.is_minus)

namespace plus

instance : pretriangulated (plus C) := infer_instance

variable {C}

def mk (K : derived_category C) (n : ℤ) [hn : K.is_ge n] :
  derived_category.plus C :=
⟨K, n, hn⟩

def mk' (K : derived_category C) (hK : K.is_plus) :
  derived_category.plus C :=
⟨K, hK⟩

abbreviation ι : plus C ⥤ derived_category C :=
full_subcategory_inclusion _

end plus

end derived_category

namespace cochain_complex

def is_plus (K : cochain_complex C ℤ) : Prop :=
  ∃ (n : ℤ), K.is_strictly_ge n

def is_minus (K : cochain_complex C ℤ) : Prop :=
  ∃ (n : ℤ), K.is_strictly_le n

lemma is_plus.Q {K : cochain_complex C ℤ} (h : K.is_plus) :
  (derived_category.Q.obj K).is_plus :=
begin
  obtain ⟨n, hn⟩ := h,
  haveI := hn,
  exact ⟨n, infer_instance⟩,
end

instance zero_is_strictly_ge (n : ℤ) : is_strictly_ge (0 : cochain_complex C ℤ) n :=
⟨λ k hk, is_zero.of_iso (is_zero_zero _)
  (homological_complex.eval C (complex_shape.up ℤ) k).map_zero_object⟩

instance zero_is_strictly_le (n : ℤ) : is_strictly_le (0 : cochain_complex C ℤ) n :=
⟨λ k hk, is_zero.of_iso (is_zero_zero _)
  (homological_complex.eval C (complex_shape.up ℤ) k).map_zero_object⟩

lemma mapping_cone_is_strictly_le {K L : cochain_complex C ℤ} (f : K ⟶ L) (n k l : ℤ)
  [K.is_strictly_le k] [L.is_strictly_le l] (hk : k ≤ n+1) (hl : l ≤ n) :
  (mapping_cone f).is_strictly_le n :=
⟨λ i hi, begin
  simp only [mapping_cone.X_is_zero_iff],
  split,
  { exact is_strictly_le.is_zero K k (i+1) (by linarith), },
  { exact is_strictly_le.is_zero L l i (by linarith), },
end⟩

lemma mapping_cone_is_strictly_ge {K L : cochain_complex C ℤ} (f : K ⟶ L) (n k l : ℤ)
  [K.is_strictly_ge k] [L.is_strictly_ge l] (hk : n+1 ≤ k) (hl : n ≤ l) :
  (mapping_cone f).is_strictly_ge n :=
⟨λ i hi, begin
  simp only [mapping_cone.X_is_zero_iff],
  split,
  { exact is_strictly_ge.is_zero K k (i+1) (by linarith), },
  { exact is_strictly_ge.is_zero L l i (by linarith), },
end⟩

lemma mapping_cone_is_plus {K L : cochain_complex C ℤ} (f : K ⟶ L)
  (hK : K.is_plus) (hL : L.is_plus) : (mapping_cone f).is_plus :=
begin
  obtain ⟨k, hK⟩ := hK,
  obtain ⟨l, hL⟩ := hL,
  haveI := hK,
  haveI := hL,
  exact ⟨min (k-1) l, mapping_cone_is_strictly_ge f _ k l
    (by linarith [min_le_left (k-1) l]) (min_le_right _ _)⟩,
end

variable (C)
abbreviation plus :=
full_subcategory (λ (K : cochain_complex C ℤ), cochain_complex.is_plus K)
abbreviation minus :=
full_subcategory (λ (K : cochain_complex C ℤ), cochain_complex.is_minus K)

namespace plus

variable {C}

abbreviation ι : plus C ⥤ cochain_complex C ℤ :=
full_subcategory_inclusion _

variable (C)

def shift_functor (k : ℤ) : plus C ⥤ plus C :=
full_subcategory.lift _ (ι ⋙ shift_functor _ k) (λ K, begin
  obtain ⟨n, hn⟩ := K.2,
  haveI := hn,
  refine ⟨n-k, _⟩,
  dsimp,
  exact shift_is_strict_ge K.1 n k (n-k) (by linarith),
end)

instance : has_shift (plus C) ℤ :=
has_shift_of_fully_faithful ι (shift_functor C)
  (λ n, full_subcategory.lift_comp_inclusion _ _ _)

end plus

namespace minus

variable {C}

abbreviation ι : minus C ⥤ cochain_complex C ℤ :=
full_subcategory_inclusion _

end minus

end cochain_complex

open category_theory.triangulated

namespace homotopy_category

variable (C)

def is_plus : set (homotopy_category C (complex_shape.up ℤ)) :=
λ K, cochain_complex.is_plus K.1

abbreviation plus :=
full_subcategory (homotopy_category.is_plus C)

instance plus_is_triangulated_subcategory' :
  category_theory.triangulated.is_triangulated_subcategory' (is_plus C) :=
{ zero := begin
    refine ⟨⟨0⟩, _, ⟨0, infer_instance⟩⟩,
    rw is_zero.iff_id_eq_zero,
    change (homotopy_category.quotient _ _).map (𝟙 0) = 0,
    simp only [id_zero, functor.map_zero],
  end,
  shift := begin
    rintro ⟨X⟩ n hX,
    exact ((cochain_complex.plus.shift_functor C n).obj ⟨X, hX⟩).2,
  end,
  distinguished_cocone_triangle' := begin
    rintro ⟨X⟩ ⟨Y⟩ hX hY ⟨f : X ⟶ Y⟩,
    refine ⟨_, _, _, _, ⟨_, _, f, ⟨iso.refl _⟩⟩⟩,
    exact cochain_complex.mapping_cone_is_plus f hX hY,
  end, }

namespace plus

variable {C}

abbreviation ι : plus C ⥤ homotopy_category C (complex_shape.up ℤ) :=
full_subcategory_inclusion _

variable (C)

abbreviation homology_functor (n : ℤ) : plus C ⥤ C :=
ι ⋙ homotopy_category.homology_functor C (complex_shape.up ℤ) n

def shift_homology_functor_iso (n k m : ℤ) (h : k + n = m):
  shift_functor _ n ⋙ homology_functor C k ≅ homology_functor C m :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right (ι.comm_shift_iso n) _ ≪≫
  functor.associator _ _ _ ≪≫
  iso_whisker_left ι (homotopy_category.shift_homology_functor_iso C n k m h)

instance : pretriangulated (plus C) :=
is_triangulated_subcategory'.pretriangulated_full_subcategory _

--instance : is_triangulated (plus C) := infer_instance

abbreviation acyclic : set (plus C) :=
(homology_functor C 0).kernel_of_is_homological

--instance : saturated (acyclic C) := infer_instance

variable {C}

lemma mem_acyclic_W_iff {K L : plus C} (φ : K ⟶ L) :
  (subcategory.W (acyclic C)) φ ↔ ∀ (n : ℤ), is_iso ((homology_functor C n).map φ) :=
by simpa only [functor.kernel_of_is_homological_W,
  ← λ n, nat_iso.is_iso_map_iff (shift_homology_functor_iso C _ _ _ (zero_add n)) φ]

variable (C)

lemma homology_functor_is_inverted_by (n : ℤ) :
  (subcategory.W (acyclic C)).is_inverted_by (homology_functor C n) :=
λ K L f hf, begin
  rw mem_acyclic_W_iff f at hf,
  exact hf n,
end

variable {C}

lemma mem_W_iff_ι_map_mem {K L : homotopy_category.plus C} (f : K ⟶ L) :
  subcategory.W (homotopy_category.acyclic C) (homotopy_category.plus.ι.map f) ↔
  subcategory.W (homotopy_category.plus.acyclic C) f :=
by simpa only [homotopy_category.mem_acyclic_W_iff, homotopy_category.plus.mem_acyclic_W_iff]

variable (C)

def single_functor (n : ℤ) : C ⥤ homotopy_category.plus C :=
full_subcategory.lift _ (homological_complex.single C (complex_shape.up ℤ) n ⋙
  homotopy_category.quotient _ _) (λ X, ⟨n, by { dsimp, apply_instance, }⟩)

def single_functor_factors (n : ℤ) :
  single_functor C n ⋙ homotopy_category.plus.ι ≅
  (homological_complex.single C (complex_shape.up ℤ) n ⋙ homotopy_category.quotient _ _) :=
full_subcategory.lift_comp_inclusion _ _ _

instance single_functor_additive (n : ℤ) : (single_functor C n).additive :=
⟨λ K L f₁ f₂, homotopy_category.plus.ι.map_injective begin
  dsimp only [single_functor],
  simp only [full_subcategory.lift_map, functor.map_add],
end⟩

end plus

end homotopy_category

namespace derived_category

namespace plus

abbreviation Qh : homotopy_category.plus C ⥤ derived_category.plus C :=
full_subcategory.lift _ (homotopy_category.plus.ι ⋙ derived_category.Qh)
begin
  rintro ⟨⟨K⟩, n, hn⟩,
  refine ⟨n, (_ : (Q.obj K).is_ge n)⟩,
  rw ← cochain_complex.is_ge_iff_Q_obj_is_ge,
  dsimp at hn,
  haveI := hn,
  exact cochain_complex.is_ge_of_is_strictly_ge K n,
end

variable (C)

def Qh_comp_ι_iso : (Qh : _ ⥤ derived_category.plus C) ⋙ derived_category.plus.ι ≅
  homotopy_category.plus.ι ⋙ derived_category.Qh :=
full_subcategory.lift_comp_inclusion _ _ _

namespace Qh_is_localization

lemma inverts :
  (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by Qh :=
λ K L f hf, begin
  haveI : is_iso (derived_category.plus.ι.map (Qh.map f)),
  { erw [is_iso_map_iff_of_nat_iso (Qh_comp_ι_iso C) f],
    dsimp only [functor.comp_map],
    apply localization.inverts derived_category.Qh (subcategory.W (homotopy_category.acyclic C)),
    simpa only [homotopy_category.plus.mem_W_iff_ι_map_mem] using hf, },
  exact is_iso_of_reflects_iso (Qh.map f) ι,
end

abbreviation L := localization.lift _ (inverts C) (subcategory.W (homotopy_category.plus.acyclic C)).Q

def L_iso : (subcategory.W (homotopy_category.plus.acyclic C)).Q ⋙ L C ≅ Qh :=
localization.lifting.iso (subcategory.W (homotopy_category.plus.acyclic C)).Q
  (subcategory.W (homotopy_category.plus.acyclic C)) _ _

lemma full_L : full (L C) :=
begin
  let F := (subcategory.W (homotopy_category.plus.acyclic C)).Q,
  haveI := localization.ess_surj F
    (subcategory.W (homotopy_category.plus.acyclic C)), -- should be an instance
  have hF : (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by F :=
    localization.inverts _ _,
  apply category_theory.full_of_comp_ess_surj F,
  rintros ⟨⟨K₁ : cochain_complex C ℤ⟩, hK₁⟩ ⟨⟨K₂ : cochain_complex C ℤ⟩, hK₂⟩ f,
  have hK₁' := hK₁,
  have hK₂' := hK₂,
  obtain ⟨n₁, hn₁⟩ := hK₁',
  obtain ⟨n₂, hn₂⟩ := hK₂',
  let n := min n₁ n₂,
  haveI : K₁.is_strictly_ge n,
  { haveI := hn₁, exact cochain_complex.is_strictly_ge_of_le _ _ _ (min_le_left n₁ n₂), },
  haveI : K₂.is_strictly_ge n,
  { haveI := hn₂, exact cochain_complex.is_strictly_ge_of_le _ _ _ (min_le_right n₁ n₂), },
  let f' : Qh.obj ⟨⟨K₁⟩, hK₁⟩ ⟶ Qh.obj ⟨⟨K₂⟩, hK₂⟩ :=
    (L_iso C).inv.app _ ≫ f ≫ (L_iso C).hom.app _,
  let f'' : derived_category.Q.obj K₁ ⟶ derived_category.Q.obj K₂ := f',
  obtain ⟨K₃, hK₃', s, g, hs, fac⟩ := right_factorisation_of_is_strictly_ge f'' n,
  replace fac := (Q.map s) ≫= fac,
  rw is_iso.hom_inv_id_assoc at fac,
  haveI := hK₃',
  haveI := hs,
  have hK₃ : homotopy_category.is_plus C ⟨K₃⟩ := ⟨n, hK₃'⟩,
  let s' : (⟨_, hK₃⟩ : homotopy_category.plus C) ⟶ ⟨_, hK₁⟩ := (homotopy_category.quotient _ _).map s,
  let g' : (⟨_, hK₃⟩ : homotopy_category.plus C) ⟶ ⟨_, hK₂⟩ := (homotopy_category.quotient _ _).map g,
  haveI : is_iso (F.map s') := hF _ begin
    rw ← homotopy_category.plus.mem_W_iff_ι_map_mem,
    erw homotopy_category.map_quotient_W_iff,
    exact hs,
  end,
  refine ⟨inv (F.map s') ≫ F.map g', _⟩,
  dsimp only,
  erw [functor.map_comp, ← cancel_epi ((L C).map (F.map s')), ← functor.map_comp_assoc,
    is_iso.hom_inv_id, (L C).map_id, id_comp, ← cancel_epi ((L_iso C).inv.app ⟨_, hK₃⟩),
    ← (L_iso C).inv.naturality g', ← fac],
  dsimp only [f'', f'],
  erw [assoc, ← (L_iso C).inv.naturality_assoc s'],
  dsimp,
  conv_lhs { congr, skip, erw assoc, congr, skip, erw assoc, },
  erw [(L_iso C).hom_inv_id_app, comp_id],
  refl,
end

instance faithful_L : faithful (L C) :=
begin
  let F := (subcategory.W (homotopy_category.plus.acyclic C)).Q,
  haveI := localization.ess_surj F
    (subcategory.W (homotopy_category.plus.acyclic C)), -- should be an instance
  have hF : (subcategory.W (homotopy_category.plus.acyclic C)).is_inverted_by F :=
    localization.inverts _ _,
  apply category_theory.faithful_of_comp_ess_surj F,
  rintros ⟨⟨K₁ : cochain_complex C ℤ⟩, hK₁⟩ ⟨⟨K₂ : cochain_complex C ℤ⟩, hK₂⟩,
  suffices : ∀ (f : F.obj {obj := {as := K₁}, property := hK₁} ⟶ F.obj {obj := {as := K₂}, property := hK₂})
    (hf : (L C).map f = 0), f = 0,
  { intros f₁ f₂ hf,
    rw [← sub_eq_zero],
    apply this,
    simpa only [functor.map_sub, sub_eq_zero] using hf, },
  intros f hf,
  obtain ⟨⟨⟨⟨K₁'⟩, hK₁'⟩, s, g, hs⟩, hz⟩ := right_calculus_of_fractions.L_map_fac F
    (subcategory.W (homotopy_category.plus.acyclic C)) f,
  dsimp [right_calculus_of_fractions.map_roof] at hz,
  simp only [hz, preadditive.is_iso.comp_left_eq_zero],
  obtain ⟨g, rfl⟩ := (homotopy_category.quotient _ _).map_surjective g,
  let g' : (⟨⟨K₁'⟩, hK₁'⟩ : homotopy_category.plus C) ⟶ ⟨⟨K₂⟩, hK₂⟩ :=
    (homotopy_category.quotient _ _).map g,
  have hg : derived_category.Qh.map g' = derived_category.Qh.map 0,
  { rw [hz, functor.map_comp, preadditive.is_iso.comp_left_eq_zero] at hf,
    simpa only [functor.comp_map, functor.map_zero, hf, zero_comp,
      preadditive.is_iso.comp_left_eq_zero] using ((L_iso C).hom.naturality g').symm, },
  rw left_calculus_of_fractions.L_map_eq_iff derived_category.Qh
    (subcategory.W (homotopy_category.acyclic C)) at hg,
  obtain ⟨⟨K₂' : cochain_complex C ℤ⟩, s, hs, fac⟩ := hg,
  obtain ⟨s, rfl⟩ := (homotopy_category.quotient _ _).map_surjective s,
  have hK₂' := hK₂,
  obtain ⟨n, hn : K₂.is_strictly_ge n⟩ := hK₂',
  rw zero_comp at fac,
  let t : (⟨⟨K₂⟩, hK₂⟩ : homotopy_category.plus C) ⟶ ⟨⟨K₂'.trunc_ge n⟩, ⟨n, infer_instance⟩⟩ :=
    (homotopy_category.quotient _ _).map (s ≫ cochain_complex.trunc_ge.π K₂' n),
  haveI : is_iso (F.map t),
  { apply hF,
    erw [← homotopy_category.plus.mem_W_iff_ι_map_mem, homotopy_category.map_quotient_W_iff],
    haveI : quasi_iso s,
    { simpa only [← homotopy_category.map_quotient_W_iff] using hs, },
    haveI : quasi_iso (cochain_complex.trunc_ge.π K₂' n),
    { rw [cochain_complex.quasi_iso_trunc_ge_π_iff, ← cochain_complex.is_ge_iff_of_quasi_iso s],
      apply_instance, },
    apply_instance, },
  simp only [← cancel_mono (F.map t), zero_comp, ← F.map_comp, ← F.map_zero],
  congr' 1,
  dsimp [t],
  erw [functor.map_comp, ← assoc, fac, zero_comp],
end

instance : ess_surj (L C) :=
⟨begin
  rintro ⟨K, hK⟩,
  let K' := Q.obj_preimage K,
  let e : Q.obj K' ≅ K := Q.obj_obj_preimage_iso K,
  obtain ⟨n, hn⟩ := hK,
  haveI := hn,
  haveI := (cochain_complex.is_ge_iff_Q_obj_is_ge K' n).2 (derived_category.is_ge.of_iso e.symm n),
  exact ⟨(morphism_property.Q _).obj ⟨⟨K'.trunc_ge n⟩, ⟨n, infer_instance⟩⟩,
    ⟨derived_category.plus.ι.preimage_iso (ι.map_iso ((L_iso C).app _) ≪≫
      (as_iso (Q.map (cochain_complex.trunc_ge.π K' n))).symm ≪≫ e)⟩⟩,
end⟩

lemma is_equivalence : is_equivalence (L C) :=
begin
  haveI := full_L C,
  exact equivalence.of_fully_faithfully_ess_surj _
end

instance : ess_surj (Qh : _ ⥤ derived_category.plus C) :=
ess_surj.of_iso (L_iso C)

end Qh_is_localization

instance Qh_is_localization :
  (Qh : _ ⥤ derived_category.plus C).is_localization
  (triangulated.subcategory.W (homotopy_category.plus.acyclic C)) :=
begin
  haveI := Qh_is_localization.is_equivalence C,
  refine functor.is_localization.of_equivalence
    (triangulated.subcategory.W (homotopy_category.plus.acyclic C)).Q
    (triangulated.subcategory.W (homotopy_category.plus.acyclic C)) Qh
    (Qh_is_localization.L C).as_equivalence _,
  dsimp only [functor.as_equivalence],
  exact localization.lifting.iso _ (subcategory.W (homotopy_category.plus.acyclic C)) _ _,
end

abbreviation single_functor (n : ℤ) : C ⥤ derived_category.plus C :=
homotopy_category.plus.single_functor C n ⋙ derived_category.plus.Qh

def homology_functor (n : ℤ) : derived_category.plus C ⥤ C :=
derived_category.plus.ι ⋙ derived_category.homology_functor C n

instance homology_functor_additive (n : ℤ) : (homology_functor C n).additive :=
by { dsimp only [homology_functor], apply_instance, }

instance homology_functor_is_homological (n : ℤ) : (homology_functor C n).is_homological :=
by { dsimp only [homology_functor], apply_instance, }

variable {C}

def triangle_of_ses {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)
  (h₁ : S.X₁.is_plus) (h₂ : S.X₂.is_plus) (h₃ : S.X₃.is_plus) :
    pretriangulated.triangle (derived_category.plus C) :=
pretriangulated.full_subcategory_lift_triangle _ (derived_category.triangle_of_ses ex)
  h₁.Q h₂.Q h₃.Q

lemma triangle_of_ses_dist {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)
  (h₁ : S.X₁.is_plus) (h₂ : S.X₂.is_plus) (h₃ : S.X₃.is_plus) :
  triangle_of_ses ex h₁ h₂ h₃ ∈ dist_triang (derived_category.plus C) :=
begin
  change (full_subcategory_inclusion _).map_triangle.obj (triangle_of_ses ex h₁ h₂ h₃)
    ∈ dist_triang (derived_category C),
  refine pretriangulated.isomorphic_distinguished _ (derived_category.triangle_of_ses_dist ex) _
    (pretriangulated.full_subcategory_lift_triangle_iso derived_category.is_plus
    (derived_category.triangle_of_ses ex) _ _ _),
end

end plus

end derived_category


import data.cpi.semantics.interaction_tensor data.cpi.transition
import tactic.abel

namespace cpi

variables {ℂ ℍ : Type} {ω : context} [half_ring ℂ] [decidable_eq ℂ]

/-- Maps a potential transition to the interaction space. -/
def potential_interaction_space [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {A : prime_species ℍ ω Γ}
  : transition.transition_from ℓ A.val
  → interaction_space ℂ ℍ ω Γ
| ⟨ _, # a , @production.concretion _ _ _ b y G, tr ⟩ := fin_fn.single ⟨ ⟦ A ⟧, ⟨ b, y, ⟦ G ⟧ ⟩, a ⟩ 1
| ⟨ _, τ@'_, E, tr ⟩ := 0
| ⟨ _, τ⟨_⟩, E, tr ⟩ := 0

lemma potential_interaction_space.equiv [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ}
    {A B : prime_species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E E' : production ℍ ω Γ k}
    {t : A.val [ℓ, α]⟶ E} {t' : B.val [ℓ, α]⟶ E'}
  , A ≈ B → E ≈ E'
  → @potential_interaction_space ℂ ℍ ω _ _ _ Γ ℓ _ (transition.transition_from.mk t)
  = potential_interaction_space (transition.transition_from.mk t')
| _ (# a) (@production.concretion _ _ _ b y E) (production.concretion E') t t' eqA (production.equiv.concretion eqE) := begin
  unfold transition.transition_from.mk potential_interaction_space,
  have : ⟦ A ⟧ = ⟦ B ⟧ := quot.sound eqA,
  have : ⟦ E ⟧ = ⟦ E' ⟧ := quot.sound eqE,
  rw [‹⟦ A ⟧ = ⟦ B ⟧›, ‹⟦ E ⟧ = ⟦ E' ⟧›],
end
| _ (τ@'_) E E' t t' _ _ := rfl
| _ (τ⟨_⟩) E E' t t' _ _ := rfl

/-- Compute the potential interaction space for all transitions from a prime species. -/
def potential_interaction_space.from_prime [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : prime_species ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ
  := finset.sum (fintype.elems (transition.transition_from ℓ A.val)) potential_interaction_space

/-- Compute the potential interaction space for all transitions from a species's prime conponents. -/
def potential_interaction_space.from_species [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose A).sum' (potential_interaction_space.from_prime ℓ)

/-- `potential_interaction_space.from_species`, lifted to quotients. -/
def potential_interaction_space.from_species' [cpi_equiv_prop ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (A : species' ℍ ω Γ)
  : interaction_space ℂ ℍ ω Γ := (cpi_equiv.prime_decompose' A).sum' (λ B, quot.lift_on B
    (potential_interaction_space.from_prime ℓ)
    (λ B₁ B₂ equ, begin
      cases cpi_equiv_prop.transition_iso ℓ equ with iso,
      let isoF := cpi_equiv_prop.transition_from_iso iso,
      suffices : ∀ x
        , (@potential_interaction_space ℂ ℍ ω _ _ _ _ ℓ _ x)
        = potential_interaction_space (isoF.to_fun x),
        from fintype.sum_iso _ _ isoF this,

      rintros ⟨ k, α, E, t ⟩,
      simp only [
        isoF, cpi_equiv_prop.transition_from_iso,
        cpi_equiv.transition_from_fwd, cpi_equiv.transition_from_inv],
      have eqE := (iso k α).2 E t,
      cases ((iso k α).fst).to_fun ⟨E, t⟩ with E' t',
      from potential_interaction_space.equiv equ eqE,
    end))

lemma potential_interaction_space.species_eq [cpi_equiv_prop ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {A : species ℍ ω Γ}
  : (potential_interaction_space.from_species ℓ A : interaction_space ℂ ℍ ω Γ)
  = potential_interaction_space.from_species' ℓ ⟦ A ⟧
  := by simp only
    [potential_interaction_space.from_species, potential_interaction_space.from_species',
     quot.lift_on, quotient.mk, cpi_equiv.prime_decompose', multiset.sum',
     function.comp, multiset.map_map]

/-- Maps a spontaneous/immediate transition to a process space.

    This computes the Σ[x ∈ B [τ@k]—→ C] k and Σ[x ∈ B [τ⟨ a, b ⟩]—→ C] M(a, b)
    components of the definition of d(c ◯ A)/dt. -/
def immediate_process_space [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} (conc : ℍ ↪ ℂ)
    {A : prime_species ℍ ω Γ}
  : transition.transition_from ℓ A.val
  → process_space ℂ ℍ ω Γ
| ⟨ _, # a , _, tr ⟩ := 0
| ⟨ _, τ@'k, production.species B, tr ⟩ :=
  conc k • (to_process_space ⟦ B ⟧ - fin_fn.single ⟦ A ⟧ 1)
| ⟨ _, τ⟨ n ⟩, _, tr ⟩ := 0

lemma immediate_process_space.equiv [cpi_equiv ℍ ω] {Γ} {ℓ : lookup ℍ ω Γ} {conc : ℍ ↪ ℂ}
    {A B : prime_species ℍ ω Γ} :
  ∀ {k} {α : label ℍ Γ k} {E E' : production ℍ ω Γ k}
    {t : A.val [ℓ, α]⟶ E} {t' : B.val [ℓ, α]⟶ E'}
  , A ≈ B → E ≈ E'
  → immediate_process_space conc (transition.transition_from.mk t)
  = immediate_process_space conc (transition.transition_from.mk t')
| _ (# a ) E E' t t' eqA eqE := rfl
| _ (τ@'k) (production.species E) (production.species E') t t' eqA (production.equiv.species eqE) := begin
  unfold transition.transition_from.mk immediate_process_space,
  have : ⟦ A ⟧ = ⟦ B ⟧ := quot.sound eqA,
  have : ⟦ E ⟧ = ⟦ E' ⟧ := quot.sound eqE,
  rw [‹⟦ A ⟧ = ⟦ B ⟧›, ‹⟦ E ⟧ = ⟦ E' ⟧›],
end
| _ (τ⟨ n ⟩) E E' t t' eqA eqE := rfl

/-- Compute the immediate process space for all transitions from a prime species. -/
def immediate_process_space.from_prime [cpi_equiv ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ)
    (A : prime_species ℍ ω Γ)
  : process_space ℂ ℍ ω Γ
  := finset.sum (fintype.elems (transition.transition_from ℓ A.val)) (immediate_process_space conc)

/-- Compute the immediate process space for all transitions from a species's prime conponents. -/
def immediate_process_space.from_species [cpi_equiv ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  : process_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose A).sum' (immediate_process_space.from_prime conc ℓ)

/-- `immediate_process_space.from_species`, lifted to quotients. -/
def immediate_process_space.from_species' [cpi_equiv_prop ℍ ω] {Γ} (conc : ℍ ↪ ℂ) (ℓ : lookup ℍ ω Γ) (A : species' ℍ ω Γ)
  : process_space ℂ ℍ ω Γ := (cpi_equiv.prime_decompose' A).sum' (λ B, quot.lift_on B
    (immediate_process_space.from_prime conc ℓ)
    (λ B₁ B₂ equ, begin
      cases cpi_equiv_prop.transition_iso ℓ equ with iso,
      let isoF := cpi_equiv_prop.transition_from_iso iso,
      suffices : ∀ x
        , immediate_process_space conc x
        = immediate_process_space conc (isoF.to_fun x),
        from fintype.sum_iso _ _ isoF this,

      rintros ⟨ k, α, E, t ⟩,
      simp only [
        isoF, cpi_equiv_prop.transition_from_iso,
        cpi_equiv.transition_from_fwd, cpi_equiv.transition_from_inv],
      have eqE := (iso k α).2 E t,
      cases ((iso k α).fst).to_fun ⟨E, t⟩ with E' t',
      from immediate_process_space.equiv equ eqE,
    end))

lemma immediate_process_space.species_eq [cpi_equiv_prop ℍ ω] {Γ} {conc : ℍ ↪ ℂ} {ℓ : lookup ℍ ω Γ} {A : species ℍ ω Γ}
  : immediate_process_space.from_species conc ℓ A
  = immediate_process_space.from_species' conc ℓ ⟦ A ⟧
  := by simp only
    [immediate_process_space.from_species, immediate_process_space.from_species',
     quot.lift_on, quotient.mk, cpi_equiv.prime_decompose', multiset.sum',
     function.comp, multiset.map_map]

/-- The vector space of potential interactions of a process (∂P). -/
def process_potential [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ)
  : process ℂ ℍ ω Γ → interaction_space ℂ ℍ ω Γ
| (c ◯ A) := c • potential_interaction_space.from_species ℓ A
| (P |ₚ Q) := process_potential P + process_potential Q

lemma process_potential.nil_zero [cpi_equiv ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) (c : ℂ)
  : process_potential ℓ (c ◯ nil) = 0
  := by simp only
      [process_potential, potential_interaction_space.from_species,
       cpi_equiv.prime_decompose_nil, multiset.sum'_zero, smul_zero]

/-- The vector space of immediate actions of a process (dP/dt)-/
def process_immediate [cpi_equiv ℍ ω]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil)) (conc : ℍ ↪ ℂ)
  : process ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| (c ◯ A)
  := c • immediate_process_space.from_species conc ℓ A
  + (½ : ℂ) • (process_potential ℓ (c ◯ A) ⊘[conc] process_potential ℓ (c ◯ A))
| (P |ₚ Q)
  := process_immediate P + process_immediate Q
   + (process_potential ℓ P ⊘[conc] process_potential ℓ Q)

lemma process_immediate.nil_zero {conc : ℍ ↪ ℂ} [cpi_equiv ℍ ω]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (c : ℂ)
  : process_immediate M ℓ conc (c ◯ nil) = 0
  := by simp only
      [process_immediate, immediate_process_space.from_species,
       process_potential.nil_zero, cpi_equiv.prime_decompose_nil,
       multiset.sum'_zero, interaction_tensor.zero_left, smul_zero, add_zero]

lemma process_potential.equiv [cpi_equiv_prop ℍ ω] {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ {P Q : process ℂ ℍ ω Γ}
  , P ≈ Q → process_potential ℓ P = process_potential ℓ Q
| P Q eq := begin
  induction eq,
  case process.equiv.refl { refl },
  case process.equiv.trans : P Q R ab bc ih_ab ih_bc { from trans ih_ab ih_bc },
  case process.equiv.symm : P Q eq ih { from symm ih },
  case process.equiv.ξ_species : c A B equ {
    suffices : potential_interaction_space.from_species ℓ A
             = potential_interaction_space.from_species ℓ B,
    { simp only [process_potential],  from congr_arg ((•) c) this },

    calc  potential_interaction_space.from_species ℓ A
        = potential_interaction_space.from_species' ℓ ⟦ A ⟧ : potential_interaction_space.species_eq
    ... = potential_interaction_space.from_species' ℓ ⟦ B ⟧ : by rw quotient.sound equ
    ... = potential_interaction_space.from_species ℓ B : potential_interaction_space.species_eq.symm
  },
  case process.equiv.ξ_parallel₁ : P P' Q eq ih {
    unfold process_potential, rw ih,
  },
  case process.equiv.ξ_parallel₂ : P Q Q' eq ih {
    unfold process_potential, rw ih,
  },
  case process.equiv.parallel_nil : P C {
    show process_potential ℓ P + process_potential ℓ (C ◯ nil) = process_potential ℓ P,
    simp only [process_potential.nil_zero, add_zero],
  },
  case cpi.process.equiv.parallel_symm { simp only [process_potential, add_comm] },
  case process.equiv.parallel_assoc { simp only [process_potential, add_assoc] },
  case process.equiv.join : A c d { simp only [process_potential, add_smul] },
  case process.equiv.split : A B c {
    simp only [process_potential, potential_interaction_space.from_species,
               cpi_equiv.prime_decompose_parallel, multiset.sum'_add, smul_add],
  },
end

private lemma process_immediate.join [cpi_equiv_prop ℍ ω] (M : affinity ℍ)
    (ℓ : lookup ℍ ω (context.extend M.arity context.nil)) {conc : ℍ ↪ ℂ} (c d : ℂ)
    (Ds : interaction_space ℂ ℍ ω (context.extend (M.arity) context.nil))
    (Ps : process_space ℂ ℍ ω (context.extend (M.arity) context.nil))
  : (c • Ds) ⊘[conc] (d • Ds) + ((½ : ℂ) • (c • Ds) ⊘[conc] (c • Ds) + (½ : ℂ) • (d • Ds) ⊘[conc] (d • Ds))
  = (½ : ℂ) • (c • Ds + d • Ds) ⊘[conc] (c • Ds + d • Ds) := begin
  generalize ehalf : (½ : ℂ) = half,

  rw [interaction_tensor.left_distrib (c • Ds) (d • Ds),
      interaction_tensor.right_distrib (c • Ds),
      interaction_tensor.right_distrib (d • Ds),
      interaction_tensor.comm (d • Ds) (c • Ds)],

  calc  (c • Ds) ⊘ (d • Ds)
      + (half • (c • Ds) ⊘ (c • Ds) + half • (d • Ds) ⊘ (d • Ds))

      = (1 : ℂ) • (c • Ds) ⊘[conc] (d • Ds)
      + (half • (c • Ds) ⊘[conc] (c • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
      : by simp only [one_smul]

  ... = (half + half) • (c • Ds) ⊘[conc] (d • Ds)
      + (half • (c • Ds) ⊘[conc] (c • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
      : by rw [half_ring.one_is_two_halves, ← ehalf]

       ... = half • (c • Ds) ⊘[conc] (c • Ds) + half • (c • Ds) ⊘[conc] (d • Ds)
           + (half • (c • Ds) ⊘[conc] (d • Ds) + half • (d • Ds) ⊘[conc] (d • Ds))
           : begin
             simp only [add_smul],
             generalize : half • (c • Ds) ⊘[conc] (d • Ds) = cd,
             generalize : half • (c • Ds) ⊘[conc] (c • Ds) = cc,
             generalize : half • (d • Ds) ⊘[conc] (d • Ds) = dd,
             abel,
            end

       ... = half • ((c • Ds) ⊘ (c • Ds) + (c • Ds) ⊘ (d • Ds)
                    + ((c • Ds) ⊘ (d • Ds) + (d • Ds) ⊘ (d • Ds)))
           : by simp only [smul_add]
end

private lemma process_immediate.split [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ) (c : ℂ)
    (A B : species ℍ ω (context.extend M.arity context.nil))
  : process_immediate M ℓ conc (c ◯ (A |ₛ B))
  = process_immediate M ℓ conc (c ◯ A |ₚ c ◯ B) := begin
  simp only [process_immediate, immediate_process_space.from_species,
             process_potential.equiv ℓ process.equiv.split,
             cpi_equiv.prime_decompose_parallel, multiset.sum'_add, smul_add],

  generalize : multiset.sum' (cpi_equiv.prime_decompose A) (immediate_process_space.from_prime conc ℓ) = dA,
  generalize : multiset.sum' (cpi_equiv.prime_decompose B) (immediate_process_space.from_prime conc ℓ) = dB,

  have : process_potential ℓ (c ◯ A |ₚ c ◯ B) = process_potential ℓ (c ◯ A) + process_potential ℓ (c ◯ B)
    := rfl,
  simp only [this],

  generalize : process_potential ℓ (c ◯ A) = pA,
  generalize : process_potential ℓ (c ◯ B) = pB,

  simp only [interaction_tensor.left_distrib, interaction_tensor.right_distrib, smul_add],
  rw interaction_tensor.comm pB pA,

  generalize : ½ • pA ⊘[conc] pA = iA,
  generalize : ½ • pB ⊘[conc] pB = iB,
  generalize : pA ⊘[conc] pB = iAB,

  calc  c • dA + c • dB + (iA + (½ : ℂ) • iAB + ((½ : ℂ) • iAB + iB))
      = c • dA + c • dB + (iA + iB + ((½ : ℂ) • iAB + (½ : ℂ) • iAB)) : by abel
  ... = c • dA + c • dB + (iA + iB + iAB)
        : by rw [← add_smul, ← half_ring.one_is_two_halves, one_smul]
  ... = c • dA + iA + (c • dB + iB) + iAB : by abel
end

lemma process_immediate.equiv [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : ∀ {P Q : process ℂ ℍ ω (context.extend M.arity context.nil)}
  , P ≈ Q
  → process_immediate M ℓ conc P
  = process_immediate M ℓ conc Q
| P Q eq := begin
  induction eq,
  case process.equiv.refl { from rfl },
  case process.equiv.symm : A B eq ih { from (symm ih) },
  case process.equiv.trans : P Q R ab bc ih_ab ih_bc { from trans ih_ab ih_bc },

  case process.equiv.ξ_species : c A B equ {
    suffices : immediate_process_space.from_species conc ℓ A
             = immediate_process_space.from_species conc ℓ B,
    { simp only [process_immediate],
      rw [process_potential.equiv ℓ (process.equiv.ξ_species equ), this]
    },

    calc  immediate_process_space.from_species conc ℓ A
        = immediate_process_space.from_species' conc ℓ ⟦ A ⟧ : immediate_process_space.species_eq
    ... = immediate_process_space.from_species' conc ℓ ⟦ B ⟧ : by rw quotient.sound equ
    ... = immediate_process_space.from_species conc ℓ B : immediate_process_space.species_eq.symm
  },
  case process.equiv.ξ_parallel₁ : P P' Q eq ih {
    simp only [process_immediate, process_potential.equiv ℓ eq, ih],
  },
  case process.equiv.ξ_parallel₂ : P Q Q' eq ih {
    simp only [process_immediate, process_potential.equiv ℓ eq, ih],
  },
  case process.equiv.parallel_nil {
    simp only [process_immediate, process_immediate.nil_zero, add_zero,
               process_potential.nil_zero, interaction_tensor.zero_left],
  },
  case cpi.process.equiv.parallel_symm : P Q {
    simp only [process_immediate, add_comm, interaction_tensor.comm],
  },
  case process.equiv.parallel_assoc : P Q R {
    simp only [process_immediate, add_assoc] ,
    simp only [add_left_comm],
    refine congr_arg _ _,
    refine congr_arg _ _,
    refine congr_arg _ _,

    unfold process_potential,

    generalize : process_potential ℓ P = p,
    generalize : process_potential ℓ Q = q,
    generalize : process_potential ℓ R = r,

    calc  p ⊘ q + (p + q) ⊘ r
        = p ⊘[conc] q + p ⊘[conc] r + q ⊘ r : by rw [interaction_tensor.left_distrib, add_assoc]
    ... = q ⊘[conc] r + p ⊘[conc] q + p ⊘[conc] r : by simp only [add_comm, add_left_comm, interaction_tensor.comm]
    ... = q ⊘[conc] r + p ⊘[conc] (q + r) : by rw [add_assoc, ← interaction_tensor.right_distrib]
  },
  case process.equiv.join : A c d {
    simp only [process_immediate, process_potential],

    generalize : potential_interaction_space.from_species ℓ A = Ds,
    generalize : immediate_process_space.from_species conc ℓ A = Ps,

    suffices
      : (c • Ds) ⊘[conc] (d • Ds) + ((½ : ℂ) • ((c • Ds) ⊘[conc] (c • Ds)) + (½ : ℂ) • (d • Ds) ⊘[conc] (d • Ds))
      = (½ : ℂ) • ((c • Ds + d • Ds) ⊘[conc] (c • Ds + d • Ds)),
      { simp only [add_assoc, add_comm, add_smul, add_left_comm, this] },

    from process_immediate.join M ℓ c d Ds Ps,
  },
  case process.equiv.split : A B c {
    from process_immediate.split M ℓ conc c A B
  },
end

/-- dP/dt lifted to quotients. -/
def process_immediate.quot [cpi_equiv_prop ℍ ω] [add_monoid ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : process' ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| P := quot.lift_on P (process_immediate M ℓ conc)
    (λ P Q, process_immediate.equiv M ℓ conc)

/-- dP/dt lifted to process spaces. -/
def process_immediate.space [cpi_equiv_prop ℍ ω] [half_ring ℍ]
    (M : affinity ℍ) (ℓ : lookup ℍ ω (context.extend M.arity context.nil))
    (conc : ℍ ↪ ℂ)
  : process_space ℂ ℍ ω (context.extend M.arity context.nil)
  → process_space ℂ ℍ ω (context.extend M.arity context.nil)
| P := process_immediate.quot M ℓ conc (process.from_space P)

end cpi

#lint-


/-
File: signature_recover_public_key_get_generator_point_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
open tactic

open starkware.cairo.common.cairo_secp.signature
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.ec

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.signature.get_generator_point autogenerated soundness theorem -/

theorem auto_sound_get_generator_point
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_get_generator_point σ.pc)
    -- input arguments on the stack
    -- conclusion
  : ensures_ret mem σ (λ κ τ, τ.ap = σ.ap + 6 ∧ spec_get_generator_point mem κ (cast_EcPoint mem (τ.ap - 6))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_get_generator_point at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12⟩,
  -- return
  step_assert_eq hpc0 hpc1 with hret0,
  step_assert_eq hpc2 hpc3 with hret1,
  step_assert_eq hpc4 hpc5 with hret2,
  step_assert_eq hpc6 hpc7 with hret3,
  step_assert_eq hpc8 hpc9 with hret4,
  step_assert_eq hpc10 hpc11 with hret5,
  step_ret hpc12,
  -- finish
  step_done, use_only [rfl, rfl],
  split, refl,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_get_generator_point mem _  _,
  { apply sound_get_generator_point, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_get_generator_point],
  try { norm_num1 }, try { arith_simps },
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub] }, },
  try { dsimp [cast_EcPoint, cast_BigInt3] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2, hret3, hret4, hret5] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import pseudo_normed_group.category.CompHausFiltPseuNormGrp

universe variables u

open category_theory
open_locale nnreal

local attribute [instance] type_pow

noncomputable theory

/-- The category of CompHaus-ly filtered pseudo-normed groups with exhaustive filtrations
and with strict morphisms. -/
structure CompHausFiltPseuNormGrp₁ : Type (u+1) :=
(M : Type u)
[str : comphaus_filtered_pseudo_normed_group M]
(exhaustive' : ∀ m : M, ∃ c, m ∈ pseudo_normed_group.filtration M c)

namespace CompHausFiltPseuNormGrp₁

instance : has_coe_to_sort CompHausFiltPseuNormGrp₁ Type* := ⟨λ M, M.M⟩
instance (M : CompHausFiltPseuNormGrp₁) : comphaus_filtered_pseudo_normed_group M := M.str

lemma exhaustive (M : CompHausFiltPseuNormGrp₁) (m : M) :
  ∃ c, m ∈ pseudo_normed_group.filtration M c := M.exhaustive' _

instance : large_category CompHausFiltPseuNormGrp₁.{u} :=
{ hom := λ A B, strict_comphaus_filtered_pseudo_normed_group_hom A B,
  id := λ A, strict_comphaus_filtered_pseudo_normed_group_hom.id,
  comp := λ A B C f g, g.comp f }

/-- The "forget ₁" functor from `CompHaus`-ly filtered normed groups with strict morphisms,
  to CompHaus-ly filtered pseudo-normed groups with bounded morphisms, which is the
  identity on objects. -/
@[simps]
def _root_.CHFPNG₁_to_CHFPNGₑₗ : CompHausFiltPseuNormGrp₁ ⥤ CompHausFiltPseuNormGrp :=
{ obj := λ M, CompHausFiltPseuNormGrp.of M,
  map := λ M₁ M₂ f, f.to_chfpsng_hom }

instance : faithful (CHFPNG₁_to_CHFPNGₑₗ.{u}) :=
{ map_injective' := λ M₁ M₂ f g h,
  by { ext x, apply_fun (λ φ, φ.to_fun) at h, exact congr_fun h x } }

instance : concrete_category CompHausFiltPseuNormGrp₁.{u} :=
{ forget :=
  { obj := λ M, M.M,
    map := λ A B f, f },
  forget_faithful := ⟨⟩ } .

def level : ℝ≥0 ⥤ CompHausFiltPseuNormGrp₁.{u} ⥤ CompHaus :=
{ obj := λ c,
  { obj := λ M, CompHaus.of $ pseudo_normed_group.filtration M c,
    map := λ A B f, ⟨_, f.level_continuous _⟩ },
  map := λ c₁ c₂ h,
    { app := λ M, by letI : fact (c₁ ≤ c₂) := ⟨le_of_hom h⟩; exact
        ⟨_, comphaus_filtered_pseudo_normed_group.continuous_cast_le _ _⟩ } } .

section limits

/-!
In this section, we show (hopefully ;)) that `CompHausFiltPseuNormGrp₁` has limits.
-/

variables {J : Type u} [small_category J] (G : J ⥤ CompHausFiltPseuNormGrp₁.{u})

open pseudo_normed_group
open category_theory.limits

/-- This is a bifunctor which associates to each `c : ℝ≥0` and `j : J`,
  the `c`-th term of the filtration of `G.obj j`. -/
def cone_point_diagram : as_small.{u} ℝ≥0 ⥤ J ⥤ CompHaus.{u} :=
as_small.down ⋙ level ⋙ (whiskering_left _ _ _).obj G

@[derive [topological_space, t2_space]]
def cone_point_type_filt (c : ℝ≥0) : Type u :=
{ x : Π j : J, filtration (G.obj j) c | ∀ ⦃i j : J⦄ (e : i ⟶ j), (G.map e).level (x _) = x _ }

instance (c : ℝ≥0) : compact_space (cone_point_type_filt G c) :=
(CompHaus.limit_cone.{_ u} (((cone_point_diagram G).obj (as_small.up.obj c)))).X.is_compact -- ;-)

namespace cone_point_type_filt

variable {G}

instance (c : ℝ≥0) : has_coe_to_fun (cone_point_type_filt G c)
  (λ x, Π j : J, filtration (G.obj j) c) := ⟨λ x, x.1⟩

@[ext] lemma ext {c} (x y : cone_point_type_filt G c) :
  (⇑x : Π j : J, filtration (G.obj j) c) = y → x = y := subtype.ext

@[simp] lemma level_apply {c : ℝ≥0} {i j : J} (x : cone_point_type_filt G c) (e : i ⟶ j) :
  (G.map e).level (x i) = x j := x.2 e

@[simp] lemma map_apply {c : ℝ≥0} {i j : J} (x : cone_point_type_filt G c) (e : i ⟶ j) :
  (G.map e) (x i) = x j := by {rw ← (G.map e).coe_level, simp }

def trans {c₁ c₂ : ℝ≥0} (h : c₁ ≤ c₂) (x : cone_point_type_filt G c₁) : cone_point_type_filt G c₂ :=
⟨λ j, cast_le' h (x j), λ i j e, by { ext, simp }⟩

@[simp] lemma trans_apply {c₁ c₂ : ℝ≥0} (h : c₁ ≤ c₂) (x : cone_point_type_filt G c₁) (j : J) :
  x.trans h j = cast_le' h (x j) := by { ext, refl }

lemma trans_injective {c₁ c₂ : ℝ≥0} (h : c₁ ≤ c₂) :
  function.injective (trans h : cone_point_type_filt G c₁ → cone_point_type_filt G c₂) :=
begin
  intros x y hh,
  ext j,
  apply_fun (λ e, (e j : G.obj j)) at hh,
  exact hh
end

lemma trans_continuous {c₁ c₂ : ℝ≥0} (h : c₁ ≤ c₂) :
  continuous (trans h : cone_point_type_filt G c₁ → cone_point_type_filt G c₂) :=
begin
  -- ;-)
  let η := ((cone_point_diagram G).map (as_small.up.map $ hom_of_le $ h)),
  let hS := (CompHaus.limit_cone_is_limit.{_ u} (((cone_point_diagram G).obj (as_small.up.obj c₂)))),
  let T := (CompHaus.limit_cone.{_ u} (((cone_point_diagram G).obj (as_small.up.obj c₁)))),
  exact (hS.map T η).continuous,
end

lemma continuous_apply {c : ℝ≥0} (j : J) : continuous (λ t : cone_point_type_filt G c, t j) :=
begin
  change continuous ((λ u : Π j, filtration (G.obj j) c, u j) ∘
    (λ u : cone_point_type_filt G c, ⇑u)),
  apply continuous.comp,
  apply continuous_apply,
  apply continuous_subtype_coe,
end

instance {c} : has_zero (cone_point_type_filt G c) := has_zero.mk $
⟨λ j, 0, λ i j e, by { ext, dsimp, simp }⟩

instance {c} : has_neg (cone_point_type_filt G c) := has_neg.mk $ λ x,
⟨λ j, - (x j), λ i j e, by { ext, dsimp, simp, }⟩

def add' {c₁ c₂} (x : cone_point_type_filt G c₁) (y : cone_point_type_filt G c₂) :
  cone_point_type_filt G (c₁ + c₂) :=
⟨λ j, add' (x j, y j), λ i j e, by { ext, dsimp, simp, }⟩

@[simp] lemma zero_apply {c} (j : J) : (0 : cone_point_type_filt G c) j = 0 := rfl
@[simp] lemma neg_apply {c} (j : J) (x : cone_point_type_filt G c) : (-x) j = - (x j) := rfl
@[simp] lemma add'_apply_coe {c₁ c₂} (j : J) (x : cone_point_type_filt G c₁)
  (y : cone_point_type_filt G c₂) : ((x.add' y) j : G.obj j) = x j + y j := rfl

lemma continuous_neg {c} : continuous (λ x : cone_point_type_filt G c, - x) :=
begin
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  change continuous ((λ x, -x) ∘ (λ a : cone_point_type_filt G c, (a j))),
  apply continuous.comp,
  apply comphaus_filtered_pseudo_normed_group.continuous_neg',
  apply continuous_apply,
end

lemma continuous_add' {c1 c2} :
  continuous (λ t : cone_point_type_filt G c1 × cone_point_type_filt G c2, t.1.add' t.2) :=
begin
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  let A : cone_point_type_filt G c1 × cone_point_type_filt G c2 →
    (Π j : J, filtration (G.obj j) c1) × (Π j : J, filtration (G.obj j) c2) :=
    λ t, (t.1,t.2),
  let B : (Π j : J, filtration (G.obj j) c1) × (Π j : J, filtration (G.obj j) c2) →
    filtration (G.obj j) c1 × filtration (G.obj j) c2 := λ t, (t.1 j, t.2 j),
  let C : filtration (G.obj j) c1 × filtration (G.obj j) c2 → filtration (G.obj j) (c1 + c2) :=
    pseudo_normed_group.add',
  change continuous (C ∘ B ∘ A),
  apply continuous.comp,
  apply comphaus_filtered_pseudo_normed_group.continuous_add',
  apply continuous.comp,
  { apply continuous.prod_mk,
    { change continuous ((λ t : Π j : J, filtration (G.obj j) c1, t j) ∘ prod.fst),
      apply continuous.comp,
      apply _root_.continuous_apply,
      exact continuous_fst },
    { change continuous ((λ t : Π j : J, filtration (G.obj j) c2, t j) ∘ prod.snd),
      apply continuous.comp,
      apply _root_.continuous_apply,
      exact continuous_snd } },
  apply continuous.prod_map,
  apply continuous_subtype_coe,
  apply continuous_subtype_coe,
end

end cone_point_type_filt

def cone_point_type_setoid : setoid (Σ (c : ℝ≥0), cone_point_type_filt G c) :=
{ r := λ x y, ∃ (d : ℝ≥0) (hx : x.1 ≤ d) (hy : y.1 ≤ d), x.2.trans hx = y.2.trans hy,
  iseqv := begin
    refine ⟨_,_,_⟩,
    { rintro ⟨c,x⟩,
      use [c, le_refl _, le_refl _] },
    { rintro ⟨c,x⟩ ⟨d,y⟩ ⟨e,h1,h2,h⟩,
      dsimp at *,
      refine ⟨_, le_sup_left, le_sup_right, _⟩,
      ext j : 3,
      symmetry,
      apply_fun (λ e, (e j : G.obj j)) at h,
      exact h },
    { rintro ⟨c,x⟩ ⟨d,y⟩ ⟨e,z⟩ ⟨i,h1,hh1,hhh1⟩ ⟨j,h2,hh2,hhh2⟩,
      dsimp at *,
      refine ⟨_, le_sup_left, le_sup_right, _⟩,
      ext jj : 3,
      apply_fun (λ e, (e jj : G.obj jj)) at hhh1,
      apply_fun (λ e, (e jj : G.obj jj)) at hhh2,
      erw [hhh1, hhh2], refl },
  end }

def cone_point_type : Type u := quotient (cone_point_type_setoid G)

namespace cone_point_type
variable {G}

def incl (c : ℝ≥0) : cone_point_type_filt G c → cone_point_type G :=
quotient.mk' ∘ sigma.mk c

lemma incl_injective (c : ℝ≥0) :
  function.injective (incl c : cone_point_type_filt G c → cone_point_type G) :=
begin
  intros x y h,
  replace h := quotient.exact' h,
  obtain ⟨d,h1,h2,h⟩ := h,
  dsimp at h1 h2 h,
  rw (show h1 = h2, by refl) at h,
  apply cone_point_type_filt.trans_injective h2,
  exact h,
end

@[simp]
lemma incl_trans {c₁ c₂ : ℝ≥0} (h : c₁ ≤ c₂) (x : cone_point_type_filt G c₁) :
  incl _ (x.trans h) = incl _ x :=
begin
  apply quotient.sound',
  refine ⟨c₁ ⊔ c₂, by simp, by simp, _⟩,
  ext,
  refl,
end

lemma incl_jointly_surjective (x : cone_point_type G) :
  ∃ (c : ℝ≥0) (y : cone_point_type_filt G c), incl c y = x :=
begin
  rcases x,
  obtain ⟨c,y⟩ := x,
  use [c,y],
  refl,
end

def index (x : cone_point_type G) : ℝ≥0 := (incl_jointly_surjective x).some

def preimage (x : cone_point_type G) : cone_point_type_filt G x.index :=
  (incl_jointly_surjective x).some_spec.some

@[simp]
lemma preimage_spec (x : cone_point_type G) : incl _ x.preimage = x :=
  (incl_jointly_surjective x).some_spec.some_spec

@[simp]
lemma coe_incl_preimage_apply {c} (x : cone_point_type_filt G c) (j : J) :
  ((incl c x).preimage j : G.obj j) = x j :=
begin
  let e := c ⊔ (incl c x).index,
  change _ = (cast_le' le_sup_left (x j) : G.obj j),
  rw ← cone_point_type_filt.trans_apply (le_sup_left : _ ≤ e) x j,
  rw ← coe_cast_le' (le_sup_right : _ ≤ e),
  rw ← cone_point_type_filt.trans_apply,
  congr' 2,
  apply incl_injective,
  simp,
end

instance : has_zero (cone_point_type G) := ⟨incl 0 0⟩

lemma zero_def : (0 : cone_point_type G) = incl 0 0 := rfl

instance : has_neg (cone_point_type G) := has_neg.mk $
λ x, incl _ (-x.preimage)

lemma neg_def (x : cone_point_type G) : -x = incl _ (-x.preimage) := rfl

instance : has_add (cone_point_type G) := has_add.mk $
λ x y, incl _ (x.preimage.add' y.preimage)

lemma add_def (x y : cone_point_type G) : x + y = incl _ (x.preimage.add' y.preimage) := rfl

lemma incl_add_incl (c₁ c₂ : ℝ≥0)
  (x₁ : cone_point_type_filt G c₁) (x₂ : cone_point_type_filt G c₂) :
  (incl c₁ x₁) + (incl c₂ x₂) = (incl (c₁ + c₂) (x₁.add' x₂)) :=
begin
  rw add_def,
  apply quotient.sound',
  refine ⟨max _ _, le_max_left _ _, le_max_right _ _, _⟩,
  ext,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.add'_apply_coe,
    coe_cast_le, coe_incl_preimage_apply, coe_cast_le'],
end

lemma zero_add (x : cone_point_type G) : 0 + x = x :=
begin
  conv_rhs {rw ← x.preimage_spec},
  apply quotient.sound',
  refine ⟨(0 : cone_point_type G).index + x.index, by simp, by simp, _⟩,
  dsimp,
  ext j : 3,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.add'_apply_coe, coe_cast_le'],
  simp only [add_left_eq_self],
  apply coe_incl_preimage_apply,
end

lemma add_comm (x y : cone_point_type G) : x + y = y + x :=
begin
  apply quotient.sound',
  refine ⟨x.index + y.index, le_refl _, le_of_eq (by {dsimp, rw add_comm}), _⟩,
  dsimp,
  ext j : 3,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.add'_apply_coe,
    coe_cast_le, coe_cast_le'],
  rw add_comm,
end

lemma add_zero (x : cone_point_type G) : x + 0 = x := by { rw add_comm, apply zero_add }

lemma add_assoc (x y z : cone_point_type G) : x + y + z = x + (y + z) :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j : 3,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.add'_apply_coe,
    coe_cast_le, coe_cast_le'],
  erw [coe_incl_preimage_apply, coe_incl_preimage_apply],
  simp [add_assoc],
end

lemma add_left_neg (x : cone_point_type G) : -x + x = 0 :=
begin
  apply quotient.sound',
  refine ⟨_,le_sup_left, le_sup_right,_⟩,
  dsimp,
  ext j : 3,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.zero_apply,
    cone_point_type_filt.add'_apply_coe, coe_cast_le, filtration.coe_zero, coe_cast_le'],
  erw coe_incl_preimage_apply,
  simp,
end

instance : add_comm_group (cone_point_type G) :=
{ add_assoc := add_assoc,
  zero_add := zero_add,
  add_zero := add_zero,
  add_left_neg := add_left_neg,
  add_comm := add_comm,
  ..(infer_instance : has_add _),
  ..(infer_instance : has_zero _),
  ..(infer_instance : has_neg _) }

variable (G)
def filt (c : ℝ≥0) : set (cone_point_type G) := set.range (incl c)

def filt_equiv (c : ℝ≥0) : cone_point_type_filt G c ≃ filt G c :=
equiv.of_bijective (λ x, ⟨_, x, rfl⟩)
begin
  split,
  { intros x y h,
    apply_fun (λ e, e.val) at h,
    apply incl_injective,
    exact h },
  { rintro ⟨_,x,rfl⟩, use x }
end

instance {c} : topological_space (filt G c) :=
topological_space.induced (filt_equiv G c).symm infer_instance

def filt_homeo (c : ℝ≥0) : filt G c ≃ₜ cone_point_type_filt G c :=
homeomorph.homeomorph_of_continuous_open (filt_equiv G c).symm continuous_induced_dom
begin
  intros U hU,
  have : inducing (filt_equiv G c).symm := ⟨rfl⟩,
  rw this.is_open_iff at hU,
  obtain ⟨U,hU,rfl⟩ := hU,
  simpa,
end

instance {c} : compact_space (filt G c) :=
(filt_homeo G c).symm.compact_space

instance {c} : t2_space (filt G c) :=
(filt_homeo G c).symm.t2_space

def filt_iso (c : ℝ≥0) : CompHaus.of (filt G c) ≅
  (CompHaus.limit_cone.{_ u} (((cone_point_diagram G).obj (as_small.up.obj c)))).X :=
{ hom := (filt_homeo G c).to_continuous_map,
  inv := (filt_homeo G c).symm.to_continuous_map,
  hom_inv_id' := by { ext1, simp },
  inv_hom_id' := by { ext1, simp } }

variable {G}

@[simp] lemma incl_neg {c} (x : cone_point_type_filt G c) :
  incl c (-x) = - incl c x :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j : 3,
  simp,
end

@[simp] lemma incl_add' {c1 c2} (x1 : cone_point_type_filt G c1) (x2 : cone_point_type_filt G c2) :
  incl (c1 + c2) (x1.add' x2) = incl c1 x1 + incl c2 x2 :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j : 3,
  simp,
end

@[simp] lemma incl_zero {c} : incl c (0 : cone_point_type_filt G c) = 0 :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j : 3,
  simp,
end

instance : pseudo_normed_group (cone_point_type G) :=
{ filtration := filt G,
  filtration_mono := begin
    rintro c1 c2 h x ⟨x,rfl⟩,
    dsimp [filt],
    use x.trans h,
    simp,
  end,
  zero_mem_filtration := begin
    intro c,
    use 0,
    simp,
  end,
  neg_mem_filtration := begin
    rintros c x ⟨x,rfl⟩,
    use -x,
    simp,
  end,
  add_mem_filtration := begin
    rintros c1 c2 x1 x2 ⟨x1,rfl⟩ ⟨x2,rfl⟩,
    use x1.add' x2,
    simp,
  end }

instance : comphaus_filtered_pseudo_normed_group (cone_point_type G) :=
{ topology := by apply_instance,
  t2 := by apply_instance,
  compact := by apply_instance,
  continuous_add' := begin
    intros c1 c2,
    let E : filtration (cone_point_type G) c1 × filtration (cone_point_type G) c2 →
      cone_point_type_filt G c1 × cone_point_type_filt G c2 :=
      λ t, ⟨(filt_homeo G c1) t.1, (filt_homeo G c2) t.2⟩,
    let E' : cone_point_type_filt G c1 × cone_point_type_filt G c2 →
      filtration (cone_point_type G) c1 × filtration (cone_point_type G) c2 :=
      λ t, ⟨(filt_homeo G c1).symm t.1, (filt_homeo G c2).symm t.2⟩,
    have hE'E : E' ∘ E = id := by { dsimp [E,E'], ext, simp, simp },
    have : (filt_homeo G (c1 + c2)).symm ∘
      (λ t : cone_point_type_filt G c1 × cone_point_type_filt G c2, t.1.add' t.2) ∘ E = add',
    { suffices : add' ∘ E' = (filt_homeo G (c1 + c2)).to_equiv.symm ∘
        (λ t : cone_point_type_filt G c1 × cone_point_type_filt G c2, t.1.add' t.2),
      { erw [← function.comp.assoc, ← this, function.comp.assoc, hE'E],
        simp },
      dsimp only [filt_homeo, homeomorph.homeomorph_of_continuous_open, E'],
      ext,
      dsimp [filt_homeo, filt_equiv, E, E'],
      simp },
    rw ← this, clear this,
    apply continuous.comp (homeomorph.continuous _),
    apply continuous.comp,
    apply cone_point_type_filt.continuous_add',
    dsimp [E],
    continuity,
  end,
  continuous_neg' := begin
    intros c,
    have : (neg' : filtration (cone_point_type G) c → filtration (cone_point_type G) c) =
      (filt_homeo G c).symm ∘ (λ x, -x) ∘ filt_homeo G c,
    { suffices :
        (neg' : filtration (cone_point_type G) c → filtration (cone_point_type G) c) ∘
          (filt_homeo G c).to_equiv.symm = (filt_homeo G c).to_equiv.symm ∘ (λ x, -x),
      { erw [← function.comp.assoc, ← this, function.comp.assoc, equiv.symm_comp_self],
        simp },
      dsimp only [filt_homeo, homeomorph.homeomorph_of_continuous_open],
      simp only [equiv.symm_symm],
      ext,
      dsimp [filt_equiv],
      simp },
    rw this,
    simp [cone_point_type_filt.continuous_neg],
  end,
  continuous_cast_le := begin
    rintro c₁ c₂ ⟨h⟩,
    change continuous (cast_le' h),
    have : cast_le' h = (filt_homeo G c₂).symm ∘
      cone_point_type_filt.trans h ∘ (filt_homeo G c₁),
    { suffices : cast_le' h ∘ (filt_homeo G c₁).to_equiv.symm =
        (filt_homeo G c₂).to_equiv.symm ∘ cone_point_type_filt.trans h,
      { erw [← function.comp.assoc, ← this, function.comp.assoc, equiv.symm_comp_self],
        simp },
      dsimp only [filt_homeo, homeomorph.homeomorph_of_continuous_open],
      simp only [equiv.symm_symm],
      ext,
      dsimp [filt_equiv],
      simp },
    simp [this, cone_point_type_filt.trans_continuous],
  end }

end cone_point_type

def cone_point : CompHausFiltPseuNormGrp₁ :=
{ M := cone_point_type G,
  exhaustive' := cone_point_type.incl_jointly_surjective }

def proj (j : J) : cone_point G ⟶ G.obj j :=
{ to_fun := λ x, x.preimage j,
  map_zero' := begin
    rw cone_point_type.zero_def,
    simp only [cone_point_type.coe_incl_preimage_apply,
      cone_point_type_filt.zero_apply, filtration.coe_zero],
  end,
  map_add' := begin
    intros x y,
    rw cone_point_type.add_def x y,
    simp only [cone_point_type.coe_incl_preimage_apply,
      cone_point_type_filt.add'_apply_coe],
  end,
  strict' := begin
    rintros c x ⟨x,rfl⟩,
    simp only [cone_point_type.coe_incl_preimage_apply,
      subtype.coe_prop],
  end,
  continuous' := begin
    intros c,
    dsimp,
    let E : filtration (cone_point_type G) c → filtration (G.obj j) c :=
      λ t, ((cone_point_type.filt_homeo G c) t) j,
    suffices : continuous E,
    { convert this,
      ext ⟨t,t,rfl⟩,
      dsimp [E],
      simp only [cone_point_type.coe_incl_preimage_apply],
      congr' 2,
      apply_fun (cone_point_type.filt_homeo G c).symm,
      simp only [homeomorph.symm_apply_apply],
      ext, refl },
    dsimp [E],
    change continuous ((λ (u : cone_point_type_filt G c), u j) ∘ cone_point_type.filt_homeo G c),
    simp only [homeomorph.comp_continuous_iff'],
    apply cone_point_type_filt.continuous_apply,
  end } .

def limit_cone : cone G :=
{ X := cone_point G,
  π :=
  { app := λ j, proj G j,
    naturality' := begin
      intros i j e,
      ext,
      dsimp,
      simp only [comp_apply, category.id_comp],
      have := (cone_point_type.preimage x).2 e,
      apply_fun (λ e, (e : G.obj j)) at this,
      exact this.symm,
    end } }

def index {M : CompHausFiltPseuNormGrp₁} (x : M) : ℝ≥0 := (M.exhaustive x).some
def preimage {M : CompHausFiltPseuNormGrp₁} (x : M) : filtration M (index x) :=
  ⟨x,(M.exhaustive x).some_spec⟩

def limit_cone_lift_map (D : cone G) : D.X → cone_point G := λ x,
cone_point_type.incl (index x) ⟨λ j, (D.π.app j).level (preimage x), begin
  intros i j e,
  ext,
  dsimp,
  simp,
end⟩

lemma limit_cone_lift_map_map_zero {D : cone G} :
  limit_cone_lift_map G D 0 = 0 :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j,
  simp only [cone_point_type_filt.trans_apply, cone_point_type_filt.zero_apply,
    coe_cast_le, filtration.coe_zero, coe_cast_le'],
  apply (D.π.app j).map_zero,
end

lemma limit_cone_lift_map_map_add {D : cone G} (a b : D.X) :
  limit_cone_lift_map G D (a + b) = limit_cone_lift_map G D a + limit_cone_lift_map G D b :=
begin
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  dsimp,
  ext j,
  dsimp [limit_cone_lift_map],
  simp only [cone_point_type_filt.trans_apply, cone_point_type.coe_incl_preimage_apply,
    cone_point_type_filt.add'_apply_coe, coe_cast_le, coe_cast_le'],
  exact (D.π.app j).map_add a b,
end

lemma limit_cone_lift_map_strict {D : cone G} {x : D.X} (c : ℝ≥0) (hx : x ∈ filtration D.X c) :
  limit_cone_lift_map G D x ∈ filtration (cone_point_type G) c :=
begin
  dsimp [limit_cone_lift_map],
  change _ ∈ set.range _,
  refine ⟨⟨λ j, (D.π.app j).level ⟨x,hx⟩, _⟩, _⟩,
  { intros i j e,
    ext,
    dsimp,
    simp },
  { dsimp,
    apply quotient.sound',
    refine ⟨_, le_sup_left, le_sup_right, _⟩,
    dsimp,
    ext j,
    simpa }
end

def limit_cone_lift (D : cone G) : D.X ⟶ cone_point G :=
{ to_fun := limit_cone_lift_map _ D,
  map_zero' := limit_cone_lift_map_map_zero _,
  map_add' := limit_cone_lift_map_map_add _,
  strict' := λ c x hx, limit_cone_lift_map_strict G c hx,
  continuous' := begin
    intros c,
    rw (cone_point_type.filt_homeo G c).inducing.continuous_iff,
    let E : filtration D.X c → cone_point_type_filt G c := λ t,
      ⟨λ j, (D.π.app j).level t, _⟩,
    swap, {
      intros i j e,
      ext,
      dsimp,
      simp },
    have : (cone_point_type.filt_homeo G c) ∘ pseudo_normed_group.level
      (limit_cone_lift_map G D) (λ c x hx, limit_cone_lift_map_strict G c hx) c = E,
    { ext1,
      apply_fun (cone_point_type.filt_homeo G c).symm,
      dsimp [E],
      simp only [homeomorph.symm_apply_apply],
      ext,
      apply quotient.sound',
      refine ⟨_, le_sup_left, le_sup_right, _⟩,
      ext,
      dsimp,
      simp only [cone_point_type_filt.trans_apply, coe_cast_le, coe_cast_le'],
      refl },
    rw this,
    apply continuous.subtype_mk,
    apply continuous_pi,
    intros j,
    dsimp,
    apply (D.π.app j).level_continuous,
  end }

def limit_cone_is_limit : is_limit (limit_cone G) :=
{ lift := λ S, limit_cone_lift _ _,
  fac' := begin
    intros S j,
    ext,
    change (limit_cone G).π.app j _ = _,
    dsimp [limit_cone_lift, limit_cone, limit_cone_lift_map, proj],
    simpa,
  end,
  uniq' := begin
    intros S m h,
    ext,
    dsimp [limit_cone_lift, limit_cone_lift_map],
    rw ← (m x).preimage_spec,
    apply quotient.sound',
    refine ⟨_, le_sup_left, le_sup_right, _⟩,
    ext j,
    dsimp,
    simp only [cone_point_type_filt.trans_apply, coe_cast_le, coe_cast_le'],
    specialize h j,
    apply_fun (λ e, e x) at h,
    exact h,
  end }

-- This is the goal of this section...
instance : has_limit G := has_limit.mk ⟨limit_cone _, limit_cone_is_limit _⟩

instance : has_limits CompHausFiltPseuNormGrp₁ :=
⟨λ J hJ, { has_limit := λ G, by resetI; apply_instance }⟩

instance (c : ℝ≥0) : preserves_limit G (level.obj c) :=
preserves_limit_of_preserves_limit_cone (limit_cone_is_limit _)
{ lift := λ S,
    (CompHaus.limit_cone_is_limit.{_ u} ((cone_point_diagram G).obj (as_small.up.obj c))).lift
    _ ≫ (cone_point_type.filt_iso _ _).inv,
  fac' := begin
    intros S j,
    dsimp,
    rw category.assoc,
    convert (CompHaus.limit_cone_is_limit.{_ u}
      ((cone_point_diagram G).obj (as_small.up.obj c))).fac S j,
    ext ⟨t,ht⟩,
    dsimp [limit_cone, cone_point_type.filt_iso, cone_point_type.filt_homeo,
      homeomorph.homeomorph_of_continuous_open, cone_point_type.filt_equiv,
      level, proj, CompHaus.limit_cone, Top.limit_cone],
    simpa,
  end,
  uniq' := begin
    intros S m hm,
    rw iso.eq_comp_inv,
    apply (CompHaus.limit_cone_is_limit.{_ u} ((cone_point_diagram G).obj (as_small.up.obj c))).uniq,
    intros j,
    rw [← hm, category.assoc],
    congr' 1,
    rw ← iso.eq_inv_comp,
    ext ⟨t,ht⟩,
    dsimp [limit_cone, cone_point_type.filt_iso, cone_point_type.filt_homeo,
      homeomorph.homeomorph_of_continuous_open, cone_point_type.filt_equiv,
      level, proj, CompHaus.limit_cone, Top.limit_cone],
    simpa,
  end } .

instance (c : ℝ≥0) : preserves_limits (level.obj c) :=
{ preserves_limits_of_shape := λ J _, by exactI
  { preserves_limit := λ G, by apply_instance, } }

lemma mem_filtration_iff_of_is_limit (C : cone G) (hC : is_limit C) (c : ℝ≥0) (x : C.X) :
  x ∈ pseudo_normed_group.filtration C.X c ↔
  (∀ j : J, C.π.app j x ∈ pseudo_normed_group.filtration (G.obj j) c) :=
begin
  split,
  { intros h j,
    apply (C.π.app j).strict h },
  { intro h,
    let E := limit_cone G,
    let e : C ≅ E := hC.unique_up_to_iso (limit_cone_is_limit _),
    let eX : C.X ≅ E.X := (cones.forget _).map_iso e,
    let w := eX.hom x,
    have hw : ∀ j, E.π.app j w ∈ filtration (G.obj j) c,
    { intros j,
      dsimp only [w],
      change (eX.hom ≫ E.π.app _) _ ∈ _,
      dsimp only [eX, functor.map_iso, cones.forget],
      convert h j,
      simp },
    suffices : w ∈ filtration (limit_cone G).X c,
    { convert eX.inv.strict this,
      change _ = (eX.hom ≫ eX.inv) x,
      rw iso.hom_inv_id,
      refl },
    change ∃ z, _,
    refine ⟨⟨λ j, ⟨_, hw _⟩, _⟩, _⟩,
    { intros i j f,
      ext1,
      dsimp,
      change (E.π.app i ≫ G.map f) _ = _,
      rw E.w },
    { obtain ⟨i,z,hz⟩ := cone_point_type.incl_jointly_surjective w,
      let d : ℝ≥0 := i ⊔ c,
      conv_rhs { rw ← hz },
      rw ← cone_point_type.incl_trans (le_sup_left : i ≤ d),
      rw ← cone_point_type.incl_trans (le_sup_right : c ≤ d),
      congr' 1,
      dsimp [cone_point_type_filt.trans],
      ext j,
      dsimp,
      change E.π.app j _ = _,
      rw ← hz,
      dsimp [E, limit_cone, proj],
      simp } }
end

lemma is_limit_ext (C : cone G) (hC : is_limit C) (x y : C.X)
  (h : ∀ j, C.π.app j x = C.π.app j y) : x = y :=
begin
  let E := limit_cone G,
  let e : C ≅ E := hC.unique_up_to_iso (limit_cone_is_limit _),
  let eX : C.X ≅ E.X := (cones.forget _).map_iso e,
  apply_fun eX.hom,
  swap,
  { intros a b hh,
    apply_fun (λ e, eX.inv e) at hh,
    change (eX.hom ≫ eX.inv) _ = (eX.hom ≫ eX.inv) _ at hh,
    simpa only [iso.hom_inv_id] using hh },
  have hh : ∀ j, (E.π.app j) (eX.hom x) = (E.π.app j) (eX.hom y),
  { intros j,
    change (eX.hom ≫ E.π.app j) x = (eX.hom ≫ E.π.app j) y,
    convert h j using 2,
    all_goals { simp } },
  obtain ⟨ca,a,ha⟩ := cone_point_type.incl_jointly_surjective (eX.hom x),
  obtain ⟨cb,b,hb⟩ := cone_point_type.incl_jointly_surjective (eX.hom y),
  rw [← ha, ← hb] at ⊢ hh,
  let d : ℝ≥0 := ca ⊔ cb,
  rw ← cone_point_type.incl_trans (le_sup_left : ca ≤ d) at ⊢ hh,
  rw ← cone_point_type.incl_trans (le_sup_right : cb ≤ d) at ⊢ hh,
  congr' 1,
  ext j,
  specialize hh j,
  convert hh using 1,
  all_goals { dsimp [E, limit_cone, proj],
    simp },
end

end limits

section products

/-!
In this section, we construct explicit finite products.
-/

def product {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u}) :
  CompHausFiltPseuNormGrp₁.{u} :=
{ M := Π i, X i,
  exhaustive' := begin
    intro m,
    choose cs hcs using (λ i, (X i).exhaustive (m i)),
    have : ∃ c : ℝ≥0, ∀ i, cs i ≤ c,
    { use finset.univ.sup cs,
      intros i,
      apply finset.le_sup (finset.mem_univ i) },
    obtain ⟨c,hc⟩ := this,
    refine ⟨c, λ i, pseudo_normed_group.filtration_mono (hc i) (hcs i)⟩,
  end }

@[simps]
def product.π {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u}) (i : α) :
  product X ⟶ X i :=
{ to_fun := λ m, m i,
  map_zero' := rfl,
  map_add' := λ x y, rfl,
  strict' := λ c x hx, hx i,
  continuous' := begin
    -- This can be golfed.
    intros c,
    have h : inducing (pseudo_normed_group.filtration_pi_equiv (λ i, X i) c) := ⟨rfl⟩,
    let e : ↥(pseudo_normed_group.filtration ↥(product X) c) →
      ↥(pseudo_normed_group.filtration ↥(X i) c) :=
      pseudo_normed_group.level (λ (m : ↥(product X)), m i) _ c,
    swap,
    { intros c x hx,
      apply hx },
    change continuous e,
    have : e = _ ∘ (pseudo_normed_group.filtration_pi_equiv (λ i, X i) c),
    rotate 2,
    { intros x, exact x i },
    { ext, refl },
    erw [this],
    apply continuous.comp,
    apply continuous_apply,
    refine inducing.continuous h
  end }

@[simps]
def product.lift {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u})
  (M : CompHausFiltPseuNormGrp₁.{u}) (f : Π i, M ⟶ X i) :
  M ⟶ product X :=
{ to_fun := λ m i, f _ m,
  map_zero' := by { ext, simp },
  map_add' := by { intros, ext, simp },
  strict' := λ c x hx i, (f i).strict hx,
  continuous' := begin
    intros c,
    have h : inducing (pseudo_normed_group.filtration_pi_equiv (λ i, X i) c) := ⟨rfl⟩,
    rw [h.continuous_iff, continuous_pi_iff],
    intros i,
    exact (f i).continuous' c,
  end }

@[simp, reassoc]
lemma product.lift_π {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u})
  (M : CompHausFiltPseuNormGrp₁.{u}) (f : Π i, M ⟶ X i) (i) :
  product.lift X M f ≫ product.π X i = f i := by { ext, simp }

lemma product.lift_unique {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u})
  (M : CompHausFiltPseuNormGrp₁.{u}) (f : Π i, M ⟶ X i) (g : M ⟶ product X)
  (hg : ∀ i, g ≫ product.π X i = f i) : g = product.lift X M f :=
by { ext, simp [← hg] }

lemma product.hom_ext {α : Type u} [fintype α] (X : α → CompHausFiltPseuNormGrp₁.{u})
  (M : CompHausFiltPseuNormGrp₁.{u}) (g₁ g₂ : M ⟶ product X)
  (h : ∀ i, g₁ ≫ product.π X i = g₂ ≫ product.π X i) : g₁ = g₂ :=
begin
  rw [product.lift_unique X M _ g₁ (λ i, rfl), product.lift_unique X M _ g₂ (λ i, rfl)],
  simp [h],
end

end products

end CompHausFiltPseuNormGrp₁


/- import mcl
import parlang
open mcl
open mcl.mclk

namespace arrcp_mcl

-- open classical
-- local attribute [instance] prop_decidable
-- instance a : decidable_eq string := sorry

#check ([5] : vector _ _)

def sig : signature --:= λ n, if n = "i" then { scope := scope.tlocal, type := ⟨_, [1], type.int⟩ } else { scope := scope.shared, type := ⟨_, [100], type.int⟩ }
| "i" := { scope := scope.tlocal, type := ⟨_, [1], type.int⟩ }
| "tid" := { scope := scope.tlocal, type := ⟨_, [1], type.int⟩ }
| _ := { scope := scope.shared, type := ⟨_, [100], type.int⟩ }

lemma i_is_tlocal : is_tlocal (sig "i") := by apply eq.refl
lemma a_is_shared : is_shared (sig "a") := by apply eq.refl
lemma tid_is_tlocal : is_tlocal (sig "tid") := by apply eq.refl

def read_i := (expression.tlocal_var "i" (λ_, 0) (show type_of (sig "i") = type.int, by apply eq.refl) (by refl) i_is_tlocal)
def read_tid := (expression.tlocal_var "tid" (λ_, 0) (show type_of (sig "tid") = type.int, by apply eq.refl) (show (sig "tid").type.dim = 1, by apply eq.refl) tid_is_tlocal)

def arrcp₁ : mclp sig := mclp.intro (λ m, 100) (
    mclk.shared_assign "b" [read_tid] (by refl) (expression.shared_var "a" (λ_, read_tid) (show type_of (sig "a") = type.int, by refl) (by refl) a_is_shared)
)

def arrcp₂ : mclp sig := mclp.intro (λ m, 10) (mclk.for "i" (by refl) (by refl) read_tid (read_i < 100) (mclk.tlocal_assign "i" [1] (show ((sig "i").type).dim = vector.length [1], by refl) (read_i + read_tid)) (
    mclk.shared_assign "b" [read_i] (by refl) (expression.shared_var "a" (λ_, read_i) (show type_of (sig "a") = type.int, by refl) (by refl) a_is_shared)
))

#eval mclp_to_program arrcp₁
#eval mclp_to_program arrcp₂
--#reduce mclp_to_program arrcp₂

example (c) : mclp_to_program arrcp₁ = c := begin
    rw arrcp₁,
    rw [mclp_to_program, mclk_to_kernel, prepend_load_expr, load_shared_vars_for_expr],
    repeat {rw list.append},
    repeat {rw list.foldl},
    repeat {rw list.foldr},
end

#eval mclp_to_program arrcp₁
#check ```(mclp_to_program arrcp₁)
#print mclp_to_program

def X : ℕ → ℕ := λ n, n + 2

meta def num_args : expr → nat
| (expr.app f a) := num_args f + 1
| e:=0

#check X
#check `(X)
#eval parlang.expr.repr `(X)

example : mclp_rel eq arrcp₁ arrcp₂ eq := begin
    apply rel_mclk_to_mclp,
end

end arrcp_mcl -/


import Smt

theorem assoc (f : Bool → Bool → Bool) (p q r : Bool) :
  f p (f q r) == f (f p q) r := by
  smt
  admit


example (f : Fin n → Prop) (h : ∀ i h, i = 0 → f ⟨i, h⟩) : f i := by
  apply h
  rw [show i.1 = 0 from sorry]

def foo (x : Fin n) : Nat :=
  match x with
  | ⟨i, _⟩ => 5 + i

example (x : Fin n) : foo x = 5 := by
  simp [foo]
  rw [show x.1 = 0 from sorry]