/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.eq_to_hom

/-!
# Cartesian products of categories

We define the category instance on `C × D` when `C` and `D` are categories.

We define:
* `sectl C Z` : the functor `C ⥤ C × D` given by `X ↦ ⟨X, Z⟩`
* `sectr Z D` : the functor `D ⥤ C × D` given by `Y ↦ ⟨Z, Y⟩`
* `fst`       : the functor `⟨X, Y⟩ ↦ X`
* `snd`       : the functor `⟨X, Y⟩ ↦ Y`
* `swap`      : the functor `C × D ⥤ D × C` given by `⟨X, Y⟩ ↦ ⟨Y, X⟩`
    (and the fact this is an equivalence)

We further define `evaluation : C ⥤ (C ⥤ D) ⥤ D` and `evaluation_uncurried : C × (C ⥤ D) ⥤ D`,
and products of functors and natural transformations, written `F.prod G` and `α.prod β`.
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

/--
`prod C D` gives the cartesian product of two categories.

See https://stacks.math.columbia.edu/tag/001K.
-/
@[simps {not_recursive := []}] -- the generates simp lemmas like `id_fst` and `comp_snd`
instance prod : category.{max v₁ v₂} (C × D) :=
{ hom     := λ X Y, ((X.1) ⟶ (Y.1)) × ((X.2) ⟶ (Y.2)),
  id      := λ X, ⟨ 𝟙 (X.1), 𝟙 (X.2) ⟩,
  comp    := λ _ _ _ f g, (f.1 ≫ g.1, f.2 ≫ g.2) }

/-- Two rfl lemmas that cannot be generated by `@[simps]`. -/
@[simp]

lemma is_iso_prod_iff {P Q : C} {S T : D} {f : (P, S) ⟶ (Q, T)} :
  is_iso f ↔ is_iso f.1 ∧ is_iso f.2 :=
begin
  split,
  { rintros ⟨g, hfg, hgf⟩,
    simp at hfg hgf,
    rcases hfg with ⟨hfg₁, hfg₂⟩,
    rcases hgf with ⟨hgf₁, hgf₂⟩,
    exact ⟨⟨⟨g.1, hfg₁, hgf₁⟩⟩, ⟨⟨g.2, hfg₂, hgf₂⟩⟩⟩ },
  { rintros ⟨⟨g₁, hfg₁, hgf₁⟩, ⟨g₂, hfg₂, hgf₂⟩⟩,
    dsimp at hfg₁ hgf₁ hfg₂ hgf₂,
    refine ⟨⟨(g₁, g₂), _, _⟩⟩; { simp; split; assumption } }
end

section
variables {C D}

/-- Construct an isomorphism in `C × D` out of two isomorphisms in `C` and `D`. -/
@[simps]
def iso.prod {P Q : C} {S T : D} (f : P ≅ Q) (g : S ≅ T) : (P, S) ≅ (Q, T) :=
{ hom := (f.hom, g.hom),
  inv := (f.inv, g.inv), }

end

end

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]
/--
`prod.category.uniform C D` is an additional instance specialised so both factors have the same
universe levels. This helps typeclass resolution.
-/
instance uniform_prod : category (C × D) := category_theory.prod C D
end

-- Next we define the natural functors into and out of product categories. For now this doesn't
-- address the universal properties.
namespace prod

/-- `sectl C Z` is the functor `C ⥤ C × D` given by `X ↦ (X, Z)`. -/
@[simps] def sectl
  (C : Type u₁) [category.{v₁} C] {D : Type u₂} [category.{v₂} D] (Z : D) : C ⥤ C × D :=
{ obj := λ X, (X, Z),
  map := λ X Y f, (f, 𝟙 Z) }

/-- `sectr Z D` is the functor `D ⥤ C × D` given by `Y ↦ (Z, Y)` . -/
@[simps] def sectr
  {C : Type u₁} [category.{v₁} C] (Z : C) (D : Type u₂) [category.{v₂} D] : D ⥤ C × D :=
{ obj := λ X, (Z, X),
  map := λ X Y f, (𝟙 Z, f) }

variables (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

/-- `fst` is the functor `(X, Y) ↦ X`. -/
@[simps] def fst : C × D ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.1 }

/-- `snd` is the functor `(X, Y) ↦ Y`. -/
@[simps] def snd : C × D ⥤ D :=
{ obj := λ X, X.2,
  map := λ X Y f, f.2 }

/-- The functor swapping the factors of a cartesian product of categories, `C × D ⥤ D × C`. -/
@[simps] def swap : C × D ⥤ D × C :=
{ obj := λ X, (X.2, X.1),
  map := λ _ _ f, (f.2, f.1) }

/--
Swapping the factors of a cartesion product of categories twice is naturally isomorphic
to the identity functor.
-/
@[simps] def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C × D) :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

/--
The equivalence, given by swapping factors, between `C × D` and `D × C`.
-/
@[simps]
def braiding : C × D ≌ D × C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))

instance swap_is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (braiding C D).functor)

end prod

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

