/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.opposites
import category_theory.thin
import category_theory.full_subcategory
import category_theory.currying
import tactic

universes v v₂ v₃ u u₂ u₃

namespace category_theory

open category_theory category_theory.category

variables {C : Type u} [category.{v} C]
variables {D : Type u₂} [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

def are_iso (X Y : C) : Prop := nonempty (X ≅ Y)

variables (C)

def skeletal : Prop := ∀ (X Y : C), (X ≅ Y) → X = Y

instance up_to_iso : setoid C :=
{ r := are_iso,
  iseqv :=
  begin
    refine ⟨λ X, ⟨iso.refl _⟩, λ X Y, _, λ X Y Z, _⟩,
    rintro ⟨i⟩,
    refine ⟨i.symm⟩,
    rintro ⟨i⟩ ⟨j⟩,
    refine ⟨i.trans j⟩,
  end }

def skel := quotient (category_theory.up_to_iso C)

instance skel_preorder : preorder (skel C) :=
{ le :=
  begin
    refine quotient.lift₂ (λ X Y, nonempty (X ⟶ Y)) _,
    rintros _ _ _ _ ⟨i₁⟩ ⟨i₂⟩,
    apply propext,
    split,
    rintro ⟨f⟩,
    refine ⟨i₁.inv ≫ f ≫ i₂.hom⟩,
    rintro ⟨g⟩,
    refine ⟨i₁.hom ≫ g ≫ i₂.inv⟩,
  end,
  le_refl :=
  begin
    refine quotient.ind (λ a, _),
    exact ⟨𝟙 _⟩,
  end,
  le_trans :=
  begin
    intros _ _ _,
    apply quotient.induction_on₃ a b c,
    rintros _ _ _ ⟨f⟩ ⟨g⟩,
    refine ⟨f ≫ g⟩,
  end }

instance skel_subsingleton {X Y : skel C} : subsingleton (X ⟶ Y) :=
⟨by { rintros ⟨⟨f₁⟩⟩ ⟨⟨f₂⟩⟩, refl }⟩

instance skel_iso_subsingleton {X Y : skel C} : subsingleton (X ≅ Y) :=
⟨by { rintros i₁ i₂, ext1, apply subsingleton.elim }⟩

def skel_quotient : C ⥤ skel C :=
{ obj := quotient.mk,
  map := λ X Y f, ⟨⟨⟨f⟩⟩⟩ }

variables {C}

@[simps]
def skel_map (F : C ⥤ D) : skel C ⥤ skel D :=
{ obj :=
  begin
    refine quotient.lift _ _,
    intro x,
    apply quotient.mk (F.obj x),
    rintros x y ⟨k⟩,
    apply quotient.sound,
    refine ⟨_⟩,
    apply F.map_iso k,
  end,
  map :=
  begin
    refine quotient.rec _ _,
    { intro x,
      refine quotient.rec _ _,
      { intros y k,
        refine ⟨⟨_⟩⟩,
        rcases k with ⟨⟨⟨k⟩⟩⟩,
        refine ⟨F.map k⟩ },
      { intros y z h,
        apply subsingleton.elim } },
    { intros x y h,
      apply subsingleton.elim }
  end }

lemma skel_quotient_map (F : C ⥤ D) : skel_quotient C ⋙ skel_map F = F ⋙ skel_quotient D :=
rfl

def skel_map_comp (F : C ⥤ D) (G : D ⥤ E) : skel_map (F ⋙ G) ≅ skel_map F ⋙ skel_map G :=
nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

def skel_map_id : skel_map (𝟭 C) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

def skel_map_func {F₁ F₂ : C ⥤ D} (k : F₁ ⟶ F₂) : skel_map F₁ ⟶ skel_map F₂ :=
{ app := λ X, quotient.rec_on_subsingleton X (λ x, ⟨⟨⟨k.app x⟩⟩⟩) }

def skel_map_iso {F₁ F₂ : C ⥤ D} (h : F₁ ≅ F₂) : skel_map F₁ ≅ skel_map F₂ :=
{ hom := skel_map_func h.hom, inv := skel_map_func h.inv }

variables [∀ X Y : C, subsingleton (X ⟶ Y)]

-- def iso_of_both_ways {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≅ Y :=
-- { hom := f, inv := g }

lemma equiv_of_both_ways {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
⟨iso_of_both_ways f g⟩

instance : partial_order (skel C) :=
{ le_antisymm :=
  begin
    refine quotient.ind₂ _,
    rintros _ _ ⟨f⟩ ⟨g⟩,
    apply quotient.sound,
    apply equiv_of_both_ways f g,
  end,
  ..category_theory.skel_preorder C }

lemma skel_is_skel : skeletal (skel C) :=
begin
  intros X Y,
  apply quotient.induction_on₂ X Y,
  rintros _ _ ⟨⟨⟨⟨f⟩⟩⟩, ⟨⟨⟨g⟩⟩⟩, _, _⟩,
  apply quotient.sound,
  apply equiv_of_both_ways f g,
end

def skel_map₂ (F : C ⥤ D ⥤ E) : skel C ⥤ skel D ⥤ skel E :=
category_theory.curry_obj
{ obj :=
  begin
    rintro ⟨x₁, x₂⟩,
    refine quotient.map₂ _ _ x₁ x₂,
    intros c d, apply (F.obj c).obj d,
    rintros c₁ c₂ ⟨hc⟩ d₁ d₂ ⟨hd⟩,
    refine ⟨(F.map_iso hc).app d₁ ≪≫ (F.obj c₂).map_iso hd⟩,
  end,
  map :=
  begin
    rintros ⟨X₁,Y₁⟩,
    rintros ⟨X₂,Y₂⟩,
    refine quotient.rec_on_subsingleton X₁ _,
    refine quotient.rec_on_subsingleton Y₁ _,
    refine quotient.rec_on_subsingleton X₂ _,
    refine quotient.rec_on_subsingleton Y₂ _,
    rintros y₂ x₂ y₁ x₁ ⟨⟨⟨hx⟩⟩, ⟨⟨hy⟩⟩⟩,
    dsimp at hx hy,
    refine ⟨⟨_⟩⟩,
    cases hx, cases hy,
    exact ⟨(F.map hx).app y₁ ≫ (F.obj x₂).map hy⟩,
  end }

def skel_map_eq {F₁ F₂ : C ⥤ D} (h : F₁ ≅ F₂) : skel_map F₁ = skel_map F₂ :=
begin
  apply functor.ext (quotient.ind _) _,
  { intro x,
    apply quotient.sound,
    refine ⟨h.app x⟩ },
  { tidy },
end

end category_theory


import measure_theory.probability_mass_function

variables {α β : Type}

lemma bind_skip' (p : pmf α) (f g : α → pmf β) :
  (∀ (a : α), f a = g a) → p.bind f = p.bind g :=
begin
  intro ha,
  ext,
  simp,
  simp_rw ha,
end

lemma bind_skip_const' (pa : pmf α) (pb : pmf β) (f : α → pmf β) :
  (∀ (a : α), f a = pb) → pa.bind f = pb :=
begin
  intro ha,
  ext,
  simp,
  simp_rw ha,
  simp [nnreal.tsum_mul_right],
end

setup_tactic_parser
meta def tactic.interactive.bind_skip  (x : parse (tk "with" *> ident)?) : tactic unit :=
do `[apply bind_skip'],
  let a := x.get_or_else `_,
  tactic.interactive.intro a

meta def tactic.interactive.bind_skip_const  (x : parse (tk "with" *> ident)?) : tactic unit :=
do `[apply bind_skip_const'],
  let a := x.get_or_else `_,
  tactic.interactive.intro a


import for_mathlib.category_theory.shift_op
import for_mathlib.category_theory.triangulated.triangulated
import for_mathlib.category_theory.triangulated.homological_functor

open category_theory category_theory.limits category_theory.category

namespace category_theory

instance right_op_preserves_zero_morphisms {C D : Type*}
  [category C] [category D] [has_zero_morphisms C]
  [has_zero_morphisms D] (F : Cᵒᵖ ⥤ D) [F.preserves_zero_morphisms] :
    F.right_op.preserves_zero_morphisms :=
⟨λ X Y, begin
  change (F.map 0).op = 0,
  simpa only [F.map_zero],
end⟩

local attribute [instance] has_shift_op_neg_ℤ

variables (C : Type*) [category C] [has_zero_object C] [preadditive C]
  [has_shift C ℤ] [∀ (n : ℤ), (shift_functor C n).additive]
  [pretriangulated C]

namespace pretriangulated

def distinguished_triangle_op : set (triangle Cᵒᵖ) :=
λ T, T.unop ∈ dist_triang C

variable {C}

lemma mem_dist_triang_iff_unop' (T : triangle Cᵒᵖ) :
  T ∈ distinguished_triangle_op C ↔ T.unop ∈ dist_triang C := by refl

lemma mem_dist_triang_iff_op' (T : triangle C) :
  (T ∈ dist_triang C) ↔ T.op ∈ distinguished_triangle_op C :=
begin
  rw mem_dist_triang_iff_unop',
  split,
  { exact λ hT, isomorphic_distinguished _ hT _ T.unop_op, },
  { exact λ hT, isomorphic_distinguished _ hT _ T.unop_op.symm, },
end

lemma isomorphic_distinguished_op (T₁ : triangle Cᵒᵖ) (hT₁ : T₁ ∈ distinguished_triangle_op C)
  (T₂ : triangle Cᵒᵖ) (e : T₂ ≅ T₁) : T₂ ∈ distinguished_triangle_op C :=
begin
  rw mem_dist_triang_iff_unop' at hT₁ ⊢,
  exact isomorphic_distinguished _ hT₁ _ ((triangle_op_equivalence C).inverse.map_iso e).unop.symm,
end

lemma contractible_distinguished_op (X : Cᵒᵖ) :
  contractible_triangle X ∈ distinguished_triangle_op C :=
begin
  rw [mem_dist_triang_iff_unop'],
  rw rotate_distinguished_triangle,
  refine isomorphic_distinguished _ (contractible_distinguished (opposite.unop X)) _ _,
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _)
    ((shift_functor C (1 : ℤ)).map_iso ((is_zero_zero Cᵒᵖ).unop).iso_zero ≪≫
    (shift_functor C (1 : ℤ)).map_zero_object) _ _ _,
  { dsimp,
    simpa only [comp_id, id_comp], },
  { dsimp,
    simp only [comp_zero], },
  { exact is_zero.eq_of_src (is_zero.of_iso (is_zero_zero C)
      ((shift_functor C (1 : ℤ)).map_iso ((is_zero_zero Cᵒᵖ).unop).iso_zero ≪≫
        (shift_functor C (1 : ℤ)).map_zero_object)) _ _, },
end

lemma rotate_distinguished_triangle_op (T : triangle Cᵒᵖ) :
  T ∈ distinguished_triangle_op C ↔ T.rotate ∈ distinguished_triangle_op C :=
begin
  simp only [mem_dist_triang_iff_unop'],
  rw [isomorphic_distinguished_iff T.unop_rotate, inv_rotate_distinguished_triangle],
end

lemma distinguished_cocone_triangle_op {X Y : Cᵒᵖ} (f : X ⟶ Y) :
  ∃ (Z : Cᵒᵖ) (g : Y ⟶ Z) (h : Z ⟶ X⟦(1 : ℤ)⟧),
    triangle.mk f g h ∈ distinguished_triangle_op C :=
begin
  obtain ⟨Z, g, h, mem⟩ := distinguished_cocone_triangle₁ f.unop,
  rw [mem_dist_triang_iff_op'] at mem,
  exact ⟨_,_,_, mem⟩,
end

lemma complete_distinguished_triangle_morphism_op (T₁ T₂ : triangle Cᵒᵖ)
  (hT₁ : T₁ ∈ distinguished_triangle_op C) (hT₂ : T₂ ∈ distinguished_triangle_op C)
  (a : T₁.obj₁ ⟶ T₂.obj₁) (b : T₁.obj₂ ⟶ T₂.obj₂) (fac : T₁.mor₁ ≫ b = a ≫ T₂.mor₁) :
  ∃ (c : T₁.obj₃ ⟶ T₂.obj₃),
    T₁.mor₂ ≫ c = b ≫ T₂.mor₂ ∧ T₁.mor₃ ≫ a⟦(1 : ℤ)⟧' = c ≫ T₂.mor₃ :=
begin
  obtain ⟨x, hc₁, hc₂⟩ := complete_distinguished_triangle_morphism₁ T₂.unop T₁.unop hT₂ hT₁ b.unop a.unop
    (quiver.hom.op_inj fac.symm),
  let f : T₂.unop ⟶ T₁.unop :=
  { hom₁ := x,
    hom₂ := b.unop,
    hom₃ := a.unop,
    comm₁' := hc₁,
    comm₂' := quiver.hom.op_inj fac.symm,
    comm₃' := hc₂, },
  let f' := (triangle_op_equivalence C).inverse.preimage f.op,
  have hf' : f = ((triangle_op_equivalence C).inverse.map f').unop :=
    quiver.hom.op_inj (functor.image_preimage _ _).symm,
  have hf'₁ : f'.hom₁ = a,
  { apply quiver.hom.unop_inj,
    change _ = f.hom₃,
    rw hf',
    refl, },
  have hf'₂ : f'.hom₂ = b,
  { apply quiver.hom.unop_inj,
    change _ = f.hom₂,
    rw hf',
    refl, },
  exact ⟨f'.hom₃, by rw [f'.comm₂, hf'₂], by rw [← f'.comm₃, hf'₁]⟩,
end

instance : pretriangulated Cᵒᵖ :=
{ distinguished_triangles := distinguished_triangle_op C,
  isomorphic_distinguished := isomorphic_distinguished_op,
  contractible_distinguished := contractible_distinguished_op,
  distinguished_cocone_triangle := λ X Y f, distinguished_cocone_triangle_op f,
  rotate_distinguished_triangle := rotate_distinguished_triangle_op,
  complete_distinguished_triangle_morphism := complete_distinguished_triangle_morphism_op, }

lemma mem_dist_triang_iff_unop (T : triangle Cᵒᵖ) :
  (T ∈ dist_triang Cᵒᵖ) ↔ T.unop ∈ dist_triang C := by refl

lemma mem_dist_triang_iff_op (T : triangle C) :
  (T ∈ dist_triang C) ↔ T.op ∈ dist_triang (Cᵒᵖ) :=
mem_dist_triang_iff_op' T

/- TODO : octahedron axiom for Cᵒᵖ -/

end pretriangulated

namespace functor

namespace is_homological

variables {C} {A : Type*} [category A] [abelian A] (F : Cᵒᵖ ⥤ A)
  [preserves_zero_morphisms F]

lemma of_unop
  (hF : ∀ (T : pretriangulated.triangle C) (hT : T ∈ dist_triang C),
    ((T.short_complex hT).map F.right_op).unop.exact) : F.is_homological :=
⟨λ T hT, hF T.unop hT⟩

end is_homological

end functor

end category_theory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro, Andrew Yang
-/
import topology.category.Top.epi_mono
import category_theory.limits.preserves.limits
import category_theory.category.ulift
import category_theory.limits.shapes.types
import category_theory.limits.concrete_category

/-!
# The category of topological spaces has all limits and colimits

Further, these limits and colimits are preserved by the forgetful functor --- that is, the
underlying types are just the limits in the category of types.
-/

open topological_space
open category_theory
open category_theory.limits
open opposite

universes u v w

noncomputable theory

namespace Top

variables {J : Type v} [small_category J]

local notation `forget` := forget Top

/--
A choice of limit cone for a functor `F : J ⥤ Top`.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone (F : J ⥤ Top.{max v u}) : cone F :=
{ X := Top.of {u : Π j : J, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j},
  π :=
  { app := λ j,
    { to_fun := λ u, u.val j,
      continuous_to_fun := show continuous ((λ u : Π j : J, F.obj j, u j) ∘ subtype.val),
        by continuity } } }

/--
A choice of limit cone for a functor `F : J ⥤ Top` whose topology is defined as an
infimum of topologies infimum.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone_infi (F : J ⥤ Top.{max v u}) : cone F :=
{ X := ⟨(types.limit_cone (F ⋙ forget)).X, ⨅j,
        (F.obj j).str.induced ((types.limit_cone (F ⋙ forget)).π.app j)⟩,
  π :=
  { app := λ j, ⟨(types.limit_cone (F ⋙ forget)).π.app j,
                 continuous_iff_le_induced.mpr (infi_le _ _)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.limit_cone (F ⋙ forget)).π.naturality f) } }

/--
The chosen cone `Top.limit_cone F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone F) :=
{ lift := λ S, { to_fun := λ x, ⟨λ j, S.π.app _ x, λ i j f, by { dsimp, erw ← S.w f, refl }⟩ },
  uniq' := λ S m h, by { ext : 3, simpa [← h] } }

/--
The chosen cone `Top.limit_cone_infi F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_infi_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone_infi F) :=
by { refine is_limit.of_faithful forget (types.limit_cone_is_limit _) (λ s, ⟨_, _⟩) (λ s, rfl),
     exact continuous_iff_coinduced_le.mpr (le_infi $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.π.app j).continuous :
         _) ) }

