import pseudo_normed_group.category
import for_mathlib.AddCommGroup.explicit_limits

import topology.category.Compactum

open category_theory
open category_theory.limits

universe u
variables {J : Type u} [small_category J]

structure PseuNormGrp₁ :=
(carrier : Type u)
[str : pseudo_normed_group carrier]
(exhaustive' : ∀ x : carrier, ∃ c : nnreal,
  x ∈ pseudo_normed_group.filtration carrier c)

namespace PseuNormGrp₁

instance : has_coe_to_sort PseuNormGrp₁.{u} (Type u) := ⟨carrier⟩
instance (M : PseuNormGrp₁.{u}) : pseudo_normed_group M := M.str

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

instance : category PseuNormGrp₁.{u} :=
{ hom := λ A B, strict_pseudo_normed_group_hom A B,
  id := λ A, strict_pseudo_normed_group_hom.id A,
  comp := λ A B C f g, f.comp g }

@[simp]
lemma id_apply (M : PseuNormGrp₁) (x : M) : (𝟙 M : M ⟶ M) x = x := rfl

@[simp]
lemma comp_apply {A B C : PseuNormGrp₁} (f : A ⟶ B) (g : B ⟶ C) (a : A) :
  (f ≫ g) a = g (f a) := rfl

def to_Ab : PseuNormGrp₁.{u} ⥤ Ab.{u} :=
{ obj := λ M, AddCommGroup.of M,
  map := λ M N f, f.to_add_monoid_hom }

variable {K : J ⥤ PseuNormGrp₁.{u}}
variable (C : limits.limit_cone (K ⋙ to_Ab))

def bounded_elements : add_subgroup C.cone.X :=
{ carrier := { x | ∃ c, ∀ j, C.cone.π.app j x ∈ pseudo_normed_group.filtration (K.obj j) c },
  zero_mem' := ⟨0, λ j, by { simp, apply pseudo_normed_group.zero_mem_filtration } ⟩,
  add_mem' := λ a b ha hb, begin
    obtain ⟨c,hc⟩ := ha,
    obtain ⟨d,hd⟩ := hb,
    use c + d,
    intros j,
    simp,
    apply pseudo_normed_group.add_mem_filtration,
    apply hc,
    apply hd,
  end,
  neg_mem' := λ a ha, begin
    obtain ⟨c,hc⟩ := ha,
    use c,
    intros j,
    simp,
    apply pseudo_normed_group.neg_mem_filtration,
    apply hc,
  end }

def bounded_elements.filt (c : nnreal) : set C.cone.X :=
{ x | ∀ j, C.cone.π.app j x ∈ pseudo_normed_group.filtration (K.obj j) c }

def bounded_elements.filt_incl (c : nnreal) :
  bounded_elements.filt C c → bounded_elements C :=
λ x, ⟨x, c, x.2⟩

def bounded_elements.filtration (c : nnreal) : set (bounded_elements C) :=
set.range (bounded_elements.filt_incl _ c)

def bounded_cone_point : PseuNormGrp₁ :=
{ carrier := bounded_elements C,
  str :=
  { filtration := bounded_elements.filtration _,
    filtration_mono := begin
      intros c₁ c₂ h x hx,
      obtain ⟨t,rfl⟩ := hx, refine ⟨⟨t,_⟩,rfl⟩, intros i,
      apply pseudo_normed_group.filtration_mono h, apply t.2,
    end,
    zero_mem_filtration := begin
      intros c, refine ⟨⟨0,λ i, _⟩,rfl⟩, simp,
        apply pseudo_normed_group.zero_mem_filtration
    end,
    neg_mem_filtration := begin
      intros c x hx,
      obtain ⟨t,rfl⟩ := hx, refine ⟨⟨-t, λ i, _⟩, rfl⟩, simp,
      apply pseudo_normed_group.neg_mem_filtration, apply t.2
    end,
    add_mem_filtration := begin
      intros c₁ c₂ x₁ x₂ h₁ h₂,
      obtain ⟨t₁,rfl⟩ := h₁, obtain ⟨t₂,rfl⟩ := h₂,
      refine ⟨⟨t₁ + t₂, λ i, _⟩, rfl⟩, simp,
      apply pseudo_normed_group.add_mem_filtration, apply t₁.2, apply t₂.2,
    end },
    exhaustive' := begin
      intros m,
      obtain ⟨c,hc⟩ := m.2,
      refine ⟨c,⟨m.1, hc⟩, by { ext, refl }⟩,
    end }

def bounded_cone : cone K :=
{ X := bounded_cone_point C,
  π :=
  { app := λ j,
    { to_fun := λ x, C.cone.π.app _ x.1,
      map_zero' := by simp,
      map_add' := λ x y, by simp,
      strict' := begin
        rintros c x ⟨x,rfl⟩,
        apply x.2,
      end },
    naturality' := begin
      intros i j f,
      ext,
      dsimp,
      rw ← C.cone.w f,
      refl,
    end } }

def bounded_cone_lift (S : cone K) : S.X ⟶ bounded_cone_point C :=
{ to_fun := λ x, ⟨C.2.lift (to_Ab.map_cone S) x, begin
    obtain ⟨c,hc⟩ := S.X.exhaustive x,
    use c,
    intros j,
    rw [← Ab.comp_apply, C.2.fac],
    apply (S.π.app j).strict,
    exact hc,
  end⟩,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp },
  strict' := begin
    intros c x hx,
    refine ⟨⟨_, λ j, _⟩,rfl⟩,
    erw [← Ab.comp_apply, C.2.fac],
    apply (S.π.app j).strict,
    exact hx,
  end }

def bounded_cone_is_limit : is_limit (bounded_cone C) :=
{ lift := λ S, bounded_cone_lift C S,
  fac' := begin
    intros S j,
    ext,
    dsimp [bounded_cone_lift, bounded_cone],
    rw [← Ab.comp_apply, C.2.fac],
    refl,
  end,
  uniq' := begin
    intros S m hm,
    ext,
    dsimp [bounded_cone_lift, bounded_cone],
    apply Ab.is_limit_ext,
    intros j,
    rw [← Ab.comp_apply, C.2.fac],
    dsimp,
    rw ← hm,
    refl,
  end }

instance : has_limits PseuNormGrp₁ :=
begin
  constructor, introsI J hJ, constructor, intros K,
  exact has_limit.mk ⟨_, bounded_cone_is_limit ⟨_,limit.is_limit _⟩⟩,
end

open pseudo_normed_group

lemma mem_filtration_iff_of_is_limit (C : cone K) (hC : is_limit C)
  (x : C.X) (c : nnreal) :
  x ∈ pseudo_normed_group.filtration C.X c ↔
  (∀ j : J, C.π.app j x ∈ pseudo_normed_group.filtration (K.obj j) c) :=
begin
  split,
  { intros h j,
    exact (C.π.app j).strict h },
  { intros h,
    let E := bounded_cone ⟨_, Ab.explicit_limit_cone_is_limit.{u u} _⟩,
    let e : C ≅ E := hC.unique_up_to_iso (bounded_cone_is_limit _),
    let eX : C.X ≅ E.X := (cones.forget _).map_iso e,
    let w := eX.hom x,
    have hw : ∀ j, E.π.app j w ∈ filtration (K.obj j) c,
    { intros j,
      dsimp only [w],
      change (eX.hom ≫ E.π.app _) _ ∈ _,
      dsimp only [eX, functor.map_iso, cones.forget],
      convert h j,
      simp },
    suffices : w ∈ filtration E.X c,
    { convert eX.inv.strict this,
      change _ = (eX.hom ≫ eX.inv) x,
      rw iso.hom_inv_id,
      refl },
    refine ⟨⟨_,hw⟩,rfl⟩ }
end

@[simps]
def _root_.strict_pseudo_normed_group_hom.level {M N : Type*}
  [pseudo_normed_group M] [pseudo_normed_group N]
  (f : strict_pseudo_normed_group_hom M N) (c) :
  filtration M c → filtration N c :=
λ x, ⟨f x, f.strict x.2⟩

@[simp]
lemma _root_.strict_pseudo_normed_group_hom.level_id
  (M : Type*) [pseudo_normed_group M] (c) :
  (strict_pseudo_normed_group_hom.id M).level c = id := by { ext, refl }

@[simp]
lemma _root_.strict_pseudo_normed_group_hom.level_comp {M N L : Type*}
  [pseudo_normed_group M] [pseudo_normed_group N] [pseudo_normed_group L]
  (f : strict_pseudo_normed_group_hom M N) (g : strict_pseudo_normed_group_hom N L) (c) :
  (f.comp g).level c = g.level c ∘ f.level c := by { ext, refl }

