/-
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


/-
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


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

Computational realization of topological spaces (experimental).
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.bases
import Mathlib.data.analysis.filter
import Mathlib.PostPort

universes u_1 u_2 l u_3 u_4 u_5 u_6

namespace Mathlib

/-- A `ctop α σ` is a realization of a topology (basis) on `α`,
  represented by a type `σ` together with operations for the top element and
  the intersection operation. -/
structure ctop (α : Type u_1) (σ : Type u_2)
where
  f : σ → set α
  top : α → σ
  top_mem : ∀ (x : α), x ∈ f (top x)
  inter : (a b : σ) → (x : α) → x ∈ f a ∩ f b → σ
  inter_mem : ∀ (a b : σ) (x : α) (h : x ∈ f a ∩ f b), x ∈ f (inter a b x h)
  inter_sub : ∀ (a b : σ) (x : α) (h : x ∈ f a ∩ f b), f (inter a b x h) ⊆ f a ∩ f b

namespace ctop

protected instance has_coe_to_fun {α : Type u_1} {σ : Type u_3} : has_coe_to_fun (ctop α σ) :=
  has_coe_to_fun.mk (fun (x : ctop α σ) => σ → set α) f

@[simp] theorem coe_mk {α : Type u_1} {σ : Type u_3} (f : σ → set α) (T : α → σ) (h₁ : ∀ (x : α), x ∈ f (T x)) (I : (a b : σ) → (x : α) → x ∈ f a ∩ f b → σ) (h₂ : ∀ (a b : σ) (x : α) (h : x ∈ f a ∩ f b), x ∈ f (I a b x h)) (h₃ : ∀ (a b : σ) (x : α) (h : x ∈ f a ∩ f b), f (I a b x h) ⊆ f a ∩ f b) (a : σ) : coe_fn (mk f T h₁ I h₂ h₃) a = f a :=
  rfl

/-- Map a ctop to an equivalent representation type. -/
def of_equiv {α : Type u_1} {σ : Type u_3} {τ : Type u_4} (E : σ ≃ τ) : ctop α σ → ctop α τ :=
  sorry

@[simp] theorem of_equiv_val {α : Type u_1} {σ : Type u_3} {τ : Type u_4} (E : σ ≃ τ) (F : ctop α σ) (a : τ) : coe_fn (of_equiv E F) a = coe_fn F (coe_fn (equiv.symm E) a) := sorry

/-- Every `ctop` is a topological space. -/
def to_topsp {α : Type u_1} {σ : Type u_3} (F : ctop α σ) : topological_space α :=
  topological_space.generate_from (set.range (f F))

theorem to_topsp_is_topological_basis {α : Type u_1} {σ : Type u_3} (F : ctop α σ) : topological_space.is_topological_basis (set.range (f F)) := sorry

@[simp] theorem mem_nhds_to_topsp {α : Type u_1} {σ : Type u_3} (F : ctop α σ) {s : set α} {a : α} : s ∈ nhds a ↔ ∃ (b : σ), a ∈ coe_fn F b ∧ coe_fn F b ⊆ s := sorry

end ctop

/-- A `ctop` realizer for the topological space `T` is a `ctop`
  which generates `T`. -/
structure ctop.realizer (α : Type u_5) [T : topological_space α]
where
  σ : Type u_6
  F : ctop α σ
  eq : ctop.to_topsp F = T

protected def ctop.to_realizer {α : Type u_1} {σ : Type u_3} (F : ctop α σ) : ctop.realizer α :=
  ctop.realizer.mk σ F sorry

namespace ctop.realizer

protected theorem is_basis {α : Type u_1} [T : topological_space α] (F : realizer α) : topological_space.is_topological_basis (set.range (f (F F))) :=
  eq.mp (Eq._oldrec (Eq.refl (topological_space.is_topological_basis (set.range (f (F F))))) (eq F))
    (to_topsp_is_topological_basis (F F))

protected theorem mem_nhds {α : Type u_1} [T : topological_space α] (F : realizer α) {s : set α} {a : α} : s ∈ nhds a ↔ ∃ (b : σ F), a ∈ coe_fn (F F) b ∧ coe_fn (F F) b ⊆ s :=
  eq.mp (Eq._oldrec (Eq.refl (s ∈ nhds a ↔ ∃ (b : σ F), a ∈ coe_fn (F F) b ∧ coe_fn (F F) b ⊆ s)) (eq F))
    (mem_nhds_to_topsp (F F))

theorem is_open_iff {α : Type u_1} [topological_space α] (F : realizer α) {s : set α} : is_open s ↔ ∀ (a : α), a ∈ s → ∃ (b : σ F), a ∈ coe_fn (F F) b ∧ coe_fn (F F) b ⊆ s :=
  iff.trans is_open_iff_mem_nhds (ball_congr fun (a : α) (h : a ∈ s) => realizer.mem_nhds F)

theorem is_closed_iff {α : Type u_1} [topological_space α] (F : realizer α) {s : set α} : is_closed s ↔ ∀ (a : α), (∀ (b : σ F), a ∈ coe_fn (F F) b → ∃ (z : α), z ∈ coe_fn (F F) b ∩ s) → a ∈ s := sorry

