import algebra.homology.homological_complex
import topology.category.Profinite.cofiltered_limit

import for_mathlib.Cech.split
import for_mathlib.Profinite.arrow_limit
import for_mathlib.Profinite.clopen_limit
import for_mathlib.simplicial.complex

import locally_constant.Vhat
import prop819.completion
--import prop819.locally_constant

open_locale nnreal

noncomputable theory

open category_theory opposite
open SemiNormedGroup

universes u v

-- We have a surjective morphism of profinite sets.
variables (F : arrow Profinite.{u}) (surj : function.surjective F.hom)
variables (M : SemiNormedGroup.{v})

/-- The cochain complex built out of the cosimplicial object obtained by applying
  `LocallyConstant.obj M` to the augmented Cech nerve of `F`. -/
abbreviation FL : cochain_complex SemiNormedGroup ℕ :=
  (((cosimplicial_object.augmented.whiskering _ _).obj (LocallyConstant.obj M)).obj
  F.augmented_cech_nerve.right_op).to_cocomplex

/-- The cochain complex built out of the cosimplicial object obtained by applying
  `LCC.obj M` to the augmented Cech nerve of `F`. -/
abbreviation FLC : cochain_complex SemiNormedGroup ℕ :=
  (((cosimplicial_object.augmented.whiskering _ _).obj (LCC.obj M)).obj
  F.augmented_cech_nerve.right_op).to_cocomplex