instance Top_has_limits_of_size : has_limits_of_size.{v} Top.{max v u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance Top_has_limits : has_limits Top.{u} := Top.Top_has_limits_of_size.{u u}

instance forget_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F,
    by exactI preserves_limit_of_preserves_limit_cone
      (limit_cone_is_limit F) (types.limit_cone_is_limit (F ⋙ forget)) } }

instance forget_preserves_limits : preserves_limits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_limits_of_size.{u u}

/--
A choice of colimit cocone for a functor `F : J ⥤ Top`.
Generally you should just use `colimit.coone F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone`).
-/
def colimit_cocone (F : J ⥤ Top.{max v u}) : cocone F :=
{ X := ⟨(types.colimit_cocone (F ⋙ forget)).X, ⨆ j,
        (F.obj j).str.coinduced ((types.colimit_cocone (F ⋙ forget)).ι.app j)⟩,
  ι :=
  { app := λ j, ⟨(types.colimit_cocone (F ⋙ forget)).ι.app j,
                 continuous_iff_coinduced_le.mpr (le_supr _ j)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.colimit_cocone (F ⋙ forget)).ι.naturality f) } }

/--
The chosen cocone `Top.colimit_cocone F` for a functor `F : J ⥤ Top` is a colimit cocone.
Generally you should just use `colimit.is_colimit F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone_is_colimit`).
-/
def colimit_cocone_is_colimit (F : J ⥤ Top.{max v u}) : is_colimit (colimit_cocone F) :=
by { refine is_colimit.of_faithful forget (types.colimit_cocone_is_colimit _) (λ s, ⟨_, _⟩)
       (λ s, rfl),
     exact continuous_iff_le_induced.mpr (supr_le $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.ι.app j).continuous :
         _) ) }

instance Top_has_colimits_of_size : has_colimits_of_size.{v} Top.{max v u} :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk { cocone := colimit_cocone F, is_colimit :=
    colimit_cocone_is_colimit F } } }

instance Top_has_colimits : has_colimits Top.{u} := Top.Top_has_colimits_of_size.{u u}

instance forget_preserves_colimits_of_size :
  preserves_colimits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F) (types.colimit_cocone_is_colimit (F ⋙ forget)) } }

instance forget_preserves_colimits : preserves_colimits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_colimits_of_size.{u u}

/-- The projection from the product as a bundled continous map. -/
abbreviation pi_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : Top.of (Π i, α i) ⟶ α i :=
⟨λ f, f i, continuous_apply i⟩

/-- The explicit fan of a family of topological spaces given by the pi type. -/
@[simps X π_app]
def pi_fan {ι : Type v} (α : ι → Top.{max v u}) : fan α :=
fan.mk (Top.of (Π i, α i)) (pi_π α)

/-- The constructed fan is indeed a limit -/
def pi_fan_is_limit {ι : Type v} (α : ι → Top.{max v u}) : is_limit (pi_fan α) :=
{ lift := λ S, { to_fun := λ s i, S.π.app ⟨i⟩ s },
  uniq' := by { intros S m h, ext x i, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The product is homeomorphic to the product of the underlying spaces,
equipped with the product topology.
-/
def pi_iso_pi {ι : Type v} (α : ι → Top.{max v u}) : ∏ α ≅ Top.of (Π i, α i) :=
(limit.is_limit _).cone_point_unique_up_to_iso (pi_fan_is_limit α)

@[simp, reassoc]
lemma pi_iso_pi_inv_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  (pi_iso_pi α).inv ≫ pi.π α i = pi_π α i :=
by simp [pi_iso_pi]

@[simp]
lemma pi_iso_pi_inv_π_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : Π i, α i) :
  (pi.π α i : _) ((pi_iso_pi α).inv x) = x i :=
concrete_category.congr_hom (pi_iso_pi_inv_π α i) x

@[simp]
lemma pi_iso_pi_hom_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : ∏ α) :
  (pi_iso_pi α).hom x i = (pi.π α i : _) x :=
begin
  have := pi_iso_pi_inv_π α i,
  rw iso.inv_comp_eq at this,
  exact concrete_category.congr_hom this x
end

/-- The inclusion to the coproduct as a bundled continous map. -/
abbreviation sigma_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : α i ⟶ Top.of (Σ i, α i) :=
⟨sigma.mk i⟩

/-- The explicit cofan of a family of topological spaces given by the sigma type. -/
@[simps X ι_app]
def sigma_cofan {ι : Type v} (α : ι → Top.{max v u}) : cofan α :=
cofan.mk (Top.of (Σ i, α i)) (sigma_ι α)

/-- The constructed cofan is indeed a colimit -/
def sigma_cofan_is_colimit {ι : Type v} (α : ι → Top.{max v u}) : is_colimit (sigma_cofan α) :=
{ desc := λ S, { to_fun := λ s, S.ι.app ⟨s.1⟩ s.2,
    continuous_to_fun := by { continuity, dsimp only, continuity } },
  uniq' := by { intros S m h,  ext ⟨i, x⟩, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The coproduct is homeomorphic to the disjoint union of the topological spaces.
-/
def sigma_iso_sigma {ι : Type v} (α : ι → Top.{max v u}) : ∐ α ≅ Top.of (Σ i, α i) :=
(colimit.is_colimit _).cocone_point_unique_up_to_iso (sigma_cofan_is_colimit α)

@[simp, reassoc]
lemma sigma_iso_sigma_hom_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  sigma.ι α i ≫ (sigma_iso_sigma α).hom = sigma_ι α i :=
by simp [sigma_iso_sigma]

@[simp]
lemma sigma_iso_sigma_hom_ι_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).hom ((sigma.ι α i : _) x) = sigma.mk i x :=
concrete_category.congr_hom (sigma_iso_sigma_hom_ι α i) x

@[simp]
lemma sigma_iso_sigma_inv_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).inv ⟨i, x⟩ = (sigma.ι α i : _) x :=
by { rw [← sigma_iso_sigma_hom_ι_apply, ← comp_app], simp, }

lemma induced_of_is_limit {F : J ⥤ Top.{max v u}} (C : cone F) (hC : is_limit C) :
  C.X.topological_space = ⨅ j, (F.obj j).topological_space.induced (C.π.app j) :=
begin
  let homeo := homeo_of_iso (hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit F)),
  refine homeo.inducing.induced.trans _,
  change induced homeo (⨅ (j : J), _) = _,
  simpa [induced_infi, induced_compose],
end

lemma limit_topology (F : J ⥤ Top.{max v u}) :
  (limit F).topological_space = ⨅ j, (F.obj j).topological_space.induced (limit.π F j) :=
induced_of_is_limit _ (limit.is_limit F)

section prod

/-- The first projection from the product. -/
abbreviation prod_fst {X Y : Top.{u}} : Top.of (X × Y) ⟶ X := ⟨prod.fst⟩

/-- The second projection from the product. -/
abbreviation prod_snd {X Y : Top.{u}} : Top.of (X × Y) ⟶ Y := ⟨prod.snd⟩

/-- The explicit binary cofan of `X, Y` given by `X × Y`. -/
def prod_binary_fan (X Y : Top.{u}) : binary_fan X Y :=
binary_fan.mk prod_fst prod_snd

/-- The constructed binary fan is indeed a limit -/
def prod_binary_fan_is_limit (X Y : Top.{u}) : is_limit (prod_binary_fan X Y) :=
{ lift := λ (S : binary_fan X Y), { to_fun := λ s, (S.fst s, S.snd s) },
  fac' := begin
    rintros S (_|_),
    tidy
  end,
  uniq' := begin
    intros S m h,
    ext x,
    { specialize h ⟨walking_pair.left⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
     { specialize h ⟨walking_pair.right⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
  end }

/--
The homeomorphism between `X ⨯ Y` and the set-theoretic product of `X` and `Y`,
equipped with the product topology.
-/
def prod_iso_prod (X Y : Top.{u}) : X ⨯ Y ≅ Top.of (X × Y) :=
(limit.is_limit _).cone_point_unique_up_to_iso (prod_binary_fan_is_limit X Y)

@[simp, reassoc] lemma prod_iso_prod_hom_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_fst = limits.prod.fst :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp, reassoc] lemma prod_iso_prod_hom_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_snd = limits.prod.snd :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp] lemma prod_iso_prod_hom_apply {X Y : Top.{u}} (x : X ⨯ Y) :
  (prod_iso_prod X Y).hom x =
    ((limits.prod.fst : X ⨯ Y ⟶ _) x, (limits.prod.snd : X ⨯ Y ⟶ _) x) :=
begin
  ext,
  { exact concrete_category.congr_hom (prod_iso_prod_hom_fst X Y) x },
  { exact concrete_category.congr_hom (prod_iso_prod_hom_snd X Y) x }
end

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.fst = prod_fst :=
by simp [iso.inv_comp_eq]

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.snd = prod_snd :=
by simp [iso.inv_comp_eq]

lemma prod_topology {X Y : Top} :
  (X ⨯ Y).topological_space =
    induced (limits.prod.fst : X ⨯ Y ⟶ _) X.topological_space ⊓
      induced (limits.prod.snd : X ⨯ Y ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (prod_iso_prod X Y),
  refine homeo.inducing.induced.trans _,
  change induced homeo (_ ⊓ _) = _,
  simpa [induced_compose]
end

lemma range_prod_map {W X Y Z : Top.{u}} (f : W ⟶ Y) (g : X ⟶ Z) :
  set.range (limits.prod.map f g) =
    (limits.prod.fst : Y ⨯ Z ⟶ _) ⁻¹' (set.range f) ∩
      (limits.prod.snd : Y ⨯ Z ⟶ _) ⁻¹' (set.range g) :=
begin
  ext,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [set.mem_preimage, set.mem_range, set.mem_inter_eq, ←comp_apply],
    simp only [limits.prod.map_fst, limits.prod.map_snd,
      exists_apply_eq_apply, comp_apply, and_self] },
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
    use (prod_iso_prod W X).inv (x₁, x₂),
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩,
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_fst, simp [hx₁] },
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_snd, simp [hx₂] } }
end