theorem mem_interior_iff {α : Type u_1} [topological_space α] (F : realizer α) {s : set α} {a : α} : a ∈ interior s ↔ ∃ (b : σ F), a ∈ coe_fn (F F) b ∧ coe_fn (F F) b ⊆ s :=
  iff.trans mem_interior_iff_mem_nhds (realizer.mem_nhds F)

protected theorem is_open {α : Type u_1} [topological_space α] (F : realizer α) (s : σ F) : is_open (coe_fn (F F) s) := sorry

theorem ext' {α : Type u_1} [T : topological_space α] {σ : Type u_2} {F : ctop α σ} (H : ∀ (a : α) (s : set α), s ∈ nhds a ↔ ∃ (b : σ), a ∈ coe_fn F b ∧ coe_fn F b ⊆ s) : to_topsp F = T := sorry

theorem ext {α : Type u_1} [T : topological_space α] {σ : Type u_2} {F : ctop α σ} (H₁ : ∀ (a : σ), is_open (coe_fn F a)) (H₂ : ∀ (a : α) (s : set α), s ∈ nhds a → ∃ (b : σ), a ∈ coe_fn F b ∧ coe_fn F b ⊆ s) : to_topsp F = T := sorry

protected def id {α : Type u_1} [topological_space α] : realizer α :=
  mk (Subtype fun (x : set α) => is_open x)
    (mk subtype.val (fun (_x : α) => { val := set.univ, property := is_open_univ }) set.mem_univ
      (fun (_x : Subtype fun (x : set α) => is_open x) => sorry) sorry sorry)
    sorry

def of_equiv {α : Type u_1} {τ : Type u_4} [topological_space α] (F : realizer α) (E : σ F ≃ τ) : realizer α :=
  mk τ (of_equiv E (F F)) sorry

@[simp] theorem of_equiv_σ {α : Type u_1} {τ : Type u_4} [topological_space α] (F : realizer α) (E : σ F ≃ τ) : σ (of_equiv F E) = τ :=
  rfl

@[simp] theorem of_equiv_F {α : Type u_1} {τ : Type u_4} [topological_space α] (F : realizer α) (E : σ F ≃ τ) (s : τ) : coe_fn (F (of_equiv F E)) s = coe_fn (F F) (coe_fn (equiv.symm E) s) := sorry

protected def nhds {α : Type u_1} [topological_space α] (F : realizer α) (a : α) : filter.realizer (nhds a) :=
  filter.realizer.mk (Subtype fun (s : σ F) => a ∈ coe_fn (F F) s)
    (cfilter.mk (fun (s : Subtype fun (s : σ F) => a ∈ coe_fn (F F) s) => coe_fn (F F) (subtype.val s))
      { val := top (F F) a, property := sorry } (fun (_x : Subtype fun (s : σ F) => a ∈ coe_fn (F F) s) => sorry) sorry
      sorry)
    sorry

@[simp] theorem nhds_σ {α : Type u_1} {β : Type u_2} [topological_space α] (m : α → β) (F : realizer α) (a : α) : filter.realizer.σ (realizer.nhds F a) = Subtype fun (s : σ F) => a ∈ coe_fn (F F) s :=
  rfl

@[simp] theorem nhds_F {α : Type u_1} {β : Type u_2} [topological_space α] (m : α → β) (F : realizer α) (a : α) (s : filter.realizer.σ (realizer.nhds F a)) : coe_fn (filter.realizer.F (realizer.nhds F a)) s = coe_fn (F F) (subtype.val s) :=
  rfl

theorem tendsto_nhds_iff {α : Type u_1} {β : Type u_2} [topological_space α] {m : β → α} {f : filter β} (F : filter.realizer f) (R : realizer α) {a : α} : filter.tendsto m f (nhds a) ↔
  ∀ (t : σ R),
    a ∈ coe_fn (F R) t →
      ∃ (s : filter.realizer.σ F), ∀ (x : β), x ∈ coe_fn (filter.realizer.F F) s → m x ∈ coe_fn (F R) t :=
  iff.trans (filter.realizer.tendsto_iff m F (realizer.nhds R a)) subtype.forall

end ctop.realizer

structure locally_finite.realizer {α : Type u_1} {β : Type u_2} [topological_space α] (F : ctop.realizer α) (f : β → set α)
where
  bas : (a : α) → Subtype fun (s : ctop.realizer.σ F) => a ∈ coe_fn (ctop.realizer.F F) s
  sets : (x : α) → fintype ↥(set_of fun (i : β) => set.nonempty (f i ∩ coe_fn (ctop.realizer.F F) ↑(bas x)))

theorem locally_finite.realizer.to_locally_finite {α : Type u_1} {β : Type u_2} [topological_space α] {F : ctop.realizer α} {f : β → set α} (R : locally_finite.realizer F f) : locally_finite f := sorry

theorem locally_finite_iff_exists_realizer {α : Type u_1} {β : Type u_2} [topological_space α] (F : ctop.realizer α) {f : β → set α} : locally_finite f ↔ Nonempty (locally_finite.realizer F f) := sorry

def compact.realizer {α : Type u_1} [topological_space α] (R : ctop.realizer α) (s : set α) :=
  {f : filter α} →
    (F : filter.realizer f) →
      (x : filter.realizer.σ F) →
        f ≠ ⊥ → coe_fn (filter.realizer.F F) x ⊆ s → Subtype fun (a : α) => a ∈ s ∧ nhds a ⊓ f ≠ ⊥