--def Rop : (simplicial_object.augmented Profinite)ᵒᵖ ⥤ cosimplicial_object.augmented Profiniteᵒᵖ :=
--{ obj := λ X, X.unop.right_op,
--  map := λ X Y f,
--  { left := quiver.hom.op (comma_morphism.right f.unop),
--    right := nat_trans.right_op (comma_morphism.left f.unop),
--    w' := by { ext, exact congr_arg (λ η, (nat_trans.app η (op x)).op) f.unop.w.symm, } } }

/-- A functorial version of `FL`. -/
def FL_functor : (arrow Profinite.{u})ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
simplicial_object.augmented_cech_nerve.op ⋙
simplicial_to_cosimplicial_augmented _ ⋙
(cosimplicial_object.augmented.whiskering _ _).obj (LocallyConstant.obj M) ⋙
cosimplicial_object.augmented.cocomplex

/-- The functor sending an augmented cosimplicial object `X` to
  the cochain complex associated to the composition of `X` with `LCC.obj M`. -/
@[simps obj map]
def FLC_functor' : (simplicial_object.augmented Profinite.{u})ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
simplicial_to_cosimplicial_augmented _ ⋙
  (cosimplicial_object.augmented.whiskering _ _).obj (SemiNormedGroup.LCC.obj M) ⋙
  cosimplicial_object.augmented.cocomplex

/-- A functorial version of `FLC`. -/
def FLC_functor : (arrow Profinite.{u})ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
simplicial_object.augmented_cech_nerve.op ⋙ FLC_functor' M

-- Sanity checks
example : FL F M = (FL_functor M).obj (op F) := rfl
example : FLC F M = (FLC_functor M).obj (op F) := rfl

lemma _root_.cosimplicial_object.augmented.cocomplex_map_norm_noninc
  {C₁ C₂ : cosimplicial_object.augmented SemiNormedGroup} (f : C₁ ⟶ C₂)
  (hf1 : f.left.norm_noninc) (hf2 : ∀ n, (f.right.app n).norm_noninc) (i : ℕ) :
  ((cosimplicial_object.augmented.cocomplex.map f).f i).norm_noninc :=
begin
  cases i,
  { exact hf1 },
  { exact hf2 _ },
end

lemma FLC_functor_map_norm_noninc {f g : (arrow Profinite.{u})ᵒᵖ} (α : f ⟶ g) (i : ℕ) :
  (((FLC_functor M).map α).f i).norm_noninc :=
begin
  refine cosimplicial_object.augmented.cocomplex_map_norm_noninc _ _ _ _,
  { exact SemiNormedGroup.LCC_obj_map_norm_noninc _ _ },
  { intro n,
    exact SemiNormedGroup.LCC_obj_map_norm_noninc _ _ },
end

--⊢ cosimplicial_object.δ
--      (functor.right_op F.cech_nerve ⋙ (curry.obj (uncurry.obj LocallyConstant ⋙ Completion)).obj M)
--      k =
--    Completion.map (cosimplicial_object.δ (functor.right_op F.cech_nerve ⋙ LocallyConstant.obj M) k)

lemma FLC_iso_helper {x y : simplex_category} (f : x ⟶ y) :
  (F.cech_nerve.right_op ⋙ LCC.obj M).map f =
  Completion.map ((F.cech_nerve.right_op ⋙ LocallyConstant.obj M).map f) :=
begin
  change Completion.map _ = _,
  congr' 1,
  dsimp [uncurry],
  erw locally_constant.map_hom_id,
  change 𝟙 _ ≫ _ = _,
  rw category.id_comp,
end

/--
This is a strict (i.e. norm-preserving) isomorphism between `FLC F M` and
the cochain complex obtained by mapping `FL F M` along the `Completion` functor.
-/
def FLC_iso : strict_iso ((Completion.map_homological_complex _).obj (FL F M)) (FLC F M) :=
{ iso := homological_complex.hom.iso_of_components
    (λ i, nat.rec_on i (eq_to_iso rfl) (λ _ _, eq_to_iso rfl))
    begin
      rintro (_|i) (_|j) (_|⟨i,w⟩); ext,
      { dsimp only [],
        delta FLC FL,
        dsimp only [
          cosimplicial_object.augmented.whiskering,
          cosimplicial_object.augmented.whiskering_obj,
          cosimplicial_object.augmented.to_cocomplex,
          cosimplicial_object.augmented.to_cocomplex_obj,
          cochain_complex.of,
          functor.map_homological_complex ],
        rw dif_pos rfl,
        rw dif_pos rfl,
        erw [category.id_comp, category.comp_id, category.comp_id, category.comp_id],
        dsimp only [cosimplicial_object.augmented.to_cocomplex_d,
          cosimplicial_object.augmented.drop, comma.snd, cosimplicial_object.whiskering,
          whiskering_right, cosimplicial_object.coboundary, functor.const_comp, LCC],
        simp only [quiver.hom.unop_op, arrow.augmented_cech_nerve_hom_app,
          whisker_right_app, nat_trans.comp_app, curry_obj_obj_map, category.id_comp,
          nat_trans.right_op_app, uncurry_obj_map, nat_trans.id_app,
          simplicial_object.augmented.right_op_hom,
          category_theory.functor.map_id, category_theory.functor.comp_map,
          SemiNormedGroup.LocallyConstant_obj_map, SemiNormedGroup.Completion_map], },
      { dsimp only [],
        delta FLC FL,
        dsimp only [
          cosimplicial_object.augmented.whiskering,
          cosimplicial_object.augmented.whiskering_obj,
          cosimplicial_object.augmented.to_cocomplex,
          cosimplicial_object.augmented.to_cocomplex_obj,
          cochain_complex.of,
          functor.map_homological_complex ],
        rw dif_pos rfl,
        rw dif_pos rfl,
        erw [category.id_comp, category.comp_id, category.comp_id, category.comp_id],
        dsimp only [
          cosimplicial_object.augmented.to_cocomplex_d,
          cosimplicial_object.augmented.drop,
          comma.snd,
          cosimplicial_object.whiskering,
          whiskering_right,
          cosimplicial_object.coboundary,
          LCC ],
        rw [Completion.map_sum],
        congr,
        funext k,
        rw [Completion.map_zsmul],
        congr' 1,
        apply FLC_iso_helper }
    end,
  is_strict := λ i, { strict_hom' := λ a, by { cases i; refl } } }.

open_locale simplicial

-- TODO: Move this to mathlib (also relax the has_limits condition).
/-- the isomorphism between the 0-th term of the Cech nerve and F.left-/
@[simps]
def cech_iso_zero {C : Type*} [category C] (F : arrow C) [limits.has_limits C]
  : F.cech_nerve _[0] ≅ F.left :=
{ hom := limits.wide_pullback.π _ 0,
  inv := limits.wide_pullback.lift F.hom (λ _, 𝟙 _) (by simp),
  hom_inv_id' := begin
    apply limits.wide_pullback.hom_ext,
    { intro i,
      simp only [limits.wide_pullback.lift_π, category.id_comp, category.comp_id, category.assoc],
      congr,
      tidy },
    { simp }
  end }

lemma augmentation_zero {C : Type*} [category C] (F : arrow C) [limits.has_limits C] :
  (cech_iso_zero F).inv ≫ F.augmented_cech_nerve.hom.app _ = F.hom := by tidy

lemma locally_constant_norm_empty (X : Profinite) [is_empty X]
  (g : (LocallyConstant.obj M).obj (op X)) : ∥g∥ = 0 :=
begin
  rw locally_constant.norm_def,
  dsimp [supr],
  suffices : set.range (λ x : ↥X, ∥ g.to_fun x ∥) = ∅,
  { erw [this, real.Sup_empty], },
  simp only [set.range_eq_empty],
end

lemma Profinite.coe_comp_apply {X Y Z : Profinite} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) := rfl

lemma locally_constant_to_fun_eq {X : Profinite} (f : locally_constant X M) :
  f.to_fun = f := rfl

lemma locally_constant_eq {X : Profinite} (f g : locally_constant X M) :
  f.to_fun = g.to_fun ↔ f = g :=
begin
  split,
  { intro h, ext, change f.to_fun _ = _, rw h, refl, },
  { intro h, rw h }
end

lemma locally_constant_eq_zero {X : Profinite} (f : locally_constant X M) :
  f = 0 ↔ set.range f.to_fun ⊆ {0} :=
begin
  split,
  { intro h, rw h, simp, },
  { intro h, ext x,
    dsimp,
    apply h,
    use x,
    refl }
end

include surj

lemma prop819_degree_zero_helper :
  function.surjective (limits.wide_pullback.base (λ i : (fin 1), F.hom)) :=
begin
  intro x,
  obtain ⟨x,rfl⟩ := surj x,
  dsimp at *,
  refine ⟨(cech_iso_zero F).inv x, _⟩,
  dsimp,
  change (limits.wide_pullback.lift F.hom _ _ ≫ limits.wide_pullback.base _) _ = _,
  simp,
end

lemma prop819_zero_norm_le (g : (LocallyConstant.obj M).obj (op F.right)) : ∥ g ∥ ≤
  ∥(LocallyConstant.obj M).map (limits.wide_pullback.base (λ i : (fin 1), F.hom)).op g∥ :=
begin
  casesI is_empty_or_nonempty F.right,
  { simp only [locally_constant_norm_empty, norm_nonneg] },
  { apply cSup_le,
    { inhabit ↥(F.right),
      dsimp only [unop_op],
      refine ⟨∥g.to_fun _∥, default, rfl⟩, },
    { rintros z ⟨z,rfl⟩,
      obtain ⟨z,rfl⟩ := (prop819_degree_zero_helper _ surj) z,
      change ∥g.to_fun _∥ ≤ _,
      erw ← LocallyConstant_map_apply M _ F.right (limits.wide_pullback.base (λ i, F.hom)) g z,
      apply locally_constant.norm_apply_le } },
end

open_locale zero_object

theorem prop819_degree_zero (f : (FLC F M).X 0) (hf : (FLC F M).d 0 1 f = 0) :
  f = 0 :=
begin
  apply injective_of_strict_iso _ _ (FLC_iso F M) _ _ hf,
  intros f hf,
  have := @controlled_exactness ((FL F M).X 0) (0 : SemiNormedGroup) ((FL F M).X 1) _ _ _ 0 1
    zero_lt_one 1 ((FL F M).d _ _) _ _ 1 zero_lt_one f _,
  { rcases this with ⟨g,h1,h2⟩,
    rw ← h1,
    simp },
  { intros g hg,
    refine ⟨0,_, by simp⟩,
    change (FL F M).d 0 1 g = 0 at hg,
    dsimp,
    symmetry,
    delta FL at hg,
    dsimp only [cosimplicial_object.augmented.whiskering,
      cosimplicial_object.augmented.whiskering_obj,
      cosimplicial_object.augmented.to_cocomplex,
      cochain_complex.of] at hg,
    rw dif_pos at hg,
    swap, {simp},
    dsimp [cosimplicial_object.augmented.to_cocomplex_d] at hg,
    ext x,
    obtain ⟨x,rfl⟩ := (prop819_degree_zero_helper F surj) x,
    apply_fun (λ e, e x) at hg,
    rw locally_constant.coe_comap at hg,
    swap, { continuity },
    exact hg },
  { rintro g ⟨g,rfl⟩,
    refine ⟨g,rfl,_⟩,
    dsimp [cosimplicial_object.augmented.to_cocomplex_d],
    simp only [locally_constant.comap_hom_apply, one_mul,
      if_true, eq_self_iff_true, category.id_comp, category.comp_id],
    apply prop819_zero_norm_le _ surj },
  { exact hf }
end
.

/-- Any discrete quotient `S` of `F.left` yields a cochain complex, as follows.
First, let `T` be the maximal quotient of `F.right` such that `F.hom : F.left ⟶ F.right`
descends to `S → T`. Next construct the augmented Cech nerve of `S → T`, and finally
apply `FL_functor M` to this augmented Cech nerve.
-/
def FLF : (discrete_quotient F.left)ᵒᵖ ⥤ cochain_complex SemiNormedGroup ℕ :=
(Profinite.arrow_diagram F surj).op ⋙ FL_functor M

/--
The diagram of cochain complexes given by `FLF F surj` fits together into a cocone
whose cocone point is defeq to `FL F M`. This is precisely this cocone.
-/
def FLF_cocone : limits.cocone (FLF F surj M) :=
(FL_functor M).map_cocone $ (Profinite.arrow_cone F surj).op

open Profinite

lemma exists_locally_constant_FLF (n : ℕ) (f : (FL F M).X (n+1)) :
  ∃ (S : discrete_quotient F.left) (g : ((FLF F surj M).obj (op S)).X (n+1)),
    ((FLF_cocone F surj M).ι.app (op S)).f _ g = f :=
begin
  have hC := Cech_cone_is_limit F surj n,
  obtain ⟨i,g,hg⟩ := Profinite.exists_locally_constant _ hC f,
  use [i, g],
  exact hg.symm,
end

lemma FLF_cocone_app_coe_eq (n : ℕ) (S : discrete_quotient F.left)
  (g : ((FLF F surj M).obj (op S)).X (n+1)) :
  (((FLF_cocone F surj M).ι.app (op S)).f _ g).to_fun =
    g.to_fun ∘ ((Cech_cone F surj n).π.app _) :=
begin
  ext x,
  change locally_constant.comap _ _ _ = _,
  rw locally_constant.coe_comap,
  swap, { continuity },
  refl,
end

lemma FLF_map_coe_eq (n : ℕ) (S T : discrete_quotient F.left) (hh : T ≤ S)
  (g : ((FLF F surj M).obj (op S)).X (n+1)) :
  (((FLF F surj M).map (hom_of_le hh).op).f _ g).to_fun  =
  g.to_fun ∘ ((Cech_cone_diagram F surj n).map (hom_of_le hh)) :=
begin
  ext x,
  change locally_constant.comap _ _ _ = _,
  rw locally_constant.coe_comap,
  swap, { continuity },
  refl,
end

lemma eq_zero_FLF (n : ℕ) (S : discrete_quotient F.left)
  (g : ((FLF F surj M).obj (op S)).X (n+1))
  (hg : ((FLF_cocone F surj M).ι.app (op S)).f _ g = 0) :
  ∃ (T : discrete_quotient F.left) (hT : T ≤ S),
    ((FLF F surj M).map (hom_of_le hT).op).f _ g = 0 :=
begin
  have := exists_image (Cech_cone_diagram F surj n)
    (Cech_cone F surj n) (Cech_cone_is_limit F surj n) S,
  obtain ⟨T,hT,hh⟩ := this,
  use T, use hT,
  rw [locally_constant_eq_zero, FLF_map_coe_eq],
  rw [locally_constant_eq_zero, FLF_cocone_app_coe_eq]  at hg,
  rintro x ⟨x,rfl⟩,
  apply hg,
  let P : (Cech_cone F surj n).X ⟶ (Cech_cone_diagram F surj n).obj S :=
    (Cech_cone F surj n).π.app _,
  let p : (Cech_cone_diagram F surj n).obj T ⟶ (Cech_cone_diagram F surj n).obj S :=
    (Cech_cone_diagram F surj n).map (hom_of_le hT),
  change ↥((Cech_cone_diagram F surj n).obj T) at x,
  have : p x ∈ set.range p, use x,
  erw ← hh at this,
  obtain ⟨y,hy⟩ := this,
  dsimp only [p] at hy,
  use y,
  dsimp only [function.comp_apply],
  erw hy,
end
.

lemma d_eq_zero_FLF (n : ℕ) (S : discrete_quotient F.left)
  (g : ((FLF F surj M).obj (op S)).X (n+1))
  (hg : (FL F M).d (n+1) (n+2)
    (((FLF_cocone F surj M).ι.app (op S)).f _ g) = 0) :
  ∃ (T : discrete_quotient F.left) (hT : T ≤ S),
  ((FLF F surj M).obj (op T)).d (n+1) (n+2)
    (((FLF F surj M).map $ (hom_of_le hT).op).f _ g) = 0 :=
begin
  have := ((FLF_cocone F surj M).ι.app (op S)).comm (n+1) (n+2),
  apply_fun (λ e, e g) at this,
  erw this at hg,
  dsimp only [SemiNormedGroup.coe_comp] at hg,
  have := eq_zero_FLF F surj M (n+1) S _ hg,
  obtain ⟨T,hT,h⟩ := this,
  use T, use hT,
  have hh := ((FLF F surj M).map (hom_of_le hT).op).comm (n+1) (n+2),
  apply_fun (λ e, e g) at hh,
  erw ← hh at h,
  exact h,
end

lemma norm_eq_FLF (n : ℕ) (S : discrete_quotient F.left)
  (g : ((FLF F surj M).obj (op S)).X (n+1)) :
  ∃ (T : discrete_quotient F.left) (hT : T ≤ S),
    ∥((FLF_cocone F surj M).ι.app (op S)).f _ g∥₊ =
    ∥(((FLF F surj M)).map (hom_of_le hT).op).f _ g∥₊ :=
begin
  have := exists_image (Cech_cone_diagram F surj n)
    (Cech_cone F surj n) (Cech_cone_is_limit F surj n) S,
  obtain ⟨T,hT,hh⟩ := this,
  use T, use hT,
  ext,
  dsimp,
  change Sup _ = Sup _,
  congr' 1,
  ext r,
  split,
  { rintros ⟨x,rfl⟩,
    dsimp only,
    change ↥(Cech_cone F surj n).X at x,
    use (Cech_cone F surj n).π.app T x,
    dsimp only,
    rw [← locally_constant_to_fun_eq, FLF_map_coe_eq,
      function.comp_apply, ← Profinite.coe_comp_apply,
      (Cech_cone F surj n).w, ← locally_constant_to_fun_eq,
      FLF_cocone_app_coe_eq],
    refl },
  { rintros ⟨x,rfl⟩,
    dsimp only,
    change ↥((Cech_cone_diagram F surj n).obj T) at x,
    have : (Cech_cone_diagram F surj n).map (hom_of_le hT) x ∈
      set.range ((Cech_cone_diagram F surj n).map (hom_of_le hT)), use x,
    rw ← hh at this,
    obtain ⟨y,hy⟩ := this,
    change ↥(Cech_cone F surj n).X at y,
    use y,
    dsimp only,
    simp_rw ← locally_constant_to_fun_eq,
    rw [FLF_map_coe_eq, FLF_cocone_app_coe_eq],
    dsimp only [function.comp_apply],
    erw hy }
end

lemma exists_locally_constant (n : ℕ) (f : (FL F M).X (n+1))
  (hf : (FL F M).d _ (n+2) f = 0) :
  -- TODO: ∃ ..., true looks a bit fuuny
  ∃ (S : discrete_quotient F.left)
    (g : ((FLF F surj M).obj (op S)).X (n+1))
    (hgf : ((FLF_cocone F surj M).ι.app (op S)).f _ g = f)
    (hgd : (((FLF F surj M).obj (op S)).d _ (n+2) g = 0))
    (hgnorm : ∥f∥₊ = ∥g∥₊), true :=
begin
  obtain ⟨S,f,rfl⟩ := exists_locally_constant_FLF F surj M n f,
  obtain ⟨T1,hT1,h1⟩ := d_eq_zero_FLF F surj M n S f hf,
  obtain ⟨T2,hT2,h2⟩ := norm_eq_FLF F surj M n S f,
  let T := T1 ⊓ T2,
  have hT : T ≤ S := le_trans inf_le_left hT1,
  have hhT1 : T ≤ T1 := inf_le_left,
  have hhT2 : T ≤ T2 := inf_le_right,
  let g := ((FLF F surj M).map (hom_of_le hT).op).f _ f,
  let g1 := ((FLF F surj M).map (hom_of_le hT1).op).f _ f,
  let g2 := ((FLF F surj M).map (hom_of_le hT2).op).f _ f,
  have hg1 : ((FLF F surj M).map (hom_of_le hhT1).op).f _ g1 = g,
  { dsimp only [g, g1],
    have : (hom_of_le hT).op = (hom_of_le hT1).op ≫ (hom_of_le hhT1).op, refl,
    rw [this, functor.map_comp],
    refl },
  have hg2 : ((FLF F surj M).map (hom_of_le hhT2).op).f _ g2 = g,
  { dsimp only [g, g2],
    have : (hom_of_le hT).op = (hom_of_le hT2).op ≫ (hom_of_le hhT2).op, refl,
    rw [this, functor.map_comp],
    refl },
  refine ⟨T, g, _, _, _, trivial⟩,
  { rw ← (FLF_cocone F surj M).w (hom_of_le hT).op,
    refl },
  { rw ← hg1,
    have := ((FLF F surj M).map (hom_of_le hhT1).op).comm (n+1) (n+2),
    apply_fun (λ e, e g1) at this,
    erw this, clear this,
    dsimp only [g1, SemiNormedGroup.coe_comp, function.comp_app],
    rw [h1, map_zero] },
  { apply le_antisymm,
    { dsimp only [g],
      have := (FLF_cocone F surj M).w (hom_of_le hT).op,
      rw ← this, clear this,
      apply LocallyConstant_obj_map_norm_noninc },
    { rw [← hg2, h2],
      apply LocallyConstant_obj_map_norm_noninc } }
end

lemma FLF_norm_noninc (n : ℕ) (S : discrete_quotient F.left)
  (f : ((FLF F surj M).obj (op S)).X n) :
  ∥((FLF_cocone F surj M).ι.app (op S)).f _ f∥₊ ≤ ∥f∥₊ :=
begin
  cases n,
  apply LocallyConstant_obj_map_norm_noninc,
  apply LocallyConstant_obj_map_norm_noninc,
end

theorem prop819 {m : ℕ} (ε : ℝ≥0) (hε : 0 < ε)
  (f : (FLC F M).X (m+1)) (hf : (FLC F M).d (m+1) (m+2) f = 0) :
  ∃ g : (FLC F M).X m, (FLC F M).d m (m+1) g = f ∧ ∥g∥₊ ≤ (1 + ε) * ∥f∥₊ :=
begin
  apply exact_of_strict_iso _ _ (FLC_iso F M) ε hε _ _ _ hf,
  apply cmpl_exact_of_exact _ _ hε,
  clear hf f m hε ε,
  intros n f hf,
  -- We've reduced to the non-completed case.
  have := exists_locally_constant F surj M _ f hf,
  rcases this with ⟨S,g,rfl,h2,h3,-⟩,
  --let gg := ((FLF_cocone F surj M).ι.app (op S)).f _ g,
  let CC : Π (n : ℕ), ((FLF F surj M).obj (op S)).X (n+1) ⟶
      ((FLF F surj M).obj (op S)).X n :=
      ((Profinite.arrow_diagram F surj).obj S).contracting_homotopy
      (LocallyConstant.obj M),
  let gc := CC _ g,
  let GG := ((FLF_cocone F surj M).ι.app (op S)).f _ gc,
  refine ⟨GG,_,_⟩,
  { dsimp only [GG],
    have := ((FLF_cocone F surj M).ι.app (op S)).comm n (n+1),
    apply_fun (λ e, e gc) at this,
    erw this, clear this,
    change ((FLF_cocone F surj M).ι.app (op S)).f (n + 1) _ = _,
    congr' 1,
    change (CC n ≫ _) g = g,
    cases n,
    { have hh := arrow.is_contracting_homotopy_one (LocallyConstant.obj M)
        ((Profinite.arrow_diagram F surj).obj S),
      apply_fun (λ e, e g) at hh,
      change CC 1 (_) + _ = g at hh,
      conv at hh {
        congr,
        congr,
        erw h2 },
      rw [map_zero, zero_add] at hh,
      exact hh },
    { have hh := arrow.is_contracting_homotopy (LocallyConstant.obj M)
        ((Profinite.arrow_diagram F surj).obj S) _,
      apply_fun (λ e, e g) at hh,
      change CC _ (_) + _ = g at hh,
      conv at hh {
        congr,
        congr,
        erw h2 },
      rw [map_zero, zero_add] at hh,
      exact hh } },
  { rw h3,
    suffices : ∥GG∥₊ ≤ ∥gc∥₊,
    { apply le_trans this _,
      cases n,
      apply LocallyConstant_obj_map_norm_noninc,
      apply LocallyConstant_obj_map_norm_noninc },
    apply FLF_norm_noninc }
end


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

example (n : Nat) : Nat × Nat := by
  show_term
    constructor
    exact n
    exact 37

example : Nat × Nat := by
  show_term constructor
  repeat exact 42


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

universes v u u_1

namespace Mathlib

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

namespace category_theory.limits

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J` instance
has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`

-- because of https://github.com/leanprover-community/lean/issues/429

def has_finite_limits (C : Type u) [category C] :=
  ∀ (J : Type v) [𝒥 : small_category J] [_inst_2 : fin_category J], has_limits_of_shape J C

protected instance has_limits_of_shape_of_has_finite_limits (C : Type u) [category C] (J : Type v)
    [small_category J] [fin_category J] [has_finite_limits C] : has_limits_of_shape J C :=
  _inst_4 J

/-- If `C` has all limits, it has finite limits. -/
theorem has_finite_limits_of_has_limits (C : Type u) [category C] [has_limits C] :
    has_finite_limits C :=
  fun (J : Type v) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) =>
    limits.has_limits_of_shape_of_has_limits

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J` instance
has a colimit.

This is often called 'finitely cocomplete'.
-/
def has_finite_colimits (C : Type u) [category C] :=
  ∀ (J : Type v) [𝒥 : small_category J] [_inst_2 : fin_category J], has_colimits_of_shape J C

protected instance has_colimits_of_shape_of_has_finite_colimits (C : Type u) [category C]
    (J : Type v) [small_category J] [fin_category J] [has_finite_colimits C] :
    has_colimits_of_shape J C :=
  _inst_4 J

/-- If `C` has all colimits, it has finite colimits. -/
theorem has_finite_colimits_of_has_colimits (C : Type u) [category C] [has_colimits C] :
    has_finite_colimits C :=
  fun (J : Type v) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) =>
    limits.has_colimits_of_shape_of_has_colimits

protected instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
  fintype.mk (list.to_finset [walking_parallel_pair.zero, walking_parallel_pair.one]) sorry

protected instance walking_parallel_pair_hom.fintype (j : walking_parallel_pair)
    (j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
  fintype.mk
    (walking_parallel_pair.rec_on j
      (walking_parallel_pair.rec_on j'
        (list.to_finset [walking_parallel_pair_hom.id walking_parallel_pair.zero])
        (list.to_finset [walking_parallel_pair_hom.left, walking_parallel_pair_hom.right]))
      (walking_parallel_pair.rec_on j' ∅
        (list.to_finset [walking_parallel_pair_hom.id walking_parallel_pair.one])))
    sorry

protected instance walking_parallel_pair.category_theory.fin_category :
    fin_category walking_parallel_pair :=
  fin_category.mk

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
namespace wide_pullback_shape

protected instance fintype_obj {J : Type v} [fintype J] : fintype (wide_pullback_shape J) :=
  eq.mpr sorry option.fintype

protected instance fintype_hom {J : Type v} [DecidableEq J] (j : wide_pullback_shape J)
    (j' : wide_pullback_shape J) : fintype (j ⟶ j') :=
  fintype.mk
    (option.cases_on j'
      (option.cases_on j (singleton (hom.id none)) fun (j : J) => singleton (hom.term j))
      fun (j' : J) =>
        dite (some j' = j) (fun (h : some j' = j) => eq.mpr sorry (singleton (hom.id j)))
          fun (h : ¬some j' = j) => ∅)
    sorry

end wide_pullback_shape

namespace wide_pushout_shape

protected instance fintype_obj {J : Type v} [fintype J] : fintype (wide_pushout_shape J) :=
  eq.mpr sorry option.fintype

protected instance fintype_hom {J : Type v} [DecidableEq J] (j : wide_pushout_shape J)
    (j' : wide_pushout_shape J) : fintype (j ⟶ j') :=
  fintype.mk
    (option.cases_on j
      (option.cases_on j' (singleton (hom.id none)) fun (j' : J) => singleton (hom.init j'))
      fun (j : J) =>
        dite (some j = j') (fun (h : some j = j') => eq.mpr sorry (singleton (hom.id j')))
          fun (h : ¬some j = j') => ∅)
    sorry

end wide_pushout_shape

protected instance fin_category_wide_pullback {J : Type v} [DecidableEq J] [fintype J] :
    fin_category (wide_pullback_shape J) :=
  fin_category.mk

protected instance fin_category_wide_pushout {J : Type v} [DecidableEq J] [fintype J] :
    fin_category (wide_pushout_shape J) :=
  fin_category.mk

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`

-- because of https://github.com/leanprover-community/lean/issues/429

def has_finite_wide_pullbacks (C : Type u) [category C] :=
  ∀ (J : Type v) [_inst_2 : DecidableEq J] [_inst_3 : fintype J],
    has_limits_of_shape (wide_pullback_shape J) C

protected instance has_limits_of_shape_wide_pullback_shape (C : Type u) [category C] (J : Type v)
    [fintype J] [has_finite_wide_pullbacks C] : has_limits_of_shape (wide_pullback_shape J) C :=
  _inst_3 J

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
def has_finite_wide_pushouts (C : Type u) [category C] :=
  ∀ (J : Type v) [_inst_2 : DecidableEq J] [_inst_3 : fintype J],
    has_colimits_of_shape (wide_pushout_shape J) C

protected instance has_colimits_of_shape_wide_pushout_shape (C : Type u) [category C] (J : Type v)
    [fintype J] [has_finite_wide_pushouts C] : has_colimits_of_shape (wide_pushout_shape J) C :=
  _inst_3 J

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/
theorem has_finite_wide_pullbacks_of_has_finite_limits (C : Type u) [category C]
    [has_finite_limits C] : has_finite_wide_pullbacks C :=
  fun (J : Type v) (_x : DecidableEq J) (_x_1 : fintype J) =>
    limits.has_limits_of_shape_of_has_finite_limits C (wide_pullback_shape J)

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
theorem has_finite_wide_pushouts_of_has_finite_limits (C : Type u) [category C]
    [has_finite_colimits C] : has_finite_wide_pushouts C :=
  fun (J : Type v) (_x : DecidableEq J) (_x_1 : fintype J) =>
    limits.has_colimits_of_shape_of_has_finite_colimits C (wide_pushout_shape J)

protected instance fintype_walking_pair : fintype walking_pair :=
  fintype.mk (insert walking_pair.left (singleton walking_pair.right)) sorry

end Mathlib


import prime
open set topological_space classical
local attribute [instance] prop_decidable
set_option pp.generalized_field_notation true
noncomputable theory

/-! # Substances and Accidents

  In this module we define the notions of `substance`, `accident`,
  `subsistence`, `inherence`, `cosubstantiality`, `simplicity` and
  the distinction between `intrinsic` and `extrinsic` accidents.

  We also prove several lemmas associated with these concepts.

-/

namespace ontology

variable {ω : ontology}

-- We next define substances as particular kinds of entities.
-- Accidents are also defined here.
section substances

  /-- An entity is said to be `perfect` if and only if the set of all possible worlds
      in which it exists is `dense` -/
  def entity.perfect (e : ω.entity) := e.exists.dense
  /-- Negation of `entity.perfect` -/
  def entity.imperfect (e : ω.entity) := ¬ e.perfect

  /-- The `substances` in the ontology are dense entities,
      every other entity is an `accident`.
      We also call a dense entity a perfect entity.
      **Substances** are entities which do not have contraries,
      and subsist in themselves. -/
  structure substance (ω : ontology) extends entity ω :=
    (perfect : to_entity.perfect)

  /-- An entity which is not a `substance` is an `accident`.
      **Accidents** have contraries and do not subsist of themselves,
      but must always inhere in another, which is a substance.-/
  structure accident (ω : ontology) extends entity ω :=
    (imperfect : to_entity.imperfect)

  @[reducible, simp]
  def substance.up (s : ω.substance) := s.to_entity
  @[reducible, simp]
  def accident.up (a : ω.accident) := a.to_entity

  instance has_coe_substance₁ : has_coe ω.substance ω.entity := ⟨substance.up⟩
  instance has_coe_substance₂ : has_coe ω.substance ω.event := ⟨λ s, s.exists⟩
  instance has_coe_accident₁ : has_coe ω.accident ω.entity := ⟨accident.up⟩
  instance has_coe_accident₂ : has_coe ω.accident ω.event := ⟨λ a, a.exists⟩

  -- entailment tests:
  -- #reduce λ (s₁ : ω.substance) (s₂ : ω.substance), s₁ ⇒ s₂
  -- #reduce λ (s : ω.substance) (e : ω.entity), s ⇒ e
  -- #reduce λ (s : ω.substance) (e : ω.entity), e ⇒ s
  -- #reduce λ (s : ω.substance) (e : ω.event), s ⇒ e
  -- #reduce λ (s : ω.substance) (e : ω.event), e ⇒ s
  -- #reduce λ (a₁ : ω.accident) (a₂ : ω.accident), a₁ ⇒ a₂
  -- #reduce λ (a : ω.accident) (e : ω.entity), a ⇒ e
  -- #reduce λ (a : ω.accident) (e : ω.entity), e ⇒ a
  -- #reduce λ (a : ω.accident) (e : ω.event), a ⇒ e
  -- #reduce λ (a : ω.accident) (e : ω.event), e ⇒ a
  -- #reduce λ (s : ω.substance) (a : ω.accident), s ⇒ a
  -- #reduce λ (s : ω.substance) (a : ω.accident), a ⇒ s

  -- By this definition, it is obvious that any entity
  -- is either a substance or an accident, therefore we can
  -- cast it to one of them.

  /-- The **antepredicament** of an `entity` is its status as either a `substance` or an `accident`.
      it casts the entity to either one of them. -/
  def entity.ante (e : ω.entity) : ω.substance ⊕ ω.accident :=
    if h : e.perfect then sum.inl ⟨e, h⟩ else sum.inr ⟨e, h⟩

  /-- An entitative event is substantive if it is dense. -/
  def event.substantive (e : ω.event) : Prop := e.entitative ∧ e.dense
  /-- An entitative event is accidental if it is not dense. -/
  def event.accidental (e : ω.event) : Prop := e.entitative ∧ ¬e.dense

  /-- The `necessary being` (substance) is the substance which exists in every possible world. -/
  def nb (ω : ontology) : ω.substance := ⟨ω.nbe, by simp [nbe, entity.perfect]⟩
  instance substance_inhabited : inhabited ω.substance := ⟨ω.nb⟩

  /-- A substance is `contingent` if it is not the necessary being (substance). -/
  @[reducible, simp]
  def substance.contingent (s : ω.substance) := s ≠ ω.nb
  /-- A substance is `necessary` if it is the necessary being (substance). -/
  @[reducible, simp]
  def substance.necessary (s : ω.substance) := s = ω.nb

  @[reducible, simp]
  def world.substances (w : ω.world) := {s : ω.substance | s.exists w}
  @[reducible, simp]
  def world.perfects (w : ω.world) := {s : ω.entity | s.exists w ∧ s.perfect}
  @[reducible, simp]
  def world.accidents (w : ω.world) := {a : ω.accident | a.exists w}
  @[reducible, simp]
  def world.imperfects (w : ω.world) := {s : ω.entity | s.exists w ∧ s.imperfect}

end substances

-- We then prove some very important lemmas for substances which
-- motivate their definition.
section substance_lemmas

  /-- The fundamental fact that justifies the definition of substances
      is that they admit no contrary entities, and this is a property
      explicitly mentioned in Aristotle's *Categories*, which suffices for
      their definition. -/
  lemma substance.nocontrary (s : ω.substance) : s.up.nocontrary :=
    begin
        intros h,
        obtain ⟨e, h⟩ := h,
        simp [entity.contrary] at h,
        rwa inter_comm s.exists e.exists at h,
        let α := e.exists ∩ s.exists,
        replace h : α = ∅ := h,
        suffices c : α.nonempty,
            replace c := c.ne_empty,
            contradiction,
        apply dense_iff_inter_open.mp s.perfect,
            exact e.existential,
        exact e.possible,
    end

  lemma substance.compatible (s : ω.substance) (e : ω.entity) : s.up.compatible e := by
    have c := s.nocontrary; push_neg at c; exact event_possible_of_ne_empty (c e)

  /-- main extensionality lemma for substances. -/
  @[ext]
  lemma substance_ext {s₁ s₂ : ω.substance} (h : s₁.exists = s₂.exists) : s₁ = s₂ :=
  by cases_type* substance entity; simp at h; simpa

  lemma perfect_iff_nocontrary : ∀ e : ω.entity, e.nocontrary ↔ e.perfect :=
      begin
        intro e,
        constructor; intro h,
          simp [entity.perfect],
          simp [entity.nocontrary, entity.contrary] at h,
          apply dense_iff_inter_open.2,
          intros U h₁ h₂,
          specialize h ⟨U, h₁, h₂⟩, simp at h,
          rwa inter_comm e.exists U at h,
          exact event_possible_of_ne_empty h,
        exact substance.nocontrary ⟨e, h⟩,
      end

  /-- Any substance existentially depends only on other substances. -/
  lemma perfect_of_substance_entails : ∀{s : ω.substance}{e : ω.entity},
                                          s ⇒ e → e.perfect :=
    begin
        intros s e h,
        have c₀ : closure (s.exists) = univ := s.perfect,
        have c₁ := closure_mono h, unfold_coes at c₁,
        rw c₀ at c₁, clear c₀,
        refine subset.antisymm _ c₁, clear c₁,
        apply subset_univ,
    end

  /-- Arbitrary unions of substances are substances. -/
  def substance_Sup (S : set ω.substance) (h : S.nonempty) : ω.substance :=
    begin
      fconstructor,
          apply entity_Sup (substance.up '' S),
          simp,
          exact h,
      simp [entity.perfect, entity_Sup],
      let sup := ⋃ (s : substance ω) (H : s ∈ S), s.exists,
      suffices : closure sup = univ, exact this,
      obtain ⟨s, hs⟩ := h,
      have c : s.exists ⇒ sup,
          intros w h₂,
          simp, exact ⟨s, hs, h₂⟩,
      replace c := closure_mono c,
      have p : closure s.exists = univ := s.perfect,
      rw p at c,
      exact eq_univ_of_univ_subset c,
    end

  /-- Finite intersections of substances are substances. -/
  def substance.meet (s₁ s₂ : ω.substance) : ω.substance :=
    begin
      fconstructor,
          fconstructor,
              exact s₁.exists ∩ s₂.exists,
          exact is_open_and s₁.existential s₂.existential,
              apply dense_iff_inter_open.mp s₂.perfect s₁.exists,
                  exact s₁.existential,
                  exact s₁.possible,
      simp [entity.perfect],
      apply dense_iff_inter_open.2,
      intros U H ne,
      apply event_possible_of_ne_empty,
      intro h,
      let α := (U ∩ (s₁.up).exists) ∩ (s₂.up).exists,
      replace h : α = ∅,
          simp [α,inter_assoc, h],
      suffices c : α.nonempty,
          replace c := c.ne_empty,
          contradiction,
      apply dense_iff_inter_open.mp s₂.perfect,
          exact is_open_inter H s₁.up.existential,
      exact dense_iff_inter_open.mp s₁.perfect U H ne,
    end

  -- instance ccl_substance : conditionally_complete_lattice ω.substance :=
  -- { sup := _,
  -- --   le := infer_instance,
  --   lt := _,
  --   le_refl := _,
  --   le_trans := _,
  --   lt_iff_le_not_le := _,
  --   le_antisymm := _,
  --   le_sup_left := _,
  --   le_sup_right := _,
  --   sup_le := _,
  --   inf := _,
  --   inf_le_left := _,
  --   inf_le_right := _,
  --   le_inf := _,
  --   Sup := _,
  --   Inf := _,
  --   le_cSup := _,
  --   cSup_le := _,
  --   cInf_le := _,
  --   le_cInf := _ }

  --TODO: This proof requires some lemmas about the specialization order.
  /- Any possible world in which a substance does not exist can be enlarged
      so as to contain the substance. -/
  -- lemma substance.addable (s : ω.substance) : -s.exists ⇒ s.up.addable := sorry

end substance_lemmas

-- We discuss the fundamental notions of subsistence,
-- inherence and consubstantiality,
-- which provide further justification for our definitions.
section subsistence

  /-- An entity `e₁` is said to `subsist` in another entity `e₂`
      if and only if `e₂` can be written as the union of `e₁`
      and its exterior; or alternatively, as the complement of its boundary.
      This entails that `e₂` is perfect. -/
  def entity.subsists (e₁ e₂ : ω.entity) := e₁.exists ∪ ~e₁.exists = e₂.exists

  @[reducible, simp]
  def entity.subsistents (e : ω.entity) := {x : ω.entity | x.subsists e}

  -- Inherence is the same relation defined between accidents and substances:
  /-- **Inherence** is the subsistence of accidents in substances.
      This is the only possible kind of subsistence for distinct entities, so
      this is simply a type cast from `entity.subsists`. -/
  def accident.inheres (a : ω.accident) (s : ω.substance) := a.up.subsists s.up

  @[reducible, simp]
  def substance.accidents (s : ω.substance) := {a : ω.accident | a.inheres s}

  /-- Only substances can support accidents -/
  lemma sub_support :  ∀ {e₁}, (∃ e₂ : ω.entity, e₂.subsists e₁) → e₁.perfect :=
  begin
      intros e₁ h,
      obtain ⟨e₂, h⟩ := h,
      simp [entity.perfect],
      simp [entity.subsists] at h,
      rw ←h,
      simp [closure_union, ext_iff], intro w,
      by_cases w ∈ closure (e₂.exists),
          simp [h],
      right,
      intro h₃,
      replace h₃ := interior_subset h₃,
      contradiction,
  end

  /-- Every accident inheres into a single substance,
      therefore we can construct this substance from the accident.
      This is called the **owner** of the accident. -/
  def accident.owner (a : ω.accident) : ω.substance :=
    let e : ω.entity := ⟨ a.exists ∪ ~a.exists
                        , event_union_exterior_open a.existential
                        , event_union_exterior_possible
                        ⟩
    in ⟨e, sub_support ⟨a.up, rfl⟩⟩

  /-- Any entity can be cast to the underlying `substance` in which it subsists.
      The entity `e` is cast to itself if it is perfect,
      and is cast to its owner if it is imperfect. -/
  def entity.substance (e : ω.entity) : ω.substance :=
    if h : e.perfect then ⟨e, h⟩ else accident.owner ⟨e,h⟩

  /-- Two entities `e₁,e₂` are said to be **cosubstantial** when their underlying substance is the same,
      i.e. when they subsist in the same substance. -/
  def entity.cosubstantial (e₁ e₂ : ω.entity) := ∃ s, e₁.subsists s ∧ e₂.subsists s

  @[ext]
  lemma cosub_ext {e₁ e₂ : ω.entity} (h : e₁.cosubstantial e₂) : e₁.substance = e₂.substance :=
    begin
      obtain ⟨s, h₁, h₂⟩ := h,
      simp [entity.subsists] at *,
      simp [entity.cosubstantial, entity.substance],
      by_cases c₁ : e₁.perfect;
      by_cases c₂ : e₂.perfect;
      simp [c₁, c₂, accident.owner];
      simp [entity.perfect] at *;
      finish [h₁,h₂,c₁,c₂],
    end

  lemma cosub_ext_iff (e₁ e₂ : ω.entity) : e₁.cosubstantial e₂ ↔ e₁.substance = e₂.substance :=
    begin
      constructor; intro h,
        exact cosub_ext h,
      use e₁.substance,
      simp [entity.subsists, entity.substance] at *,
      by_cases c₁ : e₁.perfect;
      by_cases c₂ : e₂.perfect;
      simp [c₁, c₂, accident.owner];
      simp [c₁, c₂, accident.owner] at h;
      simp [entity.perfect] at c₁;
      simp [entity.perfect] at c₂;
      unfold_coes;
      constructor;
      finish [h,c₁,c₂],
    end

  lemma cosub_ext_iff₂ (e₁ e₂ : ω.entity) : e₁.substance = e₂.substance ↔ e₁.cosubstantial e₂ :=
    by symmetry; exact cosub_ext_iff e₁ e₂

  /-- The set of entities cosubstantial to a given entity `e₁`.
      This is also an alias for `entity.cosubstantial`. -/
  @[reducible, simp, alias]
  def entity.cosubs (e₁ : ω.entity) := {e₂ | e₁.cosubstantial e₂}

  /-- Use `e₁ ≈ e₂` instead of `e₁.cosubstantial e₂` -/
  @[reducible, simp]
  instance setoid_entity : setoid ω.entity :=
    setoid.mk entity.cosubstantial
    ⟨ by simp [reflexive, cosub_ext_iff]
    , by finish [symmetric, entity.cosubstantial]
    , by finish [transitive, cosub_ext_iff]
    ⟩

end subsistence

-- We prove important lemmas about subsistence and inherence.
section subsistence_lemmas

  variables {e e₁ e₂ : ω.entity} {a : ω.accident} {s s₁ s₂ : ω.substance}

  @[simp]
  lemma entails_of_subsist : e₁.subsists e₂ → e₁ ⇒ e₂ :=
    begin
      intros h w hw,
      simp [entity.subsists] at h,
      unfold_coes,
      rw ←h,
      simp [hw],
    end

  lemma subsists.antisymm : e₁.subsists e₂ → e₂.subsists e₁ → e₁ = e₂ :=
    begin
      intros h₁ h₂,
      apply entity_ext,
      apply subset.antisymm,
        exact entails_of_subsist h₁,
      exact entails_of_subsist h₂,
    end

  @[simp]
  lemma entails_of_inheres : a.inheres s → a ⇒ s :=
    by simp [accident.inheres]; exact entails_of_subsist

  /-- An entity is a substance if and only if it subsists in itself. -/
  @[simp]
  lemma self_subsist : e.perfect ↔ (e.subsists e) :=
    begin
      constructor; intro h,
        ext, constructor; intro h₂,
          cases h₂,
            exact h₂,
          simp [event.exterior, interior_compl] at h₂,
          simp [entity.perfect, event.dense] at h,
          rw h at h₂,
          simp at h₂,
          contradiction,
      simp [h₂],
      apply sub_support,
      use e,
      exact h,
    end

  @[simp]
  lemma substance.ssubsists (s : ω.substance) : s.up.subsists s.up := self_subsist.mp s.perfect

  @[simp]
  lemma accident.inh_owner (a : ω.accident) : a.inheres a.owner :=
    by simp [accident.inheres, accident.owner, entity.subsists]

  /-- An entity only subsists in a single substance -/
  lemma unique_subsists : e.subsists e₁ → e.subsists e₂ → e₁ = e₂ :=
    by intros h₁ h₂; simp [entity.subsists] at *; rwa h₁ at h₂

  lemma unique_inheres : a.inheres s₁ → a.inheres s₂ → s₁ = s₂ :=
    begin
      intros h₁ h₂,
      obtain ⟨⟨s₁, op₁, ne₁⟩, pe₁⟩ := s₁,
      obtain ⟨⟨s₂, op₂, ne₂⟩, pe₂⟩ := s₂,
      simp [accident.inheres, entity.subsists] at *,
      rwa h₁ at h₂,
    end

  /-- Only accidents subsist in another entity distinct from themselves -/
  lemma imperfect_of_subsists_other : e.subsists e₁ → e ≠ e₁ → e.imperfect :=
    begin
      intros h₁ h₂ h₃,
      simp at h₃,
      have c := unique_subsists h₃ h₁,
      contradiction,
    end

  @[simp]
  lemma cosub_iff_subsists : e ≈ s.up ↔ e.subsists s.up :=
    begin
      simp [has_equiv.equiv],
      constructor; intro h, swap,
        exact ⟨s, h, s.ssubsists⟩,
      obtain ⟨s₂, h₁, h₂⟩ := h,
      have c := unique_subsists h₂ s.ssubsists,
      rwa c at h₁,
    end

  lemma clopen_of_cosub_nbe : e ≈ ω.nbe → e.exists.clopen :=
    begin
      intros h,
      obtain ⟨s, h₁, h₂⟩ := h,
      have c₀ := unique_subsists h₂ ω.nb.ssubsists,
      rw c₀ at h₁,
      simp [entity.subsists, nb, nbe, ext_iff] at h₁,
      refine ⟨e.existential, _⟩,
      apply closure_eq_iff_is_closed.mp,
      ext w, specialize h₁ w,
      constructor; intro h, swap,
        exact subset_closure h,
      cases h₁, exact h₁,
      contradiction,
    end

  lemma cosub_nbe_of_clopen : e.exists.clopen → e ≈ ω.nbe :=
    begin
      intros h,
      replace h := closure_eq_iff_is_closed.2 h.2,
      simp [has_equiv.equiv],
      use ω.nb,
      refine ⟨_, ω.nb.ssubsists⟩,
      simp [entity.subsists, h],
      unfold_coes,
      simp [nb, nbe],
    end

  @[simp]
  lemma clopen_iff_cosub_nbe : ∀ (e : ω.entity), e.exists.clopen ↔ e ≈ ω.nbe :=
    assume e, ⟨cosub_nbe_of_clopen, clopen_of_cosub_nbe⟩

end subsistence_lemmas

-- We delve a little deeper in our definitions concerning accidents.
section accidents

  variables (a : ω.accident) (e : ω.entity) (s : ω.substance)

  /-- An entity is called `simple` if it has no accidents. -/
  @[reducible, simp]
  def entity.simple := ∀ e' : ω.entity, e'.subsists e → e' = e
  /-- Negation of `entity.simple`. -/
  @[reducible, simp]
  def entity.composite := ¬ e.simple
  /-- A substance is called `simple` if it has no accidents. -/
  @[reducible, simp]
  def substance.simple := ¬ s.accidents.nonempty
  /-- Negation of `substance.simple`. -/
  @[reducible, simp]
  def substance.composite := s.accidents.nonempty

  /-- `regular` accidents are called `intrinsic`
      and irregular accidents are called `extrinsic`. -/
  @[reducible]
  def accident.intrinsic := a.exists.regular
  /-- Negation of `accident.intrinsic`. -/
  @[reducible]
  def accident.extrinsic := ¬ a.intrinsic

  /-- An entity is called **Intrinsically Simple** if it has no `intrinsic` accidents. -/
  @[reducible, simp]
  def entity.isimple := ∀ e' : ω.entity, e'.subsists e → e' = e ∨ ¬ e'.exists.regular
  /-- Negation of `entity.isimple`. -/
  @[reducible, simp]
  def entity.icomposite := ¬ e.isimple
  /-- A substance is called **Intrinsically Simple** if it has no `intrinsic` accidents. -/
  @[reducible, simp]
  def substance.isimple := ¬ ∃ a : ω.accident, a.intrinsic ∧ a.inheres s
  /-- Negation of `substance.isimple`. -/
  @[reducible]
  def substance.icomposite := ∃ a : ω.accident, a.intrinsic ∧ a.inheres s

  /-- A substance is called `intrinsic` if in case it is composite it has intrinsic accidents.
      It is otherwise called `extrinsic`.
      Simple substances are all intrinsic. -/
  @[reducible]
  def substance.intrinsic := s.composite → s.icomposite
  /-- Negation of `substance.intrinsic`. -/
  @[reducible]
  def substance.extrinsic := ¬ s.intrinsic

  @[simp]
  def accident.compatible := a.up.compatible e

end accidents

-- And prove lemmas about them
section accident_lemmas

  variable (a : ω.accident)

  /-- All accidents are contingent. -/
  lemma accident.contingent : a.up.contingent :=
    begin
      simp [nbe],
      by_contradiction h,
      have c := a.imperfect,
      simp [entity.imperfect, entity.subsists] at c,
      rw h at c, simp at c,
      contradiction,
    end

  /-- All accidents are simple. -/
  lemma accident.simple : a.up.simple :=
    begin
      simp,
      intros e h,
      have c₁ := sub_support ⟨e, h⟩,
      have c₂ := a.imperfect,
      contradiction,
    end

  /-- Nonempty finite intersections of accidents are accidents. -/
  def accident.compatible.ainter {a₁ a₂ : ω.accident} (h : a₁.compatible a₂.up) : ω.accident :=
    begin
      refine ⟨h.inter, _⟩,
      simp [set_of, entity.imperfect],
      intro h₂,
      set α := h.inter,
      have c₁ : α.exists ⊆ a₁.up.exists,
        simp [α],
        dunfold entity.compatible.inter,
        simp,
      let β : ω.substance := ⟨α, self_subsist.2 h₂⟩,
      have c₂ := @perfect_of_substance_entails _ β a₁.up c₁,
      exact absurd c₂ a₁.imperfect,
    end

  def accident.exterior (a : ω.accident) : ω.accident :=
    begin
      fconstructor,
        fconstructor,
          exact ~a.exists,
        simp,
          have c := a.imperfect,
          simp [entity.imperfect, entity.subsists] at c,
          by_contradiction h,
          simp [event.exterior, set.nonempty] at h,
          replace h := eq_univ_of_forall h,
          rw h at c, simp at c,
          contradiction,
        by_cases c : (~a.exists).dense,
          replace c := compl_inj_iff.2 c,
          simp [ext_iff] at c,
          obtain ⟨w, hw⟩ := a.possible,
          specialize c w,
          simp [interior] at c,
          specialize c a.exists a.existential subset_closure,
          contradiction,
        dunfold entity.imperfect entity.perfect,
        simp at c,
        simpa,
    end

  /-- Use `~e` for "the exterior of `e`" -/
  instance has_tilde_accident : has_tilde ω.accident := ⟨accident.exterior⟩

  @[simp]
  lemma accident.lem : (a.up ⊔ (~a).up) = a.owner :=
    begin
      unfold_coes,
      simp [entity_sup, accident.owner, has_sup.sup, entity_sup],
      congr,
      simp [has_tilde.tilde, accident.exterior],
    end

  lemma compl_iff_inheres_nb {a : ω.accident} : a.inheres ω.nb ↔ a.up.complemented :=
    begin
      simp [accident.inheres],
      constructor; intro h,
        refine ⟨a.contingent, _⟩,
        apply clopen_of_cosub_nbe,
        exact cosub_iff_subsists.2 h,
      apply cosub_iff_subsists.mp,
      apply cosub_nbe_of_clopen,
      exact h.2,
    end

  section extrinsic

    variables {a} (h : a.extrinsic)
    include h

    -- TODO: this doesn't really work because there will probably
    -- be examples of ontologies in which some composite substance
    -- is not intrinsically composite. You can still
    -- use this extrinsic section for something though, when you
    -- do, delete this code.
    -- def accident.extrinsic.internalize : ω.accident :=
    --   begin
    --     have h₂ := a.owner.compatible (~a).up,
    --     refine ⟨h₂.inter, _⟩,
    --     by_contradiction c,
    --     simp [entity.imperfect, -self_subsist] at c,
    --     let s : ω.substance := ⟨h₂.inter,c⟩,
    --     suffices h : (~a).up.perfect,
    --       have absurdity := (~a).imperfect,
    --       contradiction,
    --     apply @perfect_of_substance_entails _ s,
    --     intro w, unfold_coes,
    --     intro hw,
    --     simp [s, entity.compatible.inter] at hw,
    --     exact hw.2,
    --   end
    -- def accident.extrinsic.internalize_inheres : h.internalize.inheres a.owner := sorry
    -- def accident.extrinsic.internalize_intrinsic : h.internalize.intrinsic := sorry

  end extrinsic

  section intrinsic

    variables {a} (h : a.intrinsic)
    include h

    lemma accident.intrinsic.exterior : (~a).intrinsic :=
      begin
        simp [has_tilde.tilde, accident.exterior],
        simp [accident.intrinsic] at *,
        rwa ←h,
      end

    lemma accident.intrinsic.exterior_inheres : (~a).inheres a.owner :=
      begin
        simp [has_tilde.tilde, accident.exterior],
        simp [accident.inheres, accident.owner, entity.subsists],
        simp [accident.intrinsic] at h,
        rw ←h,
        exact sup_comm,
      end

    omit h
    def accident.localize (a : ω.accident) (w : ω.world) : ω.accident :=
      if a.exists w then a else ~a

    lemma accident.localize_exists (a : ω.accident) {w : ω.world} : a.owner.exists w → (a.localize w).exists w :=
      begin
        intro h,
        by_cases c : a.exists w;
          simp [accident.localize, c],
        have lem := a.lem, unfold_coes at lem, simp at lem,
        rw ←lem at h, clear lem,
        unfold_coes at h,
        simp [accident.owner, has_sup.sup, entity_sup] at h,
        cases h, contradiction,
        simpa [has_tilde.tilde, accident.exterior],
      end

    include h

    lemma accident.intrinsic.localize_inheres (w : ω.world) : (a.localize w).inheres a.owner :=
      begin
        by_cases c : a.exists w;
          simp [accident.localize, c],
        exact h.exterior_inheres,
      end
    lemma accident.intrinsic.localize_intrinsic (w : ω.world) : (a.localize w).intrinsic :=
        begin
          by_cases c : a.exists w;
            simp [accident.localize, c],
            assumption,
          exact h.exterior,
        end

    omit h
    lemma intrinsic_of_inheres_nb : a.inheres ω.nb → a.intrinsic :=
      begin
        simp [accident.inheres, accident.intrinsic, entity.subsists, nb, nbe],
        intro h,
        have c : closure a.exists = a.exists,
          simp [ext_iff] at *,
          intro w, constructor;
          intro h₀; specialize h w,
            simp [h₀] at h,
            assumption,
          exact subset_closure h₀,
        rw c,
        symmetry,
        apply interior_eq_of_open,
        exact a.existential,
      end
    lemma nb_intrinsic : ω.nb.intrinsic :=
      begin
        intro h,
        obtain ⟨a, ha⟩ := h,
        simp at ha,
        have c := intrinsic_of_inheres_nb ha,
        use a, constructor;
        assumption,
      end

    /-- Any icomposite substance has an accident in any possible world in which it exists. -/
    lemma icomposites_actual : ∀ {s : ω.substance}, s.icomposite → ∀ w, s.exists w →
                          ∃ (a : ω.accident), a ∈ s.accidents ∧ a.exists w  :=
      begin
        intros s h₁ w h₂,
        obtain ⟨a, ha₁, ha₂⟩ := h₁,
        simp [substance.accidents],
        use a.localize w,
        have c₀ := ha₁.localize_inheres w,
        have c₁ : s = a.owner,
          apply unique_inheres;
          assumption <|> simp,
        rw ←c₁ at c₀,
        rw c₁ at h₂,
        replace h₂ := a.localize_exists h₂,
        exact ⟨c₀, h₂⟩,
      end

    lemma nb_acc_actual : ω.nb.composite → ∀ w, ∃ (a : ω.accident), a ∈ ω.nb.accidents ∧ a.exists w  :=
      begin
        intros h w,
        replace h := nb_intrinsic h,
        replace h := icomposites_actual h w (by simp [nb]),
        exact h,
      end

  end intrinsic

end accident_lemmas

section simplicity_lemmas

  variable (s : ω.substance)

  -- Conjecture: is the converse true?
  @[simp]
  lemma simple_of_connected : s.exists.connected → s.simple :=
    begin
      intro h,
      replace h := h.2,
      simp [is_preconnected] at h,
      simp [set.nonempty],
      intros a c,
      specialize h a.exists a.exists.exterior,
      specialize h a.existential a.exterior.existential,
      specialize h _, swap,
        simp,
        simp [accident.inheres, entity.subsists] at c,
        rw c,
      specialize h _, swap,
        focus {
          rw inter_comm,
          apply dense_iff_inter_open.mp s.perfect,
            exact a.existential,
            exact a.possible,
        },
      specialize h _, swap,
        focus {
          rw inter_comm,
          apply dense_iff_inter_open.mp s.perfect,
            exact a.exterior.existential,
            exact a.exterior.possible,
        },
      obtain ⟨w, ⟨hw₀, hw₁, hw₂⟩⟩ := h,
      simp [closure] at hw₂,
      obtain ⟨S, hS, absurdity, insanity⟩ := hw₂,
      specialize absurdity hw₁,
      contradiction,
      -- TODO: once you become convinced
      -- you can't prove the converse,
      -- delete these comments.
      -- refine ⟨s.possible, _⟩,
      -- have c : preconnected_space s.exists → is_preconnected s.to_entity.exists,
      --   rintros ⟨hyp⟩,
      --   simp [is_preconnected] at hyp,
      --   admit,
      -- apply c,
      -- constructor,
      -- simp [is_preconnected],
      -- intros a a' open_a open_a',
      -- intros cover meet_a meet_a',
      -- rw inter_comm,
      -- apply dense_iff_inter_open.mp s.perfect,
      --   exact is_open_inter open_a open_a',
      -- obtain ⟨w, hw⟩ := meet_a,
      -- replace hw := nonempty_of_mem hw.2,
      -- obtain ⟨w', hw'⟩ := meet_a',
      -- replace hw' := nonempty_of_mem hw'.2,
      -- let a₂ : ω.accident,
      --   refine ⟨⟨a, open_a, hw⟩, _⟩,
      -- simp [ext_iff] at h,
      -- specialize h a,
      -- by_contradiction c,
      -- simp [set.nonempty] at c,
    end

  lemma nb_simple_iff_connected : ω.nb.simple ↔ ω.nb.exists.connected :=
    begin
      refine ⟨_, simple_of_connected ω.nb⟩,
      intro h,
      refine ⟨ω.nb.possible, _⟩,
      simp [is_preconnected],
      intros a₁ a₂ open_a₁ open_a₂,
      intros cover meet_a₁ meet_a₂,
      replace cover := subset.antisymm cover _,
        swap,
        simp [nb, nbe],
      simp [nb, nbe] at cover,
      rw inter_comm,
      apply dense_iff_inter_open.mp ω.nb.perfect,
        exact is_open_inter open_a₁ open_a₂,
      obtain ⟨w₁, hw₁⟩ := meet_a₁,
      replace hw₁ := nonempty_of_mem hw₁.2,
      obtain ⟨w₂, hw₂⟩ := meet_a₂,
      replace hw₂ := nonempty_of_mem hw₂.2,
      by_cases c₁ : closure a₁ = univ,
        rw inter_comm,
        apply dense_iff_inter_open.mp c₁; assumption,
      let ac₁ : ω.accident := ⟨⟨a₁, open_a₁, hw₁⟩, c₁⟩,
      simp [substance.simple, set.nonempty] at h,
      specialize h ac₁,
      by_contradiction contra,
      suffices c : ac₁.exists.clopen,
        replace c := compl_iff_inheres_nb.2 ⟨ac₁.contingent, c⟩,
        contradiction,
      refine ⟨ac₁.existential, _⟩,
      simp [ac₁],
      dunfold is_closed,
      suffices c : -a₁ = a₂, rwa c,
      simp [ext_iff] at cover,
      simp [set.nonempty] at contra,
      ext w,
      specialize contra w,
      specialize cover w,
      cases cover; finish [cover],
    end

  def connected (ω : ontology) := connected_space ω.world

  lemma nb_simple_iff_space_connected : ω.nb.simple ↔ ω.connected :=
    begin
      convert nb_simple_iff_connected,
      simp [nb, nbe],
      constructor; intro h,
        obtain ⟨⟨h⟩,⟨w⟩⟩ := h,
        refine ⟨_, h⟩,
        simp,
      exact { is_preconnected_univ := h.2
            , to_nonempty := ω.wne
            },
    end

end simplicity_lemmas

-- We define the notions of potential part and participation.
-- This allows us to define weaker notions of inherence and consubstantiality.
-- THIS SECTION IS A WORK IN PROGRESS.
section participation

  /-- An entity is said to be a **potential part** of another entity in the following cases. -/
  inductive entity.ppart : ω.entity → ω.entity → Prop
  | inherence : ∀ {e₁ e₂ : ω.entity}, e₁ ≠ e₂ → e₁.subsists e₂ → entity.ppart e₁ e₂
  | odependence : ∀ {e₁ e₂ : ω.entity}, e₁.pparticular → e₂.pparticular → e₁ :⇒ e₂ → entity.ppart e₁ e₂
  | inter : ∀ {e₁ e₂ e₃ : ω.entity} (h : e₂.compatible e₃), entity.ppart e₂ e₁ → entity.ppart e₃ e₁ → entity.ppart h.inter e₁
  | Union : ∀ {e : ω.entity} (S : set ω.entity) (h : ∀ s ∈ S, entity.ppart s e), entity.ppart (Sup S) e
  | trans : ∀ {e₁ e₂ e₃ : ω.entity}, entity.ppart e₁ e₂ → entity.ppart e₂ e₃ → entity.ppart e₁ e₃

  /-- An entity is said to be a **participate** of another entity in the following cases. -/
  inductive entity.participates : ω.entity → ω.entity → Prop
  | exemplification : ∀ {e₁ e₂ : ω.entity}, e₁.exemplifies e₂ → entity.participates e₁ e₂
  | inherence : ∀ {e₁ e₂ : ω.entity}, e₁ ≠ e₂ → e₁.subsists e₂ → entity.participates e₁ e₂
  | odependence : ∀ {e₁ e₂ : ω.entity}, e₁ !:⇒ e₂ → entity.participates e₁ e₂
  | inter : ∀ {e₁ e₂ e₃ : ω.entity} (h : e₂.compatible e₃), entity.participates e₂ e₁ → entity.participates e₃ e₁ → entity.participates h.inter e₁
  | Union : ∀ {e : ω.entity} (S : set ω.entity) (h : ∀ s ∈ S, entity.participates s e), entity.participates (Sup S) e
  | trans : ∀ {e₁ e₂ e₃ : ω.entity}, entity.participates e₁ e₂ → entity.participates e₂ e₃ → entity.participates e₁ e₃

  /-- The rigid existential **dependence** between entities `e₁` and `e₂` is said to be **founded**
      just in case it is possible to explain why they are dependent.
  -/
  inductive entity.dfounded : ω.entity → ω.entity → Prop
  | identity : ∀ {e : ω.entity}, entity.dfounded e e
  | exemplification : ∀ {e₁ e₂ : ω.entity}, e₁.exemplifies e₂ → entity.dfounded e₁ e₂
  | inherence : ∀ {e₁ e₂ : ω.entity}, e₁.subsists e₂ → entity.dfounded e₁ e₂
  | odependence : ∀ {e₁ e₂ : ω.entity}, e₁ !:⇒ e₂ → entity.dfounded e₁ e₂
  | inter : ∀ {e₁ e₂ e₃ : ω.entity} (h : e₂.compatible e₃), entity.dfounded e₂ e₁ → entity.dfounded e₃ e₁ → entity.dfounded h.inter e₁
  | Union : ∀ {e : ω.entity} (S : set ω.entity) (h : ∀ s ∈ S, entity.dfounded s e), entity.dfounded (Sup S) e
  | trans : ∀ {e₁ e₂ e₃ : ω.entity}, entity.dfounded e₁ e₂ → entity.dfounded e₂ e₃ → entity.dfounded e₁ e₃

  variables (e₁ e₂ : ω.entity)

  /-- The rigid existential **dependence** between two entities is said to be **brute** if it is unfounded.
      We say that an entity `e₁` **brutely depends** on an entity `e₂` if and only if
      `e₁ ⇒ e₂` and this dependence is not founded. -/
  def entity.bdepends := e₁ ⇒ e₂ ∧ ¬ e₁.dfounded e₂

  -- TODO: prove the soundness of the previously defined notions with respect to `⇒`.
  -- To do this, prove `e₁.ppart e₂ → e₁.participates e₂`, `e₁.participates e₂ → e₁.dfounded e₂`
  -- and `e₁.dfounded e₂ → e₁ ⇒ e₂`. Completeness should be unprovable, but we leave it as
  -- an open problem to discover necessary and sufficient conditions of completeness which
  -- can be imposed on our ontology `ω`, i.e. for which class of ontologies, if any, is our
  -- foundation theory of dependence complete.

end participation
-- We also define the related notions for intensional entities:
namespace iontology

  variables {Ω : ω.iontology} (ie₁ ie₂ : Ω.ientity)

  /-- Two ientities `ie₁,ie₂` are said to be **cosubstantial** when their underlying substance is the same,
      i.e. when they subsist in the same substance. -/
  @[reducible, simp]
  def ientity.cosubstantial := ie₁.up.substance = ie₂.up.substance

  /-- The set of ientities cosubstantial to a given ientity `ie₁`.
      This is also an alias for `ientity.cosubstantial`. -/
  @[reducible, simp, alias]
  def ientity.cosubs := {ie₂ | ie₁.cosubstantial ie₂}

  /-- Use `ie₁ ≈ ie₂` instead of `ie₁.cosubstantial ie₂` -/
  @[reducible, simp]
  instance setoid_ientity : setoid Ω.ientity :=
    setoid.mk iontology.ientity.cosubstantial
    ⟨ by simp [reflexive, iontology.ientity.cosubstantial]
    , by finish [symmetric, iontology.ientity.cosubstantial]
    , by finish [transitive, iontology.ientity.cosubstantial]
    ⟩

end iontology

end ontology


import Lean
import Smt.Solver
import Smt.Util
import Smt.Term

namespace Smt

open Lean.Elab
open Lean.Elab.Tactic
open Lean.Meta
open Smt.Solver
open Smt.Util

initialize
  Lean.registerTraceClass `Smt.debug

def queryToString (commands : List String) : String :=
  String.intercalate "\n" ("(check-sat)\n" :: commands).reverse

/-- `smt` converts the current goal into an SMT query and checks if it is
satisfiable. By default, `smt` generates the minimum valid SMT query needed to
assert the goal. However, that is not always enough:
```lean
def modus_ponens (p q : Prop) (hp : p) (f : p → q) : q := by
  smt
```
For the theorem above, `smt` generates the query below:
```smt2
(declare-const q Bool)
(assert (not q))
(check-sat)
```
which is missing the hypotheses `hp` `f` required to prove the theorem. To pass
hypotheses to the solver, use `smt [h₁, h₂, ..., hₙ]` syntax:
```lean
def modus_ponens (p q : Prop) (hp : p) (f : p → q) : q := by
  smt [hp, f]
```
The tactic then generates the query below:
```smt2
(declare-const p Bool)
(declare-const q Bool)
(assert p)
(assert (=> p q))
(assert (not q))
(check-sat)
```
-/
syntax (name := smt) "smt" ("[" ident,+,? "]")? : tactic

def parseTactic : Lean.Syntax → TacticM (List Lean.Expr)
  | `(tactic| smt)       => []
  | `(tactic| smt [$[$hs],*]) => hs.toList.mapM (fun h => elabTerm h none)
  | _                    => throwUnsupportedSyntax

@[tactic smt] def evalSmt : Tactic := fun stx => do
  -- 1. Get the current main goal.
  let goal ← Tactic.getMainTarget
  -- 2. Get the free vars in the goal and the ones passed to the tactic.
  let mut hs := getFVars goal
  hs := hs ++ (← parseTactic stx)
  hs := hs.eraseDups
  hs ← fixedPoint getAllTypeFVars hs
  -- 3. If those free variables are hypothesis, assert them. Otherwise, declare those free vars
  --    as symbolic constants/uninterpreted functions.
  let mut solver := Solver.mk []
  for h in hs do
    let n ← match h with
      | Lean.Expr.fvar id .. => (← Lean.Meta.getLocalDecl id).userName.toString
      | Lean.Expr.const n .. => n.toString
      | _                    => throwUnsupportedSyntax
    -- logInfo m!"{v.fvarId!.name} {n}"
    let t ← Lean.Meta.inferType h
    let s ← exprToTerm t
    solver := if (← Lean.Meta.inferType t).isProp then solver.assert s else match s with
      | Term.Symbol .. => solver.declareConst n s
      | _             => solver.declareFun n s
  -- Assert the goal.
  solver := solver.assert (← exprToTerm (Lean.mkNot goal))
  let query := queryToString solver.commands
  -- Run the solver and print the result.
  let res ← solver.checkSat
  logInfo m!"goal: {goal}\n\nquery:\n{query}\nresult: {res}"

end Smt


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.measure_theory.integration
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

namespace measure_theory

namespace measure

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
protected instance measurable_space {α : Type u_1} [measurable_space α] :
    measurable_space (measure α) :=
  supr
    fun (s : set α) =>
      supr
        fun (hs : is_measurable s) =>
          measurable_space.comap (fun (μ : measure α) => coe_fn μ s) (borel ennreal)

theorem measurable_coe {α : Type u_1} [measurable_space α] {s : set α} (hs : is_measurable s) :
    measurable fun (μ : measure α) => coe_fn μ s :=
  measurable.of_comap_le
    (le_supr_of_le s
      (le_supr_of_le hs
        (le_refl
          (measurable_space.comap (fun (μ : measure α) => coe_fn μ s) ennreal.measurable_space))))

theorem measurable_of_measurable_coe {α : Type u_1} {β : Type u_2} [measurable_space α]
    [measurable_space β] (f : β → measure α)
    (h : ∀ (s : set α), is_measurable s → measurable fun (b : β) => coe_fn (f b) s) :
    measurable f :=
  sorry

theorem measurable_measure {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {μ : α → measure β} :
    measurable μ ↔ ∀ (s : set β), is_measurable s → measurable fun (b : α) => coe_fn (μ b) s :=
  { mp :=
      fun (hμ : measurable μ) (s : set β) (hs : is_measurable s) =>
        measurable.comp (measurable_coe hs) hμ,
    mpr := measurable_of_measurable_coe μ }

theorem measurable_map {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    (f : α → β) (hf : measurable f) : measurable fun (μ : measure α) => coe_fn (map f) μ :=
  sorry

theorem measurable_dirac {α : Type u_1} [measurable_space α] : measurable dirac := sorry

theorem measurable_lintegral {α : Type u_1} [measurable_space α] {f : α → ennreal}
    (hf : measurable f) : measurable fun (μ : measure α) => lintegral μ fun (x : α) => f x :=
  sorry

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join {α : Type u_1} [measurable_space α] (m : measure (measure α)) : measure α :=
  of_measurable
    (fun (s : set α) (hs : is_measurable s) => lintegral m fun (μ : measure α) => coe_fn μ s) sorry
    sorry

@[simp] theorem join_apply {α : Type u_1} [measurable_space α] {m : measure (measure α)}
    {s : set α} :
    is_measurable s → coe_fn (join m) s = lintegral m fun (μ : measure α) => coe_fn μ s :=
  of_measurable_apply

theorem measurable_join {α : Type u_1} [measurable_space α] : measurable join := sorry

theorem lintegral_join {α : Type u_1} [measurable_space α] {m : measure (measure α)}
    {f : α → ennreal} (hf : measurable f) :
    (lintegral (join m) fun (x : α) => f x) =
        lintegral m fun (μ : measure α) => lintegral μ fun (x : α) => f x :=
  sorry

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β] (m : measure α)
    (f : α → measure β) : measure β :=
  join (coe_fn (map f) m)

@[simp] theorem bind_apply {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {m : measure α} {f : α → measure β} {s : set β} (hs : is_measurable s) (hf : measurable f) :
    coe_fn (bind m f) s = lintegral m fun (a : α) => coe_fn (f a) s :=
  sorry

theorem measurable_bind' {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {g : α → measure β} (hg : measurable g) : measurable fun (m : measure α) => bind m g :=
  measurable.comp measurable_join (measurable_map g hg)

theorem lintegral_bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {m : measure α} {μ : α → measure β} {f : β → ennreal} (hμ : measurable μ) (hf : measurable f) :
    (lintegral (bind m μ) fun (x : β) => f x) =
        lintegral m fun (a : α) => lintegral (μ a) fun (x : β) => f x :=
  Eq.trans (lintegral_join hf) (lintegral_map (measurable_lintegral hf) hμ)

theorem bind_bind {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {γ : Type u_3} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ}
    (hf : measurable f) (hg : measurable g) :
    bind (bind m f) g = bind m fun (a : α) => bind (f a) g :=
  sorry

theorem bind_dirac {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a :=
  sorry

theorem dirac_bind {α : Type u_1} [measurable_space α] {m : measure α} : bind m dirac = m := sorry

theorem join_eq_bind {α : Type u_1} [measurable_space α] (μ : measure (measure α)) :
    join μ = bind μ id :=
  eq.mpr (id (Eq._oldrec (Eq.refl (join μ = bind μ id)) (bind.equations._eqn_1 μ id)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (join μ = join (coe_fn (map id) μ))) map_id))
      (Eq.refl (join μ)))

theorem join_map_map {α : Type u_1} {β : Type u_2} [measurable_space α] [measurable_space β]
    {f : α → β} (hf : measurable f) (μ : measure (measure α)) :
    join (coe_fn (map ⇑(map f)) μ) = coe_fn (map f) (join μ) :=
  sorry

theorem join_map_join {α : Type u_1} [measurable_space α] (μ : measure (measure (measure α))) :
    join (coe_fn (map join) μ) = join (join μ) :=
  sorry

theorem join_map_dirac {α : Type u_1} [measurable_space α] (μ : measure α) :
    join (coe_fn (map dirac) μ) = μ :=
  dirac_bind

theorem join_dirac {α : Type u_1} [measurable_space α] (μ : measure α) : join (dirac μ) = μ :=
  Eq.trans (join_eq_bind (dirac μ)) (bind_dirac measurable_id μ)

end Mathlib


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.basic
import Mathlib.category_theory.monad.kleisli
import Mathlib.category_theory.category.Kleisli
import Mathlib.category_theory.types
import Mathlib.PostPort

universes u

namespace Mathlib

/-!

# Convert from `monad` (i.e. Lean's `Type`-based monads) to `category_theory.monad`

This allows us to use these monads in category theory.

-/

namespace category_theory

protected instance of_type_functor.monad (m : Type u → Type u) [Monad m] [is_lawful_monad m] : monad (of_type_functor m) :=
  monad.mk (nat_trans.mk pure) (nat_trans.mk mjoin)

/--
The `Kleisli` category of a `control.monad` is equivalent to the `kleisli` category of its
category-theoretic version, provided the monad is lawful.
-/
@[simp] theorem eq_unit_iso (m : Type u → Type u) [Monad m] [is_lawful_monad m] : equivalence.unit_iso (eq m) = nat_iso.of_components (fun (X : Kleisli m) => iso.refl X) (eq._proof_7 m) :=
  Eq.refl (equivalence.unit_iso (eq m))


example (p q : Prop) (hp : p) : p ∨ q :=
  by { left, assumption }


lemma foo { α : Type } ( a b : α ) ( h : a = b ): (eq.rec (eq.refl a) h) = eq.refl b := begin

end

-- set_option pp.all true

#check eq.rec
#check prod.rec

-- eq.rec (thing : type) (p : type = type')

-- (eq.rec (C^.identity (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd)))
--        (id_locked
--           (C^.Hom (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd))
--              (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd)) = C^.Hom
--              (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd))
--              (tensor^.onObjects ((Y^.fst)^.fst, tensor^.onObjects ((Y^.fst)^.snd, Y^.snd))))
--           (eq.rec
--              (eq.rec
--                 (eq.refl
--                    (C^.Hom (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd))
--                       (tensor^.onObjects (tensor^.onObjects (Y^.fst), Y^.snd))))
--                 (eq.symm pair_equality))
--              (is_strict^.associativeOnObjects ((Y^.fst)^.fst) ((Y^.fst)^.snd) (Y^.snd)))))


import justification pump1 common_meta property_catalogue.LTL
 open S A

 @[reducible] def pump1_input_1 : property.input (path pump1) := {property.input .
 Clm := {Claim .
         X := {x : path pump1 | true},
         P := λ (p : path pump1), p⊨absent.after_until ↑BolusRequest ↑Cond_6_3_ ↑Infusion_NormalOperation},
 Props := [λ (p : path pump1), p⊨responds.globally ↑Cond_6_3_ ↑Alrm_EmptyReservoir, λ (p : path pump1),
              p⊨absent.between ↑BolusRequest ↑Cond_6_3_ ↑Alrm_EmptyReservoir, λ (p : path pump1),
              p⊨absent.after_until ↑BolusRequest ↑Alrm_EmptyReservoir ↑Infusion_NormalOperation]}

 @[reducible] def pump1_strat_1 : Strategy (path pump1) := property.strategy pump1_input_1

theorem pump1_prf_1 : deductive (path pump1) pump1_strat_1 :=
begin
analyze 3,
 apply absent.after_until.from_absent_between_response,
 match_premises,
end

--responds.globally ↑Cond_6_3_ ↑Alrm_EmptyReservoir
-/


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.adjunction
import category_theory.adjunction.limits
import category_theory.limits.shapes.terminal

/-!
# Limits and colimits in the category of algebras

This file shows that the forgetful functor `forget T : algebra T ⥤ C` for a monad `T : C ⥤ C`
creates limits and creates any colimits which `T` preserves.
This is used to show that `algebra T` has any limits which `C` has, and any colimits which `C` has
and `T` preserves.
This is generalised to the case of a monadic functor `D ⥤ C`.

## TODO

Dualise for the category of coalgebras and comonadic left adjoints.
-/

namespace category_theory
open category
open category_theory.limits

universes v u v₁ v₂ u₁ u₂
-- morphism levels before object levels. See note [category_theory universes].

namespace monad

variables {C : Type u₁} [category.{v₁} C]
variables {T : monad C}

variables {J : Type u} [category.{v} J]

namespace forget_creates_limits

variables (D : J ⥤ algebra T) (c : cone (D ⋙ T.forget)) (t : is_limit c)

/-- (Impl) The natural transformation used to define the new cone -/
@[simps] def γ : (D ⋙ T.forget ⋙ ↑T) ⟶ D ⋙ T.forget := { app := λ j, (D.obj j).a }

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simps π_app] def new_cone : cone (D ⋙ forget T) :=
{ X := T.obj c.X,
  π := (functor.const_comp _ _ ↑T).inv ≫ whisker_right c.π T ≫ γ D }

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simps] def cone_point : algebra T :=
{ A := c.X,
  a := t.lift (new_cone D c),
  unit' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, t.fac, new_cone_π_app, ←T.η.naturality_assoc, functor.id_map,
      (D.obj j).unit],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' := t.hom_ext $ λ j,
  begin
    rw [category.assoc, category.assoc, t.fac (new_cone D c), new_cone_π_app,
      ←functor.map_comp_assoc, t.fac (new_cone D c), new_cone_π_app, ←T.μ.naturality_assoc,
      (D.obj j).assoc, functor.map_comp, category.assoc],
    refl,
  end }

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simps] def lifted_cone : cone D :=
{ X := cone_point D c t,
  π := { app := λ j, { f := c.π.app j },
         naturality' := λ X Y f, by { ext1, dsimp, erw c.w f, simp } } }

/-- (Impl) Prove that the lifted cone is limiting. -/
@[simps]
def lifted_cone_is_limit : is_limit (lifted_cone D c t) :=
{ lift := λ s,
  { f := t.lift ((forget T).map_cone s),
    h' := t.hom_ext $ λ j,
    begin
      dsimp,
      rw [category.assoc, category.assoc, t.fac, new_cone_π_app, ←functor.map_comp_assoc, t.fac,
        functor.map_cone_π_app],
      apply (s.π.app j).h,
    end },
  uniq' := λ s m J,
  begin
    ext1,
    apply t.hom_ext,
    intro j,
    simpa [t.fac ((forget T).map_cone s) j] using congr_arg algebra.hom.f (J j),
  end }

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]
/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
noncomputable
instance forget_creates_limits : creates_limits_of_size (forget T) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ D,
    creates_limit_of_reflects_iso (λ c t,
    { lifted_cone := forget_creates_limits.lifted_cone D c t,
      valid_lift := cones.ext (iso.refl _) (λ j, (id_comp _).symm),
      makes_limit := forget_creates_limits.lifted_cone_is_limit _ _ _ } ) } }

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
lemma has_limit_of_comp_forget_has_limit (D : J ⥤ algebra T) [has_limit (D ⋙ forget T)] :
  has_limit D :=
has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace
variables {D : J ⥤ algebra T} (c : cocone (D ⋙ forget T)) (t : is_colimit c)

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a
-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.
-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.
-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`
-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.
-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.
-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it
-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simps] def γ : ((D ⋙ forget T) ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simps]
def new_cocone : cocone ((D ⋙ forget T) ⋙ ↑T) :=
{ X := c.X,
  ι := γ ≫ c.ι }

variables [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
@[reducible]
def lambda : ((T : C ⥤ C).map_cocone c).X ⟶ c.X :=
(is_colimit_of_preserves _ t).desc (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
lemma commuting (j : J) :
(T : C ⥤ C).map (c.ι.app j) ≫ lambda c t = (D.obj j).a ≫ c.ι.app j :=
(is_colimit_of_preserves _ t).fac (new_cocone c) j

variables [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)]

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simps] def cocone_point :
algebra T :=
{ A := c.X,
  a := lambda c t,
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    rw [(show c.ι.app j ≫ T.η.app c.X ≫ _ = T.η.app (D.obj j).A ≫ _ ≫ _,
                  from T.η.naturality_assoc _ _), commuting, algebra.unit_assoc (D.obj j)],
    dsimp, simp -- See library note [dsimp, simp]
  end,
  assoc' :=
  begin
    refine (is_colimit_of_preserves _ (is_colimit_of_preserves _ t)).hom_ext (λ j, _),
    rw [functor.map_cocone_ι_app, functor.map_cocone_ι_app,
      (show (T : C ⥤ C).map ((T : C ⥤ C).map _) ≫ _ ≫ _ = _, from T.μ.naturality_assoc _ _),
      ←functor.map_comp_assoc, commuting, functor.map_comp, category.assoc, commuting],
    apply (D.obj j).assoc_assoc _,
  end }

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simps] def lifted_cocone : cocone D :=
{ X := cocone_point c t,
  ι := { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
         naturality' := λ A B f, by { ext1, dsimp, rw [comp_id], apply c.w } } }

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simps]
def lifted_cocone_is_colimit : is_colimit (lifted_cocone c t) :=
{ desc := λ s,
  { f := t.desc ((forget T).map_cocone s),
    h' := (is_colimit_of_preserves (T : C ⥤ C) t).hom_ext $ λ j,
    begin
      dsimp,
      rw [←functor.map_comp_assoc, ←category.assoc, t.fac, commuting, category.assoc, t.fac],
      apply algebra.hom.h,
    end },
  uniq' := λ s m J,
  by { ext1, apply t.hom_ext, intro j, simpa using congr_arg algebra.hom.f (J j) } }

end forget_creates_colimits

open forget_creates_colimits

-- TODO: the converse of this is true as well
/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
instance forget_creates_colimit (D : J ⥤ algebra T)
  [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]
  [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)] :
  creates_colimit D (forget T) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone :=
  { X := cocone_point c t,
    ι :=
    { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
      naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } },
  valid_lift := cocones.ext (iso.refl _) (by tidy),
  makes_colimit := lifted_cocone_is_colimit _ _ }