/--
The "evaluation at `X`" functor, such that
`(evaluation.obj X).obj F = F.obj X`,
which is functorial in both `X` and `F`.
-/
@[simps] def evaluation : C ⥤ (C ⥤ D) ⥤ D :=
{ obj := λ X,
  { obj := λ F, F.obj X,
    map := λ F G α, α.app X, },
  map := λ X Y f,
  { app := λ F, F.map f,
    naturality' := λ F G α, eq.symm (α.naturality f) } }

/--
The "evaluation of `F` at `X`" functor,
as a functor `C × (C ⥤ D) ⥤ D`.
-/
@[simps] def evaluation_uncurried : C × (C ⥤ D) ⥤ D :=
{ obj := λ p, p.2.obj p.1,
  map := λ x y f, (x.2.map f.1) ≫ (f.2.app y.1),
  map_comp' := λ X Y Z f g,
  begin
    cases g, cases f, cases Z, cases Y, cases X,
    simp only [prod_comp, nat_trans.comp_app, functor.map_comp, category.assoc],
    rw [←nat_trans.comp_app, nat_trans.naturality, nat_trans.comp_app,
        category.assoc, nat_trans.naturality],
  end }

end

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₂} [category.{v₂} B]
          {C : Type u₃} [category.{v₃} C]
          {D : Type u₄} [category.{v₄} D]

namespace functor
/-- The cartesian product of two functors. -/
@[simps] def prod (F : A ⥤ B) (G : C ⥤ D) : A × C ⥤ B × D :=
{ obj := λ X, (F.obj X.1, G.obj X.2),
  map := λ _ _ f, (F.map f.1, G.map f.2) }

/- Because of limitations in Lean 3's handling of notations, we do not setup a notation `F × G`.
   You can use `F.prod G` as a "poor man's infix", or just write `functor.prod F G`. -/

/-- Similar to `prod`, but both functors start from the same category `A` -/
@[simps] def prod' (F : A ⥤ B) (G : A ⥤ C) : A ⥤ (B × C) :=
{ obj := λ a, (F.obj a, G.obj a),
  map := λ x y f, (F.map f, G.map f), }

section
variable (C)

/-- The diagonal functor. -/
def diag : C ⥤ C × C := (𝟭 C).prod' (𝟭 C)

@[simp] lemma diag_obj (X : C) : (diag C).obj X = (X, X) := rfl

@[simp] lemma diag_map {X Y : C} (f : X ⟶ Y) : (diag C).map f = (f, f) := rfl

end

end functor

namespace nat_trans

/-- The cartesian product of two natural transformations. -/
@[simps] def prod {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) :
  F.prod H ⟶ G.prod I :=
{ app         := λ X, (α.app X.1, β.app X.2),
  naturality' := λ X Y f,
  begin
    cases X, cases Y,
    simp only [functor.prod_map, prod.mk.inj_iff, prod_comp],
    split; rw naturality
  end }

/- Again, it is inadvisable in Lean 3 to setup a notation `α × β`;
   use instead `α.prod β` or `nat_trans.prod α β`. -/

end nat_trans

/-- `F.flip` composed with evaluation is the same as evaluating `F`. -/
@[simps]
def flip_comp_evaluation (F : A ⥤ B ⥤ C) (a) :
  F.flip ⋙ (evaluation _ _).obj a ≅ F.obj a :=
nat_iso.of_components (λ b, eq_to_iso rfl) $ by tidy

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 u} [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.{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.{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.{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.{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 : has_limits.{u} Top.{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 forget_preserves_limits : preserves_limits (forget : Top.{u} ⥤ Type 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)) } }

/--
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.{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.{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 : has_colimits.{u} Top.{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 forget_preserves_colimits : preserves_colimits (forget : Top.{u} ⥤ Type 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)) } }

/-- The projection from the product as a bundled continous map. -/
abbreviation pi_π {ι : Type u} (α : ι → Top.{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 u} (α : ι → Top.{u}) : fan α :=
fan.mk (Top.of (Π i, α i)) (pi_π α)

/-- The constructed fan is indeed a limit -/
def pi_fan_is_limit {ι : Type u} (α : ι → Top.{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] } }

/--
The product is homeomorphic to the product of the underlying spaces,
equipped with the product topology.
-/
def pi_iso_pi {ι : Type u} (α : ι → Top.{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 u} (α : ι → Top) (i : ι) :
  (pi_iso_pi α).inv ≫ pi.π α i = pi_π α i :=
by simp [pi_iso_pi]

@[simp]
lemma pi_iso_pi_inv_π_apply {ι : Type u} (α : ι → Top.{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 u} (α : ι → Top.{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 u} (α : ι → Top.{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 u} (α : ι → Top.{u}) : cofan α :=
cofan.mk (Top.of (Σ i, α i)) (sigma_ι α)

/-- The constructed cofan is indeed a colimit -/
def sigma_cofan_is_colimit {ι : Type u} (α : ι → Top.{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] } }

/--
The coproduct is homeomorphic to the disjoint union of the topological spaces.
-/
def sigma_iso_sigma {ι : Type u} (α : ι → Top.{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 u} (α : ι → Top) (i : ι) :
  sigma.ι α i ≫ (sigma_iso_sigma α).hom = sigma_ι α i :=
by simp [sigma_iso_sigma]

@[simp]
lemma sigma_iso_sigma_hom_ι_apply {ι : Type u} (α : ι → Top) (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 u} (α : ι → Top) (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.{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.{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.{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.{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.{u}) (U : set ((colimit F : _) : Type 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,
  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 u} [small_category J] [is_cofiltered J] (F : J ⥤ Top.{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 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 advice

lemma conj (P Q : Prop)
      (P ∧ Q) : P :=
{! !}


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

Miscellaneous lemmas.
-/
import .predicates .tcont .expected_value

namespace certigrad
open list

lemma env_not_has_key_insert {m : env} {ref₁ ref₂ : reference} {x : T ref₂.2} :
  ref₁ ≠ ref₂ → (¬ env.has_key ref₁ m) → (¬ env.has_key ref₁ (env.insert ref₂ x m)) :=
begin
intros H_neq H_nin H_in,
exact H_nin (env.has_key_insert_diff H_neq H_in)
end

lemma env_in_nin_ne {m : env} {ref₁ ref₂ : reference} : env.has_key ref₁ m → (¬ env.has_key ref₂ m) → ref₁ ≠ ref₂ :=
begin
intros H_in H_nin H_eq,
subst H_eq,
exact H_nin H_in
end

lemma ref_notin_parents {n : node} {nodes : list node} {m : env} :
  all_parents_in_env m (n::nodes) → uniq_ids (n::nodes) m → n^.ref ∉ n^.parents :=
begin
cases n with ref parents op,
intros H_ps_in_env H_uids H_ref_in_parents,
dsimp [uniq_ids] at H_uids,
dsimp at H_ref_in_parents,
dsimp [all_parents_in_env] at H_ps_in_env,
exact H_uids^.left (H_ps_in_env^.left ref H_ref_in_parents)
end

lemma ref_ne_tgt {n : node} {nodes : list node} {m : env} {tgt : reference} :
env.has_key tgt m → uniq_ids (n::nodes) m → tgt ≠ n^.ref :=
begin
cases n with ref parents op,
intros H_tgt H_uids,
exact env_in_nin_ne H_tgt H_uids^.left
end

lemma wf_at_next {costs : list ID} {n : node} {nodes : list node} {x : T n^.ref.2} {inputs : env} {tgt : reference} :
  let next_inputs : env := env.insert n^.ref x inputs in
  well_formed_at costs (n::nodes) inputs tgt → well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs n^.ref :=
begin
intros next_inputs H_wf,
cases n with ref parents op,
assertv H_uids_next : uniq_ids nodes next_inputs := H_wf^.uids^.right x,
assertv H_ps_in_env_next : all_parents_in_env next_inputs nodes := H_wf^.ps_in_env^.right x,
assertv H_costs_scalars_next : all_costs_scalars costs nodes := H_wf^.costs_scalars^.right,
assert H_m_contains_tgt : env.has_key tgt next_inputs,
  begin dsimp, apply env.has_key_insert, exact H_wf^.m_contains_tgt end,
assert H_m_contains_ref : env.has_key ref next_inputs,
  begin dsimp, apply env.has_key_insert_same end,
assertv H_cost_scalar_tgt : tgt.1 ∈ costs → tgt.2 = [] := H_wf^.tgt_cost_scalar,
assertv H_cost_scalar_ref : ref.1 ∈ costs → ref.2 = [] := H_wf^.costs_scalars^.left,
assertv H_wf_tgt : well_formed_at costs nodes next_inputs tgt :=
  ⟨H_uids_next, H_ps_in_env_next, H_costs_scalars_next, H_m_contains_tgt, H_cost_scalar_tgt⟩,
assertv H_wf_ref : well_formed_at costs nodes next_inputs ref :=
  ⟨H_uids_next, H_ps_in_env_next, H_costs_scalars_next, H_m_contains_ref, H_cost_scalar_ref⟩,
exact ⟨H_wf_tgt, H_wf_ref⟩
end

lemma can_diff_under_ints_alt1 {costs : list ID}
  {ref : reference} {parents : list reference} {op : rand.op parents^.p2 ref.2} {nodes : list node} {inputs : env} {tgt : reference} :
  let θ : T tgt.2 := env.get tgt inputs in
  let g : T ref.2 → T tgt.2 → ℝ :=
  (λ (x : T ref.2) (θ₀ : T tgt.2),
      E (graph.to_dist (λ (inputs : env), ⟦sum_costs inputs costs⟧)
                       (env.insert ref x (env.insert tgt θ₀ inputs))
                       nodes)
        dvec.head) in
  let next_inputs := (λ (y : T ref.2), env.insert ref y inputs) in

can_differentiate_under_integrals costs (⟨ref, parents, operator.rand op⟩ :: nodes) inputs tgt
→
T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ inputs)) x ⬝ g x θ₀) θ :=
begin
dsimp [can_differentiate_under_integrals],
intro H_cdi,
note H := H_cdi^.left^.left,
clear H_cdi,
apply T.uint_right (λ θ₁ θ₂ x,
rand.op.pdf op (env.get_ks parents (env.insert tgt θ₁ inputs)) x ⬝
         E
           (graph.to_dist (λ (inputs : env), ⟦sum_costs inputs costs⟧)
              (env.insert ref x (env.insert tgt θ₂ inputs))
              nodes)
           dvec.head) _ H
end

lemma pdfs_exist_at_ignore {ref₀ : reference} {x₁ x₂ : T ref₀.2} :
  ∀ {nodes : list node} {inputs : env},
     all_parents_in_env inputs nodes →
     (¬ env.has_key ref₀ inputs) → ref₀ ∉ map node.ref nodes →
     pdfs_exist_at nodes (env.insert ref₀ x₁ inputs) → pdfs_exist_at nodes (env.insert ref₀ x₂ inputs)
| [] _ _ _ _ _ := true.intro
| (⟨ref, parents, operator.det op⟩ :: nodes) inputs H_ps_in_env H_fresh₁ H_fresh₂ H_pdfs_exist_at :=
begin
dsimp [pdfs_exist_at] at H_pdfs_exist_at,
dsimp [pdfs_exist_at],
assertv H_ref₀_notin_parents : ref₀ ∉ parents := λ H_contra, H_fresh₁ (H_ps_in_env^.left ref₀ H_contra),
assert H_ref₀_neq_ref : ref₀ ≠ ref,
{ intro H_contra, subst H_contra, exact H_fresh₂ mem_of_cons_same },

rw env.get_ks_insert_diff H_ref₀_notin_parents,
rw env.insert_insert_flip _ _ _ (ne.symm H_ref₀_neq_ref),
rw env.get_ks_insert_diff H_ref₀_notin_parents at H_pdfs_exist_at,
rw env.insert_insert_flip _ _ _ (ne.symm H_ref₀_neq_ref) at H_pdfs_exist_at,

apply (pdfs_exist_at_ignore (H_ps_in_env^.right _) _ _ H_pdfs_exist_at),

{ intro H_contra, exact H_fresh₁ (env.has_key_insert_diff H_ref₀_neq_ref H_contra) },
{ exact not_mem_of_not_mem_cons H_fresh₂ }
end

| (⟨ref, parents, operator.rand op⟩ :: nodes) inputs H_ps_in_env H_fresh₁ H_fresh₂ H_pdfs_exist_at :=
begin
dsimp [pdfs_exist_at] at H_pdfs_exist_at,
dsimp [pdfs_exist_at],
assertv H_ref₀_notin_parents : ref₀ ∉ parents := λ H_contra, H_fresh₁ (H_ps_in_env^.left ref₀ H_contra),
assert H_ref₀_neq_ref : ref₀ ≠ ref,
{ intro H_contra, subst H_contra, exact H_fresh₂ mem_of_cons_same },
rw env.get_ks_insert_diff H_ref₀_notin_parents,
rw env.get_ks_insert_diff H_ref₀_notin_parents at H_pdfs_exist_at,

apply and.intro,
{ exact H_pdfs_exist_at^.left },
intro y,
note H_pdfs_exist_at_next := H_pdfs_exist_at^.right y,
rw env.insert_insert_flip _ _ _ (ne.symm H_ref₀_neq_ref),
rw env.insert_insert_flip _ _ _ (ne.symm H_ref₀_neq_ref) at H_pdfs_exist_at_next,

apply (pdfs_exist_at_ignore (H_ps_in_env^.right _) _ _ H_pdfs_exist_at_next),
{ intro H_contra, exact H_fresh₁ (env.has_key_insert_diff H_ref₀_neq_ref H_contra) },
{ exact not_mem_of_not_mem_cons H_fresh₂ }
end

lemma pdf_continuous {ref : reference} {parents : list reference} {op : rand.op parents^.p2 ref.2}
                     {nodes : list node} {inputs : env} {tgt : reference} :
  ∀ {idx : ℕ}, at_idx parents idx tgt →
  env.has_key tgt inputs →
  grads_exist_at (⟨ref, parents, operator.rand op⟩ :: nodes) inputs tgt →
  ∀ (y : T ref.2),
    T.is_continuous (λ (x : T tgt.2),
                      (op^.pdf (dvec.update_at x (env.get_ks parents (env.insert tgt (env.get tgt inputs) inputs)) idx) y))
                      (env.get tgt inputs) :=
begin
  intros idx H_at_idx H_tgt_in_inputs H_gs_exist y,
  assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_at_idx,
  assertv H_pre_satisfied : op^.pre (env.get_ks parents inputs) := H_gs_exist^.left H_tgt_in_parents,
  simp [env.insert_get_same H_tgt_in_inputs],
  dsimp,
  simp [eq.symm (env.dvec_get_get_ks inputs H_at_idx)],
  exact (op^.cont (at_idx_p2 H_at_idx) H_pre_satisfied)
end

-- TODO(dhs): this will need to be `differentiable_of_grads_exist`
lemma continuous_of_grads_exist {costs : list ID} :
  Π {nodes : list node} {tgt : reference} {inputs : env},
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  T.is_continuous (λ (θ₀ : T tgt.2),
                    E (graph.to_dist (λ (env₀ : env), ⟦sum_costs env₀ costs⟧)
                                     (env.insert tgt θ₀ inputs)
                                     nodes)
                      dvec.head)
                 (env.get tgt inputs)
| [] tgt inputs H_wf_at H_gs_exist :=
begin
dunfold graph.to_dist,
simp [E.E_ret],
dunfold dvec.head sum_costs,
apply T.continuous_sumr,
intros cost H_cost_in_costs,
assertv H_em : (cost, []) = tgt ∨ (cost, []) ≠ tgt := decidable.em _,
cases H_em with H_eq H_neq,

-- case 1
begin
  cases tgt with tgt₁ tgt₂,
  injection H_eq with H_eq₁ H_eq₂,
  rw [H_eq₁, H_eq₂],
  dsimp,
  simp [env.get_insert_same],
  apply T.continuous_id,
end,

-- case 2
begin
  simp [λ (x₀ : T tgt.2), @env.get_insert_diff (cost, []) tgt x₀ inputs H_neq],
  apply T.continuous_const
end
end

| (⟨ref, parents, operator.det op⟩ :: nodes) tgt inputs H_wf H_gs_exist :=

let θ := env.get tgt inputs in
let x := op^.f (env.get_ks parents inputs) in
let next_inputs := env.insert ref x inputs in

-- 0. Collect useful helpers
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,

have H_get_ks_next_inputs : env.get_ks parents next_inputs = env.get_ks parents inputs,
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents) end,

have H_get_ref_next : env.get ref next_inputs = op^.f (env.get_ks parents inputs),
  begin dsimp, rw env.get_insert_same end,

have H_can_insert : env.get tgt next_inputs = env.get tgt inputs,
  begin dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_insert_next : ∀ (y : T ref.2), env.insert ref y inputs = env.insert ref y next_inputs,
  begin intro y, dsimp, rw env.insert_insert_same end,

have H_wfs : well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs ref, from wf_at_next H_wf,
have H_gs_exist_tgt : grads_exist_at nodes next_inputs tgt, from H_gs_exist^.left,

begin
dunfold graph.to_dist,
simp [E.E_bind, E.E_ret],
dunfold operator.to_dist,
simp [E.E_ret],

assertv H_em_tgt_in_parents : tgt ∈ parents ∨ tgt ∉ parents := decidable.em _,
cases H_em_tgt_in_parents with H_tgt_in_parents H_tgt_notin_parents,
-- case 1
begin
definev chain₁ : T tgt.2 → T ref.2 :=
  λ (θ₀ : T tgt.2), op^.f (env.get_ks parents (env.insert tgt θ₀ inputs)),

definev chain₂ : T tgt.2 → T ref.2 → ℝ :=
  λ (θ₀ : T tgt.2) (x₀ : T ref.2),
     E (graph.to_dist (λ (env₀ : env), ⟦sum_costs env₀ costs⟧)
                      (env.insert ref x₀ (env.insert tgt θ₀ inputs))
                        nodes)
        dvec.head,

change T.is_continuous (λ (θ₀ : T tgt.2), chain₂ θ₀ (chain₁ θ₀)) (env.get tgt inputs),

assert H_chain₁ : T.is_continuous (λ (θ₀ : T tgt.2), chain₁ θ₀) (env.get tgt inputs),
begin
dsimp,
apply T.continuous_multiple_args,
intros idx H_at_idx,
simp [env.insert_get_same H_wf^.m_contains_tgt],
rw -(env.dvec_get_get_ks _ H_at_idx),
apply (op^.is_ocont (env.get_ks parents inputs) (at_idx_p2 H_at_idx) (H_gs_exist^.right $ mem_of_at_idx H_at_idx)^.left),
end,

assert H_chain₂_θ : T.is_continuous (λ (x₀ : T tgt.2), chain₂ x₀ (chain₁ (env.get tgt inputs))) (env.get tgt inputs),
begin
dsimp,
simp [env.insert_get_same H_wf^.m_contains_tgt],
simp [λ (v₁ : T ref.2) (v₂ : T tgt.2) m, env.insert_insert_flip v₁ v₂ m (ne.symm H_tgt_neq_ref)],
rw -H_can_insert,
exact (continuous_of_grads_exist H_wfs^.left H_gs_exist_tgt)
end,

assert H_chain₂_f : T.is_continuous (chain₂ (env.get tgt inputs)) ((λ (θ₀ : T (tgt^.snd)), chain₁ θ₀) (env.get tgt inputs)),
begin
assertv H_gs_exist_ref : grads_exist_at nodes next_inputs ref := (H_gs_exist^.right H_tgt_in_parents)^.right,
dsimp,

simp [env.insert_get_same H_wf^.m_contains_tgt],
rw -H_get_ref_next,
simp [H_insert_next],

apply (continuous_of_grads_exist H_wfs^.right H_gs_exist_ref),
end,

exact (T.continuous_chain_full H_chain₁ H_chain₂_θ H_chain₂_f)
end,

-- case 2
begin
assert H_nodep_tgt : ∀ (θ₀ : T tgt.2), env.get_ks parents (env.insert tgt θ₀ inputs) = env.get_ks parents inputs,
begin intro θ₀, rw env.get_ks_insert_diff H_tgt_notin_parents end,
simp [H_nodep_tgt],
simp [λ (v₁ : T ref.2) (v₂ : T tgt.2) m, env.insert_insert_flip v₁ v₂ m (ne.symm H_tgt_neq_ref)],
rw -H_can_insert,
exact (continuous_of_grads_exist H_wfs^.left H_gs_exist_tgt)
end
end

| (⟨ref, parents, operator.rand op⟩ :: nodes) tgt inputs H_wf H_gs_exist :=

let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in

have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,
have H_insert_θ : env.insert tgt θ inputs = inputs, by rw env.insert_get_same H_wf^.m_contains_tgt,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

have H_pdf_continuous : ∀ (y : T ref.2), T.is_continuous (λ (θ₀ : T tgt.2), op^.pdf (env.get_ks parents (env.insert tgt θ₀ inputs)) y) (env.get tgt inputs), from
assume (y : T ref.2),
begin
apply (T.continuous_multiple_args parents [] tgt inputs (λ xs, op^.pdf xs y) (env.get tgt inputs)),
intros idx H_at_idx,
dsimp,
apply (pdf_continuous H_at_idx H_wf^.m_contains_tgt H_gs_exist)
end,

have H_rest_continuous : ∀ (x : dvec T [ref.2]),
  T.is_continuous (λ (θ₀ : T tgt.2),
                    E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                     (env.insert ref x^.head (env.insert tgt θ₀ inputs))
                                     nodes)
                      dvec.head)
                 (env.get tgt inputs), from
  assume x,
  have H_can_insert_x : ∀ (x : T ref.2), env.get tgt (env.insert ref x inputs) = env.get tgt inputs,
    begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,
  begin
    dsimp,
    simp [λ θ₀, env.insert_insert_flip x^.head θ₀ inputs (ne.symm H_tgt_neq_ref)],
    simp [eq.symm (H_can_insert_x x^.head)],
    exact (continuous_of_grads_exist (H_wfs _)^.left (H_gs_exist^.right _))
   end,

begin
dunfold graph.to_dist operator.to_dist,
simp [E.E_bind],
apply (E.E_continuous op (λ θ₀, env.get_ks parents (env.insert tgt θ₀ inputs)) _ _ H_pdf_continuous H_rest_continuous)
end

lemma rest_continuous {costs : list ID} {n : node} {nodes : list node} {inputs : env} {tgt : reference} {x : T n^.ref.2} :
  ∀ (x : dvec T [n^.ref.2]), tgt ≠ n^.ref →
  well_formed_at costs nodes (env.insert n^.ref x^.head inputs) tgt → grads_exist_at nodes (env.insert n^.ref x^.head inputs) tgt →
  T.is_continuous (λ (θ₀ : T tgt.2),
                    E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                     (env.insert n^.ref x^.head (env.insert tgt θ₀ inputs))
                                     nodes)
                      dvec.head)
                 (env.get tgt inputs) :=
assume x H_tgt_neq_ref H_wf_tgt H_gs_exist_tgt,
have H_can_insert_x : ∀ (x : T n^.ref.2), env.get tgt (env.insert n^.ref x inputs) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,
begin
  dsimp,
  simp [λ θ₀, env.insert_insert_flip x^.head θ₀ inputs (ne.symm H_tgt_neq_ref)],
  simp [eq.symm (H_can_insert_x x^.head)],
  exact (continuous_of_grads_exist H_wf_tgt H_gs_exist_tgt)
end

private lemma fref_notin_parents :
  Π {n : node} {nodes : list node} {inputs : env} {fref : reference},
    all_parents_in_env inputs (n::nodes) →
    (¬ env.has_key fref inputs) →
    fref ∉ n^.parents :=
begin
intro n,
cases n with ref parents op,
dsimp,
intros nodes inputs fref H_ps_in_env H_fref_fresh H_fref_in_ps,
dunfold all_parents_in_env at H_ps_in_env,
exact H_fref_fresh (H_ps_in_env^.left fref H_fref_in_ps)
end

private lemma fref_neq_ref :
  Π {n : node} {nodes : list node} {inputs : env} {fref : reference},
    (¬ env.has_key fref inputs) → fref ∉ map node.ref (n::nodes) →
    fref ≠ n^.ref :=
begin
intros n nodes inputs fref H_fref_fresh₁ H_fref_fresh₂,
intro H_contra,
subst H_contra,
exact (ne_of_not_mem_cons H_fref_fresh₂) rfl
end

lemma to_dist_congr_insert :
  Π {costs : list ID} {nodes : list node} {inputs : env} {fref : reference} {fval : T fref.2},
    all_parents_in_env inputs nodes →
    (¬ env.has_key fref inputs) → fref ∉ map node.ref nodes →
    fref.1 ∉ costs →
E (graph.to_dist (λ env₀, ⟦sum_costs env₀ costs⟧) (env.insert fref fval inputs) nodes) dvec.head
=
E (graph.to_dist (λ env₀, ⟦sum_costs env₀ costs⟧) inputs nodes) dvec.head

| costs [] inputs fref fval H_ps_in_env H_fresh₁ H_fresh₂ H_not_cost :=
begin
dunfold graph.to_dist, simp [E.E_ret],
dunfold dvec.head sum_costs map,
induction costs with cost costs IH_cost,
-- case 1
reflexivity,
-- case 2
dunfold map sumr,

assertv H_neq : (cost, []) ≠ fref :=
begin
intro H_contra,
cases fref with fid fshape,
injection H_contra with H_cost H_ignore,
dsimp at H_not_cost,
rw H_cost at H_not_cost,
exact (ne_of_not_mem_cons H_not_cost rfl)
end,

assertv H_notin : fref.1 ∉ costs := not_mem_of_not_mem_cons H_not_cost,
simp [env.get_insert_diff fval inputs H_neq],
rw IH_cost H_notin
end

| costs (⟨ref, parents, operator.det op⟩::nodes) inputs fref fval H_ps_in_env H_fresh₁ H_fresh₂ H_not_cost :=
begin
dunfold graph.to_dist operator.to_dist,
simp [E.E_bind, E.E_ret],
assertv H_fref_notin_parents : fref ∉ parents := fref_notin_parents H_ps_in_env H_fresh₁,
assertv H_fref_neq_ref : fref ≠ ref := fref_neq_ref H_fresh₁ H_fresh₂,
rw env.get_ks_insert_diff H_fref_notin_parents,
rw env.insert_insert_flip _ _ _ (ne.symm H_fref_neq_ref),
dsimp,
apply (to_dist_congr_insert (H_ps_in_env^.right _) _ _ H_not_cost),
{ intro H_contra, exact H_fresh₁ (env.has_key_insert_diff H_fref_neq_ref H_contra) },
{ exact not_mem_of_not_mem_cons H_fresh₂ }
end

| costs (⟨ref, parents, operator.rand op⟩::nodes) inputs fref fval H_ps_in_env H_fresh₁ H_fresh₂ H_not_cost :=
begin
dunfold graph.to_dist operator.to_dist,
simp [E.E_bind, E.E_ret],
assertv H_fref_notin_parents : fref ∉ parents := fref_notin_parents H_ps_in_env H_fresh₁,
assertv H_fref_neq_ref : fref ≠ ref := fref_neq_ref H_fresh₁ H_fresh₂,
rw env.get_ks_insert_diff H_fref_notin_parents,

apply congr_arg,
apply funext,
intro x,

rw env.insert_insert_flip _ _ _ (ne.symm H_fref_neq_ref),
apply (to_dist_congr_insert (H_ps_in_env^.right _) _ _ H_not_cost),
{ intro H_contra, exact H_fresh₁ (env.has_key_insert_diff H_fref_neq_ref H_contra) },
{ exact not_mem_of_not_mem_cons H_fresh₂ }
end

lemma map_filter_expand_helper {costs : list ID} (ref : reference) (parents : list reference)
                               (op : rand.op parents^.p2 ref.2)
                               (nodes : list node) (inputs : env) (tgt : reference) :
well_formed_at costs (⟨ref, parents, operator.rand op⟩::nodes) inputs tgt →
grads_exist_at (⟨ref, parents, operator.rand op⟩::nodes) inputs tgt →

∀ (y : T ref.2),
map
    (λ (idx : ℕ),
       E
         (graph.to_dist
            (λ (m : env), ⟦sum_costs m costs⟧)
            (env.insert ref y inputs)
            nodes)
         dvec.head ⬝ ∇
         (λ (θ₀ : T (tgt.snd)), T.log (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents inputs) idx) y))
         (env.get tgt inputs))
    (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))) = map
    (λ (x : ℕ),
       E
         (graph.to_dist
            (λ (m : env),
               ⟦(λ (m : env) (idx : ℕ),
                  sum_downstream_costs nodes costs ref m ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m)
                    idx
                    (tgt.snd))
                 m
                 x⟧)
            ((λ (y : T (ref.snd)), env.insert ref y inputs) y)
            nodes)
         dvec.head)
    (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))) :=
assume H_wf H_gs_exist y,
let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in

have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,

have H_get_ks_next_inputs : env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents) end,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