lemma inducing_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : inducing f) (hg : inducing g) : inducing (limits.prod.map f g) :=
begin
  constructor,
  simp only [prod_topology, induced_compose, ←coe_comp, limits.prod.map_fst, limits.prod.map_snd,
    induced_inf],
  simp only [coe_comp],
  rw [← @induced_compose _ _ _ _ _ f, ← @induced_compose _ _ _ _ _ g, ← hf.induced, ← hg.induced]
end

lemma embedding_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : embedding f) (hg : embedding g) : embedding (limits.prod.map f g) :=
⟨inducing_prod_map hf.to_inducing hg.to_inducing,
begin
  haveI := (Top.mono_iff_injective _).mpr hf.inj,
  haveI := (Top.mono_iff_injective _).mpr hg.inj,
  exact (Top.mono_iff_injective _).mp infer_instance
end⟩

end prod

section pullback

variables {X Y Z : Top.{u}}

/-- The first projection from the pullback. -/
abbreviation pullback_fst (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ X :=
⟨prod.fst ∘ subtype.val⟩

/-- The second projection from the pullback. -/
abbreviation pullback_snd (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ Y :=
⟨prod.snd ∘ subtype.val⟩

/-- The explicit pullback cone of `X, Y` given by `{ p : X × Y // f p.1 = g p.2 }`. -/
def pullback_cone (f : X ⟶ Z) (g : Y ⟶ Z) : pullback_cone f g :=
pullback_cone.mk (pullback_fst f g) (pullback_snd f g) (by { ext ⟨x, h⟩, simp [h] })

/-- The constructed cone is a limit. -/
def pullback_cone_is_limit (f : X ⟶ Z) (g : Y ⟶ Z) :
  is_limit (pullback_cone f g) := pullback_cone.is_limit_aux' _
begin
  intro s,
  split, swap,
  exact { to_fun := λ x, ⟨⟨s.fst x, s.snd x⟩,
    by simpa using concrete_category.congr_hom s.condition x⟩ },
  refine ⟨_,_,_⟩,
  { ext, delta pullback_cone, simp },
  { ext, delta pullback_cone, simp },
  { intros m h₁ h₂,
    ext x,
    { simpa using concrete_category.congr_hom h₁ x },
    { simpa using concrete_category.congr_hom h₂ x } }
end

/-- The pullback of two maps can be identified as a subspace of `X × Y`. -/
def pullback_iso_prod_subtype (f : X ⟶ Z) (g : Y ⟶ Z) :
  pullback f g ≅ Top.of { p : X × Y // f p.1 = g p.2 } :=
(limit.is_limit _).cone_point_unique_up_to_iso (pullback_cone_is_limit f g)

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.fst = pullback_fst f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_fst_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.fst : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).fst :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_fst f g) x

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.snd = pullback_snd f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_snd_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.snd : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).snd :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_snd f g) x

lemma pullback_iso_prod_subtype_hom_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_fst f g = pullback.fst :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_fst]

lemma pullback_iso_prod_subtype_hom_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_snd f g = pullback.snd :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_snd]

@[simp] lemma pullback_iso_prod_subtype_hom_apply {f : X ⟶ Z} {g : Y ⟶ Z}
  (x : pullback f g) : (pullback_iso_prod_subtype f g).hom x =
    ⟨⟨(pullback.fst : pullback f g ⟶ _) x, (pullback.snd : pullback f g ⟶ _) x⟩,
      by simpa using concrete_category.congr_hom pullback.condition x⟩ :=
begin
  ext,
  exacts [concrete_category.congr_hom (pullback_iso_prod_subtype_hom_fst f g) x,
    concrete_category.congr_hom (pullback_iso_prod_subtype_hom_snd f g) x]
end

lemma pullback_topology {X Y Z : Top.{u}} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback f g).topological_space =
    induced (pullback.fst : pullback f g ⟶ _) X.topological_space ⊓
      induced (pullback.snd : pullback f g ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (pullback_iso_prod_subtype f g),
  refine homeo.inducing.induced.trans _,
  change induced homeo (induced _ (_ ⊓ _)) = _,
  simpa [induced_compose]
end

lemma range_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  set.range (prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) =
  { x | (limits.prod.fst ≫ f) x = (limits.prod.snd ≫ g) x } :=
begin
  ext x,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [←comp_apply, set.mem_set_of_eq],
    congr' 1,
    simp [pullback.condition] },
  { intro h,
    use (pullback_iso_prod_subtype f g).inv ⟨⟨_, _⟩, h⟩,
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩; simp }
end

lemma inducing_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inducing ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨by simp [prod_topology, pullback_topology, induced_compose, ←coe_comp]⟩

lemma embedding_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  embedding ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨inducing_pullback_to_prod f g, (Top.mono_iff_injective _).mp infer_instance⟩

/-- If the map `S ⟶ T` is mono, then there is a description of the image of `W ×ₛ X ⟶ Y ×ₜ Z`. -/
lemma range_pullback_map {W X Y Z S T : Top} (f₁ : W ⟶ S) (f₂ : X ⟶ S)
  (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  set.range (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) =
    (pullback.fst : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₁) ∩
      (pullback.snd : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₂) :=
begin
  ext,
  split,
  { rintro ⟨y, rfl⟩, simp, },
  rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
  have : f₁ x₁ = f₂ x₂,
  { apply (Top.mono_iff_injective _).mp H₃,
    simp only [←comp_apply, eq₁, eq₂],
    simp only [comp_apply, hx₁, hx₂],
    simp only [←comp_apply, pullback.condition] },
  use (pullback_iso_prod_subtype f₁ f₂).inv ⟨⟨x₁, x₂⟩, this⟩,
  apply concrete.limit_ext,
  rintros (_|_|_),
  { simp only [Top.comp_app, limit.lift_π_apply, category.assoc, pullback_cone.mk_π_app_one,
      hx₁, pullback_iso_prod_subtype_inv_fst_apply, subtype.coe_mk],
    simp only [← comp_apply],
    congr,
    apply limit.w _ walking_cospan.hom.inl },
  { simp [hx₁] },
  { simp [hx₂] },
end

lemma pullback_fst_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.fst : pullback f g ⟶ _) = { x : X | ∃ y : Y, f x = g y} :=
begin
  ext x,
  split,
  { rintro ⟨y, rfl⟩,
    use (pullback.snd : pullback f g ⟶ _) y,
    exact concrete_category.congr_hom pullback.condition y },
  { rintro ⟨y, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

lemma pullback_snd_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.snd : pullback f g ⟶ _) = { y : Y | ∃ x : X, f x = g y} :=
begin
  ext y,
  split,
  { rintro ⟨x, rfl⟩,
    use (pullback.fst : pullback f g ⟶ _) x,
    exact concrete_category.congr_hom pullback.condition x },
  { rintro ⟨x, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are embeddings,
then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an embedding.

  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗      ↗
  X  ⟶  Z
-/
lemma pullback_map_embedding_of_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : embedding i₁) (H₂ : embedding i₂) (i₃ : S ⟶ T)
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  refine embedding_of_embedding_compose (continuous_map.continuous_to_fun _)
    (show continuous (prod.lift pullback.fst pullback.snd : pullback g₁ g₂ ⟶ Y ⨯ Z), from
      continuous_map.continuous_to_fun _) _,
  suffices : embedding
    (prod.lift pullback.fst pullback.snd ≫ limits.prod.map i₁ i₂ : pullback f₁ f₂ ⟶ _),
  { simpa [←coe_comp] using this },
  rw coe_comp,
  refine embedding.comp (embedding_prod_map H₁ H₂)
    (embedding_pullback_to_prod _ _)
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are open embeddings, and `S ⟶ T`
is mono, then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an open embedding.
  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗       ↗
  X  ⟶  Z
-/
lemma pullback_map_open_embedding_of_open_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : open_embedding i₁) (H₂ : open_embedding i₂) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  open_embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  split,
  { apply pullback_map_embedding_of_embeddings
      f₁ f₂ g₁ g₂ H₁.to_embedding H₂.to_embedding i₃ eq₁ eq₂ },
  { rw range_pullback_map,
    apply is_open.inter; apply continuous.is_open_preimage,
    continuity,
    exacts [H₁.open_range, H₂.open_range] }
end

lemma snd_embedding_of_left_embedding {X Y S : Top}
  {f : X ⟶ S} (H : embedding f) (g : Y ⟶ S) :
  embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_embedding_of_right_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : embedding g) :
  embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma embedding_of_pullback_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : embedding f) (H₂ : embedding g) :
  embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_embedding_of_left_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma snd_open_embedding_of_left_open_embedding {X Y S : Top}
  {f : X ⟶ S} (H : open_embedding f) (g : Y ⟶ S) :
  open_embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).open_embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_open_embedding_of_right_open_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : open_embedding g) :
  open_embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).open_embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

/-- If `X ⟶ S`, `Y ⟶ S` are open embeddings, then so is `X ×ₛ Y ⟶ S`. -/
lemma open_embedding_of_pullback_open_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : open_embedding f) (H₂ : open_embedding g) :
  open_embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_open_embedding_of_left_open_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma fst_iso_of_right_embedding_range_subset {X Y S : Top} (f : X ⟶ S) {g : Y ⟶ S}
  (hg : embedding g) (H : set.range f ⊆ set.range g) : is_iso (pullback.fst : pullback f g ⟶ X) :=
begin
  let : (pullback f g : Top) ≃ₜ X :=
    (homeomorph.of_embedding _ (fst_embedding_of_right_embedding f hg)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_fst_range, exact ⟨_, (H (set.mem_range_self x)).some_spec.symm⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma snd_iso_of_left_embedding_range_subset {X Y S : Top} {f : X ⟶ S} (hf : embedding f)
  (g : Y ⟶ S) (H : set.range g ⊆ set.range f) : is_iso (pullback.snd : pullback f g ⟶ Y) :=
begin
  let : (pullback f g : Top) ≃ₜ Y :=
    (homeomorph.of_embedding _ (snd_embedding_of_left_embedding hf g)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_snd_range, exact ⟨_, (H (set.mem_range_self x)).some_spec⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma pullback_snd_image_fst_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set X) :
  (pullback.snd : pullback f g ⟶ _) '' ((pullback.fst : pullback f g ⟶ _) ⁻¹' U) =
    g ⁻¹' (f '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.fst : pullback f g ⟶ _) y, hy,
    concrete_category.congr_hom pullback.condition y⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩, eq⟩, by simpa, by simp⟩ },
end

lemma pullback_fst_image_snd_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set Y) :
  (pullback.fst : pullback f g ⟶ _) '' ((pullback.snd : pullback f g ⟶ _) ⁻¹' U) =
    f ⁻¹' (g '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.snd : pullback f g ⟶ _) y, hy,
    (concrete_category.congr_hom pullback.condition y).symm⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩,eq.symm⟩, by simpa, by simp⟩ },
end

end pullback

--TODO: Add analogous constructions for `coprod` and `pushout`.

lemma coinduced_of_is_colimit {F : J ⥤ Top.{max v u}} (c : cocone F) (hc : is_colimit c) :
  c.X.topological_space = ⨆ j, (F.obj j).topological_space.coinduced (c.ι.app j) :=
begin
  let homeo := homeo_of_iso (hc.cocone_point_unique_up_to_iso (colimit_cocone_is_colimit F)),
  ext,
  refine homeo.symm.is_open_preimage.symm.trans (iff.trans _ is_open_supr_iff.symm),
  exact is_open_supr_iff
end

lemma colimit_topology (F : J ⥤ Top.{max v u}) :
  (colimit F).topological_space = ⨆ j, (F.obj j).topological_space.coinduced (colimit.ι F j) :=
coinduced_of_is_colimit _ (colimit.is_colimit F)