noncomputable
instance forget_creates_colimits_of_shape
  [preserves_colimits_of_shape J (T : C ⥤ C)] :
  creates_colimits_of_shape J (forget T) :=
{ creates_colimit := λ K, by apply_instance }

noncomputable
instance forget_creates_colimits
  [preserves_colimits_of_size.{v u} (T : C ⥤ C)] :
  creates_colimits_of_size.{v u} (forget T) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by apply_instance }

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
lemma forget_creates_colimits_of_monad_preserves
  [preserves_colimits_of_shape J (T : C ⥤ C)] (D : J ⥤ algebra T) [has_colimit (D ⋙ forget T)] :
has_colimit D :=
has_colimit_of_created D (forget T)

end monad

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

instance comp_comparison_forget_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit ((F ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) :=
@has_limit_of_iso _ _ _ _ (F ⋙ R) _ _
  (iso_whisker_left F (monad.comparison_forget (adjunction.of_right_adjoint R)).symm)

instance comp_comparison_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R)) :=
monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R))

/-- Any monadic functor creates limits. -/
noncomputable
def monadic_creates_limits (R : D ⥤ C) [monadic_right_adjoint R] :
  creates_limits_of_size.{v u} R :=
creates_limits_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R))

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
def monadic_creates_colimit_of_preserves_colimit (R : D ⥤ C) (K : J ⥤ D)
  [monadic_right_adjoint R]
  [preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)]
  [preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] :
  creates_colimit K R :=