begin

-- Apply map_filter_congr
apply map_filter_congr,
intros idx H_idx_in_riota H_tgt_dnth_parents_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_dnth_parents_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,

-- 7. Replace `m` with `inputs`/`next_inputs` so that we can use the gradient rule for the logpdf
dunfold sum_downstream_costs,

assert H_swap_m_for_inputs :
(graph.to_dist
       (λ (m : env),
          ⟦sum_costs m costs ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m) idx (tgt^.snd)⟧)
       (env.insert ref y inputs)
       nodes)
=
(graph.to_dist
       (λ (m : env),
          ⟦sum_costs m costs ⬝ rand.op.glogpdf op (env.get_ks parents (next_inputs y)) (env.get ref (next_inputs y)) idx (tgt^.snd)⟧)
       (env.insert ref y inputs)
       nodes),
begin
  apply graph.to_dist_congr,
  exact (H_wfs y)^.left^.uids,
  dsimp,
  intros m H_envs_match,
  apply dvec.singleton_congr,
  assert H_parents_match : env.get_ks parents m = env.get_ks parents (next_inputs y),
  begin
    apply env.get_ks_env_eq,
    intros parent H_parent_in_parents,
    apply H_envs_match,
    apply env.has_key_insert,
    exact (H_wf^.ps_in_env^.left parent H_parent_in_parents)
  end,
  assert H_ref_matches : env.get ref m = y,
  begin
    assertv H_env.has_key_ref : env.has_key ref (next_inputs y) := env.has_key_insert_same _ _,
    rw [H_envs_match ref H_env.has_key_ref, env.get_insert_same]
  end,
  simp [H_parents_match, H_ref_matches, env.get_insert_same],