@[simps]
def level : nnreal ⥤ PseuNormGrp₁.{u} ⥤ Type u :=
{ obj := λ c,
  { obj := λ M, filtration M c,
    map := λ X Y f, f.level _,
    map_id' := λ M, strict_pseudo_normed_group_hom.level_id M _,
    map_comp' := λ M N L f g, f.level_comp g c },
  map := λ c₁ c₂ h,
  { app := λ M, pseudo_normed_group.cast_le' h.le } } .

lemma level_map {X Y : PseuNormGrp₁} (f : X ⟶ Y) (c) : (level.obj c).map f = f.level _ := rfl

lemma level_map' {X Y : PseuNormGrp₁} (f : X ⟶ Y) (c) : (level.obj c).map f =
  pseudo_normed_group.level f f.strict c := rfl

def level_cone_iso_hom (c) (t : (level.obj c).obj (bounded_cone_point C)) :
  (K ⋙ level.obj c).sections :=
{ val := λ j,
  { val := C.cone.π.app j t.1.1,
    property := begin
      obtain ⟨w,hw⟩ := t.2,
      apply_fun (λ e, e.val) at hw,
      rw ← hw,
      apply w.2
    end },
  property := begin
    intros i j f,
    ext,
    dsimp,
    rw ← C.cone.w f,
    refl,
  end }

def level_cone_iso_inv (c) (t : (K ⋙ level.obj c).sections) :
  (level.obj c).obj (bounded_cone_point C) :=
{ val :=
  { val := C.2.lift (Ab.explicit_limit_cone.{u u} _) ⟨λ j, (t.1 j).1, begin
      intros i j f,
      dsimp,
      change _ = (t.val _).val,
      rw ← t.2 f,
      refl,
    end⟩,
    property := begin
      use c,
      intros j,
      rw [← Ab.comp_apply, C.2.fac],
      dsimp [Ab.explicit_limit_cone],
      apply (t.1 j).2,
    end },
  property := begin
    refine ⟨⟨_,_⟩,rfl⟩,
    intros j,
    dsimp,
    rw [← Ab.comp_apply, C.2.fac],
    dsimp [Ab.explicit_limit_cone],
    apply (t.1 j).2,
  end } .

def level_cone_iso (c) :
  (level.obj c).map_cone (bounded_cone C) ≅ types.limit_cone.{u u} _ :=
cones.ext
{ hom := level_cone_iso_hom _ _,
  inv := level_cone_iso_inv _ _,
  hom_inv_id' := begin
    ext,
    dsimp [level_cone_iso_inv, level_cone_iso_hom],
    apply Ab.is_limit_ext,
    intros j,
    rw [← Ab.comp_apply, C.2.fac],
    refl,
  end,
  inv_hom_id' := begin
    ext,
    dsimp [level_cone_iso_inv, level_cone_iso_hom],
    rw [← Ab.comp_apply, C.2.fac],
    refl,
  end }
begin
  intros j,
  ext,
  refl,
end

instance preserves_limits_level_obj (c) : preserves_limits (level.obj c) :=
begin
  constructor, introsI J hJ, constructor, intros K,
  apply preserves_limit_of_preserves_limit_cone
    (bounded_cone_is_limit ⟨_, Ab.explicit_limit_cone_is_limit _⟩),
  apply is_limit.of_iso_limit (types.limit_cone_is_limit _) (level_cone_iso _ _).symm,
end

def neg_nat_trans (c) : level.obj.{u} c ⟶ level.obj.{u} c :=
{ app := λ X, pseudo_normed_group.neg',
  naturality' := begin
    intros A B f,
    ext,
    dsimp [level, neg'],
    simp,
  end }

end PseuNormGrp₁

namespace CompHausFiltPseuNormGrp₁

@[simp]
lemma id_apply {A : CompHausFiltPseuNormGrp₁} (a : A) : (𝟙 A : A ⟶ A) a = a := rfl

@[simp]
lemma comp_apply {A B C : CompHausFiltPseuNormGrp₁} (f : A ⟶ B) (g : B ⟶ C) (a : A) :
  (f ≫ g) a = g (f a) := rfl

def to_PNG₁ :
  CompHausFiltPseuNormGrp₁.{u} ⥤ PseuNormGrp₁.{u} :=
{ obj := λ M,
  { carrier := M,
    exhaustive' := M.exhaustive },
  map := λ X Y f, { strict' := λ c x h, f.strict h .. f.to_add_monoid_hom } }

instance : faithful to_PNG₁.{u} := faithful.mk $
begin
  intros X Y f g h,
  ext,
  apply_fun (λ e, e x) at h,
  exact h
end

variable {K : J ⥤ CompHausFiltPseuNormGrp₁.{u}}
variable (C : limits.limit_cone ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab))

def filtration_equiv (c : nnreal) :
  pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c
  ≃ (CompHaus.limit_cone.{u u} (K ⋙ level.obj c)).X :=
((cones.forget _).map_iso (PseuNormGrp₁.level_cone_iso C c)).to_equiv

instance (c) :
  topological_space (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
topological_space.induced (filtration_equiv C c) infer_instance

def filtration_homeo (c : nnreal) :
  pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c
  ≃ₜ (CompHaus.limit_cone.{u u} (K ⋙ level.obj c)).X :=
homeomorph.homeomorph_of_continuous_open (filtration_equiv _ _) continuous_induced_dom
begin
  intros U hU,
  have : inducing (filtration_equiv C c) := ⟨rfl⟩,
  rw this.is_open_iff at hU,
  obtain ⟨U,hU,rfl⟩ := hU,
  simpa,
end

instance (c) : t2_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.t2_space

instance (c) : compact_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.compact_space

/-
instance (c) : totally_disconnected_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.totally_disconnected_space
-/

def level_π (j c) : pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c →
  pseudo_normed_group.filtration (K.obj j) c :=
(PseuNormGrp₁.level.obj c).map ((PseuNormGrp₁.bounded_cone C).π.app j)

lemma level_π_continuous (j c) : continuous (level_π C j c) :=
begin
  have : level_π C j c ∘ (filtration_homeo C c).symm =
    (CompHaus.limit_cone.{u u} _).π.app j,
  { ext,
    change (C.is_limit.lift _ ≫ C.cone.π.app j) _ = _,
    rw C.is_limit.fac,
    refl },
  suffices : continuous (level_π C j c ∘ (filtration_homeo C c).symm),
    by simpa using this,
  rw this,
  continuity,
end

lemma bounded_cone_point_continuous_add'_aux {J : Type u}
  [small_category J]
  {K : J ⥤ CompHausFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c₁ c₂ : nnreal), continuous
  (pseudo_normed_group.add' :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) ×
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) (c₁ + c₂))) :=
begin
  intros c₁ c₂,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) ×
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) (c₁ + c₂)) :=
    pseudo_normed_group.add',
  change continuous g,
  suffices : continuous ((filtration_homeo C _) ∘ g), by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  let e := pseudo_normed_group.add' ∘ (prod.map (level_π C j c₁) (level_π C j c₂)),
  have he : continuous e,
  { apply continuous.comp,
    apply comphaus_filtered_pseudo_normed_group.continuous_add',
    apply continuous.prod_map,
    apply level_π_continuous,
    apply level_π_continuous },
  convert he,
  ext,
  dsimp,
  simpa,
end

lemma bounded_cone_point_continuous_neg'_aux {J : Type u}
  [small_category J]
  {K : J ⥤ CompHausFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c : nnreal), continuous
  (pseudo_normed_group.neg' :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c)) :=
begin
  intros c,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
    pseudo_normed_group.neg',
  change continuous g,
  suffices : continuous ((filtration_homeo C c) ∘ g),
    by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  dsimp [g],
  intros j,
  let e := pseudo_normed_group.neg' ∘ level_π C j c,
  have he : continuous e,
  { apply continuous.comp,
    apply comphaus_filtered_pseudo_normed_group.continuous_neg',
    apply level_π_continuous },
  convert he,
  ext,
  dsimp,
  simpa,
end

lemma bounded_cone_point_continuous_cast_le_aux {J : Type u}
  [small_category J]
  {K : J ⥤ CompHausFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c₁ c₂ : nnreal) (h : c₁ ≤ c₂), continuous
  (pseudo_normed_group.cast_le' h :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂)) :=
begin
  intros c₁ c₂ h,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) :=
    pseudo_normed_group.cast_le' h,
  change continuous g,
  suffices : continuous ((filtration_homeo C _) ∘ g), by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  dsimp [g],
  let e := pseudo_normed_group.cast_le' h ∘ level_π C j c₁,
  have he : continuous e,
  { apply continuous.comp,
    haveI : fact (c₁ ≤ c₂) := ⟨h⟩,
    apply comphaus_filtered_pseudo_normed_group.continuous_cast_le,
    apply level_π_continuous },
  exact he,
end

def bounded_cone_point : CompHausFiltPseuNormGrp₁ :=
{ M := PseuNormGrp₁.bounded_cone_point C,
  str :=
  { continuous_add' := bounded_cone_point_continuous_add'_aux _,
    continuous_neg' := bounded_cone_point_continuous_neg'_aux _,
    continuous_cast_le := λ _ _ h, bounded_cone_point_continuous_cast_le_aux _ _ _ h.out,
    ..(infer_instance : pseudo_normed_group (PseuNormGrp₁.bounded_cone_point C)) },
  exhaustive' := (PseuNormGrp₁.bounded_cone_point C).exhaustive }

def bounded_cone : cone K :=
{ X := bounded_cone_point C,
  π :=
  { app := λ j,
    { continuous' := λ c, level_π_continuous _ _ _,
      ..((PseuNormGrp₁.bounded_cone C).π.app j) },
    naturality' := begin
      intros i j f,
      ext,
      dsimp,
      rw ← (PseuNormGrp₁.bounded_cone C).w f,
      refl,
    end } }

def bounded_cone_is_limit : is_limit (bounded_cone C) :=
{ lift := λ S,
  { continuous' := begin
      intros c,
      let t : pseudo_normed_group.filtration S.X c →
        pseudo_normed_group.filtration (bounded_cone C).X c :=
        (((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S)).level _),
      change continuous t,
      suffices : continuous ((filtration_homeo C c) ∘ t), by simpa using this,
      have : ⇑(filtration_homeo C c) ∘ t =
        (CompHaus.limit_cone_is_limit.{u u} _).lift ((level.obj c).map_cone S),
      { ext,
        change (C.is_limit.lift _ ≫ C.cone.π.app _) _ = _,
        rw C.is_limit.fac, refl },
      rw this,
      continuity,
    end,
    ..((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S)) },
  fac' := begin
    intros S j,
    ext,
    dsimp [bounded_cone],
    change ((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S) ≫
      (PseuNormGrp₁.bounded_cone C).π.app j) _ = _,
    rw (PseuNormGrp₁.bounded_cone_is_limit C).fac,
    refl,
  end,
  uniq' := begin
    intros S m hm,
    ext,
    dsimp,
    have : to_PNG₁.map m =
      (PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S),
    { apply (PseuNormGrp₁.bounded_cone_is_limit C).uniq (to_PNG₁.map_cone S),
      intros j,
      ext t,
      specialize hm j,
      apply_fun (λ e, e t) at hm,
      exact hm },
    rw ← this,
    refl,
  end }

instance : preserves_limit K to_PNG₁ :=

begin
  apply preserves_limit_of_preserves_limit_cone,
  rotate 2,
  exact bounded_cone ⟨_,Ab.explicit_limit_cone_is_limit.{u u} _⟩,
  exact bounded_cone_is_limit _,
  exact PseuNormGrp₁.bounded_cone_is_limit _,
end

/-
Remark: This functor even creates limits, as can be shown using the fact that the forgetful
functor from `Profinite` to `Type*` creates limits.
I don't think we actually need that strong statement, so we only prove the following.
-/
instance : preserves_limits to_PNG₁ :=
begin
  constructor, introsI J hJ, constructor
end

end CompHausFiltPseuNormGrp₁

namespace ProFiltPseuNormGrp₁

@[simp]
lemma id_apply {A : ProFiltPseuNormGrp₁} (a : A) : (𝟙 A : A ⟶ A) a = a := rfl

@[simp]
lemma comp_apply {A B C : ProFiltPseuNormGrp₁} (f : A ⟶ B) (g : B ⟶ C) (a : A) :
  (f ≫ g) a = g (f a) := rfl

def to_PNG₁ :
  ProFiltPseuNormGrp₁.{u} ⥤ PseuNormGrp₁.{u} :=
{ obj := λ M,
  { carrier := M,
    exhaustive' := M.exhaustive },
  map := λ X Y f, { strict' := λ c x h, f.strict h .. f.to_add_monoid_hom } }

instance : faithful to_PNG₁.{u} := faithful.mk $
begin
  intros X Y f g h,
  ext,
  apply_fun (λ e, e x) at h,
  exact h
end

variable {K : J ⥤ ProFiltPseuNormGrp₁.{u}}
variable (C : limits.limit_cone ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab))

def filtration_equiv (c : nnreal) :
  pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c
  ≃ (Profinite.limit_cone (K ⋙ level.obj c)).X :=
((cones.forget _).map_iso (PseuNormGrp₁.level_cone_iso C c)).to_equiv

instance (c) :
  topological_space (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
topological_space.induced (filtration_equiv C c) infer_instance

def filtration_homeo (c : nnreal) :
  pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c
  ≃ₜ (Profinite.limit_cone (K ⋙ level.obj c)).X :=
homeomorph.homeomorph_of_continuous_open (filtration_equiv _ _) continuous_induced_dom
begin
  intros U hU,
  have : inducing (filtration_equiv C c) := ⟨rfl⟩,
  rw this.is_open_iff at hU,
  obtain ⟨U,hU,rfl⟩ := hU,
  simpa,
end

instance (c) : t2_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.t2_space

instance (c) : compact_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.compact_space

instance (c) : totally_disconnected_space
  (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
(filtration_homeo C c).symm.totally_disconnected_space

def level_π (j c) : pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c →
  pseudo_normed_group.filtration (K.obj j) c :=
(PseuNormGrp₁.level.obj c).map ((PseuNormGrp₁.bounded_cone C).π.app j)

lemma level_π_continuous (j c) : continuous (level_π C j c) :=
begin
  have : level_π C j c ∘ (filtration_homeo C c).symm =
    (Profinite.limit_cone _).π.app j,
  { ext,
    change (C.is_limit.lift _ ≫ C.cone.π.app j) _ = _,
    rw C.is_limit.fac,
    refl },
  suffices : continuous (level_π C j c ∘ (filtration_homeo C c).symm),
    by simpa using this,
  rw this,
  continuity,
end

lemma bounded_cone_point_continuous_add'_aux {J : Type u}
  [small_category J]
  {K : J ⥤ ProFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c₁ c₂ : nnreal), continuous
  (pseudo_normed_group.add' :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) ×
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) (c₁ + c₂))) :=
begin
  intros c₁ c₂,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) ×
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) (c₁ + c₂)) :=
    pseudo_normed_group.add',
  change continuous g,
  suffices : continuous ((filtration_homeo C _) ∘ g), by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  let e := pseudo_normed_group.add' ∘ (prod.map (level_π C j c₁) (level_π C j c₂)),
  have he : continuous e,
  { apply continuous.comp,
    apply comphaus_filtered_pseudo_normed_group.continuous_add',
    apply continuous.prod_map,
    apply level_π_continuous,
    apply level_π_continuous },
  convert he,
  ext,
  dsimp,
  simpa,
end

lemma bounded_cone_point_continuous_neg'_aux {J : Type u}
  [small_category J]
  {K : J ⥤ ProFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c : nnreal), continuous
  (pseudo_normed_group.neg' :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c)) :=
begin
  intros c,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c) :=
    pseudo_normed_group.neg',
  change continuous g,
  suffices : continuous ((filtration_homeo C c) ∘ g),
    by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  dsimp [g],
  intros j,
  let e := pseudo_normed_group.neg' ∘ level_π C j c,
  have he : continuous e,
  { apply continuous.comp,
    apply comphaus_filtered_pseudo_normed_group.continuous_neg',
    apply level_π_continuous },
  convert he,
  ext,
  dsimp,
  simpa,
end

lemma bounded_cone_point_continuous_cast_le_aux {J : Type u}
  [small_category J]
  {K : J ⥤ ProFiltPseuNormGrp₁}
  (C : category_theory.limits.limit_cone
         ((K ⋙ to_PNG₁) ⋙ PseuNormGrp₁.to_Ab)) :
  ∀ (c₁ c₂ : nnreal) (h : c₁ ≤ c₂), continuous
  (pseudo_normed_group.cast_le' h :
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂)) :=
begin
  intros c₁ c₂ h,
  let g : (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₁) →
    (pseudo_normed_group.filtration (PseuNormGrp₁.bounded_cone_point C) c₂) :=
    pseudo_normed_group.cast_le' h,
  change continuous g,
  suffices : continuous ((filtration_homeo C _) ∘ g), by simpa using this,
  apply continuous.subtype_mk,
  apply continuous_pi,
  intros j,
  dsimp [g],
  let e := pseudo_normed_group.cast_le' h ∘ level_π C j c₁,
  have he : continuous e,
  { apply continuous.comp,
    haveI : fact (c₁ ≤ c₂) := ⟨h⟩,
    apply comphaus_filtered_pseudo_normed_group.continuous_cast_le,
    apply level_π_continuous },
  exact he,
end

def bounded_cone_point : ProFiltPseuNormGrp₁ :=
{ M := PseuNormGrp₁.bounded_cone_point C,
  str :=
  { continuous_add' := bounded_cone_point_continuous_add'_aux _,
    continuous_neg' := bounded_cone_point_continuous_neg'_aux _,
    continuous_cast_le := λ _ _ h, bounded_cone_point_continuous_cast_le_aux _ _ _ h.out,
    ..(infer_instance : pseudo_normed_group (PseuNormGrp₁.bounded_cone_point C)) },
  exhaustive' := (PseuNormGrp₁.bounded_cone_point C).exhaustive }

def bounded_cone : cone K :=
{ X := bounded_cone_point C,
  π :=
  { app := λ j,
    { continuous' := λ c, level_π_continuous _ _ _,
      ..((PseuNormGrp₁.bounded_cone C).π.app j) },
    naturality' := begin
      intros i j f,
      ext,
      dsimp,
      rw ← (PseuNormGrp₁.bounded_cone C).w f,
      refl,
    end } }

def bounded_cone_is_limit : is_limit (bounded_cone C) :=
{ lift := λ S,
  { continuous' := begin
      intros c,
      let t : pseudo_normed_group.filtration S.X c →
        pseudo_normed_group.filtration (bounded_cone C).X c :=
        (((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S)).level _),
      change continuous t,
      suffices : continuous ((filtration_homeo C c) ∘ t), by simpa using this,
      have : ⇑(filtration_homeo C c) ∘ t =
        (Profinite.limit_cone_is_limit _).lift ((level.obj c).map_cone S),
      { ext,
        change (C.is_limit.lift _ ≫ C.cone.π.app _) _ = _,
        rw C.is_limit.fac, refl },
      rw this,
      continuity,
    end,
    ..((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S)) },
  fac' := begin
    intros S j,
    ext,
    dsimp [bounded_cone],
    change ((PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S) ≫
      (PseuNormGrp₁.bounded_cone C).π.app j) _ = _,
    rw (PseuNormGrp₁.bounded_cone_is_limit C).fac,
    refl,
  end,
  uniq' := begin
    intros S m hm,
    ext,
    dsimp,
    have : to_PNG₁.map m =
      (PseuNormGrp₁.bounded_cone_is_limit C).lift (to_PNG₁.map_cone S),
    { apply (PseuNormGrp₁.bounded_cone_is_limit C).uniq (to_PNG₁.map_cone S),
      intros j,
      ext t,
      specialize hm j,
      apply_fun (λ e, e t) at hm,
      exact hm },
    rw ← this,
    refl,
  end }

instance : preserves_limit K to_PNG₁ :=

begin
  apply preserves_limit_of_preserves_limit_cone,
  rotate 2,
  exact bounded_cone ⟨_,Ab.explicit_limit_cone_is_limit.{u u} _⟩,
  exact bounded_cone_is_limit _,
  exact PseuNormGrp₁.bounded_cone_is_limit _,
end

/-
Remark: This functor even creates limits, as can be shown using the fact that the forgetful
functor from `Profinite` to `Type*` creates limits.
I don't think we actually need that strong statement, so we only prove the following.
-/
instance : preserves_limits to_PNG₁ :=
begin
  constructor, introsI J hJ, constructor
end

end ProFiltPseuNormGrp₁


import smt.basic
import smt.veriT

namespace smt.parser
open smt (atom sexpr)
open smt.atom

-- #eval nat.of_char ['1','2','3','0']

end smt.parser

namespace smt

open parser tactic ( unsafe_run_io )

-- def foo_bar :=
-- do h ← io.proc.spawn
--         { cmd := "veriT",
--           args := [
--                    -- "--proof-prune","--proof-merge","--proof-with-sharing",
--                            -- "--cnf-definitional","--disable-ackermann",
--                            -- "--disable-e",
--                            -- "--max-time=3",
--                            -- "--input=smtlib2",
--                            -- "--print-flat",
--                            -- "--disable-banner",
--                            -- "--print-simp-and-exit",
--                            "--proof=file.log"
--                              -- "--input=test.smt",
--                              -- "test.smt"
--                            ],
--           stdin := stdio.piped,
--           stdout := stdio.piped,
--           stderr := stdio.piped,
--           -- cwd := _,
--           -- env := _
--           },
--    -- xs ← buffer.to_string <$> io.fs.read_file "test.smt",
--    -- io.fs.put_str_ln h.stdin xs,
--    let xs := [ "; Integer arithmetic",
--                "(set-option :print-success false)",
--                "(set-option :produce-proofs true)",
--                "(set-logic QF_LIA)",
--                ";; (echo \"foo\")",
--                "(declare-fun x ( ) Int)",
--                "(declare-fun y ( ) Int)",
--                "(assert (! (= (- x y) (+ x (- y) 1)) :named h0))",
--                "(assert (= x y))",
--                "(check-sat)",
--                ";; (get-value ((x 0) (y 0) (x 1) (y 1)))",
--                ";; (get-model)",
--                "(get-proof)",
--                "; unsat",
--                ";; (exit)" ],
--    xs.mmap' (io.fs.put_str_ln h.stdin),
--    io.fs.close h.stdin,
--    -- dir ← io.env.get_cwd,
--    -- io.print $ dir.to_list,
--    -- io.put_str_ln h,
--    -- h' ← io.cmd { cmd := "pwd" },
--    -- io.put_str_ln h',
--    io.put_str_ln "stderr",
--    xs ← read_to_end h.stderr,
--    io.put_str_ln xs.to_string,
--    io.put_str_ln "stdout",
--    xs ← read_to_end h.stdout,
--    io.put_str_ln xs.to_string,
--    io.proc.wait h,
--    parse_log,
--    pure ()

-- run_cmd unsafe_run_io parse_log -- unsafe_run_io foo_bar

end smt

-- meta instance name.reflect : has_reflect name
-- | name.anonymous        := `(name.anonymous)
-- | (name.mk_string  s n) := `(λ n, name.mk_string  s n).subst (name.reflect n)
-- | (name.mk_numeral i n) := `(λ n, name.mk_numeral i n).subst (name.reflect n)

namespace tactic.interactive

open smt (hiding expr) tactic smt.parser
open smt.sexpr smt.atom

-- | _ := fail "run_step"

open smt.logic_fragment (hiding hashable) tactic

-- -- Currently, QF_UF/QF_IDL/QF_RDL/QF_UFIDL are covered by proof production.
-- meta def insert_with {k α} (m : rb_map k α) (f : α → α → α) (x : k) (y : α) : rb_map k α :=
-- match m.find x with
-- | some y₀ := m.insert x (f y y₀)
-- | none := m.insert x y
-- end

-- meta def of_list_with {key data} [has_lt key] [decidable_rel $ @has_lt.lt key _] (f : data → data → data) :
--   list (key × data) → rb_map key data
-- | []           := native.rb_map.mk key data
-- | ((k, v)::ls) := insert_with (of_list_with ls) f k v

meta def hash_context : tactic word64 :=
do t ← target,
   (h,_) ← solve_aux t $ do {
     ls ← local_context,
     revert_lst ls,
     hash <$> target
     },
   pure h
open smt io io.process io.fs
meta def parse_log (fn : string) (prover : solver) : tactic prover.proof_type :=
do p ← tactic.unsafe_run_io $ io.fs.read_file fn,
   parser.run prover.read p

-- def cache {α} (f : unit → α) := trunc { x : option α // x.get_or_else (f ()) = f () }

-- def cache.mk {α} (f : unit → α) : cache f :=
-- trunc.mk ⟨ none,rfl ⟩

-- def cache.read {α} {f : unit → α} : cache f → α :=
-- trunc.lift (λ y : { s : option α // _ }, y.val.get_or_else (f ())) $
-- by { intros, casesm* [subtype _], simp *, }

-- lemma cache.read_eq  {α} {f : unit → α} (x : cache f) :
--   x.read = f () :=
-- trunc.induction_on x $
-- by { rintros ⟨ a, h ⟩, simp [cache.read,trunc.lift_beta,*], }

meta def unique_file_name (logic : logic_fragment) (prover : solver) (ext : string) : tactic string :=
do h ← hash_context,
   let h' := @hash_with_salt _ (prod.hashable _ _) (prover,logic) h,
   pure $ "proof_witness_" ++ to_string (h') ++ "." ++ ext

meta def write_formulas (logic : logic_fragment) (prover : solver) (xs : list string) (h : handle) : io unit :=
do let opts := prover.options ++ [
               "(set-option :produce-proofs true)",
               "(set-logic " ++ repr logic ++ ")"  ],
   opts.mmap' $ io.fs.put_str_ln h,
   xs.mmap' io.put_str,
   xs.mmap' $ io.fs.put_str h,
   io.fs.put_str_ln h "(check-sat)",
   io.fs.put_str_ln h "(get-proof)"

meta def mk_args (prover : solver) (fn : string) : list string :=
match prover.output_to_file with
| (some opt) := prover.args ++ [opt ++ fn]
| none := prover.args
end

meta def call_solver (logic : logic_fragment) (prover : solver) (fn : string) (xs : list string) : tactic string :=
unsafe_run_io $
do let args := mk_args prover fn,
   h ← io.proc.spawn
     { cmd := prover.cmd,
       args := args,
       stdin := stdio.piped,
       stdout := stdio.piped,
       stderr := stdio.piped },
   write_formulas logic prover xs h.stdin,
   close h.stdin,
   when (prover.output_to_file.is_none) $
     do { ln ← buffer.to_string <$> get_line h.stdout,
          io.put_str ln,
          file ← mk_file_handle fn mode.write,
          if ln = "unsat\n" then
          do proof ← read_to_end h.stdout,
             write file proof,
             io.put_str_ln proof.to_string
          else pure (),
          close file },
   -- xs ← buffer.to_string <$> read_to_end h.stdout,
   -- io.put_str_ln xs,
   xs ← buffer.to_string <$> read_to_end h.stderr,
   io.put_str_ln xs,
   proc.wait h,
   pure fn

open smt.logic_fragment
meta def veriT (logic : logic_fragment := QF_LIA) : tactic unit :=
do by_contradiction none,
   dedup,
   -- try $ `[norm_num at *],
   let prover := smt.veriT,
   -- `[dsimp only [has_pow.pow,pnat.pow,nat.pow,monoid.has_pow,gpow] { fail_if_unchanged := ff } ],
   fn ← unique_file_name logic prover "log",
   trace $ repr logic,
   trace fn,
   ls ← local_context,
   ps ← ls.mmap encode_local,
   unsafe_run_io $ do {
     h ← io.mk_file_handle fn mode.write,
     io.fs.write h "".to_char_buffer },
   fn ← call_solver logic prover fn ps,
   p ← parse_log fn prover,
   prover.execute p,
   done,
   pure ()

end tactic.interactive


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.interactive_base init.meta.tactic init.meta.set_get_option_tactics

structure cc_config :=
/- If tt, congruence closure will treat implicit instance arguments as constants. -/
(ignore_instances : bool               := tt)
/- If tt, congruence closure modulo AC. -/
(ac               : bool               := tt)
/- If ho_fns is (some fns), then full (and more expensive) support for higher-order functions is
   *only* considered for the functions in fns and local functions. The performance overhead is described in the paper
   "Congruence Closure in Intensional Type Theory". If ho_fns is none, then full support is provided
   for *all* constants. -/
(ho_fns           : option (list name) := none)
/- If true, then use excluded middle -/
(em               : bool               := tt)

/-- Congruence closure state.
This may be considered to be a set of expressions and an equivalence class over this set.
The equivalence class is generated by the equational rules that are added to the cc_state and congruence,
that is, if `a = b` then `f(a) = f(b)` and so on.
 -/
meta constant cc_state                  : Type
meta constant cc_state.mk_core          : cc_config → cc_state
/-- Create a congruence closure state object using the hypotheses in the current goal. -/
meta constant cc_state.mk_using_hs_core : cc_config → tactic cc_state
/-- Get the next element in the equivalence class.
Note that if the given expr e is not in the graph then it will just return e. -/
meta constant cc_state.next             : cc_state → expr → expr
/-- Returns the root expression for each equivalence class in the graph.
If the bool argument is set to true then it only returns roots of non-singleton classes. -/
meta constant cc_state.roots_core       : cc_state → bool → list expr
/-- Get the root representative of the given expression. -/
meta constant cc_state.root             : cc_state → expr → expr
/-- "Modification Time". The field m_mt is used to implement the mod-time optimization introduce by the Simplify theorem prover.
The basic idea is to introduce a counter gmt that records the number of heuristic instantiation that have
occurred in the current branch. It is incremented after each round of heuristic instantiation.
The field m_mt records the last time any proper descendant of of thie entry was involved in a merge. -/
meta constant cc_state.mt               : cc_state → expr → nat
/-- "Global Modification Time". gmt is a number stored on the cc_state,
it is compared with the modification time of a cc_entry in e-matching. See `cc_state.mt`. -/
meta constant cc_state.gmt              : cc_state → nat
/-- Increment the Global Modification time. -/
meta constant cc_state.inc_gmt          : cc_state → cc_state
/-- Check if `e` is the root of the congruence class. -/
meta constant cc_state.is_cg_root       : cc_state → expr → bool
/-- Pretty print the entry associated with the given expression. -/
meta constant cc_state.pp_eqc           : cc_state → expr → tactic format
/-- Pretty print the entire cc graph.
If the bool argument is set to true then singleton equivalence classes will be omitted. -/
meta constant cc_state.pp_core          : cc_state → bool → tactic format
/-- Add the given expression to the graph. -/
meta constant cc_state.internalize      : cc_state → expr → tactic cc_state
/-- Add the given proof term as a new rule.
The proof term p must be an `eq _ _`, `heq _ _`, `iff _ _`, or a negation of these. -/
meta constant cc_state.add              : cc_state → expr → tactic cc_state
/-- Check whether two expressions are in the same equivalence class. -/
meta constant cc_state.is_eqv           : cc_state → expr → expr → tactic bool
/-- Check whether two expressions are not in the same equivalence class. -/
meta constant cc_state.is_not_eqv       : cc_state → expr → expr → tactic bool
/-- Returns a proof term that the given terms are equivalent in the given cc_state-/
meta constant cc_state.eqv_proof        : cc_state → expr → expr → tactic expr
/-- Returns true if the cc_state is inconsistent. For example if it had both `a = b` and `a ≠ b` in it.-/
meta constant cc_state.inconsistent     : cc_state → bool
/-- `proof_for cc e` constructs a proof for e if it is equivalent to true in cc_state -/
meta constant cc_state.proof_for        : cc_state → expr → tactic expr
/-- `refutation_for cc e` constructs a proof for `not e` if it is equivalent to false in cc_state -/
meta constant cc_state.refutation_for   : cc_state → expr → tactic expr
/-- If the given state is inconsistent, return a proof for false. Otherwise fail. -/
meta constant cc_state.proof_for_false  : cc_state → tactic expr
namespace cc_state

meta def mk : cc_state :=
cc_state.mk_core {}

meta def mk_using_hs : tactic cc_state :=
cc_state.mk_using_hs_core {}

meta def roots (s : cc_state) : list expr :=
cc_state.roots_core s tt

meta instance : has_to_tactic_format cc_state :=
⟨λ s, cc_state.pp_core s tt⟩

meta def eqc_of_core (s : cc_state) : expr → expr → list expr → list expr
| e f r :=
  let n := s.next e in
  if n = f then e::r else eqc_of_core n f (e::r)

meta def eqc_of (s : cc_state) (e : expr) : list expr :=
s.eqc_of_core e e []

meta def in_singlenton_eqc (s : cc_state) (e : expr) : bool :=
s.next e = e

meta def eqc_size (s : cc_state) (e : expr) : nat :=
(s.eqc_of e).length

meta def fold_eqc_core {α} (s : cc_state) (f : α → expr → α) (first : expr) : expr → α → α
| c a :=
  let new_a := f a c,
      next  := s.next c in
  if next =ₐ first then new_a
  else fold_eqc_core next new_a

meta def fold_eqc {α} (s : cc_state) (e : expr) (a : α) (f : α → expr → α) : α :=
fold_eqc_core s f e e a

meta def mfold_eqc {α} {m : Type → Type} [monad m] (s : cc_state) (e : expr) (a : α) (f : α → expr → m α) : m α :=
fold_eqc s e (return a) (λ act e, do a ← act, f a e)
end cc_state

open tactic
meta def tactic.cc_core (cfg : cc_config) : tactic unit :=
do intros, s ← cc_state.mk_using_hs_core cfg, t ← target, s ← s.internalize t,
   if s.inconsistent then do {
     pr ← s.proof_for_false,
     mk_app `false.elim [t, pr] >>= exact}
   else do {
     tr ← return $ expr.const `true [],
     b ← s.is_eqv t tr,
     if b then do {
       pr ← s.eqv_proof t tr,
       mk_app `of_eq_true [pr] >>= exact
     } else do {
       dbg ← get_bool_option `trace.cc.failure ff,
       if dbg then do {
         ccf ← pp s,
         fail format!"cc tactic failed, equivalence classes: \n{ccf}"
       } else do {
         fail "cc tactic failed"
       }
     }
   }

meta def tactic.cc : tactic unit :=
tactic.cc_core {}

meta def tactic.cc_dbg_core (cfg : cc_config) : tactic unit :=
save_options $
  set_bool_option `trace.cc.failure tt
  >> tactic.cc_core cfg

meta def tactic.cc_dbg : tactic unit :=
tactic.cc_dbg_core {}

meta def tactic.ac_refl : tactic unit :=
do (lhs, rhs) ← target >>= match_eq,
   s ← return $ cc_state.mk,
   s ← s.internalize lhs,
   s ← s.internalize rhs,
   b ← s.is_eqv lhs rhs,
   if b then do {
     s.eqv_proof lhs rhs >>= exact
   } else do {
     fail "ac_refl failed"
   }


import
    -- data.real.basic
    -- topology.instances.real
    -- measure_theory.borel_space
    -- measure_theory.measure_space
    states
universe u
open set topological_space classical
local attribute [instance] prop_decidable

-- ALL FILES IN THIS FOLDER ARE A WORK IN PROGRESS.
-- THE TERMINOLOGY AND IDEAS DEFINED HERE ALSO DIFFER
-- MARKEDLY FROM ONTOLOGY.LEAN.
-- THIS FILE USED TO BE THE ROOT OF THE PROJECT.

/-! # State Spaces

Here we develop the higher order consequences of our theory,
which are a consequence of the notion of state. We expand
the notion of state to define state spaces for substances,
and prove associated lemmas.

We adopt the convention that all dependent types of a substance
are to be upper cased, so for instance the type of states of a
substance `s` is `s.State`.

-/

-- TODO: refactor so our naming convention is valid.
-- TODO: refactor proofs so they are correct under the
-- new definition of states (they worked before).

namespace ontology

 variables {ω : ontology} (s : ω.substance)
 include ω

 -- The type of states of a substance
 @[reducible]
 def substance.State := quotient s.State_setoid

 -- The quotient map from worlds to states,
 -- which ontologically grounds set of states as entities.
--  @[reducible]
--  def substance.f := @quotient.mk ω.world s.State_setoid

 @[reducible]
 def substance.State_at (w : ω.world) := @quotient.mk ω.world s.State_setoid w

 -- Recall that the quotient of a topological space
 -- is itself a topological space. Therefore the type
 -- of states of a substance is naturally endowed with
 -- topological structure. A set of states will be open
 -- if and only if the set of all worlds in which the substance is
 -- in one of the states is itself open, so any nonempty set of states
 -- can only be open if there is some entity which exists precisely in
 -- the worlds in which the entity has one of those states.
 -- Therefore any nonempty set of states is ontologically grounded,
 -- and so we can consider any such set to be an ontologically grounded
 -- property of the substance, and this we call a perfection.

 @[reducible]
 def substance.Event := set s.State

 structure substance.Perfection :=
    -- the event of the perfection existing in the substance
    (exist : s.Event)
    (is_open : is_open exist)
    (ne : exist.nonempty)
    (nuniv : exist ≠ univ)

 -- We added nuniv because the necessary s.Event should not really
 -- be considered an internal perfection of the substance, since it
 -- is grounded in the nb and is always necessary.

 -- Accidents of a substance are perfections of the same substance.
 -- The most important step in this proof is to show that they are open.
 lemma state_open_of_accident : ∀ (a: ω.accident), a.inheres s → is_open (s.State_at '' a.exists) := sorry
--  begin
--     intros a H,
--     apply is_open_coinduced.2,
--     simp [preimage],
--     let α := {x : ω.world | ∃ (x_1 : ω.world), x_1 ∈ (a.val).exists ∧ substance.equiv s x_1 x},
--     suffices c : is_open α,
--         exact c,
--     suffices c : α  = a.val.exists,
--         rw c,
--         exact a.val.existential,
--     ext, constructor; intro h; simp at *,
--         obtain ⟨y, h₁, h₂⟩ := h,
--         simp [substance.equiv, substance.state] at h₂,
--         simp [ontology.world.entities, entity.subsistents] at h₂,

--         -- have c : {a : ω.accident | a.inheres s} ∩ {a : ω.accident | y ∈ (a.val).exist} ⊆
--         --          {a : ω.accident | a.inheres s} ∩ {a : ω.accident | x ∈ (a.val).exist},
--         -- rw h₂,
--         -- exact and.right (@c a ⟨H, h₁⟩),
--     existsi x,
--     constructor,
--         assumption,
--     obtain ⟨res, _, _⟩ := substance.equiv_sound s,
--     exact res x,
--  end

 -- It should then be easier to prove that it is not empty
 lemma state_ne_of_accident : ∀ (a: ω.accident), a.inheres s → (s.State_at '' a.exists).nonempty :=
 begin
    intros a H,
    simp [preimage],
    exact a.possible,
 end

 -- But it is a little bit harder to prove it is not univ
 lemma state_nuniv_of_accident : ∀ (a: ω.accident), a.inheres s → (s.State_at '' a.exists) ≠ univ := sorry
--  begin
--     intros a H,
--     simp [preimage, image, quotient.mk],
--     intro h,
--     -- This is a trick
--     -- let ψ := (@quotient.mk world ontology.substance.State_setoid),
--     replace h : univ ⊆ {b : quotient s.State_setoid | ∃ (a_1 : ω.world), a_1 ∈ (a.val).exists ∧ s.State_at a_1 = b},
--         rw ←h,
--         -- refl,
--     have c : s.val.exists = a.val.exists,
--     ext, constructor; intro h₁,--; simp at *,
--         have c := @h (s.State_at x) _,
--         simp at c,
--         obtain ⟨y, c₁, c₂⟩ := c,
--         replace c₂ : s.equiv y x := c₂,
--         simp [substance.equiv, substance.state] at c₂,
--         simp [ontology.world.entities, entity.subsistents] at c₂,
--         have c : {a : ω.accident | a.inheres s} ∩ {a : ω.accident | y ∈ (a.val).exist} ⊆
--                  {a : ω.accident | a.inheres s} ∩ {a : ω.accident | x ∈ (a.val).exist},
--         rw c₂,
--         exact and.right (@c a ⟨H, c₁⟩),
--             trivial,
--         revert x,
--         apply sub_of_inheres,
--         exact H,
--     have c₁ : s.val.exists.dense := s.property,
--     have c₂ : ¬ a.val.exists.dense := a.property,
--     rw c at c₁,
--     contradiction,
--  end

 -- Finally we can construct the perfection.
 def substance.Perfection_of (a ∈ s.accidents) : s.Perfection :=
    ⟨ s.State_at '' a.exists
    , state_open_of_accident s a H
    , state_ne_of_accident s a H
    , state_nuniv_of_accident s a H
    ⟩

 -- perfections which come from accidents
 @[reducible]
 def substance.aperfections := {p : s.Perfection | ∃ a ∈ s.accidents, (s.Perfection_of a H) = p}

 -- events which come from accidents
 @[reducible]
 def substance.aevents := {p : s.Event | ∃ a ∈ s.accidents, (s.Perfection_of a H).exist = p}

 instance state_has_mem : has_mem s.Perfection s.State :=
 ⟨λ p s, s ∈ p.exist⟩
 @[reducible]
 def perfections (x : s.State) := {p : s.Perfection | p ∈ x}

 -- We can also build a neighborhood for any state
 -- which is an aperfection in case the substance has
 -- accidents in that state and the whole space otherwise.

 structure nhd {s : ω.substance} (x : s.State) :=
    (U : s.Event)
    (is_open : is_open U)
    (elem : x ∈ U)

 noncomputable def state.nhd_default {s : ω.substance} (x : s.State) : nhd x :=
    begin
        classical,
        set elab_help := s.State_setoid,
        -- lets build a world which maps to x
        -- and has some accident, the associated perfection of which
        -- will be our neighborhood. If no such world exists, we
        -- will just use univ.
        by_cases w : ∃w, ⟦w⟧ = x ∧ (∃a : ω.accident, a.inheres s ∧ a.up ∈ w),
        swap,
            exact ⟨univ, is_open_univ, by simp⟩,
        replace w := nonempty_subtype.2 w,
        replace w := classical.choice w,
        obtain ⟨w, hw, a⟩ := w,
        replace a := nonempty_subtype.2 a,
        replace a := classical.choice a,
        obtain ⟨a, ha₁, ha₂⟩ := a,
        -- a is now our wanted accident.
        let p := s.Perfection_of a ha₁,
        -- it is now easier to build the neighborhood.
        fconstructor,
            exact p.exist,
            exact p.is_open,
        rw ←hw,
        simp [p,substance.Perfection_of],
        existsi w,
        exact ⟨ha₂, rfl⟩,
    end

 -- Each contingent substance has a bottom state. For a contingent substance
 -- this is the "state" in which the substance does not exist.

 --  lemma aux : contingent s → ∀ w,

 --  def aux (h : contingent s) : nonempty (subtype s.val.exists.compl) := sorry

 --  @[reducible]
 --  noncomputable def state_bot (h : contingent s) : s.State :=
 --      have c : ¬ ∀ x, x ∈ s.val.exists,
 --         by {obtain ⟨⟨exist, is_open, nes⟩, perfect⟩ := s,
 --             intro h',
 --             replace h' := eq_univ_of_forall h',
 --             simp [contingent, nb, nbe] at h,
 --             simp at h',
 --             contradiction,
 --            },
 --     --  φ $
 --     --  classical.choice $
 --     --  nonempty_of_exists $
 --     --  not_forall.mp c
 --     -- have d : nonempty (subtype s.val.exists.compl),
 --     --     begin
 --     --         replace c := not_forall.mp c,
 --     --         obtain ⟨x, hx⟩ := c,
 --     --         constructor,
 --     --         exact ⟨x, hx⟩,
 --     --     end,
 --     φ $
 --     subtype.val $
 --     choice $
 --     aux h

 --   begin
 --     classical,
 --     obtain ⟨⟨exist, is_open, nes⟩, perfect⟩ := s,
 --     simp [contingent, nb, nbe] at h,
 --     set s : ω.substance := ⟨⟨exist, is_open, nes⟩, perfect⟩,
 --     have c : ¬ ∀ x, x ∈ exist,
 --         intro h',
 --         replace h' := eq_univ_of_forall h',
 --         contradiction,
 --     replace c := not_forall.mp c,
 --     replace c := nonempty_of_exists c,
 --     replace c := classical.choice c,
 --     exact φ s c,
 --   end

 -- set_option trace.elaborator_detail true
 --  lemma bot_no_accidents (h : contingent s) : (s.State_set (@quotient.out _ s.State_setoid (state_bot h))) = ∅ :=
 --     begin
 --         set elab_help := s.State_setoid,
 --         simp [substance.State_set],
 --         apply eq_empty_iff_forall_not_mem.2,
 --         intro x,
 --         simp,
 --         -- simp [state_bot, ontology.φ],
 --         intros h₂ h₃,
 --         -- simp at h₃,
 --         have d := sub_of_inheres x s h₂,
 --         replace h₃ := d h₃,
 --         -- simp [(choice (aux s h)).property] at h₃,
 --         -- set c := subtype.val (choice (aux s h),
 --         -- let c := quotient.mk_out ⟦(choice (aux s h)).val⟧,
 --         -- simp [quotient.out],
 --     end

 -- The bottom has no perfections.
 -- For the necessary being it is rather that
 -- we should consider it to have a single necessary
 -- informal "perfection" which is the set which
 -- contains only the unique state of the nb.
 --   lemma state_bot_empty : perfections ⊥ = ∅ :=
 --    begin
 --     classical,
 --     set elab_help := s.State_setoid,
 --      simp [perfections],
 --      apply eq_empty_of_subset_empty,
 --      intros p hp,
 --      simp at *,
 --      let e := quotient.mk⁻¹' p.exists,
 --      let state := p.ne.some,
 --      have c : is_open e ∧ e.nonempty,
 --         constructor,
 --         exact p.existential,
 --         simp [set.nonempty],
 --         use state.out,
 --         simp,
 --         exact p.ne.some_mem,
 --     let e₂ : entity := ⟨e, c.1, c.2⟩,
 --         -- apply mem_preimage.2,
 --         -- exact p.ne,
 --         -- focus {library_search},
 --     --  by_cases contingent s;
 --     --  simp [has_bot.bot, h, has_mem.mem] at hp,

 --    end

 -- Every state space is T0 but not T1, so that its specialization order
 -- has a botton element. For a contingent substance
 -- this is the "state" in which the substance does not exist.
 -- For the necessary being it is its unique state.
 --  instance state_order_bot : order_bot s.State :=
 --   begin
 --     classical,
 --     fconstructor,
 --         by_cases contingent s,
 --             obtain ⟨⟨exist, is_open, nes⟩, perfect⟩ := s,
 --             simp [contingent, nb, nbe] at h,
 --             set s : ω.substance := ⟨⟨exist, is_open, nes⟩, perfect⟩,
 --             have c : ¬ ∀ x, x ∈ exist,
 --                 intro h',
 --                 replace h' := eq_univ_of_forall h',
 --                 contradiction,
 --             replace c := not_forall.mp c,
 --             replace c := nonempty_of_exists c,
 --             replace c := classical.choice c,
 --             exact φ s c,
 --         exact φ s (default world),
 --     intros x₁ x₂,
 --     exact ∀ p : s.Perfection, p ∈ x₁ → p ∈ x₂,
 --         intros x p h,
 --         exact h,
 --     intros x y z h₁ h₂ p hp,
 --     exact h₂ p (h₁ p hp),
 --         intros x y h₁ h₂,
 --         admit,
 --     intros x p hp,
 --     by_cases contingent s;
 --     simp [h] at hp,
 --   end

 -- Next we wish to show that the perfections which come from accidents
 -- form a basis.
 --  lemma accidents_nhds : ∀ (w : s.State) (U : set s.State), w ∈ U → is_open U → ∃ V ∈ s.aevents, w ∈ V ∧ V ⊆ U :=
 --  begin
 --      intros w U H op,
 --  end

 --  #check is_topological_basis_of_open_of_nhds

 -- Then we want to show that unions of accidents also map
 -- to perfections, and that all perfections are generated this way.

end ontology


import Lean.Meta
import Lean.Elab
open Lean.Core
open Lean.Meta
open Lean.Elab.Term
open Lean

def mvarMeta4 : MetaM Expr := do
  let mvar ← mkFreshExprMVar (some (mkConst ``Nat))
  let mvarId := mvar.mvarId!
  let mvar2 ← mkFreshExprMVar (some (mkConst ``Nat)) -- none works too
  let mvarId2 := mvar2.mvarId!
  assignExprMVar mvarId2 (mkApp (mkConst `Nat.succ) mvar) -- eg tactic returns mvar seeking mvar2
  withLocalDecl Name.anonymous BinderInfo.default (mkConst ``Nat)  $ fun x =>
  do
    assignExprMVar mvarId x
    let q ← mkLambdaFVars #[x] mvar2
    return q

syntax (name := minass) "minass!" : term

@[termElab minass] def minAssImpl4 : TermElab :=
  fun stx expectedType? =>
    do
      let e ← mvarMeta4
      return  e

def chkMinAss4  := minass!

#check chkMinAss4
#eval chkMinAss4 2

theorem zero_add : (n : Nat) →  0 + n = n := by
  intro n
  induction n
  case zero => rfl
  case succ n ih => rw [Nat.add_succ, ih]

open Nat

def recFn : Nat → Nat :=
  fun n =>
  match n with
   | zero =>  zero
   | succ n  =>  succ (recFn n)
  /-
  Nat.brecOn n
    fun n f =>
      (match n : (n : Nat) → Nat.below n → Nat with
        | zero => fun x => zero
        | succ n => fun x => succ x.fst.fst)
        f
-/
/-by
  intro n
  match n with
   | zero => exact zero
   | succ n  => exact succ (recFn n)
-/
#print recFn

#check Nat.rec
#check Nat.below

#check Eq.mp
#check congrArg

def rwPush  (mvarId : MVarId) (e : Expr) (heq : Expr)
      (symm : Bool := false): TermElabM (Expr × Nat) :=
  do
    let t ← inferType e
    let rwr ← Meta.rewrite mvarId t heq symm
    let pf := rwr.eqProof
    let tt := rwr.eNew
    Elab.logInfo m!"mvars : {rwr.mvarIds.length}"
    let pushed ← mkAppM `Eq.mp #[pf, e]
    return (pushed, rwr.mvarIds.length)

open Lean.Elab.Tactic

syntax (name := rwPushTac) "rwPushTac" term "on" term : tactic
@[tactic rwPushTac] def rwPushImpl : Tactic :=
  fun stx  =>
  match stx with
  | `(tactic|rwPushTac $t on $s) =>
    withMainContext $
    do
      let mvarId ← getMainGoal
      let e ← Elab.Tactic.elabTerm s none
      let heq ← Elab.Tactic.elabTerm t none
      let (rw, l) ← rwPush mvarId e heq
      Elab.logInfo m!"obtained {rw}"
      if ← isDefEq (← inferType rw) (← getMainTarget)
        then
        assignExprMVar mvarId rw
        replaceMainGoal []
        else
        throwTacticEx `rwPushTac mvarId m!"rwPush failed"
      return ()
  | _ => Elab.throwIllFormedSyntax

def pushEg {α : Type}{P: α → Type}{a b : α}(heq : a = b)(x : P a) : P b := by
    rwPushTac heq on x

#check @pushEg
#reduce @pushEg

def transPf {α : Type}{a b c : α}(f: α → Nat) :
          a = b → b = c → a = c := by
          intros h1  h2
          rwPushTac h2 on h1

#reduce transPf


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jared Roesch, Sebastian Ullrich

The Except monad transformer.
-/
prelude
import Init.Control.Basic
import Init.Control.Id
import Init.Coe

namespace Except
variable {ε : Type u}

@[inline] protected def pure (a : α) : Except ε α :=
  Except.ok a

@[inline] protected def map (f : α → β) : Except ε α → Except ε β
  | Except.error err => Except.error err
  | Except.ok v => Except.ok <| f v

@[simp] theorem map_id : Except.map (ε := ε) (α := α) (β := α) id = id := by
  apply funext
  intro e
  simp [Except.map]; cases e <;> rfl

@[inline] protected def mapError (f : ε → ε') : Except ε α → Except ε' α
  | Except.error err => Except.error <| f err
  | Except.ok v      => Except.ok v

@[inline] protected def bind (ma : Except ε α) (f : α → Except ε β) : Except ε β :=
  match ma with
  | Except.error err => Except.error err
  | Except.ok v      => f v

@[inline] protected def toBool : Except ε α → Bool
  | Except.ok _    => true
  | Except.error _ => false

@[inline] protected def toOption : Except ε α → Option α
  | Except.ok a    => some a
  | Except.error _ => none

@[inline] protected def tryCatch (ma : Except ε α) (handle : ε → Except ε α) : Except ε α :=
  match ma with
  | Except.ok a    => Except.ok a
  | Except.error e => handle e

def orElseLazy (x : Except ε α) (y : Unit → Except ε α) : Except ε α :=
  match x with
  | Except.ok a    => Except.ok a
  | Except.error e => y ()

instance : Monad (Except ε) where
  pure := Except.pure
  bind := Except.bind
  map  := Except.map

end Except

def ExceptT (ε : Type u) (m : Type u → Type v) (α : Type u) : Type v :=
  m (Except ε α)

@[inline] def ExceptT.mk {ε : Type u} {m : Type u → Type v} {α : Type u} (x : m (Except ε α)) : ExceptT ε m α := x
@[inline] def ExceptT.run {ε : Type u} {m : Type u → Type v} {α : Type u} (x : ExceptT ε m α) : m (Except ε α) := x

namespace ExceptT

variable {ε : Type u} {m : Type u → Type v} [Monad m]

@[inline] protected def pure {α : Type u} (a : α) : ExceptT ε m α :=
  ExceptT.mk <| pure (Except.ok a)

@[inline] protected def bindCont {α β : Type u} (f : α → ExceptT ε m β) : Except ε α → m (Except ε β)
  | Except.ok a    => f a
  | Except.error e => pure (Except.error e)

@[inline] protected def bind {α β : Type u} (ma : ExceptT ε m α) (f : α → ExceptT ε m β) : ExceptT ε m β :=
  ExceptT.mk <| ma >>= ExceptT.bindCont f

@[inline] protected def map {α β : Type u} (f : α → β) (x : ExceptT ε m α) : ExceptT ε m β :=
  ExceptT.mk <| x >>= fun a => match a with
    | (Except.ok a)    => pure <| Except.ok (f a)
    | (Except.error e) => pure <| Except.error e

@[inline] protected def lift {α : Type u} (t : m α) : ExceptT ε m α :=
  ExceptT.mk <| Except.ok <$> t

instance : MonadLift (Except ε) (ExceptT ε m) := ⟨fun e => ExceptT.mk <| pure e⟩
instance : MonadLift m (ExceptT ε m) := ⟨ExceptT.lift⟩

@[inline] protected def tryCatch {α : Type u} (ma : ExceptT ε m α) (handle : ε → ExceptT ε m α) : ExceptT ε m α :=
  ExceptT.mk <| ma >>= fun res => match res with
   | Except.ok a    => pure (Except.ok a)
   | Except.error e => (handle e)

instance : MonadFunctor m (ExceptT ε m) := ⟨fun f x => f x⟩

instance : Monad (ExceptT ε m) where
  pure := ExceptT.pure
  bind := ExceptT.bind
  map  := ExceptT.map

@[inline] protected def adapt {ε' α : Type u} (f : ε → ε') : ExceptT ε m α → ExceptT ε' m α := fun x =>
  ExceptT.mk <| Except.mapError f <$> x

end ExceptT

instance (m : Type u → Type v) (ε₁ : Type u) (ε₂ : Type u) [Monad m] [MonadExceptOf ε₁ m] : MonadExceptOf ε₁ (ExceptT ε₂ m) where
  throw e := ExceptT.mk <| throwThe ε₁ e
  tryCatch x handle := ExceptT.mk <| tryCatchThe ε₁ x handle

instance (m : Type u → Type v) (ε : Type u) [Monad m] : MonadExceptOf ε (ExceptT ε m) where
  throw e := ExceptT.mk <| pure (Except.error e)
  tryCatch := ExceptT.tryCatch

instance [Monad m] [Inhabited ε] : Inhabited (ExceptT ε m α) where
  default := throw default

instance (ε) : MonadExceptOf ε (Except ε) where
  throw    := Except.error
  tryCatch := Except.tryCatch

namespace MonadExcept
variable {ε : Type u} {m : Type v → Type w}

/-- Alternative orelse operator that allows to select which exception should be used.
    The default is to use the first exception since the standard `orelse` uses the second. -/
@[inline] def orelse' [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) (useFirstEx := true) : m α :=
  tryCatch t₁ fun e₁ => tryCatch t₂ fun e₂ => throw (if useFirstEx then e₁ else e₂)

end MonadExcept

@[inline] def observing {ε α : Type u} {m : Type u → Type v} [Monad m] [MonadExcept ε m] (x : m α) : m (Except ε α) :=
  tryCatch (do let a ← x; pure (Except.ok a)) (fun ex => pure (Except.error ex))

def liftExcept [MonadExceptOf ε m] [Pure m] : Except ε α → m α
  | Except.ok a    => pure a
  | Except.error e => throw e

instance (ε : Type u) (m : Type u → Type v) [Monad m] : MonadControl m (ExceptT ε m) where
  stM        := Except ε
  liftWith f := liftM <| f fun x => x.run
  restoreM x := x

class MonadFinally (m : Type u → Type v) where
  tryFinally' {α β} : m α → (Option α → m β) → m (α × β)

export MonadFinally (tryFinally')

/-- Execute `x` and then execute `finalizer` even if `x` threw an exception -/
@[inline] def tryFinally {m : Type u → Type v} {α β : Type u} [MonadFinally m] [Functor m] (x : m α) (finalizer : m β) : m α :=
  let y := tryFinally' x (fun _ => finalizer)
  (·.1) <$> y

instance Id.finally : MonadFinally Id where
  tryFinally' := fun x h =>
   let a := x
   let b := h (some x)
   pure (a, b)

instance ExceptT.finally {m : Type u → Type v} {ε : Type u} [MonadFinally m] [Monad m] : MonadFinally (ExceptT ε m) where
  tryFinally' := fun x h => ExceptT.mk do
    let r ← tryFinally' x fun e? => match e? with
        | some (Except.ok a) => h (some a)
        | _                  => h none
    match r with
    | (Except.ok a,    Except.ok b)    => pure (Except.ok (a, b))
    | (_,              Except.error e) => pure (Except.error e)  -- second error has precedence
    | (Except.error e, _)              => pure (Except.error e)