import category_theory.limits.fubini

import for_mathlib.Profinite.extend
import for_mathlib.AddCommGroup.exact

import condensed.ab
import pseudo_normed_group.bounded_limits
import condensed.extr.lift_comphaus
import condensed.projective_resolution
import condensed.kernel_comparison

.

universes u v

noncomputable theory

open_locale nnreal

open category_theory category_theory.limits opposite pseudo_normed_group

-- move me
namespace CompHaus

variables {J : Type u} [small_category J]
  (F G : J ⥤ CompHaus.{u}) (α : F ⟶ G)
variables (cF : cone F) (cG : cone G) (hcF : is_limit cF) (hcG : is_limit cG)

def pt {X : CompHaus.{u}} (x : X) : (⊤_ CompHaus) ⟶ X :=
⟨λ _, x, continuous_const⟩

@[simps] def diagram_of_pt (y : cG.X) : J ⥤ CompHaus.{u} :=
{ obj := λ j, pullback (α.app j) (pt y ≫ cG.π.app j),
  map := λ i j f, pullback.lift (pullback.fst ≫ F.map f) pullback.snd
    (by rw [category.assoc, α.naturality, pullback.condition_assoc, category.assoc, cG.w]),
  map_id' := λ j, by apply pullback.hom_ext; dsimp; simp,
  map_comp' := λ i j k f g, by { apply pullback.hom_ext; dsimp; simp } }

.

@[simps] def cone_of_pt (y : cG.X) : cone (diagram_of_pt F G α cG y) :=
{ X := pullback (hcG.map cF α) (pt y),
  π :=
  { app := λ j, pullback.lift
      (pullback.fst ≫ cF.π.app _)
      pullback.snd
      (by rw [category.assoc, ← pullback.condition_assoc, is_limit.map_π]),
    naturality' := λ i j f, by apply pullback.hom_ext; dsimp; simp } }

.

def is_limit_cone_of_pt (y : cG.X) : is_limit (cone_of_pt F G α cF cG hcG y) :=
{ lift := λ S, pullback.lift
    (hcF.lift ⟨S.X,
    { app := λ j, S.π.app j ≫ pullback.fst,
      naturality' := begin
        intros i j f,
        dsimp,
        rw ← S.w f, dsimp [diagram_of_pt],
        simp only [category.id_comp, category.assoc, pullback.lift_fst],
      end }⟩)
    (terminal.from _)
    begin
      apply hcG.hom_ext, intros j, dsimp,
      simp only [category.assoc, is_limit.map_π, is_limit.fac_assoc, pullback.condition],
      ext, refl,
    end,
  fac' := begin
    intros s j, dsimp, apply pullback.hom_ext,
    { simp only [category.assoc, pullback.lift_fst, pullback.lift_fst_assoc, is_limit.fac] },
    { simp only [eq_iff_true_of_subsingleton] },
  end,
  uniq' := begin
    intros s m hm,
    dsimp at m hm,
    apply pullback.hom_ext,
    { rw pullback.lift_fst,
      apply hcF.hom_ext, intros j,
      simp only [category.assoc, is_limit.fac, ← hm j, pullback.lift_fst] },
    { simp only [eq_iff_true_of_subsingleton] }
  end }

lemma is_limit.surjective_of_surjective [is_cofiltered J]
  (hα : ∀ j, function.surjective (α.app j)) :
  function.surjective (hcG.map cF α) := λ y,
let E := cone_of_pt F G α cF cG hcG y,
  hE : is_limit E := is_limit_cone_of_pt F G α cF cG hcF hcG y in
begin
  suffices : ∃ (e : (⊤_ CompHaus.{u}) ⟶ E.X),
    e ≫ (pullback.fst : E.X ⟶ cF.X) ≫ hcG.map cF α = pt y,
  { obtain ⟨e,he⟩ := this,
    use (terminal.from (CompHaus.of punit) ≫ e ≫ pullback.fst) punit.star,
    rw ← comp_apply,
    have : y = (terminal.from (CompHaus.of punit) ≫ pt y) punit.star := rfl,
    conv_rhs { rw this }, clear this, congr' 1,
    apply hcG.hom_ext,
    intros j,
    simp only [←he, category.assoc] },
  let E' := CompHaus_to_Top.map_cone E,
  let hE' : is_limit E' := is_limit_of_preserves CompHaus_to_Top hE,
  let ee : E' ≅ Top.limit_cone.{u u} _ :=
    hE'.unique_up_to_iso (Top.limit_cone_is_limit _),
  let e : E'.X ≅ (Top.limit_cone.{u u} _).X :=
    hE'.cone_point_unique_up_to_iso (Top.limit_cone_is_limit _),
  haveI : ∀ j : J, t2_space (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intros j, change t2_space ((diagram_of_pt F G α cG y).obj j), apply_instance },
  haveI : ∀ j : J, compact_space (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intros j, change compact_space ((diagram_of_pt F G α cG y).obj j), apply_instance },
  haveI : ∀ j : J, nonempty (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intro j, change nonempty ((diagram_of_pt F G α cG y).obj j),
    dsimp only [diagram_of_pt_obj],
    let y' := (terminal.from (CompHaus.of punit) ≫ pt y ≫ cG.π.app j) punit.star,
    obtain ⟨x', hx'⟩ := hα j y',
    refine ⟨(terminal.from (CompHaus.of punit) ≫ pullback.lift (pt x') (𝟙 _) _) punit.star⟩,
    ext z, exact hx', },
  have := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system
    (diagram_of_pt F G α cG y ⋙ CompHaus_to_Top),
  obtain ⟨a⟩ := this,
  let b := e.inv a,
  use pt b,
  rw pullback.condition,
  refl,
end

-- Scott: perhaps life is easier if we use this version? I'm not too sure.
lemma is_limit.surjective_of_surjective' [is_cofiltered J]
  (hα : ∀ j, function.surjective (α.app j)) :
   function.surjective (lim_map α) :=
is_limit.surjective_of_surjective _ _ _ _ _ (limit.is_limit _) _ hα

end CompHaus

namespace CompHausFiltPseuNormGrp₁

-- move this
instance : has_zero_morphisms (CompHausFiltPseuNormGrp₁.{u}) :=
{ has_zero := λ M₁ M₂, ⟨0⟩,
  comp_zero' := λ _ _ f _, rfl,
  zero_comp' := λ _ _ _ f, by { ext, exact f.map_zero } }
variables {A B C : CompHausFiltPseuNormGrp₁.{u}}

structure exact_with_constant (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0) : Prop :=
(comp_eq_zero : f ≫ g = 0)
(cond : ∀ c : ℝ≥0, g ⁻¹' {0} ∩ (filtration B c) ⊆ f '' (filtration A (r c)))
(large : id ≤ r)

lemma exact_with_constant.exact {f : A ⟶ B} {g : B ⟶ C} {r : ℝ≥0 → ℝ≥0}
  (h : exact_with_constant f g r) :
  exact ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map f) ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map g) :=
begin
  rw AddCommGroup.exact_iff',
  split,
  { ext x, have := h.comp_eq_zero, apply_fun (λ φ, φ.to_fun) at this, exact congr_fun this x },
  { intros y hy,
    obtain ⟨c, hc⟩ := B.exhaustive y,
    obtain ⟨a, ha, rfl⟩ := h.cond c ⟨_, hc⟩,
    { exact ⟨a, rfl⟩ },
    { simp only [set.mem_preimage, set.mem_singleton_iff], exact hy } },
end

-- TODO remove this; it's a redundant alias
@[simps obj_obj obj_map_to_fun map_app {fully_applied := ff}]
def Filtration : ℝ≥0 ⥤ CompHausFiltPseuNormGrp₁.{u} ⥤ CompHaus.{u} :=
CompHausFiltPseuNormGrp₁.level

instance mono_Filtration_map_app (c₁ c₂ : ℝ≥0) (h : c₁ ⟶ c₂) (M) :
  mono ((Filtration.map h).app M) :=
by { rw CompHaus.mono_iff_injective, convert injective_cast_le _ _ }

namespace exact_with_constant
noncomputable theory

variables (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0) (c : ℝ≥0) (hrc : c ≤ r c)

variables {r c}

def c_le_rc : c ⟶ r c := hom_of_le $ hrc

/-- Given `f : A ⟶ B`, `P1` is the pullback `B_c ×_{B_{rc}} A_{rc}`. -/
def P1 : CompHaus :=
pullback ((Filtration.map (c_le_rc hrc)).app B) ((Filtration.obj (r c)).map f)

@[simps]
def pt {X : CompHaus} (x : X) : (⊤_ CompHaus) ⟶ X :=
⟨λ _, x, continuous_const⟩

/-- Given `g : B ⟶ C`, `P2` is the pullback `B_c ×_{C_c} {pt}`. -/
def P2 (c : ℝ≥0) : CompHaus :=
pullback ((Filtration.obj c).map g) (pt (0 : pseudo_normed_group.filtration C c))

def P1_to_P2 (hfg : f ≫ g = 0) : P1 f hrc ⟶ P2 g c :=
pullback.lift pullback.fst (terminal.from _)
begin
  rw [← cancel_mono ((Filtration.map (c_le_rc hrc)).app C), category.assoc,
    nat_trans.naturality, pullback.condition_assoc, ← functor.map_comp, hfg],
  refl,
end

lemma P1_to_P2_comp_fst (hfg : f ≫ g = 0) :
  P1_to_P2 f g hrc hfg ≫ pullback.fst = pullback.fst :=
pullback.lift_fst _ _ _

lemma surjective (h : exact_with_constant f g r) :
  ∃ (hfg : f ≫ g = 0), ∀ c, function.surjective (P1_to_P2 f g (h.large c) hfg) :=
begin
  have hfg : f ≫ g = 0,
  { ext x, exact fun_like.congr_fun h.exact.w x },
  refine ⟨hfg, _⟩,
  intros c y,
  let π₁ : P2 g c ⟶ (Filtration.obj c).obj B := pullback.fst,
  have hy : (π₁ y).val ∈ g ⁻¹' {0} ∩ filtration B c,
  asyncI
  { refine ⟨_, (π₁ y).2⟩,
    simp only [subtype.val_eq_coe, set.mem_preimage, set.mem_singleton_iff],
    have w := @pullback.condition _ _ _ _ _
      ((Filtration.obj c).map g) (pt (0 : pseudo_normed_group.filtration C c)) _,
    have := (fun_like.congr_fun w y),
    exact congr_arg subtype.val this, },
  obtain ⟨x, hx, hfx⟩ := h.cond c hy,
  let s : CompHaus.of punit ⟶ P1 f (h.large c) :=
  terminal.from _ ≫ pullback.lift (pt (π₁ y)) (pt ⟨x, hx⟩) _,
  swap, { ext t, exact hfx.symm },
  refine ⟨s punit.star, _⟩,
  suffices : s ≫ P1_to_P2 f g (h.large c) hfg = terminal.from _ ≫ pt y,
  { exact fun_like.congr_fun this punit.star },
  delta P1_to_P2,
  apply category_theory.limits.pullback.hom_ext,
  { simp only [category.assoc, pullback.lift_fst], refl },
  { exact subsingleton.elim _ _ }
end

lemma of_surjective (hfg : f ≫ g = 0) (hr : id ≤ r)
  (h : ∀ c, function.surjective (P1_to_P2 f g (hr c) hfg)) :
  exact_with_constant f g r :=
begin
  suffices H : ∀ (c : ℝ≥0), g ⁻¹' {0} ∩ filtration B c ⊆ f '' filtration A (r c),
  { refine ⟨_, H, hr⟩,
    ext x,
    have := congr_arg (coe_fn : (A ⟶ C) → (A → C)) hfg,
    exact congr_fun this x },
  rintro c y ⟨hy, hyc⟩,
  let t : CompHaus.of punit ⟶ P2 g c :=
  pullback.lift (terminal.from _ ≫ pt ⟨y, hyc⟩) (terminal.from _) _,
  swap, { ext, exact hy },
  obtain ⟨s, hs⟩ := h c (t punit.star),
  let π₂ : P1 f (hr c) ⟶ (Filtration.obj (r c)).obj A := pullback.snd,
  refine ⟨(π₂ s).val, _⟩,
  let P := CompHaus.of punit,
  suffices : terminal.from P ≫ pt s ≫ π₂ ≫ ((Filtration.obj (r c)).map f) =
    terminal.from _ ≫ pt ⟨y, filtration_mono (hr c) hyc⟩,
  { have hs := fun_like.congr_fun this punit.star, exact ⟨(π₂ s).2, congr_arg subtype.val hs⟩ },
  have H : terminal.from P ≫ pt s ≫ P1_to_P2 f g (hr c) hfg = t,
  { apply continuous_map.ext, rintro ⟨⟩, exact hs },
  erw [← pullback.condition, ← P1_to_P2_comp_fst f g (hr c) hfg, category.assoc,
    reassoc_of H, pullback.lift_fst_assoc],
  refl
end

lemma iff_surjective :
  exact_with_constant f g r ↔
  ∃ (hfg : f ≫ g = 0) (hr : ∀ c, c ≤ r c),
    ∀ c, function.surjective (P1_to_P2 f g (hr c) hfg) :=
begin
  split,
  { intro h, obtain ⟨hfg, H⟩ := surjective _ _ h, exact ⟨hfg, h.large, H⟩ },
  { rintro ⟨hfg, hr, h⟩, exact of_surjective f g hfg hr h }
end

end exact_with_constant

namespace exact_with_constant

variables {J : Type u} [small_category J]
variables {A' B' C' : J ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (f : A' ⟶ B') (g : B' ⟶ C') (r : ℝ≥0 → ℝ≥0) (c : ℝ≥0) (hrc : c ≤ r c)

variables {r c}

@[simps obj obj_obj obj_map map map_app { fully_applied := ff }]
def P1_functor : J ⥤ walking_cospan ⥤ CompHaus.{u} :=
functor.flip $ cospan
  (whisker_left B' (Filtration.map (c_le_rc hrc)))
  (whisker_right f (Filtration.obj (r c)))

@[simps obj obj_obj obj_map map map_app { fully_applied := ff }]
def P2_functor (c : ℝ≥0) : J ⥤ walking_cospan ⥤ CompHaus.{u} :=
functor.flip $ @cospan _ _ _ ((category_theory.functor.const _).obj (⊤_ _)) _
  (whisker_right g (Filtration.obj c))
  { app := λ j, pt (0 : pseudo_normed_group.filtration (C'.obj j) c),
    naturality' := by { intros, ext, exact (C'.map f).map_zero.symm } }

lemma P1_to_P2_nat_trans_aux_1 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) none =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) none :=
begin
  dsimp [P1_to_P2],
  simp only [iso.refl_hom, iso.refl_inv, nat_trans.comp_app, eq_to_iso_refl,
    category.id_comp, category.assoc,
    cones.postcompose_obj_π, lim_map_π_assoc, limit.lift_π,
    diagram_iso_cospan_hom_app, diagram_iso_cospan_inv_app,
    pullback_cone.mk_π_app_one, limit.lift_map],
  dsimp,
  simp only [←(Filtration.obj c).map_comp, category.comp_id, category.id_comp,
    nat_trans.naturality],
end

lemma P1_to_P2_nat_trans_aux_2 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.left) =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.left) :=
begin
  dsimp [P1_to_P2],
  simp only [iso.refl_hom ,iso.refl_inv, eq_to_iso_refl, nat_trans.comp_app,
    category.id_comp, category.assoc, pullback_cone.mk_π_app_left,
    cones.postcompose_obj_π, lim_map_π_assoc, limit.lift_π, limit.lift_map,
    diagram_iso_cospan_hom_app, diagram_iso_cospan_inv_app],
  dsimp,
  simp only [category.comp_id, category.id_comp],
end

lemma P1_to_P2_nat_trans_aux_3 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.right) =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.right) :=
begin
  dsimp [P1_to_P2],
  simp only [category.id_comp, category.assoc, eq_to_iso_refl, iso.refl_inv, nat_trans.comp_app,
    pullback_cone.mk_π_app_right, cones.postcompose_obj_π, limit.lift_π, limit.lift_map,
    diagram_iso_cospan_inv_app, eq_iff_true_of_subsingleton],
end

def P1_to_P2_nat_trans (hfg : f ≫ g = 0) :
  (P1_functor f hrc ⋙ lim) ⟶ (P2_functor g c ⋙ lim) :=
{ app := λ j, begin
    refine _ ≫ P1_to_P2 (f.app j) (g.app j) hrc (by { rw [← nat_trans.comp_app, hfg], refl }) ≫ _,
    { refine lim_map (diagram_iso_cospan _).hom, },
    { refine lim_map (_ ≫ (diagram_iso_cospan _).inv), exact 𝟙 _, }
  end,
  naturality' := λ X Y h, begin
    -- It would be nicer to use `pullback.hom_ext` here, but it doesn't unify.
    -- Nevertheless, we can bash out the remaining goals with `simp`.
    apply limit.hom_ext, rintros (⟨⟩|⟨⟨⟩⟩),
    { apply P1_to_P2_nat_trans_aux_1 _ _ _ hfg, },
    { apply P1_to_P2_nat_trans_aux_2 _ _ _ hfg, },
    { apply P1_to_P2_nat_trans_aux_3 _ _ _ hfg, },
  end }

attribute [simps] P1_to_P2_nat_trans

set_option pp.universes true

/-
TODO:

jmc: below is a framework for setting up some canonical isomorphisms between limits.
It really boils down to saying that limits commute.
This shouldn't be so hard...
I'm not convinced that this is the best way to do it,
there should be a more ergonomic approach.

scott: I've replaced the definition of `P1_iso`
with one that uses the general theory for commuting limits.
-/

instance (c : ℝ≥0) : preserves_limits (Filtration.obj c) :=
by { dsimp [Filtration], apply_instance, }

def P1_iso {A B : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) {r : ℝ≥0 → ℝ≥0} {c : ℝ≥0} (hrc : c ≤ r c) (S : Profinite) :
  P1.{u} ((Profinite.extend_nat_trans.{u u+1} f).app S) hrc ≅
    limit (P1_functor.{u} (whisker_left S.fintype_diagram f) hrc ⋙ lim) :=
begin
  refine has_limit.iso_of_nat_iso (_ ≪≫ (cospan_comp_iso _ _ _).symm) ≪≫
    (limit_flip_comp_lim_iso_limit_comp_lim _).symm,
  exact cospan_ext (preserves_limit_iso _ _) (preserves_limit_iso _ _) (preserves_limit_iso _ _)
    (by { apply limit.hom_ext, intros, ext, simp, })
    (begin
      apply limit.hom_ext,
      intros,
      simp [-category_theory.functor.map_comp, ←(Filtration.obj (r c)).map_comp],
    end)
end

open category_theory.limits

def P2_iso {B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (g : B ⟶ C) (c : ℝ≥0) (S : Profinite) :
  P2.{u} ((Profinite.extend_nat_trans.{u u+1} g).app S) c ≅
    limit (P2_functor.{u} (whisker_left S.fintype_diagram g) c ⋙ lim) :=
begin
  refine has_limit.iso_of_nat_iso (_ ≪≫ (cospan_comp_iso _ _ _).symm) ≪≫
    (limit_flip_comp_lim_iso_limit_comp_lim _).symm,
  fapply cospan_ext,
  exact (preserves_limit_iso _ _),
  exact category_theory.limits.limit_const_terminal.symm,
  exact (preserves_limit_iso _ _),
  { apply limit.hom_ext, intros, simp [-category_theory.functor.map_comp, ←(Filtration.obj c).map_comp], },
  { apply limit.hom_ext, intros, ext, simp, },
end

-- move me, generalize
lemma extend_aux {A₁ B₁ A₂ B₂ : CompHaus}
  (e₁ : A₁ ≅ B₁) (e₂ : A₂ ≅ B₂) (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (hf : epi f)
  (H : e₁.inv ≫ f ≫ e₂.hom = g) :
  epi g :=
by { subst H, apply epi_comp _ _, apply_instance, apply epi_comp }

-- move me, generalize
lemma extend_aux' {A₁ B₁ A₂ B₂ : CompHaus}
  (e₁ : A₁ ≅ B₁) (e₂ : A₂ ≅ B₂) (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (hf : epi f)
  (H : f = e₁.hom ≫ g ≫ e₂.inv) :
  epi g :=
by { rw [← iso.inv_comp_eq, iso.eq_comp_inv, category.assoc] at H, apply extend_aux e₁ e₂ f g hf H }

lemma extend_aux_1 {A B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}} {r : ℝ≥0 → ℝ≥0} {c : ℝ≥0}
  (S : Profinite.{u}) (f : A ⟶ B) (g : B ⟶ C) (hrc : c ≤ r c) (w w') :
  ((P1_iso.{u} f hrc S).symm.inv ≫
         lim_map.{u u u u+1}
             (P1_to_P2_nat_trans.{u}
                (whisker_left.{u u u+1 u u+1 u} S.fintype_diagram f)
                (whisker_left.{u u u+1 u u+1 u} S.fintype_diagram g) hrc w) ≫
           (P2_iso.{u} g c S).symm.hom) ≫
      pullback.fst.{u u+1} =
    P1_to_P2.{u} ((Profinite.extend_nat_trans.{u u+1} f).app S)
        ((Profinite.extend_nat_trans.{u u+1} g).app S) hrc w' ≫
      pullback.fst.{u u+1} :=
begin
  apply (cancel_mono ((preserves_limit_iso (Filtration.obj _) _).hom)).1,
  apply limit.hom_ext,
  { -- TODO this is not the prettiest proof.
    -- We need some good simp lemmas for `P1_iso`, `P2_iso`, and `P1_to_P2`.
    intro j,
    simp only [P1_to_P2_comp_fst, category_theory.preserves_limits_iso_hom_π, category_theory.category.assoc],
    dsimp [P2_iso],
    simp only [category_theory.iso.symm_inv,
      category_theory.limits.cospan_ext_inv_app_left,
      category_theory.iso.trans_inv,
      category_theory.nat_trans.comp_app,
      category_theory.category.id_comp,
      category_theory.preserves_limits_iso_inv_π,
      category_theory.limits.cospan_comp_iso_hom_app_left,
      category_theory.category.assoc,
      category_theory.limits.has_limit.iso_of_nat_iso_inv_π_assoc],
    erw [limit_flip_comp_lim_iso_limit_comp_lim_hom_π_π, lim_map_π_assoc],
    simp only [category_theory.category.id_comp,
      CompHausFiltPseuNormGrp₁.exact_with_constant.P1_to_P2_nat_trans_app,
      category_theory.category.assoc],
    erw [lim_map_π],
    dsimp [P1_to_P2],
    simp only [category_theory.category.comp_id,
      category_theory.iso.refl_hom,
      category_theory.eq_to_iso_refl,
      category_theory.limits.lim_map_π,
      category_theory.limits.diagram_iso_cospan_hom_app,
      category_theory.limits.pullback.lift_fst],
    dsimp [P1_iso],
    simp only [category_theory.category.assoc],
    erw [limit_flip_comp_lim_iso_limit_comp_lim_inv_π_π],
    simp only [category_theory.limits.has_limit.iso_of_nat_iso_hom_π_assoc,
      category_theory.nat_trans.comp_app,
      category_theory.iso.symm_hom,
      category_theory.limits.cospan_comp_iso_inv_app_left,
      category_theory.category.assoc,
      category_theory.iso.trans_hom,
      category_theory.limits.cospan_ext_hom_app_left],
    dsimp,
    simp only [category_theory.preserves_limits_iso_hom_π, category_theory.category.id_comp], },
  all_goals { apply_instance, },
end

lemma extend {A B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (f.app S) (g.app S) r) (S : Profinite) :
  exact_with_constant
    ((Profinite.extend_nat_trans f).app S) ((Profinite.extend_nat_trans g).app S) r :=
begin
  have hr : id ≤ r := (hfg $ Fintype.of punit).large,
  rw exact_with_constant.iff_surjective,
  refine ⟨_, hr, _⟩,
  { rw [← nat_trans.comp_app, ← Profinite.extend_nat_trans_comp],
    apply limit.hom_ext,
    intro X,
    specialize hfg (S.fintype_diagram.obj X),
    erw [zero_comp, limit.lift_π],
    simp only [cones.postcompose_obj_π, whisker_left_comp, nat_trans.comp_app,
      limit.cone_π, whisker_left_app, hfg.comp_eq_zero, comp_zero], },
  intros c,
  have hfg' : whisker_left.{u u u+1 u u+1 u} S.fintype_diagram f ≫
    whisker_left.{u u u+1 u u+1 u} S.fintype_diagram g = 0,
  { ext X : 2,
    simp only [nat_trans.comp_app, whisker_left_app, (hfg (S.fintype_diagram.obj X)).comp_eq_zero],
    refl },
  have key := CompHaus.is_limit.surjective_of_surjective'
    (P1_functor.{u} (whisker_left S.fintype_diagram f) (hr c) ⋙ lim)
    (P2_functor.{u} (whisker_left S.fintype_diagram g) c ⋙ lim)
    (P1_to_P2_nat_trans _ _ _ hfg') _,
  swap,
  { intro X, specialize hfg (S.fintype_diagram.obj X), rw [iff_surjective] at hfg,
    rcases hfg with ⟨aux', hr, hfg⟩, specialize hfg c,
    rw ← CompHaus.epi_iff_surjective at hfg ⊢,
    apply_with epi_comp {instances := ff},
    { show epi ((@limits.lim _ _ _ _ _).map _), apply_instance, },
    apply_with epi_comp {instances := ff},
    { exact hfg },
    { show epi ((@limits.lim _ _ _ _ _).map _), apply_instance, }, },
  rw ← CompHaus.epi_iff_surjective at key ⊢,
  refine extend_aux (P1_iso f (hr c) S).symm (P2_iso g c S).symm _ _ key _,
  apply pullback.hom_ext,
  apply extend_aux_1,
  apply subsingleton.elim,
end

end exact_with_constant

instance has_zero_nat_trans_CHFPNG₁ {𝒞 : Type*} [category 𝒞]
  (A B : 𝒞 ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  has_zero (A ⟶ B) :=
⟨⟨0, λ S T f, by { ext t, exact (B.map f).map_zero.symm }⟩⟩

@[simp] lemma zero_app {𝒞 : Type*} [category 𝒞] (A B : 𝒞 ⥤ CompHausFiltPseuNormGrp₁.{u}) (S) :
  (0 : A ⟶ B).app S = 0 := rfl

@[simp] lemma Profinite.extend_nat_trans_zero (A B : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  Profinite.extend_nat_trans (0 : A ⟶ B) = 0 :=
begin
  apply Profinite.extend_nat_trans_ext,
  rw [Profinite.extend_nat_trans_whisker_left],
  ext S : 2,
  simp only [nat_trans.comp_app, whisker_left_app, zero_app, zero_comp, comp_zero],
end

lemma exact_with_constant_extend_zero_left (A B C : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u})
  (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (0 : A.obj S ⟶ B.obj S) (g.app S) r) (S : Profinite) :
  exact_with_constant (0 : (Profinite.extend A).obj S ⟶ (Profinite.extend B).obj S)
    ((Profinite.extend_nat_trans g).app S) r :=
begin
  have := exact_with_constant.extend (0 : A ⟶ B) g r hfg S,
  simpa,
end

lemma exact_with_constant_extend_zero_right (A B C : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u})
  (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (f.app S) (0 : B.obj S ⟶ C.obj S) r) (S : Profinite) :
  exact_with_constant ((Profinite.extend_nat_trans f).app S)
    (0 : (Profinite.extend B).obj S ⟶ (Profinite.extend C).obj S) r :=
begin
  have := exact_with_constant.extend f (0 : B ⟶ C) r hfg S,
  simpa,
end

variables (C)

lemma exact_with_constant_of_epi (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0) (hr : id ≤ r)
  (hf : ∀ c, filtration B c ⊆ f '' (filtration A (r c))) :
  exact_with_constant f (0 : B ⟶ C) r :=
begin
  refine ⟨_, _, hr⟩,
  { rw comp_zero },
  { intro c, exact set.subset.trans (set.inter_subset_right _ _) (hf c), }
end

variables (A) {C}

lemma exact_with_constant_of_mono (g : B ⟶ C) [hg : mono ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map g)] :
  exact_with_constant (0 : A ⟶ B) g id :=
begin
  refine ⟨_, _, le_rfl⟩,
  { rw zero_comp },
  { rintro c x ⟨hx, -⟩,
    suffices : x = 0, { subst x, refine ⟨0, zero_mem_filtration _, rfl⟩, },
    simp only [set.mem_preimage, set.mem_singleton_iff] at hx,
    rw [AddCommGroup.mono_iff_injective, injective_iff_map_eq_zero] at hg,
    exact hg _ hx, }
end

end CompHausFiltPseuNormGrp₁

namespace Condensed

open CompHausFiltPseuNormGrp₁

lemma zero_iff_ExtrDisc {A B : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) :
  f = 0 ↔ (∀ S : ExtrDisc, f.val.app (op S.val) = 0) :=
begin
  split,
  { rintros ⟨rfl⟩, simp },
  { intros h,
    apply (Condensed_ExtrSheafProd_equiv Ab).functor.map_injective,
    apply (ExtrSheafProd_to_presheaf Ab).map_injective,
    ext : 2,
    apply h }
end

lemma exact_iff_ExtrDisc {A B C : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) (g : B ⟶ C) :
  exact f g ↔ ∀ (S : ExtrDisc),
    exact (f.1.app $ ExtrDisc_to_Profinite.op.obj (op S))
          (g.1.app $ ExtrDisc_to_Profinite.op.obj (op S)) :=
begin
  simp only [abelian.exact_iff, zero_iff_ExtrDisc, forall_and_distrib],
  refine and_congr iff.rfl _,
  apply forall_congr,
  intro S,
  symmetry,
  rw [← cancel_epi (kernel_iso g S).hom,
    ← cancel_mono (cokernel_iso f S).hom],
  dsimp only [functor.op_obj, ExtrDisc_to_Profinite_obj],
  simp only [category.assoc, zero_comp, comp_zero],
  erw [kernel_iso_hom_assoc, cokernel_iso_hom],
  exact iff.rfl,
end

open comphaus_filtered_pseudo_normed_group
open CompHausFiltPseuNormGrp₁.exact_with_constant (P1 P2 P1_to_P2 P1_to_P2_comp_fst c_le_rc)

lemma exact_of_exact_with_constant {A B C : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : exact_with_constant f g r) :
  exact (to_Condensed.map f) (to_Condensed.map g) :=
begin
  rw exact_iff_ExtrDisc,
  intro S,
  rw exact_with_constant.iff_surjective at hfg,
  rcases hfg with ⟨hfg, hr, H⟩,
  simp only [subtype.val_eq_coe, to_Condensed_map, CompHausFiltPseuNormGrp.Presheaf.map_app,
    whisker_right_app, Ab.exact_ulift_map],
  rw AddCommGroup.exact_iff',
  split,
  { show @CompHausFiltPseuNormGrp.presheaf.map.{u}
      (CHFPNG₁_to_CHFPNGₑₗ.obj A) (CHFPNG₁_to_CHFPNGₑₗ.obj C)
      (@strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.{u u} A C _ _ (f ≫ g))
      (unop.{u+2} (ExtrDisc_to_Profinite.{u}.op.obj (op S))) = 0,
    rw hfg, ext x s, refl, },
  { rintro ⟨_, c, y₀ : S.val → filtration B c, hy₀, rfl⟩ hy,
    dsimp at hy ⊢,
    let y : CompHaus.of S.val ⟶ (Filtration.obj c).obj B := ⟨y₀, hy₀⟩,
    let t : CompHaus.of S.val ⟶ P2 g c := pullback.lift y (terminal.from _) _,
    swap,
    { apply continuous_map.ext, intros a, apply subtype.ext,
      simp only [add_monoid_hom.mem_ker, CompHausFiltPseuNormGrp.presheaf.map_apply] at hy,
      have := congr_arg subtype.val hy,
      exact congr_fun this a },
    let s := ExtrDisc.lift' _ (H c) t,
    have hs : s ≫ P1_to_P2 f g (hr c) hfg = t := ExtrDisc.lift_lifts' _ _ _,
    let π₂ : P1 f (hr c) ⟶ (Filtration.obj (r c)).obj A := pullback.snd,
    let x₀ := (s ≫ π₂).1,
    have hx₀ := (s ≫ π₂).2,
    refine ⟨⟨_, _, x₀, hx₀, rfl⟩, _⟩,
    apply_fun (λ φ, φ ≫ pullback.fst) at hs,
    erw [pullback.lift_fst y (terminal.from _)] at hs,
    rw [category.assoc, P1_to_P2_comp_fst, ← cancel_mono ((Filtration.map (c_le_rc (hr c))).app B),
      category.assoc, pullback.condition] at hs,
    ext z,
    have := fun_like.congr_fun hs z,
    exact congr_arg subtype.val this, }
end
.

@[simp] lemma to_Condensed_map_zero (A B : CompHausFiltPseuNormGrp₁.{u}) :
  to_Condensed.map (0 : A ⟶ B) = 0 :=
by { ext S s x, refl, }

lemma mono_to_Condensed_map {A B : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (hf : exact_with_constant (0 : A ⟶ A) f id) :
  mono (to_Condensed.map f) :=
begin
  refine ((abelian.tfae_mono (to_Condensed.obj A) (to_Condensed.map f)).out 2 0).mp _,
  have := exact_of_exact_with_constant (0 : A ⟶ A) f id hf,
  simpa only [to_Condensed_map_zero],
end

lemma epi_to_Condensed_map {A B : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0) (hf : exact_with_constant f (0 : B ⟶ B) r) :
  epi (to_Condensed.map f) :=
begin
  refine ((abelian.tfae_epi (to_Condensed.obj B) (to_Condensed.map f)).out 2 0).mp _,
  have := exact_of_exact_with_constant f (0 : B ⟶ B) r hf,
  simpa only [to_Condensed_map_zero]
end

end Condensed


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Floris van Doorn, Mario Carneiro

! This file was ported from Lean 3 source module tactic.choose
! leanprover-community/mathlib commit fd47bdf09e90f553519c712378e651975fe8c829
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Function.Basic
import Mathbin.Tactic.Core

/-!
# `choose` tactic

Performs Skolemization, that is, given `h : ∀ a:α, ∃ b:β, p a b |- G` produces
`f : α → β, hf: ∀ a, p a (f a) |- G`.
-/

namespace Tactic

/-- Given `α : Sort u`, `nonemp : nonempty α`, `p : α → Prop`, a context of local variables
`ctxt`, and a pair of an element `val : α` and `spec : p val`,
`mk_sometimes u α nonemp p ctx (val, spec)` produces another pair `val', spec'`
such that `val'` does not have any free variables from elements of `ctxt` whose types are
propositions. This is done by applying `function.sometimes` to abstract over all the propositional
arguments. -/
unsafe def mk_sometimes (u : level) (α nonemp p : expr) :
    List expr → expr × expr → tactic (expr × expr)
  | [], (val, spec) => pure (val, spec)
  | e :: ctxt, (val, spec) => do
    let (val, spec) ← mk_sometimes ctxt (val, spec)
    let t ← infer_type e
    let b ← is_prop t
    pure <|
        if b then
          let val' := expr.bind_lambda val e
          (expr.const `` Function.sometimes [level.zero, u] t α nonemp val',
            expr.const `` Function.sometimes_spec [u] t α nonemp p val' e spec)
        else (val, spec)
#align tactic.mk_sometimes tactic.mk_sometimes

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Changes `(h : ∀xs, ∃a:α, p a) ⊢ g` to `(d : ∀xs, a) (s : ∀xs, p (d xs)) ⊢ g` and
      `(h : ∀xs, p xs ∧ q xs) ⊢ g` to `(d : ∀xs, p xs) (s : ∀xs, q xs) ⊢ g`.
      `choose1` returns a pair of the second local constant it introduces,
      and the error result (see below).

      If `nondep` is true and `α` is inhabited, then it will remove the dependency of `d` on
      all propositional assumptions in `xs`. For example if `ys` are propositions then
      `(h : ∀xs ys, ∃a:α, p a) ⊢ g` becomes `(d : ∀xs, a) (s : ∀xs ys, p (d xs)) ⊢ g`.

      The second value returned by `choose1` is the result of nondep elimination:
      * `none`: nondep elimination was not attempted or was not applicable
      * `some none`: nondep elimination was successful
      * ``some (some `(nonempty α))``: nondep elimination was unsuccessful
        because we could not find a `nonempty α` instance
      -/
    unsafe
  def
    choose1
    ( nondep : Bool ) ( h : expr ) ( data : Name ) ( spec : Name )
      : tactic ( expr × Option ( Option expr ) )
    :=
      do
        let t ← infer_type h
          let ( ctxt , t ) ← whnf t >>= open_pis
          let t ← whnf t Transparency.all
          match
            t
            with
            |
                q( @ Exists $ ( α ) $ ( p ) )
                =>
                do
                  let α_t ← infer_type α
                    let expr.sort u ← whnf α_t transparency.all
                    let
                      ( ne_fail , nonemp )
                        ←
                        if
                          nondep
                          then
                          do
                            let ne := expr.const ` ` Nonempty [ u ] α
                              let
                                nonemp
                                  ←
                                  try_core
                                    (
                                      mk_instance Ne
                                        <|>
                                        retrieve'
                                          do
                                            let m ← mk_meta_var Ne
                                              set_goals [ m ]
                                              ctxt
                                                fun
                                                  e
                                                    =>
                                                    do
                                                      let b ← is_proof e
                                                        Monad.unlessb b
                                                          <|
                                                          (
                                                              mk_app ` ` Nonempty.intro [ e ]
                                                                >>=
                                                                note_anon none
                                                              )
                                                            $>
                                                            ( )
                                              reset_instance_cache
                                              apply_instance
                                              instantiate_mvars m
                                      )
                              pure ( some ( Option.guard ( fun _ => nonemp ) Ne ) , nonemp )
                          else
                          pure ( none , none )
                    let ctxt' ← if nonemp then ctxt fun e => not <$> is_proof e else pure ctxt
                    let value ← mk_local_def data ( α ctxt' )
                    let t' ← head_beta ( p ( value ctxt' ) )
                    let spec ← mk_local_def spec ( t' ctxt )
                    let
                      ( value_proof , spec_proof )
                        ←
                        nonemp
                          pure
                            ( fun nonemp => mk_sometimes u α nonemp p ctxt )
                            (
                              expr.const ` ` Classical.choose [ u ] α p ( h ctxt )
                                ,
                                expr.const ` ` Classical.choose_spec [ u ] α p ( h ctxt )
                              )
                    dependent_pose_core
                      [ ( value , value_proof ctxt' ) , ( spec , spec_proof ctxt ) ]
                    try ( tactic.clear h )
                    intro1
                    let e ← intro1
                    pure ( e , ne_fail )
              |
                q( $ ( p ) ∧ $ ( q ) )
                =>
                do
                  mk_app ` ` And.left [ h ctxt ] >>= lambdas ctxt >>= note data none
                    let hq ← mk_app ` ` And.right [ h ctxt ] >>= lambdas ctxt >>= note spec none
                    try ( tactic.clear h )
                    pure ( hq , none )
              | _ => fail "expected a term of the shape `∀xs, ∃a, p xs a` or `∀xs, p xs ∧ q xs`"
#align tactic.choose1 tactic.choose1

/-- Changes `(h : ∀xs, ∃as, p as ∧ q as) ⊢ g` to a list of functions `as`,
and a final hypothesis on `p as` and `q as`. If `nondep` is true then the functions will
be made to not depend on propositional arguments, when possible.

The last argument is an internal recursion variable, indicating whether nondep elimination
has been useful so far. The tactic fails if `nondep` is true, and nondep elimination is
attempted at least once, and it fails every time it is attempted, in which case it returns
an error complaining about the first attempt.
-/
unsafe def choose (nondep : Bool) :
    expr → List Name → optParam (Option (Option expr)) none → tactic Unit
  | h, [], _ => fail "expect list of variables"
  | h, [n], some (some Ne) => do
    let g ← mk_meta_var Ne
    set_goals [g]
    -- make a reasonable error state
        fail
        "choose: failed to synthesize nonempty instance"
  | h, [n], _ => do
    let cnt ← revert h
    intro n
    intron (cnt - 1)
    return ()
  | h, n :: ns, ne_fail₁ => do
    let (v, ne_fail₂) ← get_unused_name >>= choose1 nondep h n
    choose v ns <|
        match ne_fail₁, ne_fail₂ with
        | none, _ => ne_fail₂
        | some none, _ => some none
        | _, some none => some none
        | _, _ => ne_fail₁
#align tactic.choose tactic.choose

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `choose a b h h' using hyp` takes an hypothesis `hyp` of the form
`∀ (x : X) (y : Y), ∃ (a : A) (b : B), P x y a b ∧ Q x y a b`
for some `P Q : X → Y → A → B → Prop` and outputs
into context two functions `a : X → Y → A`, `b : X → Y → B` and two assumptions:
`h : ∀ (x : X) (y : Y), P x y (a x y) (b x y)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x y) (b x y)`. It also works with dependent versions.

`choose! a b h h' using hyp` does the same, except that it will remove dependency of
the functions on propositional arguments if possible. For example if `Y` is a proposition
and `A` and `B` are nonempty in the above example then we will instead get
`a : X → A`, `b : X → B`, and the assumptions
`h : ∀ (x : X) (y : Y), P x y (a x) (b x)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x) (b x)`.

Examples:

```lean
example (h : ∀n m : ℕ, ∃i j, m = n + i ∨ m + j = n) : true :=
begin
  choose i j h using h,
  guard_hyp i : ℕ → ℕ → ℕ,
  guard_hyp j : ℕ → ℕ → ℕ,
  guard_hyp h : ∀ (n m : ℕ), m = n + i n m ∨ m + j n m = n,
  trivial
end
```

```lean
example (h : ∀ i : ℕ, i < 7 → ∃ j, i < j ∧ j < i+i) : true :=
begin
  choose! f h h' using h,
  guard_hyp f : ℕ → ℕ,
  guard_hyp h : ∀ (i : ℕ), i < 7 → i < f i,
  guard_hyp h' : ∀ (i : ℕ), i < 7 → f i < i + i,
  trivial,
end
```
-/
unsafe def choose (nondep : parse (parser.optional (tk "!"))) (first : parse ident)
    (names : parse (parser.many ident)) (tgt : parse (parser.optional (tk "using" *> texpr))) :
    tactic Unit := do
  let tgt ←
    match tgt with
      | none => get_local `this
      | some e => tactic.i_to_expr_strict e
  tactic.choose nondep tgt (first :: names)
  try
      (interactive.simp none none tt [simp_arg_type.expr ``(exists_prop)] []
        (loc.ns <| some <$> names))
  try (tactic.clear tgt)
#align tactic.interactive.choose tactic.interactive.choose

add_tactic_doc
  { Name := "choose"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.choose]
    tags := ["classical logic"] }

end Interactive

end Tactic


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

import Mathlib

/-
  Some helpful lemmas about heterogenous equalities
-/

  /-- Consecutive casts can be reduced to a single cast, by transitivity  -/
  theorem cast_trans {α β : Sort _} (a : α) {h₁ : α = β} {h₂ : β = γ} :
    (cast h₂ $ cast h₁ a) = cast (Eq.trans h₁ h₂) a :=
  by
    apply eq_of_heq;
    apply HEq.trans (b:=cast h₁ a)
    apply cast_heq
    apply HEq.trans
    apply cast_heq
    apply HEq.symm
    apply cast_heq

  theorem heq_cast_left {α α' β : Sort _} (a : α) (b : β) (h : α = α') :
    HEq (cast h a) b = HEq a b :=
  by
    apply propext;
    constructor
    <;> intro premise;
    . have : HEq a (cast h a) := HEq.symm $ cast_heq _ _
      apply HEq.trans this;
      assumption;
    . apply HEq.trans _ premise;
      apply cast_heq;

  theorem heq_cast_right {α β β' : Sort _} (a : α) (b : β) {h : β = β'} :
    HEq a (cast h b) = HEq a b :=
  by
    apply propext;
    constructor
    <;> intro premise;
    . have : HEq (cast h b) b := cast_heq _ _
      apply HEq.trans _ this;
      assumption;
    . apply HEq.trans premise;
      apply HEq.symm;
      apply cast_heq;

  -- theorem heq_cast_right' {α I : Type _} {β β' : I → Type _} {i : I} (a : α) (b : β i) {h : β i = β' i} :
  --   HEq a (cast h b) = HEq a b :=
  -- by
  --   apply propext;
  --   constructor
  --   <;> intro premise;
  --   . have : HEq (cast h b) b := cast_heq _ _
  --     apply HEq.trans _ this;
  --     assumption;
  --   . apply HEq.trans premise;
  --     apply HEq.symm;
  --     apply cast_heq;

  theorem heq_fun_congr {α α' γ} (a : γ → α) (h : α = α') :
    HEq (fun x => (cast h $ a x)) a :=
  by
    cases h;
    simp only [cast_eq, heq_eq_eq]

  theorem heq_cast_left_fun {α α' β γ : Type _} (a : γ → α) (b : β) (h : α = α') :
    HEq (fun x => (cast h $ a x)) b = HEq a b :=
  by
    apply propext;
    constructor
    <;> intro premise
    <;> cases premise;
    . apply HEq.symm; apply heq_fun_congr;
    . apply heq_fun_congr;

  theorem heq_cast_right_fun {α α' β γ : Type _} (a : γ → α) (b : β) (h : α = α') :
    HEq b (fun x => (cast h $ a x)) = HEq b a :=
  by
    apply propext;
    constructor
    <;> intro premise
    <;> cases premise;
    . apply heq_fun_congr;
    . apply HEq.symm; apply heq_fun_congr;

  /-
  # Congruence
  -/
  theorem hcongr_fun {α : Sort _} {P P' : α → Sort _}
                     {f : (a : α) → P a}
                     {f' : (a : α) → P' a}
                     (a : α)
                     (H₁ : HEq f f')
                     (H₂ : P = P') :
    HEq (f a) (f' a) :=
  by
    cases H₂; cases H₁; rfl;

  theorem hcongr {α α' : Sort _} {P : α → Sort _} {P' : α' → Sort _}
                 {f : (a : α) → P a}
                 {f' : (a' : α') → P' a'}
                 (a : α) (a' : α')
                 (H₁ : HEq f f')
                 (H₂ : HEq a a')
                 (H₃ : α = α')
                 (H₄ : ∀ a, P a = P' (cast H₃ a)) :
    HEq (f a) (f' a') :=
  by
    cases H₂;
    apply hcongr_fun _ H₁;
    funext a;
    simp [cast_eq] at H₃;
    apply H₄;

  /-
  # Cast-related equalities
  -/

  theorem heq_of_eq' {α β} {a : α} {b : β} (h : β = α)  :
    a = cast h b → HEq a b :=
  by
    intro eq;
    cases eq;
    apply cast_heq;

  theorem heq_of_eq_left' {α β} {a : α} {b : β} (h : α = β)  :
    cast h a = b → HEq a b :=
  by
    intro eq;
    apply HEq.symm;
    apply heq_of_eq' h eq.symm

  theorem cast_arg  {α α' : Sort u₁}
                    {β : α → Sort u₂}
                    {β' : α' → Sort u₂}
                    {f : (a : α) → β a}
                    (a' : α')
                    (h₁ : α' = α)
                    (h₂ : ((a : α) → β a) = ((a' : α') → β' a'))
                    (h₃ : ∀ a', β (cast h₁ a') = β' a') :
    (cast (β:=(a' : α') → β' a') h₂ f) a'
      = cast (h₃ _) (f $ cast h₁ a') :=
  by
    apply eq_of_heq;
    rw [heq_cast_right];
    apply hcongr
    . apply cast_heq
    . apply HEq.symm; apply cast_heq
    . intro a'; apply Eq.symm; apply h₃

  theorem cast_arg' {α : Sort u₁} {β β' : α → Sort u₂}
                    {f : (a : α) → β a}
                    (a : α)
                    (h₁ : ((a : α) → β a) = ((a : α) → β' a))
                    (h₂ : ∀ a, β a = β' a) :
    (cast (β:=(a : α) → β' a ) h₁ f) a
      = cast (h₂ _) (f a) :=
  by
    apply cast_arg;
    rfl

  theorem cast_fun_arg {h : α = β} {f : β → γ} :
    HEq (fun (a : α) => f <| cast h a ) f :=
  by
    cases h
    simp only [cast_eq, heq_eq_eq]

  /-
  # Function Extensionality
  -/

  theorem HEq.funext {α : Sort u} {β₁ β₂ : α → Sort _}
                      {f₁ : (x : α) → β₁ x}
                      {f₂ : (x : α) → β₂ x}
                      (type_eq : β₁ = β₂ )
                      :
    (∀ (x : α), HEq (f₁ x) (f₂ x)) → HEq f₁ f₂ :=
  by
    cases type_eq
    intro h;
    apply heq_of_eq
    funext a
    apply eq_of_heq <| h a

  theorem HEq.funext' {α₁ α₂ : Sort u} {β₁ : α₁ → Sort _} {β₂ : α₂ → Sort _}
                      {f₁ : (x : α₁) → β₁ x}
                      {f₂ : (x : α₂) → β₂ x}
                      (type_eq_α : α₁ = α₂ )
                      (type_eq_β : ∀ a, (β₁ a) = (β₂ <| cast type_eq_α a) )
                      :
    (∀ (x : α₁), HEq (f₁ x) (f₂ <| cast type_eq_α x)) → HEq f₁ f₂ :=
  by
    cases type_eq_α
    apply HEq.funext
    funext x
    apply type_eq_β

section Tactic
  open Lean.Parser.Tactic

  /-- Calls `simp` with a bunch of theorems that are useful for simplifying heterogeneous
      equalities and casts
   -/
  syntax "simp_heq" (config)? (discharger)? ("only ")? ("[" simpLemma,* "]")? (location)? : tactic
  macro_rules
  | `(tactic| simp_heq $[$cfg:config]? $[$dis:discharger]? $[$loc:location]? )
      => `(tactic| simp $[$cfg]? $[$dis]?
                        only [cast_trans, heq_cast_left, heq_cast_right, cast_eq, cast_heq,
                          heq_cast_left_fun, heq_cast_right_fun, cast_arg', HEq.refl]
                        $[$loc]?
          )

end Tactic


universe u
variables (α β : Type u)

example (f : α → β) (a : α) : (λ x, f x) a = f a := eq.refl _
example (a : α) (b : α) : (a, b).1 = a := eq.refl _
example : 2 + 3 = 5 := eq.refl _


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.reflexive
import category_theory.monad.adjunction
import category_theory.monad.coequalizer

/-!
# Adjoint lifting

This file gives two constructions for building left adjoints: the adjoint triangle theorem and the
adjoint lifting theorem.
The adjoint triangle theorem says that given a functor `U : B ⥤ C` with a left adjoint `F` such
that `ε_X : FUX ⟶ X` is a regular epi. Then for any category `A` with coequalizers of reflexive
pairs, a functor `R : A ⥤ B` has a left adjoint if (and only if) the composite `R ⋙ U` does.
Note that the condition on `U` regarding `ε_X` is automatically satisfied in the case when `U` is
a monadic functor, giving the corollary: `monadic_adjoint_triangle_lift`, i.e. if `U` is monadic,
`A` has reflexive coequalizers then `R : A ⥤ B` has a left adjoint provided `R ⋙ U` does.

The adjoint lifting theorem says that given a commutative square of functors (up to isomorphism):

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` and `V` are monadic and `A` has reflexive coequalizers, then if `R` has a left adjoint
then `Q` has a left adjoint.

## Implementation

It is more convenient to prove this theorem by assuming we are given the explicit adjunction rather
than just a functor known to be a right adjoint. In docstrings, we write `(η, ε)` for the unit
and counit of the adjunction `adj₁ : F ⊣ U` and `(ι, δ)` for the unit and counit of the adjunction
`adj₂ : F' ⊣ R ⋙ U`.

## TODO

Dualise to lift right adjoints through comonads (by reversing 1-cells) and dualise to lift right
adjoints through monads (by reversing 2-cells), and the combination.

## References
* https://ncatlab.org/nlab/show/adjoint+triangle+theorem
* https://ncatlab.org/nlab/show/adjoint+lifting+theorem
* Adjoint Lifting Theorems for Categories of Algebras (PT Johnstone, 1975)
* A unified approach to the lifting of adjoints (AJ Power, 1988)
-/

namespace category_theory

open category limits

universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

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

-- Hide implementation details in this namespace
namespace lift_adjoint

variables {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A)
variables (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U)

/--
To show that `ε_X` is a coequalizer for `(FUε_X, ε_FUX)`, it suffices to assume it's always a
coequalizer of something (i.e. a regular epi).
-/
def counit_coequalises [∀ (X : B), regular_epi (adj₁.counit.app X)] (X : B) :
  is_colimit (cofork.of_π (adj₁.counit.app X) (adj₁.counit_naturality _)) :=
cofork.is_colimit.mk' _ $ λ s,
begin
  refine ⟨(regular_epi.desc' (adj₁.counit.app X) s.π _).1, _, _⟩,
  { rw ← cancel_epi (adj₁.counit.app (regular_epi.W (adj₁.counit.app X))),
    rw ← adj₁.counit_naturality_assoc,
    dsimp only [functor.comp_obj],
    rw [← s.condition, ← F.map_comp_assoc, ← U.map_comp, regular_epi.w, U.map_comp,
        F.map_comp_assoc, s.condition, ← adj₁.counit_naturality_assoc] },
  { apply (regular_epi.desc' (adj₁.counit.app X) s.π _).2 },
  { intros m hm,
    rw ← cancel_epi (adj₁.counit.app X),
    apply hm.trans (regular_epi.desc' (adj₁.counit.app X) s.π _).2.symm }
end

include adj₁ adj₂

/--
(Implementation)
To construct the left adjoint, we use the coequalizer of `F' U ε_Y` with the composite

`F' U F U X ⟶ F' U F U R F U' X ⟶ F' U R F' U X ⟶ F' U X`

where the first morphism is `F' U F ι_UX`, the second is `F' U ε_RF'UX`, and the third is `δ_F'UX`.
We will show that this coequalizer exists and that it forms the object map for a left adjoint to
`R`.
-/
def other_map (X) : F'.obj (U.obj (F.obj (U.obj X))) ⟶ F'.obj (U.obj X) :=
F'.map (U.map (F.map (adj₂.unit.app _) ≫ adj₁.counit.app _)) ≫ adj₂.counit.app _

/--
`(F'Uε_X, other_map X)` is a reflexive pair: in particular if `A` has reflexive coequalizers then
it has a coequalizer.
-/
instance (X : B) :
  is_reflexive_pair (F'.map (U.map (adj₁.counit.app X))) (other_map _ _ adj₁ adj₂ X) :=
is_reflexive_pair.mk'
  (F'.map (adj₁.unit.app (U.obj X)))
  (by {rw [← F'.map_comp, adj₁.right_triangle_components], apply F'.map_id })
  begin
    dsimp [other_map],
    rw [← F'.map_comp_assoc, U.map_comp, adj₁.unit_naturality_assoc, adj₁.right_triangle_components,
        comp_id, adj₂.left_triangle_components]
  end

variables [has_reflexive_coequalizers A]

/--
Construct the object part of the desired left adjoint as the coequalizer of `F'Uε_Y` with
`other_map`.
-/
noncomputable def construct_left_adjoint_obj (Y : B) : A :=
coequalizer (F'.map (U.map (adj₁.counit.app Y))) (other_map _ _ adj₁ adj₂ Y)

/-- The homset equivalence which helps show that `R` is a right adjoint. -/
@[simps {rhs_md := semireducible}]
noncomputable
def construct_left_adjoint_equiv [∀ (X : B), regular_epi (adj₁.counit.app X)] (Y : A) (X : B) :
  (construct_left_adjoint_obj _ _ adj₁ adj₂ X ⟶ Y) ≃ (X ⟶ R.obj Y) :=
calc (construct_left_adjoint_obj _ _ adj₁ adj₂ X ⟶ Y)
        ≃ {f : F'.obj (U.obj X) ⟶ Y //
              F'.map (U.map (adj₁.counit.app X)) ≫ f = other_map _ _ adj₁ adj₂ _ ≫ f} :
                cofork.is_colimit.hom_iso (colimit.is_colimit _) _
  ... ≃ {g : U.obj X ⟶ U.obj (R.obj Y) //
          U.map (F.map g ≫ adj₁.counit.app _) = U.map (adj₁.counit.app _) ≫ g} :
            begin
              apply (adj₂.hom_equiv _ _).subtype_equiv _,
              intro f,
              rw [← (adj₂.hom_equiv _ _).injective.eq_iff, eq_comm, adj₂.hom_equiv_naturality_left,
                  other_map, assoc, adj₂.hom_equiv_naturality_left, ← adj₂.counit_naturality,
                  adj₂.hom_equiv_naturality_left, adj₂.hom_equiv_unit,
                  adj₂.right_triangle_components, comp_id, functor.comp_map, ← U.map_comp, assoc,
                  ← adj₁.counit_naturality, adj₂.hom_equiv_unit, adj₂.hom_equiv_unit, F.map_comp,
                  assoc],
              refl,
            end
  ... ≃ {z : F.obj (U.obj X) ⟶ R.obj Y // _} :
            begin
              apply (adj₁.hom_equiv _ _).symm.subtype_equiv,
              intro g,
              rw [← (adj₁.hom_equiv _ _).symm.injective.eq_iff, adj₁.hom_equiv_counit,
                  adj₁.hom_equiv_counit, adj₁.hom_equiv_counit, F.map_comp, assoc, U.map_comp,
                  F.map_comp, assoc, adj₁.counit_naturality, adj₁.counit_naturality_assoc],
              apply eq_comm,
            end
  ... ≃ (X ⟶ R.obj Y) : (cofork.is_colimit.hom_iso (counit_coequalises adj₁ X) _).symm

/-- Construct the left adjoint to `R`, with object map `construct_left_adjoint_obj`. -/
noncomputable def construct_left_adjoint [∀ (X : B), regular_epi (adj₁.counit.app X)] : B ⥤ A :=
begin
  refine adjunction.left_adjoint_of_equiv (λ X Y, construct_left_adjoint_equiv R _ adj₁ adj₂ Y X) _,
  intros X Y Y' g h,
  rw [construct_left_adjoint_equiv_apply, construct_left_adjoint_equiv_apply, function.comp_app,
      function.comp_app, equiv.trans_apply, equiv.trans_apply, equiv.trans_apply, equiv.trans_apply,
      equiv.symm_apply_eq, subtype.ext_iff, cofork.is_colimit.hom_iso_natural,
      equiv.apply_symm_apply, equiv.subtype_equiv_apply, equiv.subtype_equiv_apply,
      equiv.subtype_equiv_apply, equiv.subtype_equiv_apply, subtype.coe_mk, subtype.coe_mk,
      subtype.coe_mk, subtype.coe_mk, ← adj₁.hom_equiv_naturality_right_symm,
      cofork.is_colimit.hom_iso_natural, adj₂.hom_equiv_naturality_right, functor.comp_map],
end

end lift_adjoint

/--
The adjoint triangle theorem: Suppose `U : B ⥤ C` has a left adjoint `F` such that each counit
`ε_X : FUX ⟶ X` is a regular epimorphism. Then if a category `A` has coequalizers of reflexive
pairs, then a functor `R : A ⥤ B` has a left adjoint if the composite `R ⋙ U` does.

Note the converse is true (with weaker assumptions), by `adjunction.comp`.
See https://ncatlab.org/nlab/show/adjoint+triangle+theorem
-/
noncomputable def adjoint_triangle_lift {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (adj₁ : F ⊣ U)
  [Π (X : B), regular_epi (adj₁.counit.app X)]
  [has_reflexive_coequalizers A]
  [is_right_adjoint (R ⋙ U)] : is_right_adjoint R :=
{ left := lift_adjoint.construct_left_adjoint R _ adj₁ (adjunction.of_right_adjoint _),
  adj := adjunction.adjunction_of_equiv_left _ _ }

/--
If `R ⋙ U` has a left adjoint, the domain of `R` has reflexive coequalizers and `U` is a monadic
functor, then `R` has a left adjoint.
This is a special case of `adjoint_triangle_lift` which is often more useful in practice.
-/
noncomputable def monadic_adjoint_triangle_lift (U : B ⥤ C) [monadic_right_adjoint U] {R : A ⥤ B}
  [has_reflexive_coequalizers A]
  [is_right_adjoint (R ⋙ U)] :
  is_right_adjoint R :=
begin
  let R' : A ⥤ _ := R ⋙ monad.comparison (adjunction.of_right_adjoint U),
  rsufficesI : is_right_adjoint R',
  { let : is_right_adjoint (R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv),
    { apply_instance },
    { let : R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv ≅ R :=
        (iso_whisker_left R (monad.comparison _).as_equivalence.unit_iso.symm : _) ≪≫
          R.right_unitor,
      exactI adjunction.right_adjoint_of_nat_iso this } },
  let : is_right_adjoint (R' ⋙ monad.forget (adjunction.of_right_adjoint U).to_monad) :=
    adjunction.right_adjoint_of_nat_iso
      (iso_whisker_left R (monad.comparison_forget (adjunction.of_right_adjoint U)).symm : _),
  letI : Π X, regular_epi ((monad.adj (adjunction.of_right_adjoint U).to_monad).counit.app X),
  { intro X,
    simp only [monad.adj_counit],
    exact ⟨_, _, _, _, monad.beck_algebra_coequalizer X⟩ },
  exact adjoint_triangle_lift R' (monad.adj _),
end

variables {D : Type u₄}
variables [category.{v₄} D]

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` has a left adjoint such that
each component of the counit is a regular epi.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def adjoint_square_lift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
  (comm : U ⋙ R ≅ Q ⋙ V)
  [is_right_adjoint U] [is_right_adjoint V] [is_right_adjoint R]
  [∀ X, regular_epi ((adjunction.of_right_adjoint V).counit.app X)]
  [has_reflexive_coequalizers A] :
  is_right_adjoint Q :=
begin
  let := adjunction.right_adjoint_of_nat_iso comm,
  exactI adjoint_triangle_lift Q (adjunction.of_right_adjoint V),
end

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` is monadic.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def monadic_adjoint_square_lift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
  (comm : U ⋙ R ≅ Q ⋙ V)
  [is_right_adjoint U] [monadic_right_adjoint V] [is_right_adjoint R]
  [has_reflexive_coequalizers A] :
  is_right_adjoint Q :=
begin
  let := adjunction.right_adjoint_of_nat_iso comm,
  exactI monadic_adjoint_triangle_lift V,
end

end category_theory


-- Mario says no finset2
#exit

-- bundled noncomputable finite sets
import tactic

import data.set.finite

def subsingleton.mk_equiv {α β} [subsingleton α] [subsingleton β]
  (f : α → β) (g : β → α) : α ≃ β :=
⟨f, g, λ _, by cc, λ _, by cc⟩

namespace fintype

universes u v

@[ext] def ext {X : Type u} (a : fintype X) (b : fintype X) :
a = b := subsingleton.elim a b

def equiv_congr {X Y} (e : X ≃ Y) : fintype X ≃ fintype Y :=
subsingleton.mk_equiv (λ fX, @fintype.of_equiv Y X fX e) (λ fY, @fintype.of_equiv X Y fY e.symm)

end fintype

namespace nonempty

universes u v

lemma of_nonempty_equiv {X : Type u} {Y : Type v} (f : X → Y) :
  nonempty X → nonempty Y :=
begin
  exact map f,
end

end nonempty

open_locale classical

universe u

variable {X : Type u}

open set

def finset2 (X : Type u) := {S : set X // finite S}

namespace finset2

-- finset2 is the same as finset

-- Group theory Sylow theorems : proposal that we do all counting
-- with finset2

-- proofs can certainly be golfed

noncomputable def equiv_finset (X : Type*) : finset2 X ≃ (finset X) :=
{ to_fun := λ T, T.2.to_finset,
  inv_fun := λ F, ⟨↑F, finite_mem_finset F⟩,
  left_inv := begin
    intro T,
    cases T with S h,
    ext x,
    apply finite.mem_to_finset,
  end,
  right_inv := begin
    intro F,
    dsimp,
    ext x,
    set S : set X := ↑F,
    rw ←(@finset.mem_coe _ _ F),
    rw finite.mem_to_finset
  end }

noncomputable def card (F : finset2 X) : ℕ :=
((finset2.equiv_finset X).to_fun F).card

-- now every theorem for finset I want for finset2

-- maybe some tactic can get them for me

end finset2

-- Don't know if I need it
-- should prove it's equivalent to Avigad's version

-- noncomputable def set.fincard {X : Type u} (S : set X) : ℕ :=
-- if h : S.finite then finset2.card (⟨S, h⟩ : finset2 X) else 37


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

import for_mathlib.dold_kan.functor_n
import for_mathlib.dold_kan.decomposition
import category_theory.idempotents.homological_complex
import category_theory.idempotents.karoubi_karoubi

/-!

# N₁ and N₂ reflects isomorphisms

In this file, it is shown that the functors
`N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ)` and
`N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ))`
reflect isomorphisms for any preadditive category `C`.

-/

open category_theory
open category_theory.category
open category_theory.idempotents
open opposite
open_locale simplicial

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]

open morph_components

instance : reflects_isomorphisms (N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ)) :=
⟨λ X Y f, begin
  introI,
  /- restating the result in a way that allows induction on the degree n -/
  suffices : ∀ (n : ℕ), is_iso (f.app (op [n])),
  { haveI : ∀ (Δ : simplex_categoryᵒᵖ), is_iso (f.app Δ) := λ Δ, this Δ.unop.len,
    apply nat_iso.is_iso_of_is_iso_app, },
  /- restating the assumption in a more practical form -/
  have h₁ := homological_complex.congr_hom (karoubi.hom_ext.mp (is_iso.hom_inv_id (N₁.map f))),
  have h₂ := homological_complex.congr_hom (karoubi.hom_ext.mp (is_iso.inv_hom_id (N₁.map f))),
  have h₃ := λ n, karoubi.homological_complex.p_comm_f_assoc (inv (N₁.map f)) (n) (f.app (op [n])),
  simp only [N₁_map_f, karoubi.comp_f, homological_complex.comp_f,
    alternating_face_map_complex.map_f, N₁_obj_p, karoubi.id_eq, assoc] at h₁ h₂ h₃,
  /- we have to construct an inverse to f in degree n, by induction on n -/
  intro n,
  induction n with n hn,
  /- degree 0 -/
  { use (inv (N₁.map f)).f.f 0,
    have h₁₀ := h₁ 0,
    have h₂₀ := h₂ 0,
    dsimp at h₁₀ h₂₀,
    simp only [id_comp, comp_id] at h₁₀ h₂₀,
    tauto, },
  /- induction step -/
  { haveI := hn,
    use φ
      { a := P_infty.f (n+1) ≫ (inv (N₁.map f)).f.f (n+1),
        b := λ i, inv (f.app (op [n])) ≫ X.σ i, },
    simp only [morph_components.id, ← id_φ, ← pre_comp_φ, pre_comp, ← post_comp_φ,
      post_comp, P_infty_f_naturality_assoc, is_iso.hom_inv_id_assoc, assoc,
      is_iso.inv_hom_id_assoc, simplicial_object.σ_naturality, h₁, h₂, h₃],
    tauto, },
end⟩

lemma compatibility_N₂_N₁_karoubi :
  N₂ ⋙ (karoubi_chain_complex_equivalence C ℕ).functor =
  karoubi_functor_category_embedding simplex_categoryᵒᵖ C ⋙ N₁ ⋙
  (karoubi_chain_complex_equivalence (karoubi C) ℕ).functor ⋙
  functor.map_homological_complex (karoubi_karoubi.equivalence C).inverse _ :=
begin
  refine category_theory.functor.ext (λ P, _) (λ P Q f, _),
  { refine homological_complex.ext _ _,
    { ext n,
      { dsimp,
        simp only [karoubi_P_infty_f, comp_id, P_infty_f_naturality, id_comp], },
      { refl, }, },
    { rintros _ n (rfl : n+1 = _),
      ext,
      have h := (alternating_face_map_complex.map P.p).comm (n+1) n,
      dsimp [N₂, karoubi_chain_complex_equivalence, karoubi_karoubi.inverse,
        karoubi_homological_complex_equivalence.functor.obj] at ⊢ h,
      simp only [karoubi.comp_f, assoc, karoubi.eq_to_hom_f, eq_to_hom_refl, id_comp, comp_id,
        karoubi_alternating_face_map_complex_d, karoubi_P_infty_f,
        ← homological_complex.hom.comm_assoc, ← h, app_idem_assoc], }, },
  { ext n,
    dsimp [karoubi_karoubi.inverse, karoubi_functor_category_embedding,
      karoubi_functor_category_embedding.map],
    simp only [karoubi.comp_f, karoubi_P_infty_f, homological_complex.eq_to_hom_f,
      karoubi.eq_to_hom_f, assoc, comp_id, P_infty_f_naturality, app_p_comp,
      karoubi_chain_complex_equivalence_functor_obj_X_p, N₂_obj_p_f, eq_to_hom_refl,
      P_infty_f_naturality_assoc, app_comp_p, P_infty_f_idem_assoc], },
end

/-- We deduce that `N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms from the fact that
`N₁ : simplicial_object (karoubi C) ⥤ karoubi (chain_complex (karoubi C) ℕ)` does. -/
instance : reflects_isomorphisms
  (N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ)) := ⟨λ X Y f,
begin
  introI,
  -- The following functor `F` reflects isomorphism because it is
  -- a composition of four functors which reflects isomorphisms.
  -- Then, it suffices to show that `F.map f` is an isomorphism.
  let F := karoubi_functor_category_embedding simplex_categoryᵒᵖ C ⋙ N₁ ⋙
    (karoubi_chain_complex_equivalence (karoubi C) ℕ).functor ⋙
    functor.map_homological_complex (karoubi_karoubi.equivalence C).inverse
      (complex_shape.down ℕ),
  haveI : is_iso (F.map f),
  { dsimp only [F],
    rw [← compatibility_N₂_N₁_karoubi, functor.comp_map],
    apply functor.map_is_iso, },
  exact is_iso_of_reflects_iso f F,
end⟩

end dold_kan

end algebraic_topology


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Lean
import Mathlib.Tactic.Congr!

/-!
# The `convert` tactic.
-/

open Lean Meta Elab Tactic

/--
Close the goal `g` using `Eq.mp v e`,
where `v` is a metavariable asserting that the type of `g` and `e` are equal.
Then call `MVarId.congrN!` (also using local hypotheses and reflexivity) on `v`,
and return the resulting goals.

With `sym = true`, reverses the equality in `v`, and uses `Eq.mpr v e` instead.
With `depth = some n`, calls `MVarId.congrN! n` instead, with `n` as the max recursion depth.
-/
def Lean.MVarId.convert (e : Expr) (sym : Bool)
    (depth : Option Nat := none) (config : Congr!.Config := {}) (g : MVarId) :
    MetaM (List MVarId) := do
  let src ← inferType e
  let tgt ← g.getType
  let v ← mkFreshExprMVar (← mkAppM ``Eq (if sym then #[src, tgt] else #[tgt, src]))
  g.assign (← mkAppM (if sym then ``Eq.mp else ``Eq.mpr) #[v, e])
  let m := v.mvarId!
  try m.congrN! depth config
  catch _ => return [m]

/--
The `exact e` and `refine e` tactics require a term `e` whose type is
definitionally equal to the goal. `convert e` is similar to `refine e`,
but the type of `e` is not required to exactly match the
goal. Instead, new goals are created for differences between the type
of `e` and the goal using the same strategies as the `congr!` tactic.
For example, in the proof state

```lean
n : ℕ,
e : prime (2 * n + 1)
⊢ prime (n + n + 1)
```

the tactic `convert e using 2` will change the goal to

```lean
⊢ n + n = 2 * n
```

In this example, the new goal can be solved using `ring`.

The `using 2` indicates it should iterate the congruence algorithm up to two times,
where `convert e` would use an unrestricted number of iterations and lead to two
impossible goals: `⊢ HAdd.hAdd = HMul.hMul` and `⊢ n = 2`.

A variant configuration is `convert (config := .unfoldSameFun) e`, which only equates function
applications for the same function (while doing so at the higher `default` transparency).
This gives the same goal of `⊢ n + n = 2 * n` without needing `using 2`.

The `convert` tactic applies congruence lemmas eagerly before reducing,
therefore it can fail in cases where `exact` succeeds:
```lean
def p (n : ℕ) := true
example (h : p 0) : p 1 := by exact h -- succeeds
example (h : p 0) : p 1 := by convert h -- fails, with leftover goal `1 = 0`
```
Limiting the depth of recursion can help with this. For example, `convert h using 1` will work
in this case.

The syntax `convert ← e` will reverse the direction of the new goals
(producing `⊢ 2 * n = n + n` in this example).

Internally, `convert e` works by creating a new goal asserting that
the goal equals the type of `e`, then simplifying it using
`congr!`. The syntax `convert e using n` can be used to control the
depth of matching (like `congr! n`). In the example, `convert e using 1`
would produce a new goal `⊢ n + n + 1 = 2 * n + 1`.

Refer to the `congr!` tactic to understand the congruence operations. One of its many
features is that if `x y : t` and an instance `Subsingleton t` is in scope,
then any goals of the form `x = y` are solved automatically.

The `convert` tactic also takes a configuration option, for example
```lean
convert (config := {transparency := .default}) h
```
These are passed to `congr!`. See `Congr!.Config` for options.
-/
syntax (name := convert) "convert" (Parser.Tactic.config)? "← "? term (" using " num)? : tactic

elab_rules : tactic
| `(tactic| convert $[$cfg:config]? $[←%$sym]? $term $[using $n]?) => withMainContext do
  let config ← Congr!.elabConfig (mkOptionalNode cfg)
  let (e, gs) ← elabTermWithHoles (allowNaturalHoles := true) term
    (← mkFreshExprMVar (mkSort (← getLevel (← getMainTarget)))) (← getMainTag)
  liftMetaTactic fun g ↦ return (← g.convert e sym.isSome (n.map (·.getNat)) config) ++ gs

-- FIXME restore when `add_tactic_doc` is ported.
-- add_tactic_doc
-- { name       := "convert",
--   category   := doc_category.tactic,
--   decl_names := [`tactic.interactive.convert],
--   tags       := ["congruence"] }

/--
`convert_to g using n` attempts to change the current goal to `g`, but unlike `change`,
it will generate equality proof obligations using `congr! n` to resolve discrepancies.
`convert_to g` defaults to using `congr! 1`.
`convert_to` is similar to `convert`, but `convert_to` takes a type (the desired subgoal) while
`convert` takes a proof term.
That is, `convert_to g using n` is equivalent to `convert (?_ : g) using n`.

The syntax for `convert_to` is the same as for `convert`, and it has variations such as
`convert_to ← g` and `convert_to (config := {transparency := .default}) g`.
-/
syntax (name := convertTo) "convert_to" (Parser.Tactic.config)? "← "? term (" using " num)? : tactic

macro_rules
| `(tactic| convert_to $[$cfg]? $[←%$sym]? $term) =>
  `(tactic| convert $[$cfg]? $[←%$sym]? (?_ : $term) using 1)
| `(tactic| convert_to $[$cfg]? $[←%$sym]? $term using $n) =>
  `(tactic| convert $[$cfg]? $[←%$sym]? (?_ : $term) using $n)


lemma maze (P Q R S T U: Prop)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
apply l,
apply j,
apply h,
exact p,
end


import hilbert.wr.pt

namespace clfrags
    namespace hilbert
        namespace wr
            namespace pt

                theorem pt₇ {a b c d e : Prop} (h₁ : pt (pt a b c) d e) : pt a b (pt c d e) :=
                    have h₂ : pt d (pt a b c) e, from pt₂ h₁,
                    have h₃ : pt d e (pt a b c), from pt₃ h₂,
                    have h₄ : pt (pt d e a) b c, from pt₆ h₃,
                    have h₅ : pt b (pt d e a) c, from pt₂ h₄,
                    have h₆ : pt b c (pt d e a), from pt₃ h₅,
                    have h₇ : pt (pt b c d) e a, from pt₆ h₆,
                    have h₈ : pt e (pt b c d) a, from pt₂ h₇,
                    have h₉ : pt e a (pt b c d), from pt₃ h₈,
                    have h₁₀ : pt (pt e a b) c d, from pt₆ h₉,
                    have h₁₁ : pt c (pt e a b) d, from pt₂ h₁₀,
                    have h₁₂ : pt c d (pt e a b), from pt₃ h₁₁,
                    have h₁₃ : pt (pt c d e) a b, from pt₆ h₁₂,
                    have h₁₄ : pt a (pt c d e) b, from pt₂ h₁₃,
                    show pt a b (pt c d e), from pt₃ h₁₄

                theorem pt₂_pt {a b c d e : Prop} (h₁ : pt d e (pt a b c)) : pt d e (pt b a c) :=
                    have h₂ : pt d (pt a b c) e, from pt₃ h₁,
                    have h₃ : pt (pt a b c) d e, from pt₂ h₂,
                    have h₄ : pt a b (pt c d e), from pt₇ h₃,
                    have h₅ : pt b a (pt c d e), from pt₂ h₄,
                    have h₆ : pt (pt b a c) d e, from pt₆ h₅,
                    have h₇ : pt d (pt b a c) e, from pt₂ h₆,
                    show pt d e (pt b a c), from pt₃ h₇

                theorem pt₃_pt {a b c d e : Prop} (h₁ : pt d e (pt a b c)) : pt d e (pt a c b) :=
                    have h₂ : pt (pt d e a) b c, from pt₆ h₁,
                    have h₃ : pt (pt d e a) c b, from pt₃ h₂,
                    show pt d e (pt a c b), from pt₇ h₃

                theorem pt₄_pt {a b c d : Prop} (h₁ : pt c d a) : pt c d (pt a b b) :=
                    have h₂ : pt (pt c d a) b b, from pt₄ h₁,
                    show pt c d (pt a b b), from pt₇ h₂

                theorem pt₅_pt {a b c d : Prop} (h₁ : pt c d (pt a b b)) : pt c d a :=
                    have h₂ : pt (pt c d a) b b, from pt₆ h₁,
                    show pt c d a, from pt₅ h₂

                theorem pt₆_pt {a b c d e f g : Prop} (h₁ : pt f g (pt a b (pt c d e)))
                    : pt f g (pt (pt a b c) d e) :=
                    have h₂ : pt (pt a b (pt c d e)) f g, from pt₂ (pt₃ h₁),
                    have h₃ : pt a b (pt (pt c d e) f g), from pt₇ h₂,
                    have h₄ : pt (pt (pt c d e) f g) a b, from pt₂ (pt₃ h₃),
                    have h₅ : pt (pt c d e) f (pt g a b), from pt₇ h₄,
                    have h₆ : pt c d (pt e f (pt g a b)), from pt₇ h₅,
                    have h₇ : pt (pt e f (pt g a b)) c d, from pt₂ (pt₃ h₆),
                    have h₈ : pt e f (pt (pt g a b) c d), from pt₇ h₇,
                    have h₉ : pt (pt (pt g a b) c d) e f, from pt₂ (pt₃ h₈),
                    have h₁₀ : pt (pt g a b) c (pt d e f), from pt₇ h₉,
                    have h₁₁ : pt g a (pt b c (pt d e f)), from pt₇ h₁₀,
                    have h₁₂ : pt (pt b c (pt d e f)) g a, from pt₂ (pt₃ h₁₁),
                    have h₁₃ : pt b c (pt (pt d e f) g a), from pt₇ h₁₂,
                    have h₁₄ : pt (pt (pt d e f) g a) b c, from pt₂ (pt₃ h₁₃),
                    have h₁₅ : pt (pt d e f) g (pt a b c), from pt₇ h₁₄,
                    have h₁₆ : pt d e (pt f g (pt a b c)), from pt₇ h₁₅,
                    have h₁₇ : pt (pt f g (pt a b c)) d e, from pt₂ (pt₃ h₁₆),
                    show pt f g (pt (pt a b c) d e), from pt₇ h₁₇

                theorem pt₈ {a b c : Prop} (h₁ : pt (pt a b c) a b) : c :=
                    have h₂ : pt a (pt a b c) b, from pt₂ h₁,
                    have h₃ : pt a b (pt a b c), from pt₃ h₂,
                    have h₄ : pt a b (pt a c b), from pt₃_pt h₃,
                    have h₅ : pt a b (pt c a b), from pt₂_pt h₄,
                    have h₆ : pt a (pt c a b) b, from pt₃ h₅,
                    have h₇ : pt (pt c a b) a b, from pt₂ h₆,
                    have h₈ : pt c a (pt b a b), from pt₇ h₇,
                    have h₉ : pt c a (pt a b b), from pt₂_pt h₈,
                    have h₁₀ : pt c a a, from pt₅_pt h₉,
                    show c, from pt₅ h₁₀

                theorem pt₉ {a b c : Prop} (h₁ : pt (pt a b c) a c) : b :=
                    have h₂ : pt a b (pt c a c), from pt₇ h₁,
                    have h₃ : pt a b (pt a c c), from pt₂_pt h₂,
                    have h₄ : pt a b a, from pt₅_pt h₃,
                    have h₅ : pt b a a, from pt₂ h₄,
                    show b, from pt₅ h₅

                theorem pt₁₀ {a b c : Prop} (h₁ : pt (pt a b c) b c) : a :=
                    have h₂ : pt a b (pt c b c), from pt₇ h₁,
                    have h₃ : pt a b (pt b c c), from pt₂_pt h₂,
                    have h₄ : pt a b b, from pt₅_pt h₃,
                    show a, from pt₅ h₄

                lemma pt₁₁' {a b c d e f : Prop} (h₁ : pt e f (pt (pt a b c) c d))
                    : pt e f (pt a b d) :=
                    have h₂ : pt e f (pt c d (pt a b c)), from pt₃_pt (pt₂_pt h₁),
                    have h₃ : pt e f (pt (pt c d a) b c), from pt₆_pt h₂,
                    have h₄ : pt e f (pt b c (pt c d a)), from pt₃_pt (pt₂_pt h₃),
                    have h₅ : pt e f (pt (pt b c c) d a), from pt₆_pt h₄,
                    have h₆ : pt e f (pt d a (pt b c c)), from pt₃_pt (pt₂_pt h₅),
                    have h₇ : pt e f (pt (pt d a b) c c), from pt₆_pt h₆,
                    have h₈ : pt e f (pt d a b), from pt₅_pt h₇,
                    show pt e f (pt a b d), from pt₃_pt (pt₂_pt h₈)

                lemma pt₁₁'' {a b c d e f : Prop} (h₁ : pt e f (pt (pt a b c) b d))
                    : pt e f (pt a c d) :=
                    have h₂ : pt e f (pt b d (pt a b c)), from pt₃_pt (pt₂_pt h₁),
                    have h₃ : pt e f (pt (pt b d a) b c), from pt₆_pt h₂,
                    have h₄ : pt e f (pt c b (pt b d a)), from pt₂_pt (pt₃_pt (pt₂_pt h₃)),
                    have h₅ : pt e f (pt (pt c b b) d a), from pt₆_pt h₄,
                    have h₆ : pt e f (pt d a (pt c b b)), from pt₃_pt (pt₂_pt h₅),
                    have h₇ : pt e f (pt (pt d a c) b b), from pt₆_pt h₆,
                    have h₈ : pt e f (pt d a c), from pt₅_pt h₇,
                    show pt e f (pt a c d), from pt₃_pt (pt₂_pt h₈)

                lemma pt₁₁''' {a b c d e f : Prop} (h₁ : pt e f (pt (pt a b c) a d))
                    : pt e f (pt b c d) :=
                    have h₂ : pt e f (pt d a (pt a b c)), from pt₂_pt (pt₃_pt (pt₂_pt h₁)),
                    have h₃ : pt e f (pt (pt d a a) b c), from pt₆_pt h₂,
                    have h₄ : pt e f (pt b c (pt d a a)), from pt₃_pt (pt₂_pt h₃),
                    have h₅ : pt e f (pt (pt b c d) a a), from pt₆_pt h₄,
                    show pt e f (pt b c d), from pt₅_pt h₅

                theorem pt₁₁ {a b c d : Prop}
                    (h₁ : pt (pt (pt a b c) a d) (pt (pt a b c) b d) (pt (pt a b c) c d)) : d :=
                    have h₂ : pt (pt (pt a b c) a d) (pt (pt a b c) b d) (pt a b d), from pt₁₁' h₁,
                    have h₃ : pt (pt (pt a b c) a d) (pt a b d) (pt (pt a b c) b d), from pt₃ h₂,
                    have h₄ : pt (pt (pt a b c) a d) (pt a b d) (pt a c d), from pt₁₁'' h₃,
                    have h₅ : pt (pt a b d) (pt (pt a b c) a d) (pt a c d), from pt₂ h₄,
                    have h₆ : pt (pt a b d) (pt a c d) (pt (pt a b c) a d) , from pt₃ h₅,
                    have h₇ : pt (pt a b d) (pt a c d) (pt b c d) , from pt₁₁''' h₆,
                    have h₈ : pt a b (pt d (pt a c d) (pt b c d)) , from pt₇ h₇,
                    have h₉ : pt a b (pt (pt a c d) d (pt b c d)) , from pt₂_pt h₈,
                    have h₁₀ : pt (pt a b (pt a c d)) d (pt b c d) , from pt₆ h₉,
                    have h₁₁ : pt (pt a b (pt a c d)) d (pt b d c) , from pt₃_pt h₁₀,
                    have h₁₂ : pt (pt a b (pt a c d)) d (pt d b c) , from pt₂_pt h₁₁,
                    have h₁₃ : pt (pt (pt a b (pt a c d)) d d) b c, from pt₆ h₁₂,
                    have h₁₄ : pt b c (pt (pt a b (pt a c d)) d d), from pt₃ (pt₂ h₁₃),
                    have h₁₅ : pt b c (pt a b (pt a c d)), from pt₅_pt h₁₄,
                    have h₁₆ : pt b c (pt b a (pt a c d)), from pt₂_pt h₁₅,
                    have h₁₇ : pt (pt b c b) a (pt a c d), from pt₆ h₁₆,
                    have h₁₈ : pt a (pt a c d) (pt b c b), from pt₃ (pt₂ h₁₇),
                    have h₁₉ : pt a (pt a c d) (pt c b b), from pt₂_pt h₁₈,
                    have h₂₀ : pt a (pt a c d) c, from pt₅_pt h₁₉,
                    have h₂₁ : pt (pt a c d) a c, from pt₂ h₂₀,
                    show d, from pt₈ h₂₁

                theorem pt₁₂ {a b c d e : Prop} (h₁ : pt a b c) (h₂ : d) (h₃ : e)
                    : pt a b (pt c d e) :=
                    have h₄ : pt (pt a b c) d e, from pt₁ h₁ h₂ h₃,
                    show pt a b (pt c d e), from pt₇ h₄

                theorem pt₁₃ {a b c d e : Prop} (h₁ : pt a b c) (h₂ : pt a b d) (h₃ : e)
                    : (pt c d e) :=
                    have h₄ : pt a b (pt c (pt a b d) e), from pt₁₂ h₁ h₂ h₃,
                    have h₅ : pt a b (pt (pt a b d) c e), from pt₂_pt h₄,
                    have h₆ : pt (pt a b (pt a b d)) c e, from pt₆ h₅,
                    have h₇ : pt c e (pt a b (pt a b d)), from pt₃ (pt₂ h₆),
                    have h₈ : pt c e (pt (pt a b d) a b), from pt₂_pt (pt₃_pt h₇),
                    have h₉ : pt c e (pt b d b), from pt₁₁''' h₈,
                    have h₁₀ : pt c e (pt d b b), from pt₂_pt h₉,
                    have h₁₁ : pt c e d, from pt₅_pt h₁₀,
                    show pt c d e, from pt₃ h₁₁

                theorem pt₁₄ {a b c d e : Prop} (h₁ : pt a b c) (h₂ : pt a b d) (h₃ : pt a b e)
                    : pt a b (pt c d e) :=
                    have h₄ : pt c d (pt a b e), from pt₁₃ h₁ h₂ h₃,
                    have h₅ : pt c d (pt e a b), from pt₂_pt (pt₃_pt h₄),
                    have h₅ : pt (pt c d e) a b, from pt₆ h₅,
                    show pt a b (pt c d e), from pt₃ (pt₂ h₅)

                theorem pt₄' {a b c : Prop} (h₁ : a) : pt (pt a b c) b c :=
                    have h₂ : pt a b b, from pt₄ h₁,
                    have h₃ : pt (pt a b b) c c, from pt₄ h₂,
                    have h₄ : pt  a b (pt b c c), from pt₇ h₃,
                    have h₅ : pt  a b (pt c b c), from pt₂_pt h₄,
                    show pt (pt a b c) b c, from pt₆ h₅

            end pt
        end wr
    end hilbert
end clfrags


import classes.context_free.basics.definition

variables {T : Type} {g : CF_grammar T}

lemma CF_deri_of_tran {v w : list (symbol T g.nt)} :
  CF_transforms g v w → CF_derives g v w :=
relation.refl_trans_gen.single

/-- The relation `CF_derives` is reflexive. -/
lemma CF_deri_self {w : list (symbol T g.nt)} :
  CF_derives g w w :=
relation.refl_trans_gen.refl

/-- The relation `CF_derives` is transitive. -/
lemma CF_deri_of_deri_deri {u v w : list (symbol T g.nt)}
    (huv : CF_derives g u v)
    (hvw : CF_derives g v w) :
  CF_derives g u w :=
relation.refl_trans_gen.trans huv hvw

lemma CF_deri_of_deri_tran {u v w : list (symbol T g.nt)}
    (huv : CF_derives g u v)
    (hvw : CF_transforms g v w) :
  CF_derives g u w :=
CF_deri_of_deri_deri huv (CF_deri_of_tran hvw)

lemma CF_deri_of_tran_deri {u v w : list (symbol T g.nt)}
    (huv : CF_transforms g u v)
    (hvw : CF_derives g v w) :
  CF_derives g u w :=
CF_deri_of_deri_deri (CF_deri_of_tran huv) hvw

lemma CF_tran_or_id_of_deri {u w : list (symbol T g.nt)} (ass : CF_derives g u w) :
  (u = w) ∨
  (∃ v : list (symbol T g.nt), (CF_transforms g u v) ∧ (CF_derives g v w)) :=
relation.refl_trans_gen.cases_head ass

lemma CF_deri_with_prefix {w₁ w₂ : list (symbol T g.nt)}
    (pᵣ : list (symbol T g.nt))
    (ass : CF_derives g w₁ w₂) :
  CF_derives g (pᵣ ++ w₁) (pᵣ ++ w₂) :=
begin
  induction ass with a b irr hyp ih,
  {
    apply CF_deri_self,
  },
  apply CF_deri_of_deri_tran,
  {
    exact ih,
  },
  rcases hyp with ⟨r, r_in, v, w, h_bef, h_aft⟩,
  use r,
  split,
  {
    exact r_in,
  },
  use pᵣ ++ v,
  use w,
  rw h_bef,
  rw h_aft,
  split;
  simp only [list.append_assoc],
end

lemma CF_deri_with_postfix {w₁ w₂ : list (symbol T g.nt)}
    (pₒ : list (symbol T g.nt))
    (ass : CF_derives g w₁ w₂) :
  CF_derives g (w₁ ++ pₒ) (w₂ ++ pₒ) :=
begin
  induction ass with a b irr hyp ih,
  {
    apply CF_deri_self,
  },
  apply CF_deri_of_deri_tran,
  {
    exact ih,
  },
  rcases hyp with ⟨r, r_in, v, w, h_bef, h_aft⟩,
  use r,
  split,
  {
    exact r_in,
  },
  use v,
  use w ++ pₒ,
  rw h_bef,
  rw h_aft,
  split;
  simp only [list.append_assoc],
end

lemma CF_deri_with_prefix_and_postfix {w₁ w₂ : list (symbol T g.nt)}
    (pᵣ pₒ : list (symbol T g.nt))
    (ass : CF_derives g w₁ w₂) :
  CF_derives g (pᵣ ++ w₁ ++ pₒ) (pᵣ ++ w₂ ++ pₒ) :=
begin
  apply CF_deri_with_postfix,
  apply CF_deri_with_prefix,
  exact ass,
end


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import ring_theory.subsemiring.pointwise
import group_theory.subgroup.pointwise
import ring_theory.subring.basic

/-! # Pointwise instances on `subring`s

This file provides the action `subring.pointwise_mul_action` which matches the action of
`mul_action_set`.

This actions is available in the `pointwise` locale.

## Implementation notes

This file is almost identical to `ring_theory/subsemiring/pointwise.lean`. Where possible, try to
keep them in sync.

-/

open set

variables {M R : Type*}

namespace subring

section monoid
variables [monoid M] [ring R] [mul_semiring_action M R]

/-- The action on a subring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action M (subring R) :=
{ smul := λ a S, S.map (mul_semiring_action.to_ring_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact one_smul M)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subring.pointwise_mul_action" in pointwise
open_locale pointwise

lemma pointwise_smul_def {a : M} (S : subring R) :
  a • S = S.map (mul_semiring_action.to_ring_hom _ _ a) := rfl

@[simp] lemma coe_pointwise_smul (m : M) (S : subring R) : ↑(m • S) = m • (S : set R) := rfl

@[simp] lemma pointwise_smul_to_add_subgroup (m : M) (S : subring R) :
  (m • S).to_add_subgroup = m • S.to_add_subgroup := rfl

@[simp] lemma pointwise_smul_to_subsemiring (m : M) (S : subring R) :
  (m • S).to_subsemiring = m • S.to_subsemiring := rfl

lemma smul_mem_pointwise_smul (m : M) (r : R) (S : subring R) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set R))

lemma mem_smul_pointwise_iff_exists (m : M) (r : R) (S : subring R) :
  r ∈ m • S ↔ ∃ (s : R), s ∈ S ∧ m • s = r :=
(set.mem_smul_set : r ∈ m • (S : set R) ↔ _)

instance pointwise_central_scalar [mul_semiring_action Mᵐᵒᵖ R] [is_central_scalar M R] :
  is_central_scalar M (subring R) :=
⟨λ a S, congr_arg (λ f, S.map f) $ ring_hom.ext $ by exact op_smul_eq_smul _⟩

end monoid

section group
variables [group M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : M} {S : subring R} {x : R} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : M} {S : subring R} {x : R} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {a : M} {S : subring R} {x : R} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : M} {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {a : M} {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma subset_pointwise_smul_iff {a : M} {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

/-! TODO: add `equiv_smul` like we have for subgroup. -/

end group

section group_with_zero
variables [group_with_zero M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R)
  (x : R) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set R) x

lemma mem_pointwise_smul_iff_inv_smul_mem₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem₀ ha (S : set R) x

lemma mem_inv_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set R) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

end subring