end,

erw H_swap_m_for_inputs,
clear H_swap_m_for_inputs,

-- 8. push E over ⬝ and cancel the first terms
rw E.E_k_scale,
apply congr_arg,

-- 9. Use glogpdf correct
assertv H_glogpdf_pre : op^.pre (env.get_ks parents (next_inputs y)) :=
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), exact (H_gs_exist^.left H_tgt_in_parents) end,

rw (op^.glogpdf_correct H_tshape_at_idx H_glogpdf_pre),

-- 10. Clean-up
dunfold E dvec.head,
dsimp,
simp [H_get_ks_next_inputs, env.get_insert_same],
rw (env.dvec_get_get_ks inputs H_tgt_at_idx)
end

lemma sum_costs_differentiable : Π (costs : list ID) (tgt : reference) (inputs : env),
  T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (cost : ID), env.get (cost, @nil ℕ) (env.insert tgt θ₀ inputs)) costs))
                      (env.get tgt inputs) :=
begin
intros costs tgt inputs,
induction costs with cost costs IHcosts,
{ dunfold sumr map, apply T.is_cdifferentiable_const },
{
dunfold sumr map, apply iff.mp (T.is_cdifferentiable_add_fs _ _ _),
split,
tactic.swap,
exact IHcosts,
assertv H_em : tgt = (cost, []) ∨ tgt ≠ (cost, []) := decidable.em _, cases H_em with H_eq H_neq,
-- case 1: tgt = (cost, [])
{ rw H_eq, simp only [env.get_insert_same], apply T.is_cdifferentiable_id },
-- case 2: tgt ≠ (cost, [])
{ simp only [λ (x : T tgt.2), env.get_insert_diff x inputs (ne.symm H_neq), H_neq], apply T.is_cdifferentiable_const }
}
end