begin
  apply creates_colimit_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.comp_creates_colimit _ _,
  apply_instance,
  let i : ((K ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) ≅ K ⋙ R :=
    functor.associator _ _ _ ≪≫
      iso_whisker_left K (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.monad.forget_creates_colimit _,
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ i.symm },
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ (iso_whisker_right i (left_adjoint R ⋙ R)).symm },
end

/-- A monadic functor creates any colimits of shapes it preserves. -/
noncomputable
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape (R : D ⥤ C)
  [monadic_right_adjoint R] [preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
begin
  have : preserves_colimits_of_shape J (left_adjoint R ⋙ R),
  { apply category_theory.limits.comp_preserves_colimits_of_shape _ _,
    apply (adjunction.left_adjoint_preserves_colimits (adjunction.of_right_adjoint R)).1,
    apply_instance },
  exactI ⟨λ K, monadic_creates_colimit_of_preserves_colimit _ _⟩,
end

/-- A monadic functor creates colimits if it preserves colimits. -/
noncomputable
def monadic_creates_colimits_of_preserves_colimits (R : D ⥤ C) [monadic_right_adjoint R]
  [preserves_colimits_of_size.{v u} R] : creates_colimits_of_size.{v u} R :=
{ creates_colimits_of_shape := λ J 𝒥₁,
    by exactI monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape _ }

section

lemma has_limit_of_reflective (F : J ⥤ D) (R : D ⥤ C) [has_limit (F ⋙ R)] [reflective R] :
  has_limit F :=
by { haveI := monadic_creates_limits.{v u} R, exact has_limit_of_created F R }

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
lemma has_limits_of_shape_of_reflective [has_limits_of_shape J C] (R : D ⥤ C) [reflective R] :
  has_limits_of_shape J D :=
{ has_limit := λ F, has_limit_of_reflective F R }

/-- If `C` has limits then any reflective subcategory has limits. -/
lemma has_limits_of_reflective (R : D ⥤ C) [has_limits_of_size.{v u} C] [reflective R] :
  has_limits_of_size.{v u} D :=
{ has_limits_of_shape := λ J 𝒥₁, by exactI has_limits_of_shape_of_reflective R }

/-- If `C` has colimits of shape `J` then any reflective subcategory has colimits of shape `J`. -/
lemma has_colimits_of_shape_of_reflective (R : D ⥤ C)
  [reflective R] [has_colimits_of_shape J C] : has_colimits_of_shape J D :=
{ has_colimit := λ F,
begin
  let c := (left_adjoint R).map_cocone (colimit.cocone (F ⋙ R)),
  letI : preserves_colimits_of_shape J _ :=
    (adjunction.of_right_adjoint R).left_adjoint_preserves_colimits.1,
  let t : is_colimit c := is_colimit_of_preserves (left_adjoint R) (colimit.is_colimit _),
  apply has_colimit.mk ⟨_, (is_colimit.precompose_inv_equiv _ _).symm t⟩,
  apply (iso_whisker_left F (as_iso (adjunction.of_right_adjoint R).counit) : _) ≪≫ F.right_unitor,
end }

/-- If `C` has colimits then any reflective subcategory has colimits. -/
lemma has_colimits_of_reflective (R : D ⥤ C) [reflective R] [has_colimits_of_size.{v u} C] :
  has_colimits_of_size.{v u} D :=
{ has_colimits_of_shape := λ J 𝒥, by exactI has_colimits_of_shape_of_reflective R }

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
noncomputable def left_adjoint_preserves_terminal_of_reflective (R : D ⥤ C) [reflective R] :
  preserves_limits_of_shape (discrete.{v} pempty) (left_adjoint R) :=
{ preserves_limit := λ K, let F := functor.empty.{v} D in
  begin
    apply preserves_limit_of_iso_diagram _ (functor.empty_ext (F ⋙ R) _),
    fsplit, intros c h, haveI : has_limit (F ⋙ R) := ⟨⟨⟨c,h⟩⟩⟩,
    haveI : has_limit F := has_limit_of_reflective F R,
    apply is_limit_change_empty_cone D (limit.is_limit F),
    apply (as_iso ((adjunction.of_right_adjoint R).counit.app _)).symm.trans,
    { apply (left_adjoint R).map_iso, letI := monadic_creates_limits.{v v} R,
      let := (category_theory.preserves_limit_of_creates_limit_and_has_limit F R).preserves,
      apply (this (limit.is_limit F)).cone_point_unique_up_to_iso h },
    apply_instance,
  end }

end
end category_theory


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((a1).read i1) ≠ (((((a1).write i2 ((a2).read i3)).write i3 ((a1).read i1)).write i1 ((a1).read i1)).read i3) → False := by
  arr


import pseudo_normed_group.category.ProFiltPseuNormGrp

universe variables u

open category_theory
open_locale nnreal

noncomputable theory

local attribute [instance] type_pow

/-- The bundled category whose objects are `profinitely_filtered_pseudo_normed_group`s
equipped (this is the `₁`) with exhaustive filtrations and strict morphisms. -/
structure ProFiltPseuNormGrp₁ : Type (u+1) :=
(M : Type u)
[str : profinitely_filtered_pseudo_normed_group M]
(exhaustive' : ∀ m : M, ∃ c, m ∈ pseudo_normed_group.filtration M c)

namespace ProFiltPseuNormGrp₁

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

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

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

def PFPNG₁_to_PFPNGₑₗ : ProFiltPseuNormGrp₁ ⥤ ProFiltPseuNormGrp :=
{ obj := λ M, ProFiltPseuNormGrp.of M,
  map := λ M₁ M₂ f, f.to_chfpsng_hom }

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

/-- The forgetful functor from groups filtered by profinite spaces to
groups filtered by compact Hausdorff spaces. -/
def _root_.PFPNG₁_to_CHFPNG₁ₑₗ : ProFiltPseuNormGrp₁.{u} ⥤ CompHausFiltPseuNormGrp₁.{u} :=
{ obj := λ M,
  { M := M,
    exhaustive' := M.exhaustive },
  map := λ A B f, f }

def limit_cone {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrp₁.{u}) :
  limits.cone K :=
{ X :=
  { M := (CompHausFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ)).X,
    str :=
    { continuous_add' := comphaus_filtered_pseudo_normed_group.continuous_add',
      continuous_neg' := comphaus_filtered_pseudo_normed_group.continuous_neg',
      continuous_cast_le := comphaus_filtered_pseudo_normed_group.continuous_cast_le,
      td := begin
        intro c,
        let E := (CompHausFiltPseuNormGrp₁.cone_point_type.filt_homeo (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c),
        haveI : totally_disconnected_space
          (CompHausFiltPseuNormGrp₁.cone_point_type_filt (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c) :=
        begin
          dsimp [CompHausFiltPseuNormGrp₁.cone_point_type_filt],
          apply_instance,
        end,
        apply E.symm.totally_disconnected_space,
      end,
      ..(infer_instance : pseudo_normed_group _) },
    exhaustive' :=  CompHausFiltPseuNormGrp₁.exhaustive _ },
  π :=
  { app := λ j, (CompHausFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ)).π.app j,
    naturality' := (CompHausFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ)).π.naturality } }

instance {J : Type u} [small_category J] : creates_limits_of_shape J PFPNG₁_to_CHFPNG₁ₑₗ :=
{ creates_limit := λ K,
  { reflects := λ C hC,
    { lift := λ S, hC.lift (PFPNG₁_to_CHFPNG₁ₑₗ.map_cone S),
      fac' := λ S j, hC.fac _ _,
      uniq' := λ S m h, hC.uniq (PFPNG₁_to_CHFPNG₁ₑₗ.map_cone S) m h },
    lifts := λ C hC,
    { lifted_cone := limit_cone _,
      valid_lift :=
        (CompHausFiltPseuNormGrp₁.limit_cone_is_limit (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ)).unique_up_to_iso hC } } }

instance : creates_limits PFPNG₁_to_CHFPNG₁ₑₗ := ⟨⟩

def limit_cone_is_limit {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrp₁.{u}) :
  limits.is_limit (limit_cone K) :=
limits.is_limit_of_reflects PFPNG₁_to_CHFPNG₁ₑₗ (CompHausFiltPseuNormGrp₁.limit_cone_is_limit _)

instance : limits.has_limits ProFiltPseuNormGrp₁.{u} :=
has_limits_of_has_limits_creates_limits PFPNG₁_to_CHFPNG₁ₑₗ

lemma eq_of_π_eq {J : Type u} [small_category J] {K : J ⥤ ProFiltPseuNormGrp₁.{u}}
  (C : limits.cone K) (hC : limits.is_limit C) (x y : C.X)
  (cond : ∀ j, C.π.app j x = C.π.app j y) : x = y :=
begin
  let D := limit_cone K,
  let hD : limits.is_limit D := limit_cone_is_limit _,
  let E : C.X ≅ D.X := hC.cone_point_unique_up_to_iso hD,
  apply_fun E.hom,
  swap, {
    intros a b h,
    apply_fun E.inv at h,
    change (E.hom ≫ E.inv) _ = (E.hom ≫ E.inv) _ at h,
    simpa using h },
  apply quotient.sound',
  refine ⟨_, le_sup_left, le_sup_right, _⟩,
  simp,
  ext j : 3,
  dsimp, simp,
  exact cond j,
end

lemma coe_comp_apply {A B C : ProFiltPseuNormGrp₁} (f : A ⟶ B) (g : B ⟶ C) (x : A) :
  (f ≫ g) x = g (f x) := rfl

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

instance {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrp₁.{u}) (c : ℝ≥0) :
  limits.preserves_limit K (level.obj c) :=
begin
  constructor,
  intros E hE,
  apply limits.is_limit_of_reflects Profinite_to_CompHaus,
  change limits.is_limit ((CompHausFiltPseuNormGrp₁.level.obj c).map_cone
    (PFPNG₁_to_CHFPNG₁ₑₗ.map_cone E)),
  apply limits.is_limit_of_preserves,
  apply limits.is_limit_of_preserves,
  assumption
end

lemma mem_filtration_iff_of_is_limit {J : Type u} [small_category J]
  (K : J ⥤ ProFiltPseuNormGrp₁.{u}) (C : limits.cone K)
  (hC : limits.is_limit C) (c : ℝ≥0) (x : C.X) :
  x ∈ pseudo_normed_group.filtration C.X c ↔
  (∀ j : J, C.π.app j x ∈ pseudo_normed_group.filtration (K.obj j) c) :=
CompHausFiltPseuNormGrp₁.mem_filtration_iff_of_is_limit (K ⋙ PFPNG₁_to_CHFPNG₁ₑₗ)
  (PFPNG₁_to_CHFPNG₁ₑₗ.map_cone C) (limits.is_limit_of_preserves _ hC) _ _

lemma is_limit_ext {J : Type u} [small_category J]
  (K : J ⥤ ProFiltPseuNormGrp₁.{u}) (C : limits.cone K)
  (hC : limits.is_limit C) (x y : C.X)
  (h : ∀ j, C.π.app j x = C.π.app j y) : x = y :=
CompHausFiltPseuNormGrp₁.is_limit_ext _ _ (limits.is_limit_of_preserves PFPNG₁_to_CHFPNG₁ₑₗ hC) _ _ h

section explicit_product

def product {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrp₁.{u}) :
  ProFiltPseuNormGrp₁.{u} :=
{ M := Π i, X i,
  str := infer_instance,
  exhaustive' := (CompHausFiltPseuNormGrp₁.product (λ i, (PFPNG₁_to_CHFPNG₁ₑₗ.obj (X i)))).exhaustive' }

@[simps]
def product.π {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrp₁.{u}) (i) :
  product X ⟶ X i :=
CompHausFiltPseuNormGrp₁.product.π (λ i, (PFPNG₁_to_CHFPNG₁ₑₗ.obj (X i))) i

@[simps]
def product.lift {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrp₁.{u})
  (M : ProFiltPseuNormGrp₁.{u}) (f : Π i, M ⟶ X i) : M ⟶ product X :=
CompHausFiltPseuNormGrp₁.product.lift (λ i, (PFPNG₁_to_CHFPNG₁ₑₗ.obj (X i))) (PFPNG₁_to_CHFPNG₁ₑₗ.obj M) f

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

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

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

end explicit_product

end ProFiltPseuNormGrp₁