lemma colimit_is_open_iff (F : J ⥤ Top.{max v u}) (U : set ((colimit F : _) : Type (max v u))) :
  is_open U ↔ ∀ j, is_open (colimit.ι F j ⁻¹' U) :=
begin
  conv_lhs { rw colimit_topology F },
  exact is_open_supr_iff
end

lemma coequalizer_is_open_iff (F : walking_parallel_pair.{u} ⥤ Top.{u})
  (U : set ((colimit F : _) : Type u)) :
  is_open U ↔ is_open (colimit.ι F walking_parallel_pair.one ⁻¹' U) :=
begin
  rw colimit_is_open_iff.{u},
  split,
  { intro H, exact H _ },
  { intros H j,
    cases j,
    { rw ←colimit.w F walking_parallel_pair_hom.left,
      exact (F.map walking_parallel_pair_hom.left).continuous_to_fun.is_open_preimage _ H },
    { exact H } }
end

end Top

namespace Top

section cofiltered_limit

variables {J : Type v} [small_category J] [is_cofiltered J] (F : J ⥤ Top.{max v u})
  (C : cone F) (hC : is_limit C)

include hC

/--
Given a *compatible* collection of topological bases for the factors in a cofiltered limit
which contain `set.univ` and are closed under intersections, the induced *naive* collection
of sets in the limit is, in fact, a topological basis.
-/
theorem is_topological_basis_cofiltered_limit
  (T : Π j, set (set (F.obj j))) (hT : ∀ j, is_topological_basis (T j))
  (univ : ∀ (i : J), set.univ ∈ T i)
  (inter : ∀ i (U1 U2 : set (F.obj i)), U1 ∈ T i → U2 ∈ T i → U1 ∩ U2 ∈ T i)
  (compat : ∀ (i j : J) (f : i ⟶ j) (V : set (F.obj j)) (hV : V ∈ T j), (F.map f) ⁻¹' V ∈ T i) :
  is_topological_basis { U : set C.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = C.π.app j ⁻¹' V } :=
begin
  classical,
  -- The limit cone for `F` whose topology is defined as an infimum.
  let D := limit_cone_infi F,
  -- The isomorphism between the cone point of `C` and the cone point of `D`.
  let E : C.X ≅ D.X := hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit _),
  have hE : inducing E.hom := (Top.homeo_of_iso E).inducing,
  -- Reduce to the assertion of the theorem with `D` instead of `C`.
  suffices : is_topological_basis
    { U : set D.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = D.π.app j ⁻¹' V },
  { convert this.inducing hE,
    ext U0,
    split,
    { rintro ⟨j, V, hV, rfl⟩,
      refine ⟨D.π.app j ⁻¹' V, ⟨j, V, hV, rfl⟩, rfl⟩ },
    { rintro ⟨W, ⟨j, V, hV, rfl⟩, rfl⟩,
      refine ⟨j, V, hV, rfl⟩ } },
  -- Using `D`, we can apply the characterization of the topological basis of a
  -- topology defined as an infimum...
  convert is_topological_basis_infi hT (λ j (x : D.X), D.π.app j x),
  ext U0,
  split,
  { rintros  ⟨j, V, hV, rfl⟩,
    let U : Π i, set (F.obj i) := λ i, if h : i = j then (by {rw h, exact V}) else set.univ,
    refine ⟨U,{j},_,_⟩,
    { rintro i h,
      rw finset.mem_singleton at h,
      dsimp [U],
      rw dif_pos h,
      subst h,
      exact hV },
    { dsimp [U],
      simp } },
  { rintros ⟨U, G, h1, h2⟩,
    obtain ⟨j, hj⟩ := is_cofiltered.inf_objs_exists G,
    let g : ∀ e (he : e ∈ G), j ⟶ e := λ _ he, (hj he).some,
    let Vs : J → set (F.obj j) := λ e, if h : e ∈ G then F.map (g e h) ⁻¹' (U e) else set.univ,
    let V : set (F.obj j) := ⋂ (e : J) (he : e ∈ G), Vs e,
    refine ⟨j, V, _, _⟩,
    { -- An intermediate claim used to apply induction along `G : finset J` later on.
      have : ∀ (S : set (set (F.obj j))) (E : finset J) (P : J → set (F.obj j))
        (univ : set.univ ∈ S)
        (inter : ∀ A B : set (F.obj j), A ∈ S → B ∈ S → A ∩ B ∈ S)
        (cond : ∀ (e : J) (he : e ∈ E), P e ∈ S), (⋂ e (he : e ∈ E), P e) ∈ S,
      { intros S E,
        apply E.induction_on,
        { intros P he hh,
          simpa },
        { intros a E ha hh1 hh2 hh3 hh4 hh5,
          rw finset.set_bInter_insert,
          refine hh4 _ _ (hh5 _ (finset.mem_insert_self _ _)) (hh1 _ hh3 hh4 _),
          intros e he,
          exact hh5 e (finset.mem_insert_of_mem he) } },
      -- use the intermediate claim to finish off the goal using `univ` and `inter`.
      refine this _ _ _ (univ _) (inter _) _,
      intros e he,
      dsimp [Vs],
      rw dif_pos he,
      exact compat j e (g e he) (U e) (h1 e he), },
    { -- conclude...
      rw h2,
      dsimp [V],
      rw set.preimage_Inter,
      congr' 1,
      ext1 e,
      rw set.preimage_Inter,
      congr' 1,
      ext1 he,
      dsimp [Vs],
      rw [dif_pos he, ← set.preimage_comp],
      congr' 1,
      change _ = ⇑(D.π.app j ≫ F.map (g e he)),
      rw D.w } }
end

end cofiltered_limit

section topological_konig

/-!
## Topological Kőnig's lemma

A topological version of Kőnig's lemma is that the inverse limit of nonempty compact Hausdorff
spaces is nonempty.  (Note: this can be generalized further to inverse limits of nonempty compact
T0 spaces, where all the maps are closed maps; see [Stone1979] --- however there is an erratum
for Theorem 4 that the element in the inverse limit can have cofinally many components that are
not closed points.)

We give this in a more general form, which is that cofiltered limits
of nonempty compact Hausdorff spaces are nonempty
(`nonempty_limit_cone_of_compact_t2_cofiltered_system`).

This also applies to inverse limits, where `{J : Type u} [preorder J] [is_directed J (≤)]` and
`F : Jᵒᵖ ⥤ Top`.

The theorem is specialized to nonempty finite types (which are compact Hausdorff with the
discrete topology) in `nonempty_sections_of_fintype_cofiltered_system` and
`nonempty_sections_of_fintype_inverse_system`.

(See <https://stacks.math.columbia.edu/tag/086J> for the Set version.)
-/

variables {J : Type u} [small_category J]
variables (F : J ⥤ Top.{u})

private abbreviation finite_diagram_arrow {J : Type u} [small_category J] (G : finset J) :=
Σ' (X Y : J) (mX : X ∈ G) (mY : Y ∈ G), X ⟶ Y
private abbreviation finite_diagram (J : Type u) [small_category J] :=
Σ (G : finset J), finset (finite_diagram_arrow G)

/--
Partial sections of a cofiltered limit are sections when restricted to
a finite subset of objects and morphisms of `J`.
-/
def partial_sections {J : Type u} [small_category J] (F : J ⥤ Top.{u})
  {G : finset J} (H : finset (finite_diagram_arrow G)) : set (Π j, F.obj j) :=
{ u | ∀ {f : finite_diagram_arrow G} (hf : f ∈ H), F.map f.2.2.2.2 (u f.1) = u f.2.1 }

lemma partial_sections.nonempty [is_cofiltered J] [h : Π (j : J), nonempty (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  (partial_sections F H).nonempty :=
begin
  classical,
  use λ (j : J), if hj : j ∈ G
                 then F.map (is_cofiltered.inf_to G H hj) (h (is_cofiltered.inf G H)).some
                 else (h _).some,
  rintros ⟨X, Y, hX, hY, f⟩ hf,
  dsimp only,
  rwa [dif_pos hX, dif_pos hY, ←comp_app, ←F.map_comp,
       @is_cofiltered.inf_to_commutes _ _ _ G H],
end

lemma partial_sections.directed :
  directed superset (λ (G : finite_diagram J), partial_sections F G.2) :=
begin
  classical,
  intros A B,
  let ιA : finite_diagram_arrow A.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_left _ f.2.2.1, finset.mem_union_left _ f.2.2.2.1,
          f.2.2.2.2⟩,
  let ιB : finite_diagram_arrow B.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_right _ f.2.2.1, finset.mem_union_right _ f.2.2.2.1,
          f.2.2.2.2⟩,
  refine ⟨⟨A.1 ⊔ B.1, A.2.image ιA ⊔ B.2.image ιB⟩, _, _⟩,
  { rintro u hu f hf,
    have : ιA f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_left,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this },
  { rintro u hu f hf,
    have : ιB f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_right,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this }
end

lemma partial_sections.closed [Π (j : J), t2_space (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  is_closed (partial_sections F H) :=
begin
  have : partial_sections F H =
    ⋂ {f : finite_diagram_arrow G} (hf : f ∈ H), { u | F.map f.2.2.2.2 (u f.1) = u f.2.1 },
  { ext1,
    simp only [set.mem_Inter, set.mem_set_of_eq],
    refl, },
  rw this,
  apply is_closed_bInter,
  intros f hf,
  apply is_closed_eq,
  continuity,
end

/--
Cofiltered limits of nonempty compact Hausdorff spaces are nonempty topological spaces.
--/
lemma nonempty_limit_cone_of_compact_t2_cofiltered_system
  [is_cofiltered J]
  [Π (j : J), nonempty (F.obj j)]
  [Π (j : J), compact_space (F.obj j)]
  [Π (j : J), t2_space (F.obj j)] :
  nonempty (Top.limit_cone.{u} F).X :=
begin
  classical,
  obtain ⟨u, hu⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ G, partial_sections F _)
    (partial_sections.directed F)
    (λ G, partial_sections.nonempty F _)
    (λ G, is_closed.is_compact (partial_sections.closed F _))
    (λ G, partial_sections.closed F _),
  use u,
  intros X Y f,
  let G : finite_diagram J :=
    ⟨{X, Y},
     {⟨X, Y,
      by simp only [true_or, eq_self_iff_true, finset.mem_insert],
      by simp only [eq_self_iff_true, or_true, finset.mem_insert, finset.mem_singleton],
      f⟩}⟩,
  exact hu _ ⟨G, rfl⟩ (finset.mem_singleton_self _),
end

end topological_konig

end Top

section fintype_konig

/-- This bootstraps `nonempty_sections_of_fintype_inverse_system`. In this version,
the `F` functor is between categories of the same universe, and it is an easy
corollary to `Top.nonempty_limit_cone_of_compact_t2_inverse_system`. -/
lemma nonempty_sections_of_fintype_cofiltered_system.init
  {J : Type u} [small_category J] [is_cofiltered J] (F : J ⥤ Type u)
  [hf : Π (j : J), fintype (F.obj j)] [hne : Π (j : J), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  let F' : J ⥤ Top := F ⋙ Top.discrete,
  haveI : Π (j : J), fintype (F'.obj j) := hf,
  haveI : Π (j : J), nonempty (F'.obj j) := hne,
  obtain ⟨⟨u, hu⟩⟩ := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system F',
  exact ⟨u, λ _ _ f, hu f⟩,
end

/-- The cofiltered limit of nonempty finite types is nonempty.

See `nonempty_sections_of_fintype_inverse_system` for a specialization to inverse limits. -/
theorem nonempty_sections_of_fintype_cofiltered_system
  {J : Type u} [category.{w} J] [is_cofiltered J] (F : J ⥤ Type v)
  [Π (j : J), fintype (F.obj j)] [Π (j : J), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  -- Step 1: lift everything to the `max u v w` universe.
  let J' : Type (max w v u) := as_small.{max w v} J,
  let down : J' ⥤ J := as_small.down,
  let F' : J' ⥤ Type (max u v w) := down ⋙ F ⋙ ulift_functor.{(max u w) v},
  haveI : ∀ i, nonempty (F'.obj i) := λ i, ⟨⟨classical.arbitrary (F.obj (down.obj i))⟩⟩,
  haveI : ∀ i, fintype (F'.obj i) := λ i, fintype.of_equiv (F.obj (down.obj i)) equiv.ulift.symm,
  -- Step 2: apply the bootstrap theorem
  obtain ⟨u, hu⟩ := nonempty_sections_of_fintype_cofiltered_system.init F',
  -- Step 3: interpret the results
  use λ j, (u ⟨j⟩).down,
  intros j j' f,
  have h := @hu (⟨j⟩ : J') (⟨j'⟩ : J') (ulift.up f),
  simp only [as_small.down, functor.comp_map, ulift_functor_map, functor.op_map] at h,
  simp_rw [←h],
  refl,
end

/-- The inverse limit of nonempty finite types is nonempty.

See `nonempty_sections_of_fintype_cofiltered_system` for a generalization to cofiltered limits.
That version applies in almost all cases, and the only difference is that this version
allows `J` to be empty.

This may be regarded as a generalization of Kőnig's lemma.
To specialize: given a locally finite connected graph, take `Jᵒᵖ` to be `ℕ` and
`F j` to be length-`j` paths that start from an arbitrary fixed vertex.
Elements of `F.sections` can be read off as infinite rays in the graph. -/
theorem nonempty_sections_of_fintype_inverse_system
  {J : Type u} [preorder J] [is_directed J (≤)] (F : Jᵒᵖ ⥤ Type v)
  [Π (j : Jᵒᵖ), fintype (F.obj j)] [Π (j : Jᵒᵖ), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  casesI is_empty_or_nonempty J,
  { haveI : is_empty Jᵒᵖ := ⟨λ j, is_empty_elim j.unop⟩,  -- TODO: this should be a global instance
    exact ⟨is_empty_elim, is_empty_elim⟩, },
  { exact nonempty_sections_of_fintype_cofiltered_system _, },
end

end fintype_konig


import seplog.e_semantics
import seplog.d_context_test
import data.finset.basic

open Binop open Relop open Unop open TypeDecl open Expr open Val
open cmd

-- Const
--------
run_cmd test (eval (@const gBool tt) ∅) $ some tt

-- Get Var
----------
run_cmd test (eval (getvar $ @Var.mk gBool "x") ∅) none
run_cmd test (eval (getvar $ @Var.mk gBool "x") (@Store.singleton gBool "x" tt))
             $ some tt

-- Relop
--------
run_cmd test (@relop_eval (gInt) EQ
                          (some 1) (some 0)) ff
-- Binop
--------

run_cmd test (@binop_eval gInt PLUS (some 1) (some 2147483647))
             none -- Overflow

run_cmd test (@binop_eval gStr PLUS (some "a") (some "b")) $ some "ab"

-- Unop
--------
run_cmd test (@unop_eval gBool NOT (some tt)) (some ff)

-- Get field
------------
-- TODO

-- Compute
----------
run_cmd test (some ∅) $ compute ∅ skip

run_cmd test (compute ∅ assign1) $ some (@Store.singleton gBool "a" tt, ∅, ∅)

run_cmd test (compute ∅ lookup1) none  -- lookup fails, as heap is empty

def heap_1_10: Heap := Heap.singleton 1 (pInt 10) -- 10 written to memory #1
run_cmd test (compute (∅, heap_1_10, ∅) lookup1)
           $ some (Store.singleton "y" (pInt 10), heap_1_10, ∅)

-- Looks up value at y, doubles, then writes it to address #1 in Heap
run_cmd test (compute (@Store.singleton gInt "y" 10, heap_1_10, ∅) mutate_yy)
           $ some (@Store.singleton gInt "y" 10,
                   @Heap.singleton gInt 1 20, ∅)

def vndk:= gRef "Vndkdep"
def vvndk: Var (gPtr vndk) := ⟨"x"⟩

run_cmd test (compute (∅,∅,imb_decls) $ new vvndk) (some (
  @Store.singleton (gPtr vndk) "x" 1, -- store a pointer to the value
  @Heap.singleton vndk 1 default_vndkdep, -- actual value stored here
  imb_decls))

--------------------------------------------------------------------------------
def ll := gRef "LL"

def callee: Expr (gPtr ll) := const 1
def nullptr: Expr (gPtr ll) := goNil
def llargs: list (Σ α, Expr α) := [⟨_, goTrue⟩, ⟨_, nullptr⟩]

def create_ll_heap: list (ℤ × ℤ) → Heap
 | [] := ∅
 | [(adr, val)]  := @Heap.singleton (gRef "LL") ⟨adr⟩
   (list_to_struct "LL" [("val",  ⟨_, pInt val⟩),
                         ("next", ⟨gPtr ll, pPtr ll none⟩)])
 | ((adr,v)::(nxt,nv)::t)  :=
    @Heap.update (create_ll_heap ((nxt,nv)::t) ) ll
      (list_to_struct "LL" [("val",  ⟨_, pInt v⟩),
                                ("next", ⟨_, pPtr ll (some nxt)⟩)]) ⟨adr⟩

def llctx (vs: list (ℤ × ℤ)): Ctx := (∅, create_ll_heap vs, ll_decl)

#eval render $ llctx [(1,10),(2,20),(1,30)]
/-
 - Updating the value of a struct
 -/
run_cmd test_str -- "val" field has been updated from 1 to 0
"Store
 - x: LL{next: 1, val: 0} (LL)
Heap

Decls
" $ option.iget $ compute ∅ (⟨"x"⟩ ⇐ ex_update)

/-
 - Context fed as input to the cyclic method call
 -/
 def fed_input := option.iget $ method_input_ctx (llctx [(1, 1)]) cycsig
                                                 llargs (sum.inl callee)
run_cmd test_str
"Store
 - first: tt (Bool)
 - head: ? (*LL)
 - this: 1 (*LL)
Heap
 - 1: LL{next: ?, val: 1} (LL)
Decls
 - LL" $ fed_input

/-
 - Resulting output context after executing the program on the above input
 - Note we have added `this_inst` and `res` to the store.
 -/
run_cmd test_str --
"Store
 - first: tt (Bool)
 - head: 1 (*LL)
 - res: ff (Bool)
 - this: 1 (*LL)
 - this_inst: LL{next: ?, val: 1} (LL)
Heap
 - 1: LL{next: ?, val: 1} (LL)
Decls
 - LL" (compute fed_input cycprog).iget

/-
 - Create input, run command, and extract output. Only change to context is the
 - storage of the result in the variable 'x' in the store.
 -/
meta def run_cyc (lst: list (ℤ × ℤ)): option bool :=
  (@Store.lookup gBool -- getting the result at 'x'
    (prod.fst -- extract the store component of the result context
      $ option.iget -- if program fails just return empty store
        $ compute (llctx lst) -- use input data to create Ctx prior to call
            (call (sum.inl callee) "cyclic" -- call w/ the LL in heap pos #1
                llargs -- (first=true, head=NULL)
                    [⟨gBool, ⟨"x"⟩⟩])) -- write result to this variable
  "x") >>= some ∘ bval -- (last argument for Store.lookup)

-- 3-cycle
run_cmd test (run_cyc [(1, 10), (2, 30), (1, 20)]) (some tt)
-- 1-cycle
run_cmd test (run_cyc [(1, 10), (1,10)]) (some tt)
-- Not a cycle
run_cmd test (run_cyc [(1, 10)]) (some ff)

-- Program error b/c we initially call method with a pointer to a LL at heap#1.
run_cmd test (run_cyc [(2, 10)]) none

-- spec
def is_cyclic': finset ℤ → list (ℤ × ℤ) → bool
 | seen [] := ff
 | seen ((h,_)::t) := if h ∈ seen then tt else is_cyclic' (seen ∪ {h}) t

def is_cyclic (l: list (ℤ × ℤ)): bool:= is_cyclic' ∅ l

-- Look up a boolean variable named "res" in the store of a context
def extract (c: option Ctx): option bool:=
  c >>= λ ⟨s,_,_⟩, @Store.lookup gBool s "res" >>= some ∘ bval

/-
 - The program always terminates and always returns the same result as is_cyclic
 -/
theorem cyc_meets_spec: ∀ (lst: list (ℤ × ℤ)) (res: Ctx),
    exec (some $ llctx lst) cycprog res
    → some (is_cyclic lst) = extract res :=  sorry


-- main theorem: add_iter_finite
import algebra
import combinators
import add_monotonic

namespace iter

universes u v
variables {α β : Type*}

section params_unary
variables {σ I V : Type} [linear_order I]
[has_zero V] [has_add V]
{a : iter σ I V}
variables (s t : σ)

@[simp] lemma step_progress_iff {s} {i : ℕ} : a.terminal_by s i.succ ↔ a.terminal_by (a.δ s) i := by simp
lemma step_progress {s} {i : ℕ} : a.terminal_by s i.succ → a.terminal_by (a.δ s) i := step_progress_iff.mp

lemma terminal_by_mono {s} (i i' : ℕ) :
a.monotonic → a.terminal_by s i → i ≤ i' → a.terminal_by s i' := begin
intros mono fin hle,
obtain ⟨k,_⟩ := le_iff_exists_add.mp hle,
induction k with n hn generalizing s i i'; rw h, exact fin,
apply terminal_succ_terminal _ mono,
exact hn _ _ fin (le_iff_exists_add.mpr ⟨n, rfl⟩) rfl,
end

end params_unary

section params_binary

variables {σ₁ σ₂ I V : Type} [linear_order I] [add_monoid V]
{a : iter σ₁ I V} {b : iter σ₂ I V}
{s₁ : σ₁} {s₂ : σ₂}

-- lemma step_trichotomy (s₁:σ₁)(s₂:σ₂) : ((a +'b).δ (s₁,s₂)) = (a.δ s₁, s₂) ∨ ((a +'b).δ (s₁,s₂)) = (a.δ s₁, b.δ s₂) ∨ ((a +'b).δ (s₁,s₂)) = (s₁, b.δ s₂) := begin
-- simp only [add_iter, iter.δ], split_ifs, tidy,
-- end

lemma step_sem_trichotomy (a : iter σ₁ I V) (b : iter σ₂ I V) (s₁:σ₁) (s₂:σ₂)
:  (((a +'b).δ (s₁,s₂)) = (a.δ s₁, s₂) ∧ ¬ a.terminal s₁ ∧ (a+'b).semantics₁ (s₁, s₂) = a.semantics₁ s₁)
∨ (((a +'b).δ (s₁,s₂)) = (a.δ s₁, b.δ s₂) ∧ (a.terminal s₁ ∧ b.terminal s₂ ∨ ¬a.terminal s₁ ∧ ¬b.terminal s₂) ∧ (a+'b).semantics₁ (s₁, s₂) = a.semantics₁ s₁ + b.semantics₁ s₂)
∨ (((a +'b).δ (s₁,s₂)) = (s₁, b.δ s₂) ∧ ¬ b.terminal s₂ ∧ (a+'b).semantics₁ (s₁, s₂) = b.semantics₁ s₂) :=
begin
simp only [semantics₁, add_emit, add_iter, iter.δ],
split_ifs with h1 h2 h3 h4,
{
  rcases h1 with ⟨_,⟨hi1,_⟩⟩,
  simp only [and_true, true_and, eq_self_iff_true, option.mem_def] at *,
  apply or.inl,
  intro h1,
  replace := emit_none_of_terminal h1,
  replace := ι_top_emit_none.mpr this,
  rw hi1 at this,
  exact option.some_ne_none _ this,
},
{
  rcases h2 with ⟨_,⟨hi2,_⟩⟩,
  simp only [true_and, and_true, not_lt, eq_self_iff_true, option.mem_def] at *,
  apply or.inr,
  apply or.inr,
  intro h1,
  have := emit_none_of_terminal h1,
  have := ι_top_emit_none.mpr this,
  rw hi2 at this,
  exact option.some_ne_none _ this,
},
{
  simp only [true_and, and_true, not_lt, prod.mk.inj_iff, eq_self_iff_true] at *,
  apply or.inr, apply or.inl,
  have : a.ι s₁ = b.ι s₂ := le_antisymm h2 h1,
  split,
  cases h2 : a.ι s₁; rw h2 at this,
  {apply or.inl, exact ⟨h2, this.symm⟩},
  {apply or.inr, exact ⟨some_not_terminal h2, some_not_terminal this.symm⟩},
  cases h3 : a.emit s₁ with v1;
  cases h4 : b.emit s₂ with v2,
  case option.some option.some {
    cases v1 with i1 v1; cases v2 with i2 v2,
    have : i1 = i2,
    { simp only [ι, h3, h4] at this,
      apply option.some.inj this },

    cases v1; cases v2;
    simp only [option.lift_or_get, merge_indexed_values, semantics₁, add_zero, zero_add, this],
    simp only [elementary], funext j, split_ifs with h; {simp [h, this]},
  },
  all_goals { simp  },
},
end

lemma step_trichotomy (a : iter σ₁ I V) (b : iter σ₂ I V) (s₁:σ₁) (s₂:σ₂)
:  (((a +'b).δ (s₁,s₂)) = (a.δ s₁, s₂) ∧ ¬ a.terminal s₁)
∨ (((a +'b).δ (s₁,s₂)) = (a.δ s₁, b.δ s₂) ∧ (a.terminal s₁ ∧ b.terminal s₂ ∨ ¬a.terminal s₁ ∧ ¬b.terminal s₂))
∨ (((a +'b).δ (s₁,s₂)) = (s₁, b.δ s₂) ∧ ¬ b.terminal s₂) := begin
obtain (h|h|h) := step_sem_trichotomy a b s₁ s₂,
exact or.inl ⟨h.1, h.2.1⟩,
exact or.inr (or.inl ⟨h.1, h.2.1⟩),
exact or.inr (or.inr ⟨h.1, h.2.1⟩),
end

@[simp] lemma sum_zero {i j : ℕ} : 0 = i + j ↔ i = 0 ∧ j = 0 := begin
induction i; induction j; dec_trivial,
end

lemma add_iter_bound {s₁ : σ₁} {s₂ : σ₂} {i j : ℕ}
  : a.monotonic → b.monotonic → a.terminal_by s₁ i → b.terminal_by s₂ j → (a+'b).terminal_by (s₁,s₂) (i+j) := λ amono bmono,
begin
--obtain ⟨n, hnij⟩ : ∃ n, n = i + j := ⟨_, rfl⟩,
generalize hnij : i+j = n,
induction n with n hn generalizing i j s₁ s₂,
{ obtain ⟨i0, j0⟩ := sum_zero.1 hnij.symm,
  intros h1 h2, --simp [terminal_by, ι, emit, add_emit, h1, h2, le_top],
  simp [*, step, one_smul, add_iter_terminal] at * },
intros h1 h2,
obtain (h|⟨heq, hterm⟩|h) := step_trichotomy a b s₁ s₂,
{ -- a.δ
  rw [terminal_by, step_succ, h.1, ←terminal_by],
  obtain ⟨i', h3⟩ := not_terminal_succ h.2 h1,
  rw h3 at h1,
  refine hn _ (step_progress h1) h2,
  { simp only [*, nat.succ_add] at * },
},
swap,
{ -- b.δ
  rw [terminal_by, step_succ, h.1, ←terminal_by],
  obtain ⟨j', h3⟩ := not_terminal_succ h.2 h2,
  rw h3 at h2,
  refine hn _ h1 (step_progress h2),
  { simp only [*, nat.add_succ] at * }
},
{ -- a.δ, b.δ
cases hterm,
  { -- the only place we use monotonicity (i+j might go too far)
    apply terminal_by_mono 0 _ (add_iter_monotonic amono bmono)
        (add_iter_terminal hterm.1 hterm.2) (nat.zero_le _),
  },
  {
    rw [terminal_by, step_succ, heq, ← terminal_by],
    obtain ⟨i', hi'⟩ := not_terminal_succ hterm.1 h1,
    obtain ⟨j', hj'⟩ := not_terminal_succ hterm.2 h2,
    rw hi' at h1,
    rw hj' at h2,
    have h3 := step_progress h1,
    have h4 := step_progress h2,
    replace h4 := terminal_by_mono j' j'.succ bmono h4 (nat.le_succ _),
    rw ← hj' at h4,
    refine hn (by simp only [*, nat.succ_add] at *) h3 h4,
  },
},
end

theorem add_iter_finite {a : iter σ₁ I V} {b : iter σ₂ I V} {s₁:σ₁} {s₂:σ₂}
: a.monotonic → b.monotonic → a.finite s₁ → b.finite s₂ → (a +' b).finite (s₁,s₂) := begin
rintros amono bmono ⟨ta, fina⟩ ⟨tb, finb⟩,
obtain ⟨i,hi⟩ := index_of_path fina.1,
obtain ⟨j,hj⟩ := index_of_path finb.1,
rw hi at fina,
rw hj at finb,
have reachable := path_of_index (s₁,s₂) (i+j),
have terminal := add_iter_bound amono bmono (fina.2) (finb.2),
exact ⟨_, ⟨reachable, terminal⟩⟩,
end

end params_binary

end iter


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

Extra definitions on option.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.PostPort

universes u_1 u_2 u v w

namespace Mathlib

namespace option

/-- An elimination principle for `option`. It is a nondependent version of `option.rec_on`. -/
@[simp] protected def elim {α : Type u_1} {β : Type u_2} : Option α → β → (α → β) → β := sorry

protected instance has_mem {α : Type u_1} : has_mem α (Option α) :=
  has_mem.mk fun (a : α) (b : Option α) => b = some a

@[simp] theorem mem_def {α : Type u_1} {a : α} {b : Option α} : a ∈ b ↔ b = some a := iff.rfl

theorem is_none_iff_eq_none {α : Type u_1} {o : Option α} : is_none o = tt ↔ o = none :=
  { mp := eq_none_of_is_none, mpr := fun (e : o = none) => Eq.symm e ▸ rfl }

theorem some_inj {α : Type u_1} {a : α} {b : α} : some a = some b ↔ a = b := sorry

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
def decidable_eq_none {α : Type u_1} {o : Option α} : Decidable (o = none) :=
  decidable_of_decidable_of_iff (bool.decidable_eq (is_none o) tt) is_none_iff_eq_none

protected instance decidable_forall_mem {α : Type u_1} {p : α → Prop} [decidable_pred p]
    (o : Option α) : Decidable (∀ (a : α), a ∈ o → p a) :=
  sorry

protected instance decidable_exists_mem {α : Type u_1} {p : α → Prop} [decidable_pred p]
    (o : Option α) : Decidable (∃ (a : α), ∃ (H : a ∈ o), p a) :=
  sorry

/-- inhabited `get` function. Returns `a` if the input is `some a`,
  otherwise returns `default`. -/
def iget {α : Type u_1} [Inhabited α] : Option α → α := sorry

@[simp] theorem iget_some {α : Type u_1} [Inhabited α] {a : α} : iget (some a) = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard {α : Type u_1} (p : α → Prop) [decidable_pred p] (a : α) : Option α :=
  ite (p a) (some a) none

/-- `filter p o` returns `some a` if `o` is `some a`
  and `p a` holds, otherwise `none`. -/
def filter {α : Type u_1} (p : α → Prop) [decidable_pred p] (o : Option α) : Option α :=
  option.bind o (guard p)

def to_list {α : Type u_1} : Option α → List α := sorry

@[simp] theorem mem_to_list {α : Type u_1} {a : α} {o : Option α} : a ∈ to_list o ↔ a ∈ o := sorry

def lift_or_get {α : Type u_1} (f : α → α → α) : Option α → Option α → Option α := sorry

protected instance lift_or_get_comm {α : Type u_1} (f : α → α → α) [h : is_commutative α f] :
    is_commutative (Option α) (lift_or_get f) :=
  sorry

protected instance lift_or_get_assoc {α : Type u_1} (f : α → α → α) [h : is_associative α f] :
    is_associative (Option α) (lift_or_get f) :=
  sorry

protected instance lift_or_get_idem {α : Type u_1} (f : α → α → α) [h : is_idempotent α f] :
    is_idempotent (Option α) (lift_or_get f) :=
  sorry

protected instance lift_or_get_is_left_id {α : Type u_1} (f : α → α → α) :
    is_left_id (Option α) (lift_or_get f) none :=
  is_left_id.mk
    fun (a : Option α) =>
      option.cases_on a
        (eq.mpr
          (id
            (Eq.trans
              ((fun (a a_1 : Option α) (e_1 : a = a_1) (ᾰ ᾰ_1 : Option α) (e_2 : ᾰ = ᾰ_1) =>
                  congr (congr_arg Eq e_1) e_2)
                (lift_or_get f none none) none (lift_or_get.equations._eqn_1 f) none none
                (Eq.refl none))
              (propext (eq_self_iff_true none))))
          trivial)
        fun (a : α) =>
          eq.mpr
            (id
              (Eq.trans
                (Eq.trans
                  ((fun (a a_1 : Option α) (e_1 : a = a_1) (ᾰ ᾰ_1 : Option α) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    (lift_or_get f none (some a)) (some a) (lift_or_get.equations._eqn_2 f a)
                    (some a) (some a) (Eq.refl (some a)))
                  (some.inj_eq a a))
                (propext (eq_self_iff_true a))))
            trivial

protected instance lift_or_get_is_right_id {α : Type u_1} (f : α → α → α) :
    is_right_id (Option α) (lift_or_get f) none :=
  is_right_id.mk
    fun (a : Option α) =>
      option.cases_on a
        (eq.mpr
          (id
            (Eq.trans
              ((fun (a a_1 : Option α) (e_1 : a = a_1) (ᾰ ᾰ_1 : Option α) (e_2 : ᾰ = ᾰ_1) =>
                  congr (congr_arg Eq e_1) e_2)
                (lift_or_get f none none) none (lift_or_get.equations._eqn_1 f) none none
                (Eq.refl none))
              (propext (eq_self_iff_true none))))
          trivial)
        fun (a : α) =>
          eq.mpr
            (id
              (Eq.trans
                (Eq.trans
                  ((fun (a a_1 : Option α) (e_1 : a = a_1) (ᾰ ᾰ_1 : Option α) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    (lift_or_get f (some a) none) (some a) (lift_or_get.equations._eqn_3 f a)
                    (some a) (some a) (Eq.refl (some a)))
                  (some.inj_eq a a))
                (propext (eq_self_iff_true a))))
            trivial

inductive rel {α : Type u_1} {β : Type u_2} (r : α → β → Prop) : Option α → Option β → Prop where
| some : ∀ {a : α} {b : β}, r a b → rel r (some a) (some b)
| none : rel r none none

/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp] def pbind {α : Type u_1} {β : Type u_2} (x : Option α) :
    ((a : α) → a ∈ x → Option β) → Option β :=
  sorry

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f x h` is essentially the same as `map f x`
  but is defined only when all members of `x` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β)
    (x : Option α) : (∀ (a : α), a ∈ x → p a) → Option β :=
  sorry

/--
Flatten an `option` of `option`, a specialization of `mjoin`.
-/
@[simp] def join {α : Type u_1} : Option (Option α) → Option α :=
  fun (x : Option (Option α)) => x >>= id

protected def traverse {F : Type u → Type v} [Applicative F] {α : Type u_1} {β : Type u}
    (f : α → F β) : Option α → F (Option β) :=
  sorry

/- By analogy with `monad.sequence` in `init/category/combinators.lean`. -/

/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def maybe {m : Type u → Type v} [Monad m] {α : Type u} : Option (m α) → m (Option α) := sorry

/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def mmap {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) (o : Option α) :
    m (Option β) :=
  maybe (option.map f o)

end Mathlib


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.factorisation_axiom
import for_mathlib.algebraic_topology.homotopical_algebra.three_of_two
import for_mathlib.category_theory.retracts

open category_theory category_theory.limits

namespace algebraic_topology

variables (C : Type*) [category C]

@[ext]
class category_with_fib_cof_weq := (fib cof weq : morphism_property C)

namespace category_with_fib_cof_weq

variables {C} (data : category_with_fib_cof_weq C) (data' : category_with_fib_cof_weq Cᵒᵖ)

@[simps]
def op : category_with_fib_cof_weq Cᵒᵖ :=
{ fib := data.cof.op,
  cof := data.fib.op,
  weq := data.weq.op }

@[simps]
def unop : category_with_fib_cof_weq C :=
{ fib := data'.cof.unop,
  cof := data'.fib.unop,
  weq := data'.weq.unop }

lemma unop_op : data.op.unop = data :=
by ext1; refl

lemma op_unop : data'.unop.op = data' :=
by ext1; refl

def triv_fib := data.fib ∩ data.weq
def triv_cof := data.cof ∩ data.weq

def inverse_image {D : Type*} [category D] (F : D ⥤ C) : category_with_fib_cof_weq D :=
{ fib := data.fib.inverse_image F,
  cof := data.cof.inverse_image F,
  weq := data.weq.inverse_image F }

def CM2 := data.weq.three_of_two
lemma CM2_iff_op : data.CM2 ↔ data.op.CM2 := morphism_property.three_of_two.iff_op _

namespace CM2

variable {data}

lemma inverse_image {D : Type*} [category D] (h : data.CM2) (F : D ⥤ C) :
  (category_with_fib_cof_weq.inverse_image data F).CM2 :=
morphism_property.three_of_two.for_inverse_image h F

end CM2

def CM3a := data.weq.is_stable_by_retract
def CM3b := data.fib.is_stable_by_retract
def CM3c := data.cof.is_stable_by_retract

structure CM3 : Prop :=
(weq : data.CM3a)
(fib : data.CM3b)
(cof : data.CM3c)

namespace CM3

variable {data}

lemma triv_cof (h : data.CM3) : data.triv_cof.is_stable_by_retract :=
morphism_property.is_stable_by_retract.of_inter h.cof h.weq
lemma triv_fib (h : data.CM3) : data.triv_fib.is_stable_by_retract :=
morphism_property.is_stable_by_retract.of_inter h.fib h.weq

lemma inverse_image {D : Type*} [category D] (h : data.CM3) (F : D ⥤ C) :
  (category_with_fib_cof_weq.inverse_image data F).CM3 :=
{ weq := h.weq.inverse_image F,
  fib := h.fib.inverse_image F,
  cof := h.cof.inverse_image F, }

end CM3

lemma CM3a_iff_op : data.CM3a ↔ data.op.CM3a := morphism_property.is_stable_by_retract.iff_op _
lemma CM3b_iff_op : data.CM3b ↔ data.op.CM3c := morphism_property.is_stable_by_retract.iff_op _
lemma CM3c_iff_op : data.CM3c ↔ data.op.CM3b := morphism_property.is_stable_by_retract.iff_op _
lemma CM3_iff : data.CM3 ↔ data.CM3a ∧ data.CM3b ∧ data.CM3c :=
by { split; rintro ⟨a, b, c⟩; exact ⟨a, b, c⟩, }
lemma CM3_iff_op : data.CM3 ↔ data.op.CM3 :=
by { simp only [CM3_iff, ← CM3a_iff_op, ← CM3b_iff_op, ← CM3c_iff_op], tauto, }

def CM4a := data.triv_cof.has_lifting_property data.fib
def CM4b := data.cof.has_lifting_property data.triv_fib
def CM4 := data.CM4a ∧ data.CM4b
lemma CM4a_iff_op : data.CM4a ↔ data.op.CM4b := morphism_property.has_lifting_property.iff_op _ _
lemma CM4b_iff_op : data.CM4b ↔ data.op.CM4a := morphism_property.has_lifting_property.iff_op _ _
lemma CM4_iff_op : data.CM4 ↔ data.op.CM4 :=
by { dsimp only [CM4], rw [← CM4a_iff_op, ← CM4b_iff_op], tauto, }

def CM5a := factorisation_axiom data.triv_cof data.fib
def CM5b := factorisation_axiom data.cof data.triv_fib
def CM5 := data.CM5a ∧ data.CM5b

lemma CM5a_iff_op : data.CM5a ↔ data.op.CM5b := factorisation_axiom.iff_op _ _
lemma CM5b_iff_op : data.CM5b ↔ data.op.CM5a := factorisation_axiom.iff_op _ _
lemma CM5_iff_op : data.CM5 ↔ data.op.CM5 :=
by { dsimp only [CM5], rw [← CM5a_iff_op, ← CM5b_iff_op], tauto, }

end category_with_fib_cof_weq

end algebraic_topology


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.seq.wseq
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace computation

def parallel.aux2 {α : Type u} : List (computation α) → α ⊕ List (computation α) :=
  list.foldr (fun (c : computation α) (o : α ⊕ List (computation α)) => sorry) (sum.inr [])

def parallel.aux1 {α : Type u} :
    List (computation α) × wseq (computation α) → α ⊕ List (computation α) × wseq (computation α) :=
  sorry

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel {α : Type u} (S : wseq (computation α)) : computation α := corec sorry ([], S)

theorem terminates_parallel.aux {α : Type u} {l : List (computation α)} {S : wseq (computation α)}
    {c : computation α} : c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) :=
  sorry

theorem terminates_parallel {α : Type u} {S : wseq (computation α)} {c : computation α} (h : c ∈ S)
    [T : terminates c] : terminates (parallel S) :=
  sorry

theorem exists_of_mem_parallel {α : Type u} {S : wseq (computation α)} {a : α}
    (h : a ∈ parallel S) : ∃ (c : computation α), ∃ (H : c ∈ S), a ∈ c :=
  sorry

theorem map_parallel {α : Type u} {β : Type v} (f : α → β) (S : wseq (computation α)) :
    map f (parallel S) = parallel (wseq.map (map f) S) :=
  sorry

theorem parallel_empty {α : Type u} (S : wseq (computation α)) (h : wseq.head S ~> none) :
    parallel S = empty α :=
  sorry

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort

def parallel_rec {α : Type u} {S : wseq (computation α)} (C : α → Sort v)
    (H : (s : computation α) → s ∈ S → (a : α) → a ∈ s → C a) {a : α} (h : a ∈ parallel S) : C a :=
  let T : wseq (computation (α × computation α)) :=
    wseq.map (fun (c : computation α) => map (fun (a : α) => (a, c)) c) S;
  (fun (_x : α × computation α) (e : get (parallel T) = _x) =>
      Prod.rec
        (fun (a' : α) (c : computation α) (e : get (parallel T) = (a', c)) =>
          and.dcases_on sorry fun (ac : a ∈ c) (cs : c ∈ S) => H c cs a ac)
        _x e)
    (get (parallel T)) sorry

theorem parallel_promises {α : Type u} {S : wseq (computation α)} {a : α}
    (H : ∀ (s : computation α), s ∈ S → s ~> a) : parallel S ~> a :=
  sorry

theorem mem_parallel {α : Type u} {S : wseq (computation α)} {a : α}
    (H : ∀ (s : computation α), s ∈ S → s ~> a) {c : computation α} (cs : c ∈ S) (ac : a ∈ c) :
    a ∈ parallel S :=
  mem_of_promises (parallel S) (parallel_promises H)

theorem parallel_congr_lem {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (H : wseq.lift_rel equiv S T) :
    (∀ (s : computation α), s ∈ S → s ~> a) ↔ ∀ (t : computation α), t ∈ T → t ~> a :=
  sorry

-- The parallel operation is only deterministic when all computation paths lead to the same value

theorem parallel_congr_left {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (h1 : ∀ (s : computation α), s ∈ S → s ~> a) (H : wseq.lift_rel equiv S T) :
    parallel S ~ parallel T :=
  sorry

theorem parallel_congr_right {α : Type u} {S : wseq (computation α)} {T : wseq (computation α)}
    {a : α} (h2 : ∀ (t : computation α), t ∈ T → t ~> a) (H : wseq.lift_rel equiv S T) :
    parallel S ~ parallel T :=
  parallel_congr_left (iff.mpr (parallel_congr_lem H) h2) H

end Mathlib


import .presheaves

open category_theory opposite

noncomputable theory

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

inductive prod_coprod : Type
| of_cat' : C → prod_coprod
| prod : prod_coprod → prod_coprod → prod_coprod
| coprod : prod_coprod → prod_coprod → prod_coprod

variable {C}

namespace prod_coprod

inductive hom_syntax : Π (X Y : prod_coprod C), Type
| of_cat {X Y : C} : (X ⟶ Y) → hom_syntax (of_cat' X) (of_cat' Y)
| prod_mk {X Y Z : prod_coprod C} : hom_syntax X Y → hom_syntax X Z → hom_syntax X (Y.prod Z)
| fst {X Y : prod_coprod C} : hom_syntax (X.prod Y) X
| snd {X Y : prod_coprod C} : hom_syntax (X.prod Y) Y
| coprod_mk {X Y Z : prod_coprod C} : hom_syntax X Z → hom_syntax Y Z → hom_syntax (X.coprod Y) Z
| inl {X Y : prod_coprod C} : hom_syntax X (X.coprod Y)
| inr {X Y : prod_coprod C} : hom_syntax Y (X.coprod Y)
| id (X : prod_coprod C) : hom_syntax X X
| comp {X Y Z : prod_coprod C} : hom_syntax X Y → hom_syntax Y Z → hom_syntax X Z

namespace hom_syntax

inductive rel : Π {X Y : prod_coprod C}, hom_syntax X Y → hom_syntax X Y → Prop
| refl {X Y : prod_coprod C} (f : hom_syntax X Y) : rel f f
| symm {X Y : prod_coprod C} {f g : hom_syntax X Y} : rel f g → rel g f
| trans {X Y : prod_coprod C} {f g h : hom_syntax X Y} : rel f g → rel g h → rel f h
| comp_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Y} {g₁ g₂ : hom_syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.comp g₁) (f₂.comp g₂)
| prod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Y} {g₁ g₂ : hom_syntax X Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.prod_mk g₁) (f₂.prod_mk g₂)
| coprod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : hom_syntax X Z} {g₁ g₂ : hom_syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.coprod_mk g₁) (f₂.coprod_mk g₂)
| id_comp {X Y : prod_coprod C} (f : hom_syntax X Y) : rel ((hom_syntax.id X).comp f) f
| comp_id {X Y : prod_coprod C} (f : hom_syntax X Y) : rel (f.comp (hom_syntax.id Y)) f
| assoc {W X Y Z : prod_coprod C} (f : hom_syntax W X) (g : hom_syntax X Y) (h : hom_syntax Y Z) :
  rel ((f.comp g).comp h) (f.comp (g.comp h))
| of_cat_id {X : C} : rel (hom_syntax.of_cat (𝟙 X)) (hom_syntax.id (of_cat' X))
| of_cat_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  rel (hom_syntax.of_cat (f ≫ g)) (hom_syntax.comp (hom_syntax.of_cat f) (hom_syntax.of_cat g))
| mk_comp_fst {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax X Z) :
  rel (hom_syntax.comp (hom_syntax.prod_mk f g) hom_syntax.fst) f
| mk_comp_snd {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax X Z) :
  rel (hom_syntax.comp (hom_syntax.prod_mk f g) hom_syntax.snd) g
| prod_eta {X Y Z : prod_coprod C} (f : hom_syntax X (Y.prod Z)) :
  rel (hom_syntax.prod_mk (f.comp hom_syntax.fst) (f.comp hom_syntax.snd)) f
| inl_comp_mk {X Y Z : prod_coprod C} (f : hom_syntax X Z) (g : hom_syntax Y Z) :
  rel (hom_syntax.comp hom_syntax.inl (hom_syntax.coprod_mk f g)) f
| inr_comp_mk {X Y Z : prod_coprod C} (f : hom_syntax X Z) (g : hom_syntax Y Z) :
  rel (hom_syntax.comp hom_syntax.inr (hom_syntax.coprod_mk f g)) g
| coprod_eta {X Y Z : prod_coprod C} (f : hom_syntax (X.coprod Y) Z) :
  rel (hom_syntax.coprod_mk (hom_syntax.inl.comp f) (hom_syntax.inr.comp f)) f

attribute [refl] rel.refl
attribute [symm] rel.symm
attribute [trans] rel.trans

infixl ` ♥ `: 50 := rel

lemma rel_prod {X Y Z : prod_coprod C} {f g : hom_syntax X (Y.prod Z)}
  (h₁ : rel (f.comp hom_syntax.fst) (g.comp hom_syntax.fst))
  (h₂ : rel (f.comp hom_syntax.snd) (g.comp hom_syntax.snd)) :
  rel f g :=
calc f ♥ hom_syntax.prod_mk (f.comp hom_syntax.fst) (f.comp hom_syntax.snd) : rel.symm (rel.prod_eta f)
   ... ♥ hom_syntax.prod_mk (g.comp hom_syntax.fst) (g.comp hom_syntax.snd) : rel.prod_mk_congr h₁ h₂
   ... ♥ g : rel.prod_eta g

lemma rel_coprod {X Y Z : prod_coprod C} {f g : hom_syntax (X.coprod Y) Z}
  (h₁ : rel (hom_syntax.inl.comp f) (hom_syntax.inl.comp g))
  (h₂ : rel (hom_syntax.inr.comp f) (hom_syntax.inr.comp g)) :
  rel f g :=
calc f ♥ hom_syntax.coprod_mk (hom_syntax.inl.comp f) (hom_syntax.inr.comp f) : rel.symm (rel.coprod_eta f)
   ... ♥ hom_syntax.coprod_mk (hom_syntax.inl.comp g) (hom_syntax.inr.comp g) : rel.coprod_mk_congr h₁ h₂
   ... ♥ g : rel.coprod_eta g

instance rel_setoid (X Y : prod_coprod C) : setoid (hom_syntax X Y) :=
{ r := rel,
  iseqv := ⟨rel.refl, λ _ _, rel.symm, λ _ _ _, rel.trans⟩ }

end hom_syntax

section hom_syntax

open hom_syntax

def hom (X Y : prod_coprod C) : Type := quotient (hom_syntax.rel_setoid X Y)

instance : category_struct (prod_coprod C) :=
{ hom := hom,
  id := λ X, quotient.mk' (hom_syntax.id X),
  comp := λ X Y Z f g, quotient.lift_on₂ f g (λ f g, quotient.mk' (hom_syntax.comp f g))
    (λ f₁ g₁ f₂ g₂ hf hg, quotient.sound (rel.comp_congr hf hg)) }

instance : category (prod_coprod C) :=
{ id_comp' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.id_comp f)),
  comp_id' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.comp_id f)),
  assoc' := λ W X Y Z f g h, quotient.induction_on₃ f g h
    (λ f g h, quotient.sound (rel.assoc f g h)) }

def of_syntax {X Y : prod_coprod C} : hom_syntax X Y → (X ⟶ Y) := quotient.mk

def of_cat : C ⥤ prod_coprod C :=
{ obj := λ X, of_cat' X,
  map := λ X Y f, of_syntax (hom_syntax.of_cat f),
  map_id' := λ X, quotient.sound rel.of_cat_id,
  map_comp' := λ X Y Z f g, quotient.sound (rel.of_cat_comp f g) }

@[simp] lemma of_cat_obj (X : C) : of_cat.obj X = of_cat' X := rfl

def prod_mk {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) : X ⟶ (Y.prod Z) :=
quotient.lift_on₂ f g (λ f g, of_syntax (prod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.prod_mk_congr _ _; assumption
end

def fst {X Y : prod_coprod C} : (X.prod Y) ⟶ X :=
of_syntax fst

def snd {X Y : prod_coprod C} : (X.prod Y) ⟶ Y :=
of_syntax snd

@[simp] lemma prod_mk_comp_fst {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ fst = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.mk_comp_fst _ _))

@[simp] lemma prod_mk_comp_snd {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ snd = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.mk_comp_snd _ _))

lemma prod_mk_eta {X Y Z : prod_coprod C} (f : X ⟶ Y.prod Z) :
  prod_mk (f ≫ fst) (f ≫ snd) = f :=
quotient.induction_on f (λ f, quotient.sound (hom_syntax.rel.prod_eta _))

@[ext] lemma prod_hom_ext {X Y Z : prod_coprod C} {f g : X ⟶ Y.prod Z}
  (h₁ : f ≫ fst = g ≫ fst) (h₂ : f ≫ snd = g ≫ snd) : f = g :=
begin
  conv_lhs { rw ← prod_mk_eta f },
  rw [h₁, h₂, prod_mk_eta]
end

def coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) : (X.coprod Y) ⟶ Z :=
quotient.lift_on₂ f g (λ f g, of_syntax (coprod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.coprod_mk_congr _ _; assumption
end

def inl {X Y : prod_coprod C} : X ⟶ (X.coprod Y) :=
of_syntax inl

def inr {X Y : prod_coprod C} : Y ⟶ (X.coprod Y) :=
of_syntax inr

@[elab_as_eliminator] lemma hom_induction
  {motive : Π (X Y : prod_coprod C), (X ⟶ Y) → Prop}
  {X Y : prod_coprod C} (f : X ⟶ Y)
  (h₁ : Π {X Y : C} (f : X ⟶ Y), motive _ _ (of_cat.map f))
  (h₂ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z),
     motive X Y f → motive X Z g → motive _ _ (prod_mk f g))
  (h₃ : Π {X Y : prod_coprod C}, motive (X.prod Y) X fst)
  (h₄ : Π {X Y : prod_coprod C}, motive (X.prod Y) Y snd)
  (h₅ : Π {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z),
     motive X Z f → motive Y Z g → motive _ _ (coprod_mk f g))
  (h₆ : Π {X Y : prod_coprod C}, motive X (X.coprod Y) inl)
  (h₇ : Π {X Y : prod_coprod C}, motive Y (X.coprod Y) inr)
  (h₈ : Π (X : prod_coprod C), motive X X (𝟙 X))
  (h₉ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : Y ⟶ Z),
     motive X Y f → motive Y Z g → motive X Z (f ≫ g)) :
  motive X Y f :=
quotient.induction_on f
  begin
    intro f,
    apply hom_syntax.rec_on f; try { assumption },
    { intros _ _ _ f g,
      exact h₂ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₅ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₉ (of_syntax f) (of_syntax g) }
  end

@[simp] lemma inl_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inl ≫ coprod_mk f g = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.inl_comp_mk _ _))

@[simp] lemma inr_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inr ≫ coprod_mk f g = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (hom_syntax.rel.inr_comp_mk _ _))

lemma coprod_mk_eta {X Y Z : prod_coprod C} (f : X.coprod Y ⟶ Z) :
  coprod_mk (inl ≫ f) (inr ≫ f) = f :=
quotient.induction_on f (λ f, quotient.sound (hom_syntax.rel.coprod_eta _))

@[ext] lemma coprod_hom_ext {X Y Z : prod_coprod C} {f g : X.coprod Y ⟶ Z}
  (h₁ : inl ≫ f = inl ≫ g ) (h₂ : inr ≫ f = inr ≫ g) : f = g :=
begin
  conv_lhs { rw ← coprod_mk_eta f },
  rw [h₁, h₂, coprod_mk_eta]
end

def to_presheaf_obj (X : prod_coprod C) : (Cᵒᵖ ⥤ Type) :=
prod_coprod.rec_on X
  yoneda.obj
  (λ X Y ih₁ ih₂, Pprod ih₁ ih₂)
  (λ X Y ih₁ ih₂, Pcoprod ih₁ ih₂)

@[simp] def to_presheaf_hom_syntax : Π {X Y : prod_coprod C}, hom_syntax X Y →
  ((to_presheaf_obj X) ⟶ (to_presheaf_obj Y))
| _ _ (hom_syntax.of_cat f) := yoneda.map f
| _ _ (hom_syntax.prod_mk f g) := Pprod_lift (to_presheaf_hom_syntax f) (to_presheaf_hom_syntax g)
| _ _ (hom_syntax.fst) := Pprod_fst
| _ _ (hom_syntax.snd) := Pprod_snd
| _ _ (hom_syntax.coprod_mk f g) := Pcoprod_lift (to_presheaf_hom_syntax f) (to_presheaf_hom_syntax g)
| _ _ (hom_syntax.inl) := Pcoprod_inl
| _ _ (hom_syntax.inr) := Pcoprod_inr
| _ _ (hom_syntax.id X) := 𝟙 _
| _ _ (hom_syntax.comp f g) := to_presheaf_hom_syntax f ≫ to_presheaf_hom_syntax g

lemma to_presheaf_hom_syntax_comp {X Y Z : prod_coprod C} (f : hom_syntax X Y) (g : hom_syntax Y Z) :
  to_presheaf_hom_syntax (f.comp g) = to_presheaf_hom_syntax f ≫ to_presheaf_hom_syntax g := rfl

lemma to_presheaf_hom_syntax_rel {X Y : prod_coprod C} (f g : hom_syntax X Y) (h : rel f g) :
  to_presheaf_hom_syntax f = to_presheaf_hom_syntax g :=
begin
  induction h; try { simp * }; try { ext }; try { refl }; tidy,
end

def to_presheaf : prod_coprod C ⥤ (Cᵒᵖ ⥤ Type) :=
{ obj := to_presheaf_obj,
  map := λ X Y f, quotient.lift_on f (to_presheaf_hom_syntax) to_presheaf_hom_syntax_rel,
  map_id' := λ _, rfl,
  map_comp' := λ _ _ _ f g, quotient.induction_on₂ f g begin intros, simp,
    erw quotient.lift_on_mk,
    simp [to_presheaf_hom_syntax_comp] end }

@[simp] lemma to_presheaf_obj_of_cat (X : C) : to_presheaf.obj (of_cat' X) = yoneda.obj X := rfl

@[simp] lemma to_presheaf_obj_prod (X Y : prod_coprod C) : to_presheaf.obj (prod X Y) =
  Pprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_obj_coprod (X Y : prod_coprod C) : to_presheaf.obj (coprod X Y) =
  Pcoprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_of_cat {X Y : C} (f : X ⟶ Y) :
  to_presheaf.map (of_cat.map f) = yoneda.map f := rfl

@[simp] lemma to_presheaf_prod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Y) (g : X ⟶ Z) :
  to_presheaf.map (prod_mk f g) = Pprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_coprod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Z) (g : Y ⟶ Z) :
  to_presheaf.map (coprod_mk f g) = Pcoprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_fst {X Y : prod_coprod C} :
  to_presheaf.map (fst : X.prod Y ⟶ X) = Pprod_fst := rfl

@[simp] lemma to_presheaf_snd {X Y : prod_coprod C} :
  to_presheaf.map (snd : X.prod Y ⟶ Y) = Pprod_snd := rfl

@[simp] lemma to_presheaf_inl {X Y : prod_coprod C} :
  to_presheaf.map (inl : X ⟶ X.coprod Y) = Pcoprod_inl := rfl

@[simp] lemma to_presheaf_inr {X Y : prod_coprod C} :
  to_presheaf.map (inr : Y ⟶ X.coprod Y) = Pcoprod_inr := rfl

end hom_syntax

def transformation_syntax : Π {X : C} {Y : prod_coprod C}, (to_presheaf.obj Y).obj (opposite.op X) →
  hom_syntax (of_cat' X) Y
| X (of_cat' Y) := λ f, hom_syntax.of_cat f
| X (prod Y Z) := λ f, hom_syntax.prod_mk (transformation_syntax f.1) (transformation_syntax f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation_syntax f).comp hom_syntax.inl)
  (λ f, (transformation_syntax f).comp hom_syntax.inr)

@[simp] def transformation : Π {X : C} {Y : prod_coprod C},
  (to_presheaf.obj Y).obj (opposite.op X) →
  ((of_cat' X) ⟶ Y)
| X (of_cat' Y) := λ f, of_cat.map f
| X (prod Y Z) := λ f, prod_mk (transformation f.1) (transformation f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation f) ≫ inl)
  (λ f, (transformation f) ≫ inr)

lemma transformation_eq_of_syntax_transformation_syntax {X : C} {Y : prod_coprod C}
  (x : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation x = of_syntax (transformation_syntax x) :=
by induction Y; simp [transformation, transformation_syntax, *]; tidy

lemma transformation_left_naturality : Π {X Y : prod_coprod C}
  (f : X ⟶ Y) ⦃Z : C⦄ (z : (to_presheaf.obj X).obj (op Z)),
  transformation ((to_presheaf.map f).app (op Z) z) =
  transformation z ≫ f :=
begin
  intros X Y f Z z, revert Z z,
  refine hom_induction f _ _ _ _ _ _ _ _ _; intros; try { ext };
  try { dsimp at * }; try { simp * at * },
  cases z; simp *
end

def transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) :
  (to_presheaf.obj Y).obj (opposite.op X) :=
yoneda_equiv (to_presheaf.map f)

lemma transformation_transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : transformation (transformation_inverse f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  exact category.id_comp _,
end

lemma transformation_inverse_transformation {X : C} {Y : prod_coprod C}
  (f : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation_inverse (transformation f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  induction Y,
  { simp [transformation], exact category.id_comp _ },
  { simp [transformation, *] },
  { cases f;
    simp [transformation, *] }
end

instance of_cat_full : full (@of_cat C _) :=
{ preimage := λ X Y f, ((to_presheaf.map f).app (op X) (𝟙 X)),
  witness' := λ X Y f, begin
    have := transformation_left_naturality f (𝟙 X),
    simp at this,
    erw [category.id_comp] at this,
    simpa using this
  end }

instance of_cat_faithful : faithful (@of_cat C _) :=
{ map_injective' := λ X Y f g h, begin
    have := congr_arg transformation_inverse h,
    simp [transformation_inverse] at this,
    erw [category.id_comp] at this,
    erw [category.id_comp] at this,
    assumption
end }

def normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : hom_syntax (of_cat' X) Y :=
transformation_syntax (transformation_inverse f)

lemma of_syntax_normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : of_syntax (normalize f) = f :=
by rw [normalize, ← transformation_eq_of_syntax_transformation_syntax,
  transformation_transformation_inverse]

end prod_coprod


class Preorder (α : Type u) extends LT α :=
  (le : α → α → Prop)
  (lt_iff_le_not_le : ∀ a b : α, lt a b ↔ (le a b ∧ ¬ le b a) := by intros; rfl)

theorem Preorder.toLE_injective (A B : Preorder α) (h : A.le = B.le) (h2 : A.toLT = B.toLT) : A = B := by
  cases A; cases B; cases h
  congr


/-
Copyright (c) 2021 Luke Kershaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luke Kershaw
-/
import category_theory.preadditive.additive_functor
import category_theory.shift.basic
import category_theory.triangulated.rotate

/-!
# Pretriangulated Categories

This file contains the definition of pretriangulated categories and triangulated functors
between them.

## Implementation Notes

We work under the assumption that pretriangulated categories are preadditive categories,
but not necessarily additive categories, as is assumed in some sources.

TODO: generalise this to n-angulated categories as in https://arxiv.org/abs/1006.4592
-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v v₀ v₁ v₂ u u₀ u₁ u₂

namespace category_theory
open category pretriangulated

/-
We work in a preadditive category `C` equipped with an additive shift.
-/
variables (C : Type u) [category.{v} C] [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ n : ℤ, functor.additive (shift_functor C n)]
variables (D : Type u₂) [category.{v₂} D] [has_zero_object D] [has_shift D ℤ] [preadditive D]
  [∀ n : ℤ, functor.additive (shift_functor D n)]

/--
A preadditive category `C` with an additive shift, and a class of "distinguished triangles"
relative to that shift is called pretriangulated if the following hold:
* Any triangle that is isomorphic to a distinguished triangle is also distinguished.
* Any triangle of the form `(X,X,0,id,0,0)` is distinguished.
* For any morphism `f : X ⟶ Y` there exists a distinguished triangle of the form `(X,Y,Z,f,g,h)`.
* The triangle `(X,Y,Z,f,g,h)` is distinguished if and only if `(Y,Z,X⟦1⟧,g,h,-f⟦1⟧)` is.
* Given a diagram:
  ```
        f       g       h
    X  ───> Y  ───> Z  ───> X⟦1⟧
    │       │                │
    │a      │b               │a⟦1⟧'
    V       V                V
    X' ───> Y' ───> Z' ───> X'⟦1⟧
        f'      g'      h'
  ```
  where the left square commutes, and whose rows are distinguished triangles,
  there exists a morphism `c : Z ⟶ Z'` such that `(a,b,c)` is a triangle morphism.

See <https://stacks.math.columbia.edu/tag/0145>
-/
class pretriangulated :=
(distinguished_triangles [] : set (triangle C))
(isomorphic_distinguished : Π (T₁ ∈ distinguished_triangles) (T₂ ≅ T₁),
  T₂ ∈ distinguished_triangles)
(contractible_distinguished : Π (X : C), (contractible_triangle X) ∈ distinguished_triangles)
(distinguished_cocone_triangle : Π (X Y : C) (f : X ⟶ Y), (∃ (Z : C) (g : Y ⟶ Z)
  (h : Z ⟶ X⟦(1:ℤ)⟧),
  triangle.mk f g h ∈ distinguished_triangles))
(rotate_distinguished_triangle : Π (T : triangle C),
  T ∈ distinguished_triangles ↔ T.rotate ∈ distinguished_triangles)
(complete_distinguished_triangle_morphism : Π (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ distinguished_triangles) (h₂ : T₂ ∈ distinguished_triangles) (a : T₁.obj₁ ⟶ T₂.obj₁)
  (b : T₁.obj₂ ⟶ T₂.obj₂) (comm₁ : T₁.mor₁ ≫ b = a ≫ T₂.mor₁),
  (∃ (c : T₁.obj₃ ⟶ T₂.obj₃), (T₁.mor₂ ≫ c = b ≫ T₂.mor₂) ∧ (T₁.mor₃ ≫ a⟦1⟧' = c ≫ T₂.mor₃) ))

namespace pretriangulated
variables [hC : pretriangulated C]

include hC

notation `dist_triang `:20 C := distinguished_triangles C
/--
Given any distinguished triangle `T`, then we know `T.rotate` is also distinguished.
-/
lemma rot_of_dist_triangle (T ∈ dist_triang C) : (T.rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle T).mp H

/--
Given any distinguished triangle `T`, then we know `T.inv_rotate` is also distinguished.
-/
lemma inv_rot_of_dist_triangle (T ∈ dist_triang C) : (T.inv_rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle (T.inv_rotate)).mpr
  (isomorphic_distinguished T H T.inv_rotate.rotate (inv_rot_comp_rot.app T))

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `f ≫ g = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₁₂ (T ∈ dist_triang C) : T.mor₁ ≫ T.mor₂ = 0 :=
begin
  obtain ⟨c, hc⟩ := complete_distinguished_triangle_morphism _ _
    (contractible_distinguished T.obj₁) H (𝟙 T.obj₁) T.mor₁ rfl,
  simpa only [contractible_triangle_mor₂, zero_comp] using hc.left.symm,
end

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `g ≫ h = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₂₃  (T ∈ dist_triang C) : T.mor₂ ≫ T.mor₃ = 0 :=
comp_dist_triangle_mor_zero₁₂ C T.rotate (rot_of_dist_triangle C T H)

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `h ≫ f⟦1⟧ = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₃₁ (T ∈ dist_triang C) :
  T.mor₃ ≫ ((shift_equiv C 1).functor.map T.mor₁) = 0 :=
have H₂ : _ := rot_of_dist_triangle C T.rotate (rot_of_dist_triangle C T H),
by simpa using comp_dist_triangle_mor_zero₁₂ C (T.rotate.rotate) H₂

/-
TODO: If `C` is pretriangulated with respect to a shift,
then `Cᵒᵖ` is pretriangulated with respect to the inverse shift.
-/

end pretriangulated
end category_theory