lemma pd_is_cdifferentiable (costs : list ID) : Π (tgt : reference) (inputs : env) (nodes : list node),
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  pdfs_exist_at nodes inputs →
  can_differentiate_under_integrals costs nodes inputs tgt →

  T.is_cdifferentiable (λ (θ₀ : T tgt.2), E (graph.to_dist (λ m, ⟦sum_costs m costs⟧) (env.insert tgt θ₀ inputs) nodes) dvec.head) (env.get tgt inputs)
| tgt inputs [] := assume H_wf H_gs_exist H_pdfs_exist H_diff_under_int, sum_costs_differentiable costs tgt inputs

| tgt inputs (⟨ref, parents, operator.det op⟩ :: nodes) :=
assume H_wf H_gs_exist H_pdfs_exist H_diff_under_int,

let θ := env.get tgt inputs in
let x := op^.f (env.get_ks parents inputs) in
let next_inputs := env.insert ref x inputs in

-- 0. Collect useful helpers
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,

have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,

have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,

have H_can_insert : env.get tgt next_inputs = env.get tgt inputs,
  begin dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs ref, from wf_at_next H_wf,
have H_gs_exist_tgt : grads_exist_at nodes next_inputs tgt, from H_gs_exist^.left,
have H_pdfs_exist_next : pdfs_exist_at nodes next_inputs, from H_pdfs_exist,

begin
note H_pdiff_tgt := pd_is_cdifferentiable tgt next_inputs nodes H_wfs^.left H_gs_exist_tgt H_pdfs_exist_next H_diff_under_int^.left,

dsimp [graph.to_dist, operator.to_dist],
simp only [E.E_ret, E.E_bind, dvec.head],
apply T.is_cdifferentiable_binary (λ θ₁ θ₂, E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                                            (env.insert ref (det.op.f op (env.get_ks parents (env.insert tgt θ₂ inputs))) (env.insert tgt θ₁ inputs))
                                                            nodes)
                                             dvec.head),
{ -- case 1, simple recursive case
dsimp,
simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip x θ inputs (ne.symm H_tgt_neq_ref)],
simp only [env.insert_get_same H_wf^.m_contains_tgt],
simp only [H_can_insert] at H_pdiff_tgt,
exact H_pdiff_tgt
}, -- end case 1, simple recursive case

-- start case 2
dsimp,
simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip x θ inputs (ne.symm H_tgt_neq_ref)],

apply T.is_cdifferentiable_multiple_args _ _ _ op^.f _ (λ (x' : T ref.snd),
       E
         (graph.to_dist
            (λ (m : env), ⟦sum_costs m costs⟧)
            (env.insert tgt (env.get tgt inputs) (env.insert ref x' inputs))
            nodes)
         dvec.head),

intros idx H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,

dsimp,

assertv H_gs_exist_ref : grads_exist_at nodes next_inputs ref := (H_gs_exist^.right H_tgt_in_parents)^.right,
assertv H_diff_under_int_ref : can_differentiate_under_integrals costs nodes next_inputs ref := H_diff_under_int^.right H_tgt_in_parents,

note H_pdiff_ref := pd_is_cdifferentiable ref next_inputs nodes H_wfs^.right H_gs_exist_ref H_pdfs_exist_next H_diff_under_int_ref,
simp only [env.insert_get_same H_wf^.m_contains_tgt],

note H_odiff := op^.is_odiff (env.get_ks parents inputs) (H_gs_exist^.right H_tgt_in_parents)^.left idx tgt.2 H_tshape_at_idx
                   (λ x', E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                           (env.insert tgt (env.get tgt inputs) (env.insert ref x' inputs))
                                            nodes)
                             dvec.head),

simp only [λ m, env.dvec_get_get_ks m H_tgt_at_idx] at H_odiff,
apply H_odiff,

dsimp at H_pdiff_ref,
simp only [env.get_insert_same] at H_pdiff_ref,

simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip θ x inputs H_tgt_neq_ref, env.insert_get_same H_wf^.m_contains_tgt],
simp only [env.insert_insert_same] at H_pdiff_ref,
exact H_pdiff_ref
end

| tgt inputs (⟨ref, parents, operator.rand op⟩ :: nodes) :=
assume H_wf H_gs_exist H_pdfs_exist H_diff_under_int,

let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in

-- 0. Collect useful helpers
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,
have H_insert_θ : env.insert tgt θ inputs = inputs, by rw env.insert_get_same H_wf^.m_contains_tgt,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_op_pre : op^.pre (env.get_ks parents inputs), from H_pdfs_exist^.left,

let g : T ref.2 → T tgt.2 → ℝ :=
  (λ (x : T ref.2) (θ₀ : T tgt.2),
      E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                       (env.insert ref x (env.insert tgt θ₀ inputs))
                       nodes)
        dvec.head) in

have H_g_uint : T.is_uniformly_integrable_around
    (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)),
       rand.op.pdf op (env.get_ks parents (env.insert tgt θ₀ inputs)) x ⬝ E
         (graph.to_dist
            (λ (m : env), ⟦sum_costs m costs⟧)
            (env.insert ref x (env.insert tgt θ₀ inputs))
            nodes)
         dvec.head)
    (env.get tgt inputs), from H_diff_under_int^.left^.left,

have H_g_grad_uint : T.is_uniformly_integrable_around
    (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)),
       ∇
         (λ (θ₁ : T (tgt.snd)),
            (λ (x : T (ref.snd)) (θ₀ : T (tgt.snd)),
               rand.op.pdf op (env.get_ks parents (env.insert tgt θ₀ inputs)) x ⬝ E
                 (graph.to_dist
                    (λ (m : env), ⟦sum_costs m costs⟧)
                    (env.insert ref x (env.insert tgt θ₀ inputs))
                    nodes)
                 dvec.head)
              x
              θ₁)
         θ₀)
    (env.get tgt inputs), from H_diff_under_int^.left^.right^.left^.left,

begin
dunfold graph.to_dist operator.to_dist,
simp only [E.E_bind],

note H_pdiff_tgt := λ y, pd_is_cdifferentiable tgt (next_inputs y) nodes (H_wfs y)^.left (H_gs_exist^.right y) (H_pdfs_exist^.right y) (H_diff_under_int^.right y),
dunfold E T.dintegral dvec.head,
apply T.is_cdifferentiable_integral _ _ _ H_g_uint H_g_grad_uint,

intro y,

apply T.is_cdifferentiable_binary (λ θ₁ θ₂, rand.op.pdf op (env.get_ks parents (env.insert tgt θ₁ inputs)) y
                                           ⬝ E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧) (env.insert ref y (env.insert tgt θ₂ inputs)) nodes) dvec.head),
begin -- start PDF differentiable
dsimp,
apply iff.mp (T.is_cdifferentiable_fscale _ _ _),
apply T.is_cdifferentiable_multiple_args _ _ _ (λ θ, op^.pdf θ y) _ (λ y : ℝ, y),
intros idx H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,
dsimp,

note H_pdf_cdiff := @rand.op.pdf_cdiff _ _ op (env.get_ks parents inputs) y idx tgt.2 H_tshape_at_idx H_pdfs_exist^.left,
dsimp [rand.pdf_cdiff] at H_pdf_cdiff,
simp only [env.insert_get_same H_wf^.m_contains_tgt],
simp only [λ m, env.dvec_get_get_ks m H_tgt_at_idx] at H_pdf_cdiff,
exact H_pdf_cdiff,
end, -- end PDF differentiable

begin -- start E differentiable
dsimp,
dsimp at H_pdiff_tgt,
apply iff.mp (T.is_cdifferentiable_scale_f _ _ _),
simp only [λ x y z, env.insert_insert_flip x y z H_tgt_neq_ref] at H_pdiff_tgt,
simp only [λ x y, env.get_insert_diff x y H_tgt_neq_ref] at H_pdiff_tgt,
apply H_pdiff_tgt
end -- end E differentiable

end

lemma is_gdifferentiable_of_pre {costs : list ID} : Π (tgt : reference) (inputs : env) (nodes : list node),
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  pdfs_exist_at nodes inputs →
  can_differentiate_under_integrals costs nodes inputs tgt →
  is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head
| tgt inputs [] := λ H_wf H_gs_exist H_pdfs_exist H_diff_under_int, trivial

| tgt inputs (⟨ref, parents, operator.det op⟩ :: nodes) :=
assume H_wf H_gs_exist H_pdfs_exist H_diff_under_int,

let θ := env.get tgt inputs in
let x := op^.f (env.get_ks parents inputs) in
let next_inputs := env.insert ref x inputs in

have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,

have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,

have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,

have H_can_insert : env.get tgt next_inputs = env.get tgt inputs,
  begin dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs ref, from wf_at_next H_wf,

have H_gs_exist_tgt : grads_exist_at nodes next_inputs tgt, from H_gs_exist^.left,
have H_pdfs_exist_next : pdfs_exist_at nodes next_inputs, from H_pdfs_exist,

have H_gdiff_tgt : is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt next_inputs nodes dvec.head, from
  is_gdifferentiable_of_pre tgt next_inputs nodes H_wfs^.left H_gs_exist_tgt H_pdfs_exist_next H_diff_under_int^.left,

begin
dsimp [grads_exist_at] at H_gs_exist,
dsimp [pdfs_exist_at] at H_pdfs_exist,
dsimp [is_gdifferentiable] at H_gdiff_tgt,
dsimp [is_gdifferentiable],
-- TODO(dhs): replace once `apply` tactic can handle nesting
split, tactic.rotate 1, split, tactic.rotate 1, split, tactic.rotate 2,

----------------------------------- start 1/4
begin
simp only [env.insert_get_same H_wf^.m_contains_tgt, env.get_insert_same],
note H_pdiff := pd_is_cdifferentiable costs tgt next_inputs nodes H_wfs^.left H_gs_exist_tgt H_pdfs_exist_next H_diff_under_int^.left,
dsimp at H_pdiff,
simp only [H_can_insert] at H_pdiff,
simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip θ x inputs H_tgt_neq_ref] at H_pdiff,
exact H_pdiff,
end,
----------------------------------- end 1/4

----------------------------------- start 2/4
begin
apply T.is_cdifferentiable_sumr,
intros idx H_idx_in_filter,
cases of_in_filter _ _ _ H_idx_in_filter with H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,
assertv H_gs_exist_ref : grads_exist_at nodes next_inputs ref := (H_gs_exist^.right H_tgt_in_parents)^.right,

note H_pdiff := pd_is_cdifferentiable costs ref next_inputs nodes H_wfs^.right H_gs_exist_ref H_pdfs_exist_next (H_diff_under_int^.right H_tgt_in_parents),
dsimp at H_pdiff,
simp only [env.insert_get_same H_wf^.m_contains_tgt],
simp only [env.get_insert_same, env.insert_insert_same] at H_pdiff,

note H_odiff := op^.is_odiff (env.get_ks parents inputs) (H_gs_exist^.right H_tgt_in_parents)^.left idx tgt.2 H_tshape_at_idx
                   (λ x', E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                           (env.insert tgt (env.get tgt inputs) (env.insert ref x' inputs))
                                            nodes)
                             dvec.head),

simp only [λ m, env.dvec_get_get_ks m H_tgt_at_idx] at H_odiff,
simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip θ x inputs H_tgt_neq_ref, env.insert_get_same H_wf^.m_contains_tgt] at H_odiff,
apply H_odiff,
exact H_pdiff
end,
----------------------------------- end 2/4

----------------------------------- start 3/4
begin
exact H_gdiff_tgt
end,
----------------------------------- end 3/4

----------------------------------- start 4/4
begin
intros idx H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,
assertv H_gs_exist_ref : grads_exist_at nodes next_inputs ref := (H_gs_exist^.right H_tgt_in_parents)^.right,
apply is_gdifferentiable_of_pre ref next_inputs nodes H_wfs^.right H_gs_exist_ref H_pdfs_exist_next (H_diff_under_int^.right H_tgt_in_parents),
end,
----------------------------------- end 4/4

end

| tgt inputs (⟨ref, parents, operator.rand op⟩ :: nodes) :=
assume H_wf H_gs_exist H_pdfs_exist H_diff_under_int,
let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in

-- 0. Collect useful helpers

have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,
have H_insert_θ : env.insert tgt θ inputs = inputs, by rw env.insert_get_same H_wf^.m_contains_tgt,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_op_pre : op^.pre (env.get_ks parents inputs), from H_pdfs_exist^.left,

begin
dsimp [is_gdifferentiable],
-- TODO(dhs): use apply and.intro _ (and.intro _ _) once tactic is fixed
split, tactic.rotate 1, split, tactic.rotate 2,

----------------------------------- start 1/3
begin
dunfold E T.dintegral,

note H_g_uint := can_diff_under_ints_alt1 H_diff_under_int,
note H_g_grad_uint := H_diff_under_int^.left^.right^.left^.right,
apply T.is_cdifferentiable_integral _ _ _ H_g_uint H_g_grad_uint,

intro y,
apply iff.mp (T.is_cdifferentiable_scale_f _ _ _),

note H_pdiff := pd_is_cdifferentiable costs tgt (next_inputs y) nodes (H_wfs y)^.left (H_gs_exist^.right y) (H_pdfs_exist^.right y) (H_diff_under_int^.right y),
dsimp [dvec.head], dsimp at H_pdiff,
simp only [H_can_insert_y] at H_pdiff,
simp only [λ (x : T ref.2) (θ : T tgt.2), env.insert_insert_flip θ x inputs H_tgt_neq_ref, env.insert_get_same H_wf^.m_contains_tgt] at H_pdiff,
exact H_pdiff
end,
----------------------------------- end 1/3

----------------------------------- start 2/3
begin
apply T.is_cdifferentiable_sumr,
intros idx H_idx_in_filter,
cases of_in_filter _ _ _ H_idx_in_filter with H_idx_in_riota H_tgt_eq_dnth_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,

note H_g_uint_idx := H_diff_under_int^.left^.right^.right^.left _ H_tgt_at_idx,
note H_g_grad_uint_idx := H_diff_under_int^.left^.right^.right^.right _ H_tgt_at_idx,

dunfold E T.dintegral,
apply T.is_cdifferentiable_integral _ _ _ H_g_uint_idx H_g_grad_uint_idx,
tactic.rotate 2,
dsimp [dvec.head],

intro y,
apply iff.mp (T.is_cdifferentiable_fscale _ _ _),

note H_pdf_cdiff := @rand.op.pdf_cdiff _ _ op (env.get_ks parents inputs) y idx tgt.2 H_tshape_at_idx H_pdfs_exist^.left,
dsimp [rand.pdf_cdiff] at H_pdf_cdiff,
simp only [env.insert_get_same H_wf^.m_contains_tgt],
simp only [λ m, env.dvec_get_get_ks m H_tgt_at_idx] at H_pdf_cdiff,
exact H_pdf_cdiff,
end,
----------------------------------- end 2/3

----------------------------------- start 3/3
begin
exact λ y, is_gdifferentiable_of_pre _ _ _ (H_wfs y)^.left (H_gs_exist^.right y) (H_pdfs_exist^.right y) (H_diff_under_int^.right y)
end
----------------------------------- end 3/3

end

lemma can_diff_under_ints_of_all_pdfs_std (costs : list ID) : Π (nodes : list node) (m : env) (tgt : reference),
  all_pdfs_std nodes
  → can_diff_under_ints_pdfs_std costs nodes m tgt
  → can_differentiate_under_integrals costs nodes m tgt
| [] m tgt H_std H_cdi := trivial

| (⟨ref, parents, operator.det op⟩ :: nodes) m tgt H_std H_cdi :=
begin
simp [all_pdfs_std_det] at H_std,
dsimp [can_diff_under_ints_pdfs_std] at H_cdi,
dsimp [can_differentiate_under_integrals],
split,
apply can_diff_under_ints_of_all_pdfs_std,
exact H_std,
exact H_cdi^.left,
intro H_in,
apply can_diff_under_ints_of_all_pdfs_std,
exact H_std,
exact H_cdi^.right H_in
end

| (⟨(ref, .(shape)), [], operator.rand (rand.op.mvn_std shape)⟩ :: nodes) m tgt H_std H_cdi :=
begin
dsimp [all_pdfs_std] at H_std,
dsimp [can_diff_under_ints_pdfs_std] at H_cdi,
dsimp [can_differentiate_under_integrals],
split,
split,
exact H_cdi^.left^.left,
split,
exact and.intro H_cdi^.left^.right H_cdi^.left^.right,
split,
intros H H_contra,
exfalso,
exact list.at_idx_over H_contra (nat.not_lt_zero _),
intros H H_contra,
exfalso,
exact list.at_idx_over H_contra (nat.not_lt_zero _),
intro y,
apply can_diff_under_ints_of_all_pdfs_std,
exact H_std,
exact H_cdi^.right y
end

| (⟨(ref, .(shape)), [(parent₁, .(shape)), (parent₂, .(shape))], operator.rand (rand.op.mvn shape)⟩ :: nodes) m tgt H_std H_cdi :=
begin
dsimp [all_pdfs_std] at H_std,
exfalso,
exact H_std
end

end certigrad


import Mt.Reservation
import Mt.Task.Basic

namespace Mt.TaskM

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

/-- Validation primitive for reasoning for composable tasks.

  Validation may assume `assuming` and must ensure the following:
  * The task has to behave conform to the specification at all times
  * The task never panics
  * Finally, `motive` holds after the task completes

  ### Proving `valid`
  The definition is rather cumbersome to work with. You should use
  helper theorems like `valid_pure`, `valid_bind`, `valid_rmr`, ...

  They are designed to be used with the `apply` tactic.

  ### Blocking predicate: `assuming`
  When validating our task, we can assume `assuming state = true`. However,
  in most cases we have `assuming = λ _ => true`, i.e. our hypothesis does
  not provide anything useful.

  There is one important exception: Blocking threads. If a thread
  waits for a certain condition before it continues its task, we can
  safely assume that this condition holds when the task is excuting.

  ### Final goal: `motive`
  A valid thread must drop its reservations in the end. Therefore, the
  final goal on those tasks is `λ _ r => r = IsReservation.empty`.
  However, intermediate tasks (i.e. single operations) do not need to
  share this goal.

  In fact, they usally do not. If one operation
  prepares the next operation, it usually creates some reservation to
  ensure that no other thread undos this preparation. In this example,
  the motive should encode that the preparation has been made.

  `motive` is the only way to pass facts from one iteration to the next.
  See `valid_bind` for more information.
-/
def valid {T : Type} (p : TaskM spec T) (r : spec.Reservation)
  (assuming : spec.State -> Bool)
  (motive : T -> spec.Reservation -> Prop)
  : Prop :=∀ env_r s,
    assuming s →
    spec.validate (env_r + r) s → ∃ r' : spec.Reservation,
    match h : p.iterate s with
    | IterationResult.Done s' t => spec.validate (env_r + r') s' ∧ motive t r'
    | IterationResult.Panic .. => False
    | IterationResult.Running s' block_until cont =>
        spec.validate (env_r + r') s' ∧
        cont.valid r' block_until motive
termination_by valid => p
decreasing_by simp_wf ; exact is_direct_cont.running h

/-- To prove that `pure t` is valid you need to prove that the `motive` holds -/
theorem valid_pure {T : Type} {t : T} {r assuming motive}
  (is_valid : motive t r)
  : valid (spec :=spec) (pure t) r assuming motive :=by
  rw [valid]
  intro env_r s _ initial_valid
  exists r

/-- To prove that `a >>= f` is valid you need to prove that both `a` and `f u`
  for all results `u` are valid.

  In many cases, `a` does something to prepare `f u`. Since only `f u` needs
  to fulfil the final motive, we can choose an arbitrary motive to validate `a`
  as "intermediate goal".

  To validate `f u` with the original `motive`, we can use the fact that the
  intermediate goal `motive_u` has been ensured by `a`. Motives use only results
  and reservations, which cannot be changed by other threads. Therefore, they
  stay valid even if other threads become active between `a` and `f u`.
-/
theorem valid_bind {U V : Type}
  {mu : TaskM spec U}
  {f : U -> TaskM spec V}
  {r assuming motive}
  (motive_u : U -> spec.Reservation -> Prop)
  (mu_valid : mu.valid r assuming motive_u)
  (f_valid : ∀ r' u,
    motive_u u r' →
    (f u).valid r' (λ _ => true) motive)
  : valid (mu >>= f) r assuming motive :=by
  rw [valid]
  intro env_r s assuming_true initial_valid
  rw [iterate_bind]
  rw [valid] at mu_valid
  cases iteration : iterate mu s
  all_goals (
    simp only []
    have mu_valid :=mu_valid env_r s assuming_true initial_valid
    rw [iteration] at mu_valid
    simp only [] at mu_valid
    cases mu_valid ; rename_i r' mu_valid
    exists r'
  )
  . exact ⟨mu_valid.left, f_valid _ _ mu_valid.right⟩
  . constructor
    . exact mu_valid.left
    . have :=is_direct_cont.running iteration
      exact valid_bind motive_u mu_valid.right f_valid
termination_by valid_bind => mu

theorem valid_rmr {T : Type}
  {f : spec.State -> T × spec.State}
  {r assuming motive}
  (f_valid : ∀ env_r s,
    assuming s →
    spec.validate (env_r + r) s → ∃ r' : spec.Reservation,
    match f s with
    | ⟨t, s'⟩ => spec.validate (env_r + r') s' ∧ motive t r'
  )
  : (atomic_read_modify_read f).valid r assuming motive :=by
  rw [valid]
  intro env_r s assuming_true initial_valid
  rw [iterate_rmr]
  exact f_valid env_r s assuming_true initial_valid

theorem valid_rm
  {f : spec.State -> spec.State}
  {r assuming motive}
  (f_valid : ∀ env_r s,
    assuming s →
    spec.validate (env_r + r) s → ∃ r' : spec.Reservation,
    match f s with
    | s' => spec.validate (env_r + r') s' ∧ motive ⟨⟩ r')
  : (atomic_read_modify f).valid r assuming motive :=valid_rmr f_valid

theorem valid_read
  {f : spec.State -> T}
  {r assuming motive}
  (f_valid : ∀ env_r s,
    assuming s →
    spec.validate (env_r + r) s → ∃ r' : spec.Reservation,
    match f s with
    | t => spec.validate (env_r + r') s ∧ motive t r')
  : (atomic_read f).valid r assuming motive :=valid_rmr f_valid

theorem valid_assert
  {cond : spec.State -> Bool}
  {r assuming motive}
  (motive_holds : motive ⟨⟩ r)
  (assertion_succeeds : ∀ env_r s,
    assuming s →
    spec.validate (env_r + r) s →
    cond s)
  : (atomic_assert cond).valid r assuming motive :=by
  rw [valid]
  intro env_r s assuming_true initial_valid
  rw [iterate_assert]
  have cond_true :=assertion_succeeds env_r s assuming_true initial_valid
  rw [cond_true]
  exists r

theorem valid_blocking_rmr
  {block_until : spec.State -> Bool}
  {f : spec.State -> T × spec.State}
  {r assuming motive}
  (f_valid : ∀ env_r s,
    block_until s →
    spec.validate (env_r + r) s → ∃ r' : spec.Reservation,
    match f s with
    | ⟨t, s'⟩ => spec.validate (env_r + r') s' ∧ motive t r'
  )
  : (atomic_blocking_rmr block_until f).valid r assuming motive :=by
  rw [valid]
  intro env_r s _ initial_valid
  simp only [iterate_blocking_rmr, initial_valid, true_and]

  exists r
  exact ⟨initial_valid, valid_rmr f_valid⟩

end Mt.TaskM