import category_theory.preadditive.functor_category

import pseudo_normed_group.FP
import locally_constant.SemiNormedGroup
import locally_constant.Vhat

/-!

# The category of locally constant maps

Various constructions of pseudo-normed groups of locally constant functions.

## Main definitions

- `LC V`: the functor sending a profinite set `S` to the locally constant
  functions from `S` to `V`
- `LCFP V r' c n`: the functor sending a profinitely filtered pseudo-normed
  group with T⁻¹ to V(M_c^n), the locally constant functions from M_c^n to V.

-/
namespace category_theory
namespace nat_trans

@[simp] lemma op_comp {C D} [category C] [category D]
  {F G H : C ⥤ D} {α : F ⟶ G} {β : G ⟶ H} :
  nat_trans.op (α ≫ β) = nat_trans.op β ≫ nat_trans.op α := rfl

end nat_trans
end category_theory

open_locale classical nnreal big_operators
noncomputable theory
local attribute [instance] type_pow

open SemiNormedGroup opposite Profinite pseudo_normed_group category_theory breen_deligne
open profinitely_filtered_pseudo_normed_group

universe variable u
variables (r : ℝ≥0) (V : SemiNormedGroup) (r' : ℝ≥0)
variables (c c₁ c₂ c₃ c₄ : ℝ≥0) (l m n : ℕ)

/-- `LC V n` is the functor that sends a profinite set `S` to `V(S)` -/
def LC (V : SemiNormedGroup) : Profiniteᵒᵖ ⥤ SemiNormedGroup :=
LocallyConstant.obj V

namespace LC

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) : ((LC V).map f).norm_noninc :=
locally_constant.comap_hom_norm_noninc _ _

instance obj.normed_with_aut [normed_with_aut r V] [fact (0 < r)] (A : Profiniteᵒᵖ) :
  normed_with_aut r ((LC V).obj A) :=
SemiNormedGroup.normed_with_aut_LocallyConstant _ _ _

@[simps hom_app_apply inv_app_apply {fully_applied := ff}]
def T [normed_with_aut r V] : LC V ≅ LC V :=
LocallyConstant.map_iso normed_with_aut.T

lemma T_eq [normed_with_aut r V] [fact (0 < r)] (A) :
  (T r V).hom.app A = normed_with_aut.T.hom := rfl

lemma norm_T_le [normed_with_aut r V] [fact (0 < r)] (A) :
  ∥(LC.T r V).hom.app A∥ ≤ r :=
begin
  rw T_eq,
  refine normed_group_hom.op_norm_le_bound _ (nnreal.zero_le_coe) (λ v, _),
  exact le_of_eq (normed_with_aut.norm_T v)
end

@[simps {fully_applied := ff}]
def T_inv [normed_with_aut r V] [fact (0 < r)] : LC V ⟶ LC V :=
(LocallyConstant.map (normed_with_aut.T.inv : V ⟶ V) : _)

lemma T_inv_eq [normed_with_aut r V] [fact (0 < r)] : (T r V).inv = T_inv r V := rfl

lemma T_inv_eq' [normed_with_aut r V] [fact (0 < r)] (A) :
  (T_inv r V).app A = normed_with_aut.T.inv := rfl

lemma norm_T_inv_le [normed_with_aut r V] [fact (0 < r)] (A) :
  ∥(T_inv r V).app A∥ ≤ r⁻¹ :=
begin
  rw T_inv_eq',
  refine normed_group_hom.op_norm_le_bound _ (inv_nonneg.2 (nnreal.zero_le_coe)) (λ v, _),
  exact (normed_with_aut.norm_T_inv _ v).le
end

end LC

/-- The "functor" that sends `M` and `c` to `V((filtration M c)^n)` -/
def LCFP (V : SemiNormedGroup) (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
(FiltrationPow r' c n).op ⋙ LC V

theorem LCFP_def (V : SemiNormedGroup) (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  LCFP V r' c n = (FiltrationPow r' c n).op ⋙ LocallyConstant.obj V := rfl

namespace LCFP

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) : ((LCFP V r' c n).map f).norm_noninc :=
LC.map_norm_noninc _ _

@[simps {fully_applied := ff}]
def res (r' : ℝ≥0) (c₁ c₂ : ℝ≥0) [fact (c₂ ≤ c₁)] (n : ℕ) : LCFP V r' c₁ n ⟶ LCFP V r' c₂ n :=
(whisker_right (nat_trans.op (FiltrationPow.cast_le r' c₂ c₁ n)) (LocallyConstant.obj V) : _)

@[simp] lemma res_refl : res V r' c c n = 𝟙 _ :=
by { simp [res, FiltrationPow.cast_le_refl], refl }

lemma res_comp_res [h₁ : fact (c₃ ≤ c₂)] [h₂ : fact (c₂ ≤ c₁)] :
  res V r' c₁ c₂ n ≫ res V r' c₂ c₃ n = @res V r' c₁ c₃ ⟨le_trans h₁.1 h₂.1⟩ n :=
by simp only [res, ← whisker_right_comp, ← nat_trans.op_comp, FiltrationPow.cast_le_comp]

lemma res_norm_noninc [fact (c₂ ≤ c₁)] (M) : ((res V r' c₁ c₂ n).app M).norm_noninc :=
locally_constant.comap_hom_norm_noninc _ _

section Tinv
open profinitely_filtered_pseudo_normed_group_with_Tinv
variables [fact (0 < r')]

@[simps {fully_applied := ff}]
def Tinv [fact (c₂ ≤ r' * c₁)] : LCFP V r' c₁ n ⟶ LCFP V r' c₂ n :=
(whisker_right (nat_trans.op $ FiltrationPow.Tinv r' c₂ c₁ n) (LocallyConstant.obj V) : _)

lemma Tinv_def [fact (c₂ ≤ r' * c₁)] : Tinv V r' c₁ c₂ n =
  whisker_right (nat_trans.op $ FiltrationPow.Tinv r' c₂ c₁ n) (LC V) := rfl

lemma res_comp_Tinv
  [fact (c₂ ≤ c₁)] [fact (c₃ ≤ c₂)] [fact (c₂ ≤ r' * c₁)] [fact (c₃ ≤ r' * c₂)] :
  res V r' c₁ c₂ n ≫ Tinv V r' c₂ c₃ n = Tinv V r' c₁ c₂ n ≫ res V r' c₂ c₃ n :=
begin
  simp only [Tinv, res, ← whisker_right_comp, ← nat_trans.op_comp],
  refl
end

lemma Tinv_norm_noninc [fact (c₂ ≤ r' * c₁)] (M) : ((Tinv V r' c₁ c₂ n).app M).norm_noninc :=
locally_constant.comap_hom_norm_noninc _ _

end Tinv

section normed_with_aut

variables [normed_with_aut r V]

instance [fact (0 < r)] (M) : normed_with_aut r ((LCFP V r' c n).obj M) :=
LC.obj.normed_with_aut _ _ _

@[simps {fully_applied := ff}]
def T [fact (0 < r)] : LCFP V r' c n ≅ LCFP V r' c n :=
((whiskering_left _ _ _).obj _).map_iso $ LC.T _ _

@[simps app_apply {fully_applied := ff}]
def T_inv [fact (0 < r)] : LCFP V r' c n ⟶ LCFP V r' c n :=
(whisker_left _ (LC.T_inv r V) : _)

lemma T_inv_eq [fact (0 < r)] : (T r V r' c n).inv = T_inv r V r' c n := rfl

lemma T_inv_def [fact (0 < r)] :
  T_inv r V r' c n = (whisker_left  (FiltrationPow r' c n).op
      (LocallyConstant.map (normed_with_aut.T.inv : V ⟶ V)) : _) :=
rfl

end normed_with_aut

end LCFP

namespace breen_deligne

open LCFP

variables {l m n}

namespace basic_universal_map

variables (ϕ : basic_universal_map m n)

def eval_LCFP (c₁ c₂ : ℝ≥0) [ϕ.suitable c₂ c₁] : LCFP V r' c₁ n ⟶ LCFP V r' c₂ m :=
(whisker_right (nat_trans.op $ ϕ.eval_FP r' c₂ c₁) (LocallyConstant.obj V) : _)

def eval_LCFP' (c₁ c₂ : ℝ≥0) : LCFP V r' c₁ n ⟶ LCFP V r' c₂ m :=
if H : ϕ.suitable c₂ c₁
then by exactI (whisker_right (nat_trans.op $ ϕ.eval_FP r' c₂ c₁) (LocallyConstant.obj V) : _)
else 0

lemma eval_LCFP_eq_eval_LCFP' (h : ϕ.suitable c₂ c₁) :
  ϕ.eval_LCFP V r' c₁ c₂ = ϕ.eval_LCFP' V r' c₁ c₂ :=
by { delta eval_LCFP eval_LCFP', rw dif_pos h }

lemma eval_LCFP'_def [h : ϕ.suitable c₂ c₁] :
  ϕ.eval_LCFP' V r' c₁ c₂ =
    (whisker_right (nat_trans.op $ ϕ.eval_FP r' c₂ c₁) (LocallyConstant.obj V) : _) :=
dif_pos h

lemma eval_LCFP'_not_suitable (h : ¬ ϕ.suitable c₂ c₁) :
  ϕ.eval_LCFP' V r' c₁ c₂ = 0 :=
dif_neg h

lemma eval_LCFP'_comp (f : basic_universal_map m n) (g : basic_universal_map l m)
  [hf : f.suitable c₂ c₁] [hg : g.suitable c₃ c₂] :
  (basic_universal_map.comp f g).eval_LCFP' V r' c₁ c₃ = f.eval_LCFP' V r' c₁ c₂ ≫ g.eval_LCFP' V r' c₂ c₃ :=
begin
  haveI : (basic_universal_map.comp f g).suitable c₃ c₁ := suitable_comp c₂,
  simp only [eval_LCFP'_def, eval_FP_comp r' _ c₂, nat_trans.op_comp, whisker_right_comp]
end

lemma eval_LCFP_comp (f : basic_universal_map m n) (g : basic_universal_map l m)
  [hf : f.suitable c₂ c₁] [hg : g.suitable c₃ c₂] :
  @eval_LCFP V r' _ _ (basic_universal_map.comp f g) c₁ c₃ (suitable_comp c₂) =
    f.eval_LCFP V r' c₁ c₂ ≫ g.eval_LCFP V r' c₂ c₃ :=
by { simp only [eval_LCFP_eq_eval_LCFP'], apply eval_LCFP'_comp }

lemma res_comp_eval_LCFP
  [fact (c₂ ≤ c₁)] [fact (c₄ ≤ c₃)] [ϕ.suitable c₄ c₂] [ϕ.suitable c₃ c₁] :
  res V r' c₁ c₂ n ≫ ϕ.eval_LCFP V r' c₂ c₄ = ϕ.eval_LCFP V r' c₁ c₃ ≫ res V r' c₃ c₄ m :=
by simp only [res, eval_LCFP, ← whisker_right_comp, ← nat_trans.op_comp,
  cast_le_comp_eval_FP _ c₄ c₃ c₂ c₁]

lemma Tinv_comp_eval_LCFP [fact (0 < r')] [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₄ c₂] [ϕ.suitable c₃ c₁] :
  Tinv V r' c₁ c₂ n ≫ ϕ.eval_LCFP V r' c₂ c₄ = ϕ.eval_LCFP V r' c₁ c₃ ≫ Tinv V r' c₃ c₄ m :=
by simp only [Tinv, eval_LCFP, ← whisker_right_comp, ← nat_trans.op_comp,
  Tinv_comp_eval_FP _ _ c₄ c₃ c₂ c₁]

lemma T_inv_comp_eval_LCFP [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁] :
  T_inv r V r' c₁ n ≫ ϕ.eval_LCFP V r' c₁ c₂ = ϕ.eval_LCFP V r' c₁ c₂ ≫ T_inv r V r' c₂ m :=
begin
  ext M : 2,
  simp only [T_inv_def, eval_LCFP, nat_trans.comp_app,  whisker_right_app, whisker_left_app,
    nat_trans.naturality]
end

end basic_universal_map

namespace universal_map

open free_abelian_group

variables (ϕ : universal_map m n)

def eval_LCFP [ϕ.suitable c₂ c₁] : LCFP V r' c₁ n ⟶ LCFP V r' c₂ m :=
∑ g : {g : basic_universal_map m n // g ∈ ϕ.support},
  begin
    haveI := suitable_of_mem_support ϕ c₂ c₁ g g.2,
    exact coeff (g : basic_universal_map m n) ϕ • (basic_universal_map.eval_LCFP V r' g c₁ c₂)
  end

def eval_LCFP' : LCFP V r' c₁ n ⟶ LCFP V r' c₂ m :=
∑ g in ϕ.support, coeff g ϕ • (g.eval_LCFP' V r' c₁ c₂)

lemma eval_LCFP_eq_eval_LCFP' (h : ϕ.suitable c₂ c₁) :
  ϕ.eval_LCFP V r' c₁ c₂ = ϕ.eval_LCFP' V r' c₁ c₂ :=
begin
  simp only [eval_LCFP, eval_LCFP', basic_universal_map.eval_LCFP_eq_eval_LCFP',
    subtype.val_eq_coe],
  symmetry,
  apply finset.sum_subtype ϕ.support (λ _, iff.rfl),
end

@[simp] lemma eval_LCFP'_of (f : basic_universal_map m n) :
  eval_LCFP' V r' c₁ c₂ (of f) = f.eval_LCFP' V r' c₁ c₂ :=
by simp only [eval_LCFP', support_of, coeff_of_self, one_smul, finset.sum_singleton]

@[simp] lemma eval_LCFP_of (f : basic_universal_map m n) [f.suitable c₂ c₁] :
  eval_LCFP V r' c₁ c₂ (of f) = f.eval_LCFP V r' c₁ c₂ :=
by rw [eval_LCFP_eq_eval_LCFP', eval_LCFP'_of, basic_universal_map.eval_LCFP_eq_eval_LCFP']

@[simp] lemma eval_LCFP'_zero :
  (0 : universal_map m n).eval_LCFP' V r' c₁ c₂ = 0 :=
by rw [eval_LCFP', support_zero, finset.sum_empty]

@[simp] lemma eval_LCFP_zero :
  (0 : universal_map m n).eval_LCFP V r' c₁ c₂ = 0 :=
by rw [eval_LCFP_eq_eval_LCFP', eval_LCFP'_zero]

@[simp] lemma eval_LCFP'_neg (f : universal_map m n) :
  eval_LCFP' V r' c₁ c₂ (-f) = -f.eval_LCFP' V r' c₁ c₂ :=
by simp only [eval_LCFP', add_monoid_hom.map_neg, finset.sum_neg_distrib, neg_smul, support_neg]

@[simp] lemma eval_LCFP_neg (f : universal_map m n) [f.suitable c₂ c₁] :
  eval_LCFP V r' c₁ c₂ (-f) = -f.eval_LCFP V r' c₁ c₂ :=
by simp only [eval_LCFP_eq_eval_LCFP', eval_LCFP'_neg]

lemma eval_LCFP'_add (f g : universal_map m n) :
  eval_LCFP' V r' c₁ c₂ (f + g) = f.eval_LCFP' V r' c₁ c₂ + g.eval_LCFP' V r' c₁ c₂ :=
begin
  simp only [eval_LCFP'],
  rw finset.sum_subset (support_add f g), -- two goals
  simp only [add_monoid_hom.map_add _ f g, add_smul],
  convert finset.sum_add_distrib using 2, -- three goals
  apply finset.sum_subset (finset.subset_union_left _ _), swap,
  apply finset.sum_subset (finset.subset_union_right _ _),
  all_goals { rintros x - h, rw not_mem_support_iff at h, simp [h] },
end

lemma eval_LCFP_add (f g : universal_map m n) [f.suitable c₂ c₁] [g.suitable c₂ c₁] :
  eval_LCFP V r' c₁ c₂ (f + g) = f.eval_LCFP V r' c₁ c₂ + g.eval_LCFP V r' c₁ c₂ :=
by simp only [eval_LCFP_eq_eval_LCFP', eval_LCFP'_add]

lemma eval_LCFP_sub (f g : universal_map m n) [f.suitable c₂ c₁] [g.suitable c₂ c₁] :
  eval_LCFP V r' c₁ c₂ (f - g) = f.eval_LCFP V r' c₁ c₂ - g.eval_LCFP V r' c₁ c₂ :=
by simp only [sub_eq_add_neg, eval_LCFP_add, eval_LCFP_neg]

lemma eval_LCFP'_comp_of (g : basic_universal_map m n) (f : basic_universal_map l m)
  [hg : g.suitable c₂ c₁] [hf : f.suitable c₃ c₂] :
  eval_LCFP' V r' c₁ c₃ ((comp (of g)) (of f)) =
    eval_LCFP' V r' c₁ c₂ (of g) ≫ eval_LCFP' V r' c₂ c₃ (of f) :=
begin
  simp only [comp_of, eval_LCFP'_of],
  haveI hfg : (basic_universal_map.comp g f).suitable c₃ c₁ := basic_universal_map.suitable_comp c₂,
  rw ← basic_universal_map.eval_LCFP'_comp,
end

open category_theory category_theory.limits category_theory.preadditive

lemma eval_LCFP'_comp (g : universal_map m n) (f : universal_map l m)
  [hg : g.suitable c₂ c₁] [hf : f.suitable c₃ c₂] :
  (comp g f).eval_LCFP' V r' c₁ c₃ = g.eval_LCFP' V r' c₁ c₂ ≫ f.eval_LCFP' V r' c₂ c₃ :=
begin
  unfreezingI { revert hf },
  apply free_abelian_group.induction_on_free_predicate
    (suitable c₂ c₁) (suitable_free_predicate c₂ c₁) g hg; unfreezingI { clear_dependent g },
  { intros h₂,
    simp only [eval_LCFP'_zero, zero_comp, pi.zero_apply,
      add_monoid_hom.zero_apply, add_monoid_hom.map_zero] },
  { intros g hg hf,
    -- now do another nested induction on `f`
    apply free_abelian_group.induction_on_free_predicate
      (suitable c₃ c₂) (suitable_free_predicate c₃ c₂) f hf; unfreezingI { clear_dependent f },
    { simp only [eval_LCFP'_zero, comp_zero, add_monoid_hom.map_zero] },
    { intros f hf,
      rw suitable_of_iff at hf hg,
      resetI,
      apply eval_LCFP'_comp_of },
    { intros f hf IH,
      simp only [IH, eval_LCFP'_neg, add_monoid_hom.map_neg, comp_neg] },
    { rintros (f₁ : universal_map l m) (f₂ : universal_map l m) hf₁ hf₂ IH₁ IH₂, resetI,
      haveI Hg₁f : (comp (of g) f₁).suitable c₃ c₁ := suitable.comp c₂,
      haveI Hg₂f : (comp (of g) f₂).suitable c₃ c₁ := suitable.comp c₂,
      simp only [add_monoid_hom.map_add, eval_LCFP'_add, IH₁, IH₂, comp_add] } },
  { intros g hg IH hf, resetI, specialize IH,
    simp only [IH, add_monoid_hom.map_neg, eval_LCFP'_neg,
      add_monoid_hom.neg_apply, neg_inj, neg_comp] },
  { rintros (g₁ : universal_map m n) (g₂ : universal_map m n) hg₁ hg₂ IH₁ IH₂ hf, resetI,
    haveI Hg₁f : (comp g₁ f).suitable c₃ c₁ := suitable.comp c₂,
    haveI Hg₂f : (comp g₂ f).suitable c₃ c₁ := suitable.comp c₂,
    simp only [add_monoid_hom.map_add, add_monoid_hom.add_apply, eval_LCFP'_add, IH₁, IH₂, add_comp] }
end

lemma eval_LCFP_comp (g : universal_map m n) (f : universal_map l m)
  [hg : g.suitable c₂ c₁] [hf : f.suitable c₃ c₂] :
  @eval_LCFP V r' c₁ c₃ _ _ (comp g f) (suitable.comp c₂) =
    g.eval_LCFP V r' c₁ c₂ ≫ f.eval_LCFP V r' c₂ c₃ :=
by { simp only [eval_LCFP_eq_eval_LCFP'], apply eval_LCFP'_comp }

lemma res_comp_eval_LCFP [fact (c₂ ≤ c₁)] [fact (c₄ ≤ c₃)] [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂] :
  res V r' c₁ c₂ n ≫ ϕ.eval_LCFP V r' c₂ c₄ = ϕ.eval_LCFP V r' c₁ c₃ ≫ res V r' c₃ c₄ m :=
begin
  simp only [eval_LCFP, comp_sum, sum_comp, comp_zsmul, zsmul_comp],
  apply finset.sum_congr rfl,
  rintros ⟨g, hg⟩ -,
  haveI : g.suitable c₃ c₁ := suitable_of_mem_support ϕ _ _ g hg,
  haveI : g.suitable c₄ c₂ := suitable_of_mem_support ϕ _ _ g hg,
  simp only [subtype.coe_mk, g.res_comp_eval_LCFP V r' c₁ c₂ c₃ c₄],
end

lemma Tinv_comp_eval_LCFP [fact (0 < r')] [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂] :
  Tinv V r' c₁ c₂ n ≫ ϕ.eval_LCFP V r' c₂ c₄ = ϕ.eval_LCFP V r' c₁ c₃ ≫ Tinv V r' c₃ c₄ m :=
begin
  simp only [eval_LCFP, comp_sum, sum_comp, comp_zsmul, zsmul_comp],
  apply finset.sum_congr rfl,
  rintros ⟨g, hg⟩ -,
  haveI : g.suitable c₃ c₁ := suitable_of_mem_support ϕ _ _ g hg,
  haveI : g.suitable c₄ c₂ := suitable_of_mem_support ϕ _ _ g hg,
  congr' 1, apply basic_universal_map.Tinv_comp_eval_LCFP V r',
end

lemma T_inv_comp_eval_LCFP [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁] :
  T_inv r V r' c₁ n ≫ ϕ.eval_LCFP V r' c₁ c₂ =
    ϕ.eval_LCFP V r' c₁ c₂ ≫ T_inv r V r' c₂ m :=
begin
  simp only [eval_LCFP, comp_sum, sum_comp, comp_zsmul, zsmul_comp],
  apply finset.sum_congr rfl,
  rintros ⟨g, hg⟩ -,
  haveI : g.suitable c₂ c₁ := suitable_of_mem_support ϕ _ _ g hg,
  congr' 1,
  apply basic_universal_map.T_inv_comp_eval_LCFP r V r',
end

lemma norm_eval_LCFP_le [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁]
  (N : ℕ) (h : ϕ.bound_by N) (M) :
  ∥(ϕ.eval_LCFP V r' c₁ c₂).app M∥ ≤ N :=
begin
  rw [eval_LCFP_eq_eval_LCFP', eval_LCFP'],
  have : (∑ (g : basic_universal_map m n) in support ϕ, (coeff g ϕ).nat_abs : ℝ) ≤ N,
  { exact_mod_cast h },
  simp only [← nat_trans.app_hom_apply, add_monoid_hom.map_sum, add_monoid_hom.map_zsmul],
  refine le_trans (norm_sum_le_of_le ϕ.support _) this,
  intros g hg,
  have aux := ϕ.suitable_of_mem_support c₂ c₁ g hg,
  refine le_trans (norm_zsmul_le _ _) _,
  suffices : ∥(nat_trans.app_hom M) (basic_universal_map.eval_LCFP' V r' g c₁ c₂)∥ ≤ 1,
  { have aux₁ : ∥(coeff g) ϕ∥ = ↑(((coeff g) ϕ).nat_abs),
    { rw [@coe_coe ℕ ℤ ℝ _ _ _, ← int.abs_eq_nat_abs, int.cast_abs],
    refl },
    rw aux₁,
    exact mul_le_of_le_one_right ((coeff g) ϕ).nat_abs.cast_nonneg this },
  rw [← g.eval_LCFP_eq_eval_LCFP' V r' c₁ c₂, basic_universal_map.eval_LCFP],
  { apply normed_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.1,
    exact locally_constant.comap_hom_norm_noninc _ _, exact aux },
end

end universal_map

end breen_deligne


def as := [-1, 2, 0, -3, 4]

#eval as.map fun a => ite (GE.ge a 0) [a] [] -- Works

#eval as.map fun a => ite (a ≥ 0) [a] [] -- Fails if we use `withSynthesize` instead of `withSynthesizeLight` at `elabBinRel`

example : True :=
  /-
  Requires type annotation at the numeral, otherwise we get a type error at `rfl`
  because `(0 == 1)` does not reduce to `false` until the default instance is applied.
  Possible improvement: before reporting a type mismatch, apply default instances, and try again.
  -/
  have : (0 == (1 : Nat)) = false := rfl
  ⟨⟩


theorem false_implies_false : false → false :=
begin
  sorry
end


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.sheaf
import category_theory.sites.cover_lifting
import category_theory.adjunction.fully_faithful

/-!
# Dense subsites

We define `cover_dense` functors into sites as functors such that there exists a covering sieve
that factors through images of the functor for each object in `D`.

We will primarily consider cover-dense functors that are also full, since this notion is in general
not well-behaved otherwise. Note that https://ncatlab.org/nlab/show/dense+sub-site indeed has a
weaker notion of cover-dense that loosens this requirement, but it would not have all the properties
we would need, and some sheafification would be needed for here and there.

## Main results

- `category_theory.cover_dense.presheaf_hom`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any presheaf `ℱ` and sheaf `ℱ'` on `D`, and a morphism `α : G ⋙ ℱ ⟶ G ⋙ ℱ'`,
  we may glue them together to obtain a morphism of presheaves `ℱ ⟶ ℱ'`.
- `category_theory.cover_dense.sheaf_iso`: If `ℱ` above is a sheaf and `α` is an iso,
  then the result is also an iso.
- `category_theory.cover_dense.iso_of_restrict_iso`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any sheaves `ℱ, ℱ'` on `D`, and a morphism `α : ℱ ⟶ ℱ'`, then `α` is an iso if
  `G ⋙ ℱ ⟶ G ⋙ ℱ'` is iso.
- `category_theory.cover_dense.Sheaf_equiv_of_cover_preserving_cover_lifting`:
  If `G : (C, J) ⥤ (D, K)` is fully-faithful, cover-lifting, cover-preserving, and cover-dense,
  then it will induce an equivalence of categories of sheaves valued in a complete category.

## References

* [Elephant]: *Sketches of an Elephant*, ℱ. T. Johnstone: C2.2.
* https://ncatlab.org/nlab/show/dense+sub-site
* https://ncatlab.org/nlab/show/comparison+lemma

-/

universes w v u

namespace category_theory

variables {C : Type*} [category C] {D : Type*} [category D] {E : Type*} [category E]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology E}

/--
An auxiliary structure that witnesses the fact that `f` factors through an image object of `G`.
-/
@[nolint has_nonempty_instance]
structure presieve.cover_by_image_structure (G : C ⥤ D) {V U : D} (f : V ⟶ U) :=
(obj : C)
(lift : V ⟶ G.obj obj)
(map : G.obj obj ⟶ U)
(fac' : lift ≫ map = f . obviously)

restate_axiom presieve.cover_by_image_structure.fac'

attribute [simp, reassoc] presieve.cover_by_image_structure.fac

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `presieve.cover_by_image G U` is the presieve
of `U` consisting of those arrows that factor through images of `G`.
-/
def presieve.cover_by_image (G : C ⥤ D) (U : D) : presieve U :=
λ Y f, nonempty (presieve.cover_by_image_structure G f)

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `sieve.cover_by_image G U` is the sieve of `U`
consisting of those arrows that factor through images of `G`.
-/
def sieve.cover_by_image (G : C ⥤ D) (U : D) : sieve U :=
⟨presieve.cover_by_image G U,
  λ X Y f ⟨⟨Z, f₁, f₂, (e : _ = _)⟩⟩ g,
    ⟨⟨Z, g ≫ f₁, f₂, show (g ≫ f₁) ≫ f₂ = g ≫ f, by rw [category.assoc, ← e]⟩⟩⟩

lemma presieve.in_cover_by_image (G : C ⥤ D) {X : D} {Y : C} (f : G.obj Y ⟶ X) :
  presieve.cover_by_image G X f := ⟨⟨Y, 𝟙 _, f, by simp⟩⟩

/--
A functor `G : (C, J) ⥤ (D, K)` is called `cover_dense` if for each object in `D`,
  there exists a covering sieve in `D` that factors through images of `G`.

This definition can be found in https://ncatlab.org/nlab/show/dense+sub-site Definition 2.2.
-/
structure cover_dense (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(is_cover : ∀ (U : D), sieve.cover_by_image G U ∈ K U)

open presieve opposite

namespace cover_dense

variable {K}

variables {A : Type*} [category A] {G : C ⥤ D} (H : cover_dense K G)

-- this is not marked with `@[ext]` because `H` can not be inferred from the type
lemma ext (H : cover_dense K G) (ℱ : SheafOfTypes K) (X : D) {s t : ℱ.val.obj (op X)}
  (h : ∀ ⦃Y : C⦄ (f : G.obj Y ⟶ X), ℱ.val.map f.op s = ℱ.val.map f.op t) :
  s = t :=
begin
  apply (ℱ.cond (sieve.cover_by_image G X) (H.is_cover X)).is_separated_for.ext,
  rintros Y _ ⟨Z, f₁, f₂, ⟨rfl⟩⟩,
  simp [h f₂]
end

/--
(Implementation). Given an hom between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an hom between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def hom_over {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (ℱ ⋙ coyoneda.obj (op X)) ⟶ G.op ⋙ (sheaf_over ℱ' X).val :=
whisker_right α (coyoneda.obj (op X))

/--
(Implementation). Given an iso between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an iso between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def iso_over {ℱ ℱ' : Sheaf K A} (α : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (sheaf_over ℱ X).val ≅ G.op ⋙ (sheaf_over ℱ' X).val :=
iso_whisker_right α (coyoneda.obj (op X))

lemma sheaf_eq_amalgamation (ℱ : Sheaf K A) {X : A} {U : D} {T : sieve U} (hT)
  (x : family_of_elements _ T) (hx) (t) (h : x.is_amalgamation t) :
  t = (ℱ.cond X T hT).amalgamate x hx :=
(ℱ.cond X T hT).is_separated_for x t _ h ((ℱ.cond X T hT).is_amalgamation hx)

include H
variable [full G]
namespace types
variables {ℱ : Dᵒᵖ ⥤ Type v} {ℱ' : SheafOfTypes.{v} K} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val)

/--
(Implementation). Given a section of `ℱ` on `X`, we can obtain a family of elements valued in `ℱ'`
that is defined on a cover generated by the images of `G`. -/
@[simp, nolint unused_arguments] noncomputable
def pushforward_family {X} (x : ℱ.obj (op X)) :
  family_of_elements ℱ'.val (cover_by_image G X) := λ Y f hf,
ℱ'.val.map hf.some.lift.op $ α.app (op _) (ℱ.map hf.some.map.op x : _)

/-- (Implementation). The `pushforward_family` defined is compatible. -/
lemma pushforward_family_compatible {X} (x : ℱ.obj (op X)) :
  (pushforward_family H α x).compatible :=
begin
  intros Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ e,
  apply H.ext,
  intros Y f,
  simp only [pushforward_family, ← functor_to_types.map_comp_apply, ← op_comp],
  change (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _ =
    (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _,
  rw ← G.image_preimage (f ≫ g₁ ≫ _),
  rw ← G.image_preimage (f ≫ g₂ ≫ _),
  erw ← α.naturality (G.preimage _).op,
  erw ← α.naturality (G.preimage _).op,
  refine congr_fun _ x,
  simp only [quiver.hom.unop_op, functor.comp_map, ← op_comp, ← category.assoc,
    functor.op_map, ← ℱ.map_comp, G.image_preimage],
  congr' 3,
  simp [e]
end

/-- (Implementation). The morphism `ℱ(X) ⟶ ℱ'(X)` given by gluing the `pushforward_family`. -/
noncomputable
def app_hom (X : D) : ℱ.obj (op X) ⟶ ℱ'.val.obj (op X) := λ x,
  (ℱ'.cond _ (H.is_cover X)).amalgamate
    (pushforward_family H α x)
    (pushforward_family_compatible H α x)

@[simp] lemma pushforward_family_apply {X} (x : ℱ.obj (op X)) {Y : C} (f : G.obj Y ⟶ X) :
  pushforward_family H α x f (presieve.in_cover_by_image G f) = α.app (op Y) (ℱ.map f.op x) :=
begin
  unfold pushforward_family,
  refine congr_fun _ x,
  rw ← G.image_preimage (nonempty.some _ : presieve.cover_by_image_structure _ _).lift,
  change ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _ = ℱ.map f.op ≫ α.app (op Y),
  erw ← α.naturality (G.preimage _).op,
  simp only [← functor.map_comp, ← category.assoc, functor.comp_map, G.image_preimage,
     G.op_map, quiver.hom.unop_op, ← op_comp, presieve.cover_by_image_structure.fac],
end

@[simp] lemma app_hom_restrict {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) (x) :
  ℱ'.val.map f (app_hom H α X x) = α.app (op Y) (ℱ.map f x) :=
begin
  refine ((ℱ'.cond _ (H.is_cover X)).valid_glue
    (pushforward_family_compatible H α x) f.unop (presieve.in_cover_by_image G f.unop)).trans _,
  apply pushforward_family_apply
end

@[simp] lemma app_hom_valid_glue {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) :
  app_hom H α X ≫ ℱ'.val.map f = ℱ.map f ≫ α.app (op Y) :=
by { ext, apply app_hom_restrict }

/--
(Implementation). The maps given in `app_iso` is inverse to each other and gives a `ℱ(X) ≅ ℱ'(X)`.
-/
@[simps] noncomputable
def app_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : D) :
  ℱ.val.obj (op X) ≅ ℱ'.val.obj (op X) :=
{ hom := app_hom H i.hom X,
  inv := app_hom H i.inv X,
  hom_inv_id' := by { ext x, apply H.ext, intros Y f, simp },
  inv_hom_id' := by { ext x, apply H.ext, intros Y f, simp } }

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of types, where `G` is full
and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation between sheaves.
-/
@[simps] noncomputable
def presheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) : ℱ ⟶ ℱ'.val :=
{ app := λ X, app_hom H α (unop X), naturality' := λ X Y f,
  begin
    ext x,
    apply H.ext ℱ' (unop Y),
    intros Y' f',
    simp only [app_hom_restrict, types_comp_apply, ← functor_to_types.map_comp_apply],
    rw app_hom_restrict H α (f ≫ f'.op : op (unop X) ⟶ _)
  end }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
nat_iso.of_components (λ X, app_iso H i (unop X)) (presheaf_hom H i.hom).naturality

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between sheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := ⟨(presheaf_iso H i).hom⟩,
  inv := ⟨(presheaf_iso H i).inv⟩,
  hom_inv_id' := by { ext1, apply (presheaf_iso H i).hom_inv_id },
  inv_hom_id' := by { ext1, apply (presheaf_iso H i).inv_hom_id } }

end types
open types

variables {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A}

/-- (Implementation). The sheaf map given in `types.sheaf_hom` is natural in terms of `X`. -/
@[simps] noncomputable
def sheaf_coyoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ ⟶
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ'.val :=
{ app := λ X, presheaf_hom H (hom_over α (unop X)), naturality' := λ X Y f,
  begin
    ext U x,
    change app_hom H (hom_over α (unop Y)) (unop U) (f.unop ≫ x) =
      f.unop ≫ app_hom H (hom_over α (unop X)) (unop U) x,
    symmetry,
    apply sheaf_eq_amalgamation,
    apply H.is_cover,
    intros Y' f' hf',
    change unop X ⟶ ℱ.obj (op (unop _)) at x,
    dsimp,
    simp only [pushforward_family, functor.comp_map,
      coyoneda_obj_map, hom_over_app, category.assoc],
    congr' 1,
    conv_lhs { rw ← hf'.some.fac },
    simp only [← category.assoc, op_comp, functor.map_comp],
    congr' 1,
    refine (app_hom_restrict H (hom_over α (unop X)) hf'.some.map.op x).trans _,
    simp
  end }

/--
(Implementation). `sheaf_coyoneda_hom` but the order of the arguments of the functor are swapped.
-/
noncomputable
def sheaf_yoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⋙ yoneda ⟶ ℱ'.val ⋙ yoneda :=
begin
  let α := sheaf_coyoneda_hom H α,
  refine { app := _, naturality' := _ },
  { intro U,
    refine { app := λ X, (α.app X).app U,
      naturality' := λ X Y f, by simpa using congr_app (α.naturality f) U } },
  { intros U V i,
    ext X x,
    exact congr_fun ((α.app X).naturality i) x },
end

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation
between presheaves.
-/
noncomputable
def sheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⟶ ℱ'.val :=
let α' := sheaf_yoneda_hom H α in
  { app := λ X, yoneda.preimage (α'.app X),
    naturality' := λ X Y f, yoneda.map_injective (by simpa using α'.naturality f) }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
begin
  haveI : ∀ (X : Dᵒᵖ), is_iso ((sheaf_hom H i.hom).app X),
  { intro X,
    apply is_iso_of_reflects_iso _ yoneda,
    use (sheaf_yoneda_hom H i.inv).app X,
    split;
      ext x : 2;
      simp only [sheaf_hom, nat_trans.comp_app, nat_trans.id_app, functor.image_preimage],
      exact ((presheaf_iso H (iso_over i (unop x))).app X).hom_inv_id,
      exact ((presheaf_iso H (iso_over i (unop x))).app X).inv_hom_id,
    apply_instance },
  haveI : is_iso (sheaf_hom H i.hom) := by apply nat_iso.is_iso_of_is_iso_app,
  apply as_iso (sheaf_hom H i.hom),
end

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := ⟨(presheaf_iso H i).hom⟩,
  inv := ⟨(presheaf_iso H i).inv⟩,
  hom_inv_id' := by { ext1, apply (presheaf_iso H i).hom_inv_id },
  inv_hom_id' := by { ext1, apply (presheaf_iso H i).inv_hom_id } }

/--
The constructed `sheaf_hom α` is equal to `α` when restricted onto `C`.
-/
lemma sheaf_hom_restrict_eq (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  whisker_left G.op (sheaf_hom H α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (G.obj (unop X))), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  simp only [pushforward_family, functor.comp_map, yoneda_map_app,
    coyoneda_obj_map, op_comp, functor_to_types.map_comp_apply, hom_over_app, ← category.assoc],
  congr' 1,
  simp only [category.assoc],
  congr' 1,
  rw ← G.image_preimage hf.some.map,
  symmetry,
  apply α.naturality (G.preimage hf.some.map).op,
  apply_instance
end

/--
If the pullback map is obtained via whiskering,
then the result `sheaf_hom (whisker_left G.op α)` is equal to `α`.
-/
lemma sheaf_hom_eq (α : ℱ ⟶ ℱ'.val) : sheaf_hom H (whisker_left G.op α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  swap, { apply_instance },
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (unop X)), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  dsimp,
  simp,
end

/--
A full and cover-dense functor `G` induces an equivalence between morphisms into a sheaf and
morphisms over the restrictions via `G`.
-/
noncomputable
def restrict_hom_equiv_hom : (G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) ≃ (ℱ ⟶ ℱ'.val) :=
{ to_fun := sheaf_hom H,
  inv_fun := whisker_left G.op,
  left_inv := sheaf_hom_restrict_eq H,
  right_inv := sheaf_hom_eq H }

/--
Given a full and cover-dense functor `G` and a natural transformation of sheaves `α : ℱ ⟶ ℱ'`,
if the pullback of `α` along `G` is iso, then `α` is also iso.
-/
lemma iso_of_restrict_iso {ℱ ℱ' : Sheaf K A} (α : ℱ ⟶ ℱ')
  (i : is_iso (whisker_left G.op α.val)) : is_iso α :=
begin
  convert is_iso.of_iso (sheaf_iso H (as_iso (whisker_left G.op α.val))) using 1,
  ext1,
  apply (sheaf_hom_eq _ _).symm
end

/-- A fully faithful cover-dense functor preserves compatible families. -/
lemma compatible_preserving [faithful G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ eq,
  apply H.ext,
  intros W i,
  simp only [← functor_to_types.map_comp_apply, ← op_comp],
  rw ← G.image_preimage (i ≫ f₁),
  rw ← G.image_preimage (i ≫ f₂),
  apply hx,
  apply G.map_injective,
  simp [eq]
end

noncomputable
instance sites.pullback.full [faithful G] (Hp : cover_preserving J K G) :
  full (sites.pullback A H.compatible_preserving Hp) :=
{ preimage := λ ℱ ℱ' α, ⟨H.sheaf_hom α.val⟩,
  witness' := λ ℱ ℱ' α, Sheaf.hom.ext _ _ $ H.sheaf_hom_restrict_eq α.val }

instance sites.pullback.faithful [faithful G] (Hp : cover_preserving J K G) :
  faithful (sites.pullback A H.compatible_preserving Hp) :=
{ map_injective' := begin
    intros ℱ ℱ' α β e,
    ext1,
    apply_fun (λ e, e.val) at e,
    dsimp at e,
    rw [← H.sheaf_hom_eq α.val, ← H.sheaf_hom_eq β.val, e],
  end }

end cover_dense

end category_theory

namespace category_theory.cover_dense

open category_theory

variables {C D : Type u} [category.{v} C] [category.{v} D]
variables {G : C ⥤ D} [full G] [faithful G]
variables {J : grothendieck_topology C} {K : grothendieck_topology D}
variables {A : Type w} [category.{max u v} A] [limits.has_limits A]
variables (Hd : cover_dense K G) (Hp : cover_preserving J K G) (Hl : cover_lifting J K G)

include Hd Hp Hl

/--
Given a functor between small sites that is cover-dense, cover-preserving, and cover-lifting,
it induces an equivalence of category of sheaves valued in a complete category.
-/
@[simps functor inverse] noncomputable
def Sheaf_equiv_of_cover_preserving_cover_lifting : Sheaf J A ≌ Sheaf K A :=
begin
  symmetry,
  let α := sites.pullback_copullback_adjunction.{w v u} A Hp Hl Hd.compatible_preserving,
  haveI : ∀ (X : Sheaf J A), is_iso (α.counit.app X),
  { intro ℱ,
    apply_with (reflects_isomorphisms.reflects (Sheaf_to_presheaf J A)) { instances := ff },
    exact is_iso.of_iso ((@as_iso _ _ _ _ _ (Ran.reflective A G.op)).app ℱ.val) },
  haveI : is_iso α.counit := nat_iso.is_iso_of_is_iso_app _,
  exact
  { functor := sites.pullback A Hd.compatible_preserving Hp,
    inverse := sites.copullback A Hl,
    unit_iso := as_iso α.unit,
    counit_iso := as_iso α.counit,
    functor_unit_iso_comp' := λ ℱ, by convert α.left_triangle_components }
end

end category_theory.cover_dense


import category_theory.comma
import category_theory.adjunction.basic
import category_theory.limits.shapes
import category_theory.epi_mono
import cartesian_closed
import pullbacks
import comma
import over
import to_mathlib

/-!
# Properties of the over category.
We say `C` is locally cartesian closed if it has all finite limits, and each
`C/B` is cartesian closed.

Given `f : A ⟶ B` in `C/B`, the iterated slice `(C/B)/f` is isomorphic to
`C/A`, and so `f* : C/B ⥤ (C/B)/f` is 'the same thing' as pulling back
morphisms along `f`. In particular, `C` is locally cartesian closed iff
it has finite limits and `f* : C/B ⥤ C/A` has a right adjoint (for each
`f : A ⟶ B`).

From here, we can show that if `C` is locally cartesian closed and has
reflexive coequalizers, then every morphism factors into a regular epic
and monic.
-/
namespace category_theory
open category limits

universes v u
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

variable (C)
class is_locally_cartesian_closed extends has_pullbacks.{v} C :=
(overs_cc : Π (B : C), is_cartesian_closed (over B))

instance cartesian_closed_over_of_lcc [has_binary_products.{v} C] [is_locally_cartesian_closed.{v} C] {B : C} :
  is_cartesian_closed (over B) := @is_locally_cartesian_closed.overs_cc _ 𝒞 _ B

universe u₂

variable {C}
lemma equiv_reflects_mono {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
faithful_reflects_mono e.functor hef

lemma equiv_reflects_epi {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : epi (e.functor.map f)) : epi f :=
faithful_reflects_epi e.functor hef

lemma equiv_preserves_mono {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D) :
  mono f → mono (e.functor.map f) :=
begin
  intro hf, apply equiv_reflects_mono ((e.functor).map f) e.symm,
  erw equivalence.inv_fun_map,
  apply mono_comp_of_mono,
  apply @is_iso.mono_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _), apply is_iso.of_iso_inverse,
  apply mono_comp_of_mono _ _ hf,
  apply @is_iso.mono_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _), apply is_iso.of_iso,
end

lemma equiv_preserves_epi {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D) :
  epi f → epi (e.functor.map f) :=
begin
  intro hf, apply equiv_reflects_epi ((e.functor).map f) e.symm,
  erw equivalence.inv_fun_map,
  apply epi_comp_of_epi,
  apply @is_iso.epi_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _), apply is_iso.of_iso_inverse,
  apply epi_comp_of_epi _ _ hf,
  apply @is_iso.epi_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _), apply is_iso.of_iso,
end

lemma equiv_mono_iff {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D) :
  mono f ↔ mono (e.functor.map f) :=
⟨equiv_preserves_mono f e, equiv_reflects_mono f e⟩

lemma equiv_epi_iff {D : Type u₂} [category.{v} D] (X Y : C) (f : X ⟶ Y) (e : C ≌ D) :
  epi f ↔ epi (e.functor.map f) :=
⟨equiv_preserves_epi f e, equiv_reflects_epi f e⟩

lemma over_epi {B : C} {f g : over B} {k : f ⟶ g} (ke : epi k.left) : epi k :=
begin
  split, intros h l m a, ext, rw [← cancel_epi k.left, ← over.comp_left, a], refl
end
lemma over_epi' [has_binary_products.{v} C] (B : C) (f g : over B) (k : f ⟶ g) (ke : epi k) : epi k.left :=
left_adjoint_preserves_epi (forget_adj_star _) ke

lemma over_epi'' [has_binary_products.{v} C] (B : C) (f g : over B) (k : f ⟶ g) : epi k ↔ epi k.left :=
⟨over_epi' _ _ _ _, over_epi⟩

@[reducible]
def pullback_along [has_pullbacks.{v} C] {A B : C} (f : A ⟶ B) : over B ⥤ over A :=
star (over.mk f) ⋙ (over.iterated_slice_equiv _).functor

def over_iso {B : C} (f g : over B) (hl : f.left ≅ g.left) (hw : hl.hom ≫ g.hom = f.hom) : (f ≅ g) :=
{ hom := over.hom_mk hl.hom, inv := over.hom_mk hl.inv (by simp [iso.inv_comp_eq, hw]) }

def over_left_iso {B : C} {f g : over B} (hf : f ≅ g) : f.left ≅ g.left :=
{ hom := hf.hom.left, inv := hf.inv.left, hom_inv_id' := begin rw [← over.comp_left, hf.hom_inv_id], refl end, inv_hom_id' := begin rw [← over.comp_left, hf.inv_hom_id], refl end}

lemma pullback_along_obj_of_id [has_pullbacks.{v} C] {A B : C} (f : A ⟶ B) : (pullback_along f).obj (over.mk (𝟙 B)) ≅ over.mk (𝟙 A) :=
begin
  apply over_iso, swap,
  have: over.mk f⨯⊤_ over B ≅ over.mk f, apply prod.right_unitor,
  apply over_left_iso this,
  dunfold over_left_iso over.iterated_slice_equiv pullback_along equivalence.mk, simp, dsimp, simp,
end

lemma pullback_of_obj [has_pullbacks.{v} C] {A B D : C} (f : A ⟶ B) (g : D ⟶ B) :
  ((pullback_along f).map (terminal.from (over.mk g))).left = (pullback.fst : pullback f g ⟶ A) ≫ (pullback.with_id_l f).inv :=
begin
  dsimp [pullback_along, equivalence.mk, pullback.with_id_l, pullback.with_id_r, identify_limit_apex, iso_apex_of_iso_cone, pullback.with_id_r', pullback.flip', flip_limit_cone, cospan_cone.flip, is_limit.unique_up_to_iso, is_limit.lift_cone_morphism],
  ext, simp, dsimp, erw limit.lift_π, simp, dunfold pullback_cone.snd, dsimp, simp, erw limit.lift_π, dsimp, simp,
  erw limit.lift_π, dsimp,
  slice_rhs 3 4 {erw limit.lift_π},
  dsimp, slice_rhs 2 3 {erw limit.lift_π}, symmetry, apply pullback.condition
end

variables [is_locally_cartesian_closed.{v} C]

lemma thing {A B : C} (f : A ⟶ B) : is_left_adjoint (pullback_along f) :=
{ right := _ ⋙ _, adj := adjunction.comp _ _ (@star_adj_pi_of_exponentiable (over B) _ (over.mk f) _ _ _ (@is_cartesian_closed.cart_closed _ _ _ (is_locally_cartesian_closed.overs_cc B) _)) (equivalence.to_adjunction _) }

variables [has_binary_products.{v} C]
/--
 P ⟶ A
 ↓   ↓
 D ↠ B
If g : D ⟶ B is epi then the pullback of g along f is epi
-/
theorem pullback_preserves_epi {A B D : C}
  (f : A ⟶ B) {g : D ⟶ B} (hg : epi g) :
  epi (pullback.fst : pullback f g ⟶ A) :=
begin
  set g' : over.mk g ⟶ ⊤_ over B := terminal.from (over.mk g),
  have: epi g' := over_epi hg,
  have q: epi ((pullback_along f).map g'),
    apply left_adjoint_preserves_epi, apply (thing f).adj, assumption,
  rw over_epi'' at q,
  erw pullback_of_obj f g at q,
  have: (pullback.fst : pullback f g ⟶ A) ≫ (pullback.with_id_l f).inv ≫ (pullback.with_id_l f).hom = (pullback.fst : pullback f g ⟶ A),
    simp,
  rw ← this, rw ← assoc, apply epi_comp_of_epi, assumption, apply is_iso.epi_of_iso
end

lemma pullback_preserves_epi' {A B D : C}
  (f : A ⟶ B) {g : D ⟶ B} (hg : epi g) :
epi (pullback.snd : pullback g f ⟶ A) :=
begin
  have: (pullback.snd : pullback g f ⟶ A) = (pullback.flip' _ _).hom ≫ (pullback.fst : pullback f g ⟶ A), -- TODO: this should be a lemma
    dunfold pullback.flip' iso_apex_of_iso_cone flip_limit_cone flip_hom flip_twice, dsimp, erw id_comp, rw [limit.lift_π], refl,
  rw this, apply epi_comp_of_epi, apply is_iso.epi_of_iso,
  apply pullback_preserves_epi _ hg
end
lemma pullback_preserves_epi'' {A B D : C}
  (f : A ⟶ B) {g : D ⟶ B} (hg : epi g) {c : pullback_cone g f} (t : is_limit c) :
epi (pullback_cone.snd c) :=
begin
  have y := is_limit.unique_up_to_iso t (limit.is_limit _),
  have z: pullback_cone.snd c = y.hom.hom ≫ pullback_cone.snd (limit.cone (cospan g f)),
    rw y.hom.w,
  rw z, apply epi_comp_of_epi,
    apply @is_iso.epi_of_iso _ _ _ _ _ _, refine ⟨_, _, _⟩, apply y.inv.hom,
    show ((y.hom ≫ y.inv).hom = 𝟙 c.X), rw y.hom_inv_id, refl,
    show ((y.inv ≫ y.hom).hom = 𝟙 _), rw y.inv_hom_id, refl,
  exact pullback_preserves_epi' f hg
end

variables [has_coequalizers.{v} C] {A B : C} (f : A ⟶ B)

-- Technically the regular coimage, but in a LCCC with coequalizers it is the image
def image : C := coequalizer (pullback.fst : pullback f f ⟶ A) (pullback.snd : pullback f f ⟶ A)
def epi_part : A ⟶ image f := coequalizer.π pullback.fst pullback.snd
def mono_part : image f ⟶ B := coequalizer.desc _ _ f pullback.condition

lemma factorises : epi_part f ≫ mono_part f = f :=
by simp [epi_part, mono_part]

lemma coequalizer_epi (g h : A ⟶ B) : epi (coequalizer.π g h) :=
begin
  split, intros k l m q, apply colimit.hom_ext, intro, cases j,
  rw ← colimit.w (parallel_pair _ _) walking_parallel_pair_hom.left, rw assoc, rw q, simp,
  exact q,
end
lemma epi_part_is_epi : epi (epi_part f) := coequalizer_epi _ _

lemma prod_map_epi (D : C) {q : A ⟶ B} (hq : epi q) : epi (limits.prod.map q (𝟙 D)) :=
pullback_preserves_epi'' _ hq (pullback_prod _ _)

lemma prod_map_epi' (D : C) {q : A ⟶ B} (hq : epi q) : epi (limits.prod.map (𝟙 D) q) :=
pullback_preserves_epi'' _ hq (pullback_prod' q D)

lemma mono_part_is_mono : mono (mono_part f) :=
begin
  split, intros D g h gmhm,
  set R := pullback f f,
  set I := image f,
  set q := epi_part f,
  set m := mono_part f,
  set E := pullback (limits.prod.map q q) (limits.prod.lift g h),
  set n : E ⟶ D := pullback.snd,
  set kl : E ⟶ A ⨯ A := pullback.fst,
  set a : R ⟶ A := pullback.fst,
  set b : R ⟶ A := pullback.snd,
  set k : E ⟶ A := kl ≫ limits.prod.fst,
  set l : E ⟶ A := kl ≫ limits.prod.snd,
  have kqng: k ≫ q = n ≫ g,
    have: (kl ≫ limits.prod.map q q) ≫ limits.prod.fst = (n ≫ limits.prod.lift g h) ≫ limits.prod.fst, rw pullback.condition,
    rw [assoc, assoc, lift_fst, map_fst, ← assoc] at this, exact this,
  have lqnh: l ≫ q = n ≫ h,
    have: (kl ≫ limits.prod.map q q) ≫ limits.prod.snd = (n ≫ limits.prod.lift g h) ≫ limits.prod.snd, rw pullback.condition,
    rw [assoc, assoc, lift_snd, map_snd, ← assoc] at this, exact this,
  have kflf: k ≫ f = l ≫ f,
    rw [← factorises f, ← assoc, kqng, assoc, gmhm, ← assoc, ← lqnh, assoc],
  set p : E ⟶ R := pullback.lift k l kflf,
  have pak: p ≫ a = k, simp,
  have pbl: p ≫ b = l, simp,
  have aqbq: a ≫ q = b ≫ q := coequalizer.condition a b,
  have: n ≫ g = n ≫ h,
    rw [← kqng, ← pak, assoc, aqbq, ← assoc, pbl, lqnh],
  haveI: epi n := pullback_preserves_epi' _ _,
  rwa ← cancel_epi n,
  have: limits.prod.map q q = limits.prod.map (𝟙 _) q ≫ limits.prod.map q (𝟙 _),
    apply prod.hom_ext, simp, dsimp, simp, simp,
  rw this, apply epi_comp_of_epi, apply prod_map_epi' A (epi_part_is_epi f),
  apply prod_map_epi _ (epi_part_is_epi f)
end

variable {f}
def image_map {A' B' : C} {f' : A' ⟶ B'} {l : A ⟶ A'} {r : B ⟶ B'} (h : l ≫ f' = f ≫ r) : image f ⟶ image f' :=
begin
  apply coequalizer.desc _ _ (l ≫ epi_part f'),
  rw ← @cancel_mono _ _ _ _ _ (mono_part f') (mono_part_is_mono _),
  rw assoc, rw assoc, rw factorises, rw assoc, rw assoc, rw factorises,
  rw h,
  rw ← factorises f, rw ← assoc, rw ← assoc, rw ← assoc, rw ← assoc,
  congr' 2, rw factorises, apply coequalizer.condition
end

lemma image_map_comm_left {A' B' : C} {f' : A' ⟶ B'} {l : A ⟶ A'} {r : B ⟶ B'} (h : l ≫ f' = f ≫ r) :
  epi_part f ≫ image_map h = l ≫ epi_part f' :=
colimit.ι_desc _ _

lemma image_map_comm_right {A' B' : C} {f' : A' ⟶ B'} {l : A ⟶ A'} {r : B ⟶ B'} (h : l ≫ f' = f ≫ r) :
  image_map h ≫ mono_part f' = mono_part f ≫ r :=
begin
  haveI := epi_part_is_epi f,
  rw ← cancel_epi (epi_part f),
  rw ← assoc, rw image_map_comm_left, rw assoc, rw factorises, rw h, rw ← assoc, rw factorises
end

lemma cofork.of_π_app_zero {X Y : C} {f g : X ⟶ Y} {P : C} (π : Y ⟶ P) (w : f ≫ π = g ≫ π) :
  (cofork.of_π π w).ι.app walking_parallel_pair.zero = f ≫ π := rfl
lemma cofork.of_π_app_one {X Y : C} {f g : X ⟶ Y} {P : C} (π : Y ⟶ P) (w : f ≫ π = g ≫ π) :
  (cofork.of_π π w).ι.app walking_parallel_pair.one = π := rfl

lemma coequalizer.hom_ext {X Y P : C} {f g : X ⟶ Y} {h k : coequalizer f g ⟶ P}
  (hyp : coequalizer.π f g ≫ h = coequalizer.π f g ≫ k) :
h = k :=
begin
  apply colimit.hom_ext, intro j, cases j,
  rw ← colimit.w (parallel_pair f g) walking_parallel_pair_hom.left, rw assoc, rw assoc, congr' 1,
  rw hyp, rw hyp
end

lemma image_map_uniq {A' B' : C} {f' : A' ⟶ B'} {l : A ⟶ A'} {r : B ⟶ B'} (h : l ≫ f' = f ≫ r) (k : image f ⟶ image f') :
  epi_part f ≫ k = l ≫ epi_part f' → k ≫ mono_part f' = mono_part f ≫ r → k = image_map h :=
begin
  intros, refine coequalizer.hom_ext _,
  erw a, erw image_map_comm_left
end

-- Image is a functor from the "arrow" category
def image.functor : comma (𝟭 C) (𝟭 C) ⥤ C :=
{ obj := λ f, image f.hom,
  map := λ f g k, image_map k.w,
  map_id' := λ f, begin symmetry, apply image_map_uniq, erw [id_comp, comp_id], erw [id_comp, comp_id] end,
  map_comp' := λ f g h α β,
    begin
      symmetry,
      apply image_map_uniq,
      rw [← assoc, image_map_comm_left, assoc, image_map_comm_left, ← assoc], refl,
      rw [assoc, image_map_comm_right, ← assoc, image_map_comm_right, assoc], refl
    end
}

def image_is_smallest_subobject {I : C} {q : A ⟶ I} {m : I ⟶ B} (hm : mono m) (h : q ≫ m = f) :
  image f ⟶ I :=
begin
  apply coequalizer.desc _ _ q, rw ← cancel_mono m, simp [h], rw pullback.condition
end

lemma smallest_subobject_factors {I : C} {q : A ⟶ I} {m : I ⟶ B} (hm : mono m) (h : q ≫ m = f) :
  image_is_smallest_subobject hm h ≫ m = mono_part f :=
begin
  haveI := epi_part_is_epi f,
  rw ← cancel_epi (epi_part f),
  rw factorises, rw ← assoc, erw colimit.ι_desc,
  exact h
end
end category_theory


/-
Copyright (c) 2020 Bhavik Mehta, Edward Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Edward Ayers
-/

import category_theory.limits.shapes
import category_theory.limits.preserves
import .comma

/-!
# Pullbacks

Many, many lemmas to work with pullbacks.
-/
open category_theory category_theory.category category_theory.limits

universes u v
variables {C : Type u} [𝒞 : category.{v} C]
variables {J : Type v} [small_category J]
include 𝒞

variables {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}

@[simp] lemma pullback_cone.simp_left {L : C} {lx : L ⟶ X} {ly : L ⟶ Y} {e : lx ≫ f = ly ≫ g} :
  ((pullback_cone.mk lx ly e).π).app walking_cospan.left = lx := rfl
@[simp] lemma pullback_cone.simp_right {L : C} {lx : L ⟶ X} {ly : L ⟶ Y} {e : lx ≫ f = ly ≫ g} :
  ((pullback_cone.mk lx ly e).π).app walking_cospan.right = ly := rfl

lemma pi_app {W : C} {h : X ⟶ Z} {k : Y ⟶ Z} {c₁ c₂ : cone (cospan h k)} {f : W ⟶ c₁.X} {g : W ⟶ c₂.X}
  (h1 : f ≫ pullback_cone.fst c₁ = g ≫ pullback_cone.fst c₂)
  (h2 : f ≫ pullback_cone.snd c₁ = g ≫ pullback_cone.snd c₂) :
  ∀ (j : walking_cospan), f ≫ c₁.π.app j = g ≫ c₂.π.app j :=
begin
  intro j, cases j, exact h1, exact h2,
  rw ← cone.w c₂ walking_cospan.hom.inl,
  rw ← cone.w c₁ walking_cospan.hom.inl,
  rw ← assoc, rw ← assoc, rw h1
end

/-- This is often useful in proving we have a limit for a pullback. -/
lemma pi_app_left {h : X ⟶ Z} {k : Y ⟶ Z} (c₁ c₂ : cone (cospan h k)) (f : c₂.X ⟶ c₁.X)
  (h1 : f ≫ pullback_cone.fst c₁ = pullback_cone.fst c₂)
  (h2 : f ≫ pullback_cone.snd c₁ = pullback_cone.snd c₂) :
  ∀ (j : walking_cospan), f ≫ c₁.π.app j = c₂.π.app j :=
begin
  convert @pi_app C _ _ _ _ _ _ _ c₁ c₂ f (𝟙 _) _ _,
  simp, simpa, simpa
end

lemma pullback_cone.hom_ext {t : pullback_cone f g} (h : is_limit t) {W : C} {f₁ f₂ : W ⟶ t.X}
  (h1 : f₁ ≫ pullback_cone.fst t = f₂ ≫ pullback_cone.fst t)
  (h2 : f₁ ≫ pullback_cone.snd t = f₂ ≫ pullback_cone.snd t) :
  f₁ = f₂ :=
is_limit.hom_ext h (pi_app h1 h2)

lemma pullback.hom_ext {X Y Z A : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_limit (cospan f g)]
  (a b : A ⟶ pullback f g)
  (h1 : a ≫ pullback.fst = b ≫ pullback.fst)
  (h2 : a ≫ pullback.snd = b ≫ pullback.snd)
    : a = b :=
pullback_cone.hom_ext (limit.is_limit _) h1 h2

@[simp] lemma pullback.lift_self_id {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} [has_limit (cospan f g)] :
  pullback.lift pullback.fst pullback.snd pullback.condition = 𝟙 (pullback f g) :=
begin
  apply pullback.hom_ext,
  rw limit.lift_π, rw id_comp, refl,
  rw limit.lift_π, rw id_comp, refl
end

def iso_apex_of_iso_cone {F : J ⥤ C} {c₁ c₂ : cone F} (h : c₁ ≅ c₂) : c₁.X ≅ c₂.X :=
{ hom := h.hom.hom,
  inv := h.inv.hom,
  hom_inv_id' :=
  begin
    show (h.hom ≫ h.inv).hom = 𝟙 (c₁.X),
    have: h.hom ≫ h.inv = 𝟙 c₁ := h.hom_inv_id',
    rw this, refl
  end,
  inv_hom_id' :=
  begin
    show (h.inv ≫ h.hom).hom = 𝟙 (c₂.X),
    have: h.inv ≫ h.hom = 𝟙 c₂ := h.inv_hom_id',
    rw this, refl
  end,
}

-- The pasting lemma for pullbacks.
lemma pasting {C : Type u} [𝒞 : category.{v} C] {U V W X Y Z : C}
  (f : U ⟶ V) (g : V ⟶ W) (h : U ⟶ X) (k : V ⟶ Y) (l : W ⟶ Z) (m : X ⟶ Y) (n : Y ⟶ Z)
  (left_comm : f ≫ k = h ≫ m) (right_comm : g ≫ l = k ≫ n)
  (right : is_limit (pullback_cone.mk g k right_comm)) :
  is_limit (pullback_cone.mk (f ≫ g) h (begin rw assoc, rw right_comm, rw ← assoc, rw left_comm, rw assoc end)) ≅
  is_limit (pullback_cone.mk f h left_comm) :=
{ hom :=
  begin
    intro entire,
    refine ⟨λ c, _, _, _⟩,
    { have new_cone_comm: (pullback_cone.fst c ≫ g) ≫ l = pullback_cone.snd c ≫ m ≫ n,
        rw assoc, rw ← pullback_cone.condition_assoc, rw right_comm,
      exact entire.lift (pullback_cone.mk (pullback_cone.fst c ≫ g) (pullback_cone.snd c) new_cone_comm) },
    { intro c,
      have new_cone_comm: (pullback_cone.fst c ≫ g) ≫ l = pullback_cone.snd c ≫ m ≫ n,
        rw assoc, rw ← pullback_cone.condition_assoc, rw right_comm,
      set new_cone := pullback_cone.mk (pullback_cone.fst c ≫ g) (pullback_cone.snd c) new_cone_comm,
      have coned := entire.fac new_cone,
      apply pi_app_left (pullback_cone.mk f h left_comm),
      { apply pullback_cone.hom_ext right,
        { rw assoc, exact coned walking_cospan.left },
        { rw assoc, conv_lhs {congr, skip, erw left_comm}, rw ← assoc,
          erw [pullback_cone.condition c, coned walking_cospan.right], refl } },
      { exact coned walking_cospan.right }},
    { intros c r j,
      have new_cone_comm: (pullback_cone.fst c ≫ g) ≫ l = pullback_cone.snd c ≫ m ≫ n,
        rw assoc, rw ← pullback_cone.condition_assoc, rw right_comm,
      set new_cone := pullback_cone.mk (pullback_cone.fst c ≫ g) (pullback_cone.snd c) new_cone_comm,
      apply entire.uniq new_cone r, -- BM: here
      apply pi_app_left (pullback_cone.mk (f ≫ g) h _) new_cone _,
      { show r ≫ f ≫ g = _ ≫ g, rw ← assoc, congr, exact j walking_cospan.left },
      { show r ≫ h = (new_cone.π).app walking_cospan.right, exact j walking_cospan.right },
    }
  end,
  inv :=
  begin
    intro left,
    refine ⟨λ c, _, λ c, _, λ c, _⟩,
    { have new_cone_comm: pullback_cone.fst c ≫ l = (pullback_cone.snd c ≫ m) ≫ n,
        rw assoc, rw pullback_cone.condition,
      have new_cone2_comm: (right.lift (pullback_cone.mk _ _ new_cone_comm)) ≫ k = (pullback_cone.snd c : c.X ⟶ X) ≫ m :=
           right.fac (pullback_cone.mk _ _ new_cone_comm) walking_cospan.right,
      exact left.lift (pullback_cone.mk _ _ new_cone2_comm) },
    { set π₁ : c.X ⟶ W := pullback_cone.fst c,
      set π₂ : c.X ⟶ X := pullback_cone.snd c,
      have new_cone_comm: π₁ ≫ l = (π₂ ≫ m) ≫ n,
        rw assoc, rw pullback_cone.condition,
      have new_cone2_comm: (right.lift (pullback_cone.mk _ _ new_cone_comm)) ≫ k = π₂ ≫ m :=
            right.fac (pullback_cone.mk _ _ new_cone_comm) walking_cospan.right,
      set new_cone := pullback_cone.mk _ _ new_cone_comm,
      set new_cone2 := pullback_cone.mk _ _ new_cone2_comm,
      apply pi_app_left (pullback_cone.mk (f ≫ g) h _) c,
      erw [← assoc, left.fac' new_cone2 walking_cospan.left, right.fac' new_cone walking_cospan.left], refl,
      exact left.fac' new_cone2 walking_cospan.right },
    { set π₁ : c.X ⟶ W := pullback_cone.fst c,
      set π₂ : c.X ⟶ X := pullback_cone.snd c,
      have new_cone_comm: π₁ ≫ l = (π₂ ≫ m) ≫ n,
        rw assoc, rw pullback_cone.condition,
      set new_cone := pullback_cone.mk _ _ new_cone_comm,
      have new_cone2_comm: (right.lift new_cone) ≫ k = π₂ ≫ m := right.fac' new_cone walking_cospan.right,
      set new_cone2 := pullback_cone.mk _ _ new_cone2_comm,
      intros r J,
      show r = left.lift new_cone2,
      have Jr: r ≫ h = π₂ := J walking_cospan.right,
      apply left.uniq new_cone2, -- BM: here
      apply pi_app_left (pullback_cone.mk f h left_comm) new_cone2 _ _ Jr,
      { apply right.uniq new_cone, -- BM: here
        apply pi_app_left (pullback_cone.mk g k right_comm) new_cone,
        { rw assoc, exact J walking_cospan.left},
        { rw assoc, show r ≫ f ≫ k = π₂ ≫ m, rw ← Jr, conv_rhs {rw assoc}, congr, exact left_comm} } }
  end
, hom_inv_id' := subsingleton.elim _ _
, inv_hom_id' := subsingleton.elim _ _
}

def pullback.with_id_r' {X Y : C} (f : X ⟶ Y) :
  is_limit (pullback_cone.mk f (𝟙 X) (by simp) : pullback_cone (𝟙 Y) f) :=
{ lift := λ c, (c.π).app walking_cospan.right,
  fac' := λ c j,
  begin
    cases j, -- BM: triple case
    { erw ← pullback_cone.condition c, simp },
    { erw comp_id },
    show _ ≫ f ≫ 𝟙 Y = _,
    erw [comp_id, ← c.π.naturality walking_cospan.hom.inr, id_comp],
  end,
  uniq' := λ _ _ J, by erw ← J walking_cospan.right; exact (comp_id _ _).symm
}

@[reducible]
def cospan_cone.flip {f : X ⟶ Z} {g : Y ⟶ Z} (c : cone (cospan f g)) : cone (cospan g f) :=
pullback_cone.mk (pullback_cone.snd c) (pullback_cone.fst c) (pullback_cone.condition c).symm

def flip_mk {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} (comm : f ≫ h = g ≫ k) :
  cospan_cone.flip (pullback_cone.mk f g comm) ≅ pullback_cone.mk g f comm.symm :=
by apply cones.ext (iso.refl _) (λ j, _); erw id_comp

def flip_twice {f : X ⟶ Z} {g : Y ⟶ Z} (c : cone (cospan f g)) : cospan_cone.flip (cospan_cone.flip c) ≅ c :=
begin
  apply cones.ext _ _, exact iso.refl _,
  intros j, erw id_comp, cases j, -- BM: triple case
  refl, refl,
  apply cone.w c walking_cospan.hom.inl
end

def flip_hom {f : X ⟶ Z} {g : Y ⟶ Z} {c₁ c₂ : cone (cospan f g)} (h : c₁ ⟶ c₂) : cospan_cone.flip c₁ ⟶ cospan_cone.flip c₂ :=
{ hom := h.hom,
  w' := begin rintro (_ | _ | _), apply h.w, apply h.w, erw [← assoc, h.w], refl end} -- BM: triple case

def pullback.flip {Y Z W : C} {h : Y ⟶ W} {k : Z ⟶ W} {c : cone (cospan h k)} (z : is_limit c) :
  is_limit (cospan_cone.flip c) :=
{ lift := λ s, z.lift (cospan_cone.flip s),
  fac' := λ s j, walking_cospan.cases_on j (z.fac' (cospan_cone.flip s) walking_cospan.right)
                                           (z.fac' (cospan_cone.flip s) walking_cospan.left)
        (begin
            show _ ≫ _ ≫ _ = _, rw ← cone.w s walking_cospan.hom.inr,
            rw ← pullback_cone.condition c, rw ← assoc,
            erw z.fac', refl
          end), -- BM: triple case
  uniq' := λ s m J,
  begin
    apply z.uniq (cospan_cone.flip s),
    apply pi_app_left c (cospan_cone.flip s),
    erw J walking_cospan.right, refl,
    erw J walking_cospan.left, refl,
  end
}
def pullback.flip'' {Y Z W : C} {h : Y ⟶ W} {k : Z ⟶ W} {c : cone (cospan h k)} :
  is_limit c ≅ is_limit (cospan_cone.flip c) :=
{ hom := pullback.flip, inv := pullback.flip ≫ (λ l, is_limit.of_iso_limit l (flip_twice _))}

def flip_limit_cone [@has_pullbacks C 𝒞] (f : X ⟶ Z) (g : Y ⟶ Z) :
  cospan_cone.flip (limit.cone (cospan g f)) ≅ limit.cone (cospan f g) :=
{ hom := limit.cone_morphism _,
  inv := ((flip_twice _).inv ≫ flip_hom (limit.cone_morphism _)),
  hom_inv_id' :=
  begin
    ext, simp, dunfold flip_hom flip_twice cones.ext, erw [id_comp, limit.lift_π],
    { erw limit.lift_π, refl },
    { simp, erw limit.lift_π, dunfold flip_twice cospan_cone.flip, simp,
      erw [id_comp, limit.lift_π], refl }
  end,
  inv_hom_id' := is_limit.uniq_cone_morphism (limit.is_limit _) }

def pullback.flip' [@has_pullbacks C 𝒞] (f : X ⟶ Z) (g : Y ⟶ Z) : pullback f g ≅ pullback g f :=
iso_apex_of_iso_cone (flip_limit_cone f g).symm

def pullback.with_id_l' {X Y : C} (f : X ⟶ Y) :
  is_limit (pullback_cone.mk (𝟙 X) f (show (𝟙 X) ≫ f = f ≫ (𝟙 Y), by simp)) :=
is_limit.of_iso_limit (pullback.flip (pullback.with_id_r' f)) (flip_mk _)

def identify_limit_apex {F : J ⥤ C} [has_limit F] {a : cone F} (t : is_limit a) :
  (limit.cone F).X ≅ a.X :=
iso_apex_of_iso_cone (is_limit.unique_up_to_iso (limit.is_limit _) t)

/- Note that we need `has_pullbacks` even though this particular pullback always exists, because here we are showing that the
constructive limit derived using has_pullbacks has to be iso to this simple definition.  -/
def pullback.with_id_r [@has_pullbacks C 𝒞] {X Y : C} (f : X ⟶ Y) :
  pullback (𝟙 Y) f ≅ X :=
identify_limit_apex (pullback.with_id_r' f)

def pullback.with_id_l [@has_pullbacks C 𝒞] {X Y : C} (f : X ⟶ Y) :
  pullback f (𝟙 Y) ≅ X :=
pullback.flip' _ _ ≪≫ pullback.with_id_r f

lemma make_pullback [has_limit (cospan f g)] :
  pullback_cone.mk pullback.fst pullback.snd pullback.condition ≅ limit.cone (cospan f g) :=
begin
  apply cones.ext _ (λ j, _), refl, erw id_comp, cases j, refl, refl,
  apply (limit.cone (cospan f g)).w walking_cospan.hom.inl
end

-- todo: use pasting here
lemma pullback.comp_l {W X Y Z : C} {xz : X ⟶ Z} {yz : Y ⟶ Z} {wx : W ⟶ X} [@has_pullbacks C 𝒞]:
pullback (wx ≫ xz) yz ≅ pullback wx (@pullback.fst _ _ _ _ _ xz yz _) :=
begin
  apply iso.mk _ _ _ _,
  { refine pullback.lift pullback.fst (pullback.lift (pullback.fst ≫ wx) pullback.snd _) _, simp, rw pullback.condition,  simp},
  { refine pullback.lift pullback.fst (pullback.snd ≫ pullback.snd) _, rw ← category.assoc, rw pullback.condition, simp, rw pullback.condition },
  {apply pullback.hom_ext, simp, simp },
  {apply pullback.hom_ext, simp, simp, apply pullback.hom_ext, simp, apply pullback.condition, simp},
end

lemma test [has_pullbacks.{v} C] {X Y Z : C} {xz : X ⟶ Z} {yz : Y ⟶ Z} :
  is_limit (pullback_cone.mk pullback.fst pullback.snd pullback.condition : pullback_cone yz xz) :=
(limit.is_limit _).of_iso_limit make_pullback.symm

lemma pullback.comp_r {W X Y Z : C} {xz : X ⟶ Z} {yz : Y ⟶ Z} {wx : W ⟶ X} [@has_pullbacks C 𝒞]:
  pullback yz (wx ≫ xz) ≅ pullback (@pullback.snd _ _ _ _ _ yz xz _) wx :=
identify_limit_apex ((pasting _ _ _ _ _ _ _ _ _ test).inv test) ≪≫ iso_apex_of_iso_cone make_pullback

-- Show
-- D × A ⟶ B × A
--   |       |
--   v       v
--   D   ⟶   B
-- is a pullback (needed in over/exponentiable_in_slice)
def pullback_prod (xy : X ⟶ Y) (Z : C) [has_binary_products.{v} C] :
  is_limit (pullback_cone.mk limits.prod.fst (limits.prod.map xy (𝟙 Z)) (by simp) : pullback_cone xy limits.prod.fst) :=
{ lift := λ s, prod.lift (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.snd),
  fac' := λ s,
    begin
      apply pi_app_left (pullback_cone.mk limits.prod.fst (limits.prod.map xy (𝟙 Z)) _) s, dsimp,
        dunfold pullback_cone.fst, simp, -- this should have been just simp
      apply limit.hom_ext, intro j, cases j, simp, dsimp, -- this should be easy.
        dunfold pullback_cone.snd, rw pullback_cone.simp_right, simp, exact pullback_cone.condition s,
      simp, dunfold pullback_cone.snd, simp, dsimp, simp -- look here ed
    end,
  uniq' := λ s m J,
    begin
      ext, cases j, simp, apply J walking_cospan.left, simp, dunfold pullback_cone.snd, erw ← J walking_cospan.right,
      simp, dsimp, simp
    end
}

def pullback_prod' (xy : X ⟶ Y) (Z : C) [has_binary_products.{v} C] :
  is_limit (pullback_cone.mk limits.prod.snd (limits.prod.map (𝟙 Z) xy) (by simp) : pullback_cone xy limits.prod.snd) :=
{ lift := λ s, prod.lift (pullback_cone.snd s ≫ limits.prod.fst) (pullback_cone.fst s),
  fac' := λ s,
    begin
      apply pi_app_left (pullback_cone.mk limits.prod.snd (limits.prod.map (𝟙 Z) xy) _) s, dsimp,
        dunfold pullback_cone.fst, simp,
      apply limit.hom_ext, intro j, cases j, simp, dsimp,
        dunfold pullback_cone.snd, rw pullback_cone.simp_right, simp, dsimp, simp,
      simp, dunfold pullback_cone.snd, simp, dsimp, rw pullback_cone.condition s,
    end,
  uniq' := λ s m J,
    begin
      ext, cases j, simp, dunfold pullback_cone.snd, erw ← J walking_cospan.right, simp, dsimp, simp,
      simp, dsimp, dunfold pullback_cone.fst, erw ← J walking_cospan.left, simp,
    end
}

@[reducible]
def pullback_of_iso {U V W X : C} {f : U ⟶ X} {g : V ⟶ X} {h : W ⟶ X} (z : V ≅ W) (hyp : z.hom ≫ h = g) (c : pullback_cone f g) :
  pullback_cone f h :=
pullback_cone.mk c.fst (c.snd ≫ z.hom) (by rw [pullback_cone.condition c, assoc, hyp])

set_option pp.implicit false

lemma pullback_of_iso_is_limit {U V W X : C} (f : U ⟶ X) {g : V ⟶ X} {h : W ⟶ X} (z : V ≅ W)
  (hyp : z.hom ≫ h = g) (c : pullback_cone f g) :
is_limit c ≅ is_limit (pullback_of_iso z hyp c) :=
{ hom := λ t,
  { lift :=
    begin
      intro s, apply t.lift (pullback_of_iso z.symm _ s), rw [iso.symm_hom, iso.inv_comp_eq, hyp],
    end,
    fac' :=
    begin
      intro s, apply pi_app_left (pullback_of_iso z hyp c) s,
      apply t.fac,
      erw ← assoc, rw t.fac, erw assoc, simp
    end,
    uniq' :=
    begin
      intros s m J, apply t.uniq (pullback_of_iso z.symm _ s),
      apply pi_app_left c (pullback_of_iso _ _ _),
      erw J walking_cospan.left, refl,
      erw ← iso.comp_inv_eq, rw assoc, exact J walking_cospan.right
    end },
  inv := λ t,
  { lift := λ s, t.lift (pullback_of_iso z hyp s),
    fac' :=
    begin
      intro s,
      apply pi_app_left c s,
        exact t.fac (pullback_of_iso z hyp s) walking_cospan.left,
      have := t.fac (pullback_of_iso z hyp s) walking_cospan.right, simp at this,
      rw ← assoc at this,
      rw cancel_mono at this, assumption
    end,
    uniq' := λ s m J,
    begin
      apply t.uniq (pullback_of_iso z hyp s),
      apply pi_app_left (pullback_of_iso z hyp c) (pullback_of_iso z hyp s),
      apply J walking_cospan.left,
      erw ← assoc, erw J walking_cospan.right, refl
    end},
  hom_inv_id' := subsingleton.elim _ _,
  inv_hom_id' := subsingleton.elim _ _}

/--
If V and W are isomorphic, and g : V ⟶ X, h : W ⟶ X respect the isomorphism, then
the pullback of f along g is isomorphic to the pullback of f along h
-/
lemma pullback_of_iso_apex [has_pullbacks.{v} C] {U V W X : C} {f : U ⟶ X} {g : V ⟶ X} {h : W ⟶ X} (z : V ≅ W) (hyp : z.hom ≫ h = g) :
  pullback f g ≅ pullback f h :=
(identify_limit_apex ((pullback_of_iso_is_limit f z hyp (limit.cone _)).hom (limit.is_limit _))).symm

lemma pullback.comp_l' {W X Y Z : C} {xz : X ⟶ Z} {yz : Y ⟶ Z} {wx : W ⟶ X} [@has_pullbacks C 𝒞]:
pullback (wx ≫ xz) yz ≅ pullback wx (@pullback.fst _ _ _ _ _ xz yz _) :=
pullback.flip' _ _ ≪≫ pullback.comp_r ≪≫ pullback.flip' _ _ ≪≫
begin
  show pullback wx (@pullback.snd _ _ _ _ _ yz xz _ : pullback yz xz ⟶ X) ≅ pullback wx (@pullback.fst _ _ _ _ _ xz yz _ : pullback xz yz ⟶ X),
  apply pullback_of_iso_apex (pullback.flip' _ _),
  -- XXX: this goal should probably be its own lemma
  dunfold pullback.flip' iso_apex_of_iso_cone flip_limit_cone flip_twice flip_hom,
  show (𝟙 _ ≫ _) ≫ _ = _,
  erw id_comp,
  erw [limit.lift_π], refl
end

-- [todo] comp_r; I was hoping there would be a cool way of lifting the isomorphism `(cospan f g).cones ≅ (cospan g f).cones` but can't see it.

/-- Pullback of a monic is monic. -/
lemma pullback.preserve_mono [@has_pullbacks C 𝒞]
  {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} (hm : mono f) : @mono _ _ (pullback f g) _ pullback.snd :=
begin
  split, intros A a b e,
  have c : pullback.fst ≫ f = pullback.snd ≫ g, apply pullback.condition,
  apply pullback.hom_ext,
    show a ≫ pullback.fst = b ≫ pullback.fst,
    apply hm.1, simp,
    rw c, rw ← category.assoc,  rw e, simp,
  show a ≫ pullback.snd = b ≫ pullback.snd, assumption,
end

def over.pullback [@has_pullbacks C 𝒞] {X Y : C} (f : X ⟶ Y) (g : over Y) : over X :=
over.mk (@pullback.fst _ _ _ _ _ f g.hom _)

@[simp] lemma over_pullback_def [@has_pullbacks C 𝒞] {X Y : C} (f : X ⟶ Y) (g : over Y) :
  (over.pullback f g).hom = pullback.fst := rfl

lemma mono_of_pullback (X Y : C) (f : X ⟶ Y)
  (hl : is_limit (pullback_cone.mk (𝟙 X) (𝟙 X) (by simp) : pullback_cone f f)) : mono f :=
begin
  split, intros,
  set new_cone : pullback_cone f f := pullback_cone.mk g h w,
  exact (hl.fac new_cone walking_cospan.left).symm.trans (hl.fac new_cone walking_cospan.right),
end

lemma pullback_of_mono (X Y : C) (f : X ⟶ Y) (hf : mono f) :
  is_limit (pullback_cone.mk (𝟙 X) (𝟙 X) (by simp) : pullback_cone f f) :=
{ lift := λ s, pullback_cone.fst s,
  fac' := λ s, begin apply pi_app_left (pullback_cone.mk (𝟙 X) (𝟙 X) _) s, erw comp_id, erw comp_id, rw ← cancel_mono f, exact pullback_cone.condition s end,
  uniq' := λ s m J, (comp_id _ m).symm.trans (J walking_cospan.left) }

universe u₂

lemma cospan_comp {D : Type u₂} [category.{v} D] (F : C ⥤ D) : cospan (F.map f) (F.map g) = cospan f g ⋙ F :=
begin
  apply category_theory.functor.ext, intros, cases f_1, simp, simp, simp, dsimp, simp,
  intro j, cases j, simp, simp, simp
end

lemma preserves_mono_of_preserves_pullback {D : Type u₂} [category.{v} D] (F : C ⥤ D)
  (hF : preserves_limits_of_shape walking_cospan F) (X Y : C) (f : X ⟶ Y) (hf : mono f) :
  mono (F.map f) :=
begin
  apply mono_of_pullback,
  have that: is_limit _ := preserves_limit.preserves F (pullback_of_mono _ _ f hf),
  have: cospan (F.map f) (F.map f) = cospan f f ⋙ F := cospan_comp _,
  convert that,
  dsimp [functor.map_cone, cones.functoriality, pullback_cone.mk],
  congr, assumption, assumption, refine function.hfunext rfl _, intros, tactic.case_bash, simp, simp, simp,
  apply proof_irrel_heq
end


import topology.category.Top.opens
import grothendieck
import tactic.equiv_rw

universes u

open category_theory topological_space category_theory.limits

namespace topological_space.opens

section
variables (X : Type u) [topological_space X]

section
variables {X} (U V : opens X)

@[derive partial_order]
def opens_sieve' := {s : set (opens X) // ∀ V ∈ s, V ≤ U ∧ ∀ W ≤ V, W ∈ s }

@[simps]
def equivalence' : opens_sieve' U ≃o sieve U :=
{ inv_fun := λ S,
  { val := λ V, ∃ (h : V ≤ U), S.arrows (over.mk (hom_of_le h)),
    property := by { rintro V ⟨VU, hVU⟩, exact ⟨VU, λ W WV, ⟨_, S.downward_closed hVU (hom_of_le WV)⟩⟩ } },
  to_fun := λ S,
  { arrows := λ f, f.left ∈ S.1,
    subs := λ V W VU WV hVU, ((S.2 V) hVU).2 W (le_of_hom WV) },
  right_inv := λ S, sieve.ext_iff $ λ V VU,
    ⟨by { rintro ⟨_, q⟩, convert q }, by { rintro hf, refine ⟨le_of_hom VU, _⟩, convert hf }⟩,
  left_inv := λ S, subtype.ext_val $ funext $ λ V,
    propext ⟨by {rintro ⟨_, q⟩, exact q}, λ hV, ⟨(S.2 V hV).1, hV⟩⟩,
  map_rel_iff' := λ a b, ⟨λ h V VU hVU, h hVU, λ h V hV, h _ (hom_of_le (a.2 _ hV).1) hV⟩ }

instance : order_top (opens_sieve' U) :=
{ top := ⟨λ V, V ≤ U, by tidy⟩,
  le_top := λ S V hV, (S.2 V hV).1,
  ..topological_space.opens.opens_sieve'.partial_order _ }

def is_covering' (s : opens_sieve' U) : Prop := ∀ x ∈ U, ∃ V, V ∈ s.1 ∧ x ∈ V

def restrict' {U : opens X} (V : opens X) (s : opens_sieve' U) : opens_sieve' V :=
begin
  refine subtype.map (set.image (⊓ V)) _ s,
  rintros S hS _ ⟨W', hW', rfl⟩,
  refine ⟨lattice.inf_le_right _ _, λ V' hV', ⟨V' ⊓ W', _, _⟩⟩,
  apply (hS _ hW').2,
  refine lattice.inf_le_right _ _,
  simp only [],
  rw inf_assoc,
  apply inf_of_le_left hV',
end

lemma restrict_equivalence {U V : opens X} (VU : V ⟶ U) (s : opens_sieve' U) :
  equivalence' _ (restrict' V s) = sieve.pullback (equivalence' _ s) VU :=
sieve.ext_iff $ λ W WV,
  ⟨ by {rintro ⟨W, h, q⟩, cases q, exact (s.2 _ h).2 _ (lattice.inf_le_left _ _)},
    λ hW, ⟨_, hW, inf_of_le_left (le_of_hom WV)⟩⟩

lemma covering'_trans (r s : opens_sieve' U) (hs : is_covering' U s)
  (hr : ∀ {Y : opens X} (a : Y ≤ U), s.1 Y → is_covering' _ (restrict' Y r)) :
  is_covering' U r :=
begin
  intros x hx,
  obtain ⟨V, Vs, xV⟩ := hs x hx,
  obtain ⟨_, ⟨W, Wr, rfl⟩, xW⟩ :=
    hr (lattice.inf_le_left U V) ((s.2 _ Vs).2 _ (lattice.inf_le_right _ _)) x ⟨hx, xV⟩,
  exact ⟨_, Wr, xW.1⟩,
end

end

def covering : sieve_set (opens X) := λ U S, is_covering' _ ((equivalence' _).symm S)

lemma covering_sieve (U : opens X) (S : sieve U) :
  S ∈ covering X U ↔ ∀ x ∈ U, ∃ V, x ∈ V ∧ ∃ (f : V ≤ U), over.mk (hom_of_le f) ∈ S.arrows :=
ball_congr (λ x hx, exists_congr (λ V, and_comm _ _))

instance : grothendieck (covering X) :=
{ max := λ U,
  begin
    change U.is_covering' _,
    rw order_iso.map_top (equivalence' U).symm,
    intros x hx,
    exact ⟨U, le_refl _, hx⟩,
  end,
  stab := λ U V s hs f x hx,
  begin
    equiv_rw (equivalence' U).to_equiv.symm at s,
    change ∀ (x ∈ U), _ at hs,
    simp only [rel_iso.coe_fn_to_equiv, equiv.symm_symm, order_iso.symm_apply_apply] at hs,
    simp only [rel_iso.coe_fn_to_equiv],
    rw ← restrict_equivalence,
    simp only [order_iso.symm_apply_apply],
    dsimp [restrict', subtype.map],
    obtain ⟨W, hW₁, hW₂⟩ := hs x (le_of_hom f hx),
    refine ⟨_ ⊓ _, ⟨W, hW₁, rfl⟩, hW₂, hx⟩,
  end,
  trans := λ U s hs r h,
  begin
    equiv_rw (equivalence' U).to_equiv.symm at s,
    equiv_rw (equivalence' U).to_equiv.symm at r,
    change is_covering' _ _,
    change is_covering' _ _ at hs,
    simp only [rel_iso.coe_fn_to_equiv, order_iso.symm_apply_apply, equiv.symm_symm] at ⊢ hs h,
    refine U.covering'_trans r s hs _,
    intros V VU Vs,
    specialize h (hom_of_le VU) _,
    rw ← restrict_equivalence at h,
    change is_covering' _ _ at h,
    simp only [rel_iso.coe_fn_to_equiv, order_iso.symm_apply_apply, equiv.symm_symm] at h,
    apply h,
    apply Vs,
  end }

end

end topological_space.opens


set_option trace.Elab.info true
example (x y : Nat) (h : x = y) : 0 + x = y + 0 := by
  have := by exact h.symm
--
--^ $/lean/plainGoal
-- Good: ..., this : y = x |- 0 + x = y + 0

example (x : Nat) : x = 0 + (0 + (0 + x)) ∧ p := by
  constructor
  · cases x
    next => rfl
                               -- Good: we get multiple states here as expected
                               --v $/lean/plainGoal
    next => repeat rw [Nat.zero_add]
                                  --^ $/lean/plainGoal
                                  -- Bad? We still get all states except the one closed by implicit `rfl`
--^ $/lean/plainGoal
-- Good: ... |- p

example (x : Nat) : x = 0 + (0 + (0 + x)) ∧ p := by
  constructor
  match x with
  | 0 => rfl
                                 -- Bad? We still get all states except the one closed by implicit `rfl`
                                 --v $/lean/plainGoal
  | y+1 => repeat rw [Nat.zero_add]
       --^ $/lean/plainGoal
       -- Good: we get the succ state here
--^ $/lean/plainGoal
-- Good:  ... |- p


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
prelude
import Init.Tactics
set_option linter.missingDocs true -- keep it documented

/-! # SizeOf -/

/--
`SizeOf` is a typeclass automatically derived for every inductive type,
which equips the type with a "size" function to `Nat`.
The default instance defines each constructor to be `1` plus the sum of the
sizes of all the constructor fields.

This is used for proofs by well-founded induction, since every field of the
constructor has a smaller size than the constructor itself,
and in many cases this will suffice to do the proof that a recursive function
is only called on smaller values.
If the default proof strategy fails, it is recommended to supply a custom
size measure using the `termination_by` argument on the function definition.
-/
class SizeOf (α : Sort u) where
  /-- The "size" of an element, a natural number which decreases on fields of
  each inductive type. -/
  sizeOf : α → Nat

export SizeOf (sizeOf)

/-!
Declare `SizeOf` instances and theorems for types declared before `SizeOf`.
From now on, the inductive compiler will automatically generate `SizeOf` instances and theorems.
-/

/--
Every type `α` has a default `SizeOf` instance that just returns `0`
for every element of `α`.
-/
protected def default.sizeOf (α : Sort u) : α → Nat
  | _ => 0

instance (priority := low) (α : Sort u) : SizeOf α where
  sizeOf := default.sizeOf α

@[simp] theorem sizeOf_default (n : α) : sizeOf n = 0 := rfl

instance : SizeOf Nat where
  sizeOf n := n

@[simp] theorem sizeOf_nat (n : Nat) : sizeOf n = n := rfl

instance [SizeOf α] : SizeOf (Unit → α) where
  sizeOf f := sizeOf (f ())

@[simp] theorem sizeOf_thunk [SizeOf α] (f : Unit → α) : sizeOf f = sizeOf (f ()) :=
  rfl

deriving instance SizeOf for PUnit
deriving instance SizeOf for Prod
deriving instance SizeOf for PProd
deriving instance SizeOf for MProd
deriving instance SizeOf for Bool
deriving instance SizeOf for Subtype
deriving instance SizeOf for PLift
deriving instance SizeOf for ULift
deriving instance SizeOf for Decidable
deriving instance SizeOf for Fin
deriving instance SizeOf for UInt8
deriving instance SizeOf for UInt16
deriving instance SizeOf for UInt32
deriving instance SizeOf for UInt64
deriving instance SizeOf for USize
deriving instance SizeOf for Char
deriving instance SizeOf for Option
deriving instance SizeOf for List
deriving instance SizeOf for String
deriving instance SizeOf for String.Pos
deriving instance SizeOf for Substring
deriving instance SizeOf for Array
deriving instance SizeOf for Except
deriving instance SizeOf for EStateM.Result

@[simp] theorem Unit.sizeOf (u : Unit) : sizeOf u = 1 := rfl
@[simp] theorem Bool.sizeOf_eq_one (b : Bool) : sizeOf b = 1 := by cases b <;> rfl

namespace Lean

/--
We manually define the `Lean.Name` instance because we use
an opaque function for computing the hashcode field.
-/
protected noncomputable def Name.sizeOf : Name → Nat
  | anonymous => 1
  | str p s   => 1 + Name.sizeOf p + sizeOf s
  | num p n   => 1 + Name.sizeOf p + sizeOf n

noncomputable instance : SizeOf Name where
  sizeOf n := n.sizeOf

@[simp] theorem Name.anonymous.sizeOf_spec : sizeOf anonymous = 1 :=
  rfl
@[simp] theorem Name.str.sizeOf_spec (p : Name) (s : String) : sizeOf (str p s) = 1 + sizeOf p + sizeOf s :=
  rfl
@[simp] theorem Name.num.sizeOf_spec (p : Name) (n : Nat) : sizeOf (num p n) = 1 + sizeOf p + sizeOf n :=
  rfl

deriving instance SizeOf for SourceInfo
deriving instance SizeOf for Syntax
deriving instance SizeOf for TSyntax
deriving instance SizeOf for Syntax.SepArray
deriving instance SizeOf for Syntax.TSepArray
deriving instance SizeOf for ParserDescr
deriving instance SizeOf for MacroScopesView
deriving instance SizeOf for Macro.Context
deriving instance SizeOf for Macro.Exception
deriving instance SizeOf for Macro.State
deriving instance SizeOf for Macro.Methods

end Lean


import for_mathlib.short_complex_functor_category

noncomputable theory

open category_theory category_theory.category category_theory.limits

namespace category_theory

namespace functor

variables {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃] [has_zero_morphisms C₃]
  [has_zero_object C₃]

lemma is_zero_of_comp (F : C₁ ⥤ C₂) (G : C₂ ⥤ C₃) (h : limits.is_zero G) :
  limits.is_zero (F ⋙ G) :=
begin
  rw limits.is_zero.iff_id_eq_zero,
  ext,
  apply limits.is_zero.eq_zero_of_src,
  dsimp,
  apply limits.is_zero.obj,
  exact h,
end

end functor

end category_theory

namespace homological_complex

variables (C : Type*) [category C] [has_zero_morphisms C] [has_zero_object C]
  {M : Type*} (c : complex_shape M)

@[simps]
def prev_functor (i : M) : homological_complex C c ⥤ C :=
{ obj := λ X, X.X_prev i,
  map := λ X Y f, f.prev i,
  map_id' := λ X, begin
    rcases h : c.prev i with _ | ⟨j, hij⟩,
    { apply is_zero.eq_of_src,
      exact is_zero.of_iso (limits.is_zero_zero C) (X.X_prev_iso_zero h), },
    { simp only [hom.prev_eq _ hij, id_f, id_comp, iso.hom_inv_id], },
  end,
  map_comp' := λ X Y W f g, begin
    rcases h : c.prev i with _ | ⟨j, hij⟩,
    { apply is_zero.eq_of_src,
      exact is_zero.of_iso (limits.is_zero_zero C) (X.X_prev_iso_zero h), },
    { simp only [hom.prev_eq _ hij, comp_f, assoc, iso.inv_hom_id_assoc, eq_self_iff_true], },
  end, }

@[simps]
def next_functor (i : M) : homological_complex C c ⥤ C :=
{ obj := λ X, X.X_next i,
  map := λ X Y f, f.next i,
  map_id' := λ X, begin
    rcases h : c.next i with _ | ⟨j, hij⟩,
    { apply is_zero.eq_of_src,
      exact is_zero.of_iso (limits.is_zero_zero C) (X.X_next_iso_zero h), },
    { simp only [hom.next_eq _ hij, id_f, id_comp, iso.hom_inv_id], },
  end,
  map_comp' := λ X Y W f g, begin
    rcases h : c.next i with _ | ⟨j, hij⟩,
    { apply is_zero.eq_of_src,
      exact is_zero.of_iso (limits.is_zero_zero C) (X.X_next_iso_zero h), },
    { simp only [hom.next_eq _ hij, comp_f, assoc, iso.inv_hom_id_assoc, eq_self_iff_true], },
  end, }

def prev_functor_is_zero (i : M) (h : c.prev i = none) : is_zero (prev_functor C c i) :=
begin
  rw is_zero.iff_id_eq_zero,
  ext X,
  apply is_zero.eq_of_src,
  exact is_zero.of_iso (limits.is_zero_zero C) (X.X_prev_iso_zero h),
end

def next_functor_is_zero (i : M) (h : c.next i = none) : is_zero (next_functor C c i) :=
begin
  rw is_zero.iff_id_eq_zero,
  ext X,
  apply is_zero.eq_of_src,
  exact is_zero.of_iso (limits.is_zero_zero C) (X.X_next_iso_zero h),
end

def prev_functor_iso_eval (i j : M) (hij : c.rel j i) :
  prev_functor C c i ≅ homological_complex.eval C c j :=
nat_iso.of_components
  (λ X, X.X_prev_iso hij)
  (λ X Y f, by { dsimp, simp only [hom.prev_eq f hij, assoc, iso.inv_hom_id, comp_id], })

def next_functor_iso_eval (i j : M) (hij : c.rel i j) :
  next_functor C c i ≅ homological_complex.eval C c j :=
nat_iso.of_components
  (λ X, X.X_next_iso hij)
  (λ X Y f, by { dsimp, simp only [hom.next_eq f hij, assoc, iso.inv_hom_id, comp_id], })

end homological_complex

namespace short_complex

variables (C : Type*) [category C] [has_zero_morphisms C] [has_zero_object C]
  {M : Type*} (c : complex_shape M)

def functor_homological_complex_π₁_iso_prev_functor (i : M) :
  functor_homological_complex C c i ⋙ π₁ ≅ homological_complex.prev_functor C c i := by refl

def functor_homological_complex_π₂_iso_eval (i : M) :
  functor_homological_complex C c i ⋙ π₂ ≅ homological_complex.eval C c i := by refl

def functor_homological_complex_π₃_iso_next_functor (i : M) :
  functor_homological_complex C c i ⋙ π₃ ≅ homological_complex.next_functor C c i := by refl

end short_complex


namespace ctx
    @[inline, reducible] def pipe {A B: Sort _} (a: A) (f: A → B): B := f a
    infix ` ↦ `:50 := pipe

    -- converting to continuation passing style
    def of {A X: Sort _} (a: A): (A → X) → X :=
        λ xa: A → X,
        xa a

    def uncurry {A B X: Sort _} (fx: ((A → B) → X) → X): A → (B → X) → X :=
        begin
            intros a xb,
            apply fx,
            intro f,
            apply xb,
            apply f,
            exact a,
        end

    def of_func {A B X: Sort _} (f: A → B): A → (B → X) → X :=
        uncurry (of f)

    def curry.of_dne {A B C X: Sort _} (bdne: ((B → X) → X) → C) (fx: A → (B → X) → X): ((A → C) → X) → X :=
        begin
            intro xf,
            apply xf,
            intro a,
            let bxx: (B → X) → X := fx a,
            apply bdne,
            exact bxx,
        end

    -- classical logic equivalents in ctx style
    def dne {A X: Sort _} (xxa: (A → X) → X) (ctx: A → X): X :=
        xxa ctx

    theorem dne.of_prop {X: Sort _} {P: Prop} (xxp: (P → X) → X) (ctx: P → X): X :=
        dne xxp ctx

    def lem.of_sum {A X: Type _} (ctx: A ⊕ (A → X) → X): X :=
        begin
            apply ctx,
            apply sum.inr,
            intro a,
            apply ctx,
            apply sum.inl,
            exact a,
        end

    theorem lem.of_or {X: Sort _} {P: Prop} (ctx: P ∨ (P → X) → X): X :=
        begin
            apply ctx,
            right,
            intro p,
            apply ctx,
            left,
            exact p,
        end

    -- conversion between functions to X and ¬X
    def of_not {A X: Sort _} (na: ¬A): A → X :=
        begin
            intro a,
            apply false.elim,
            apply na,
            exact a,
        end

    theorem of_not.of_prop {X: Sort _} {P: Prop} (np: ¬P): P → X :=
        of_not np

    def inner_to_not {A X: Sort _} (xxa: (A → X) → X): ¬A → X :=
        λ na: A → false,
        let f: A → X := of_not na in
        xxa f

    theorem inner_to_not.of_prop {X: Sort _} {P: Prop} (xxp: (P → X) → X): ¬P → X :=
        inner_to_not xxp

    -- we get more power if we use a fixed return value X and assume (A → X) → ¬A
    namespace fixed_output
        constant X: Sort _
        axiom to_not {A: Sort _}: (A → X) → ¬A

        theorem to_not.of_prop {P: Prop} (xp: P → X): ¬P :=
            to_not xp

        def to_double_neg {A: Sort _} (xxa: (A → X) → X): ¬¬A :=
            xxa ↦ inner_to_not ↦ to_not

        noncomputable def curry {A B: Sort _} (fx: A → (B → X) → X): ((A → ¬¬B) → X) → X :=
            curry.of_dne to_double_neg fx

        noncomputable def of_double_neg {A: Sort _} (nna: ¬¬A): (A → X) → X :=
            λ xa: A → X,
            let na: A → false := to_not xa in
            let bot: false := nna na in
            false.elim bot
    end fixed_output
end ctx


import for_mathlib.snake_lemma
import for_mathlib.exact_seq2

noncomputable theory

open category_theory category_theory.limits

variables {𝒜 : Type*} [category 𝒜] [abelian 𝒜]
variables (A₀ B₀ C₀ : 𝒜)
variables (A₁ B₁ C₁ : 𝒜)
variables (A₂ B₂ C₂ : 𝒜)
variables (A₃ B₃ C₃ : 𝒜)
variables (f₀ : A₀ ⟶ B₀) (g₀ : B₀ ⟶ C₀)
variables (a₀ : A₀ ⟶ A₁) (b₀ : B₀ ⟶ B₁) (c₀ : C₀ ⟶ C₁)
variables (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁)
variables (a₁ : A₁ ⟶ A₂) (b₁ : B₁ ⟶ B₂) (c₁ : C₁ ⟶ C₂)
variables (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂)
variables (a₂ : A₂ ⟶ A₃) (b₂ : B₂ ⟶ B₃) (c₂ : C₂ ⟶ C₃)
variables (f₃ : A₃ ⟶ B₃) (g₃ : B₃ ⟶ C₃)

namespace category_theory

local notation `kernel_map`   := kernel.map _ _ _ _
local notation `cokernel_map` := cokernel.map _ _ _ _

structure snake : Prop :=
(row_exact₁ : exact f₁ g₁)
(row_exact₂ : exact f₂ g₂)
[row_epi : epi g₁]
[row_mono : mono f₂]
(col_exact_a : exact_seq 𝒜 [a₀, a₁, a₂])
(col_exact_b : exact_seq 𝒜 [b₀, b₁, b₂])
(col_exact_c : exact_seq 𝒜 [c₀, c₁, c₂])
[col_mono_a : mono a₀]
[col_mono_b : mono b₀]
[col_mono_c : mono c₀]
[col_epi_a : epi a₂]
[col_epi_b : epi b₂]
[col_epi_c : epi c₂]
(sq_a₀ : a₀ ≫ f₁ = f₀ ≫ b₀)
(sq_b₀ : b₀ ≫ g₁ = g₀ ≫ c₀)
(sq_a₁ : a₁ ≫ f₂ = f₁ ≫ b₁)
(sq_b₁ : b₁ ≫ g₂ = g₁ ≫ c₁)
(sq_a₂ : a₂ ≫ f₃ = f₂ ≫ b₂)
(sq_b₂ : b₂ ≫ g₃ = g₂ ≫ c₂)

namespace snake

lemma mk_of_sequence_hom (sq₁ : a₁ ≫ f₂ = f₁ ≫ b₁) (sq₂ : b₁ ≫ g₂ = g₁ ≫ c₁)
  (h₁ : exact f₁ g₁) (h₂ : exact f₂ g₂) [epi g₁] [mono f₂] : snake
  (kernel a₁) (kernel b₁) (kernel c₁)
  A₁ B₁ C₁
  A₂ B₂ C₂
  (cokernel a₁) (cokernel b₁) (cokernel c₁)
  (kernel_map sq₁) (kernel_map sq₂)
  (kernel.ι _) (kernel.ι _) (kernel.ι _)
  f₁ g₁
  a₁ b₁ c₁
  f₂ g₂
  (cokernel.π _) (cokernel.π _) (cokernel.π _)
  (cokernel_map sq₁) (cokernel_map sq₂) :=
{ row_exact₁ := h₁,
  row_exact₂ := h₂,
  col_exact_a := exact_seq.cons _ _ exact_kernel_ι _ $ (exact_iff_exact_seq _ _).mp (abelian.exact_cokernel _),
  col_exact_b := exact_seq.cons _ _ exact_kernel_ι _ $ (exact_iff_exact_seq _ _).mp (abelian.exact_cokernel _),
  col_exact_c := exact_seq.cons _ _ exact_kernel_ι _ $ (exact_iff_exact_seq _ _).mp (abelian.exact_cokernel _),
  sq_a₀ := (limits.kernel.lift_ι _ _ _).symm,
  sq_b₀ := (limits.kernel.lift_ι _ _ _).symm,
  sq_a₁ := sq₁,
  sq_b₁ := sq₂,
  sq_a₂ := cokernel.π_desc _ _ _,
  sq_b₂ := cokernel.π_desc _ _ _ }

variables
 {A₀ B₀ C₀
  A₁ B₁ C₁
  A₂ B₂ C₂
  A₃ B₃ C₃
  f₀ g₀ a₀ b₀ c₀ f₁ g₁ a₁ b₁ c₁ f₂ g₂ a₂ b₂ c₂ f₃ g₃}

variables (S : snake
  A₀ B₀ C₀
  A₁ B₁ C₁
  A₂ B₂ C₂
  A₃ B₃ C₃
  f₀ g₀ a₀ b₀ c₀ f₁ g₁ a₁ b₁ c₁ f₂ g₂ a₂ b₂ c₂ f₃ g₃)

variables

def snake_diagram : snake_diagram ⥤ 𝒜 :=
snake_diagram.mk_functor
![![A₀, B₀, C₀],
  ![A₁, B₁, C₁],
  ![A₂, B₂, C₂],
  ![A₃, B₃, C₃]]
f₀ g₀ a₀ b₀ c₀ f₁ g₁ a₁ b₁ c₁ f₂ g₂ a₂ b₂ c₂ f₃ g₃
S.sq_a₀ S.sq_b₀ S.sq_a₁ S.sq_b₁ S.sq_a₂ S.sq_b₂

lemma is_snake_input : is_snake_input S.snake_diagram :=
{ row_exact₁ := by { dsimp only [snake_diagram], simpa using S.row_exact₁, },
  row_exact₂ := by { dsimp only [snake_diagram], simpa using S.row_exact₂ },
  col_exact₁ := begin
    intros j,
    dsimp only [snake_diagram],
    fin_cases j with [0, 1, 2]; simp; rw exact_iff_exact_seq,
    exacts [S.col_exact_a.extract 0 2, S.col_exact_b.extract 0 2, S.col_exact_c.extract 0 2],
  end,
  col_exact₂ := begin
    intros j,
    dsimp only [snake_diagram],
    fin_cases j with [0, 1, 2]; simp; rw exact_iff_exact_seq,
    exacts [S.col_exact_a.extract 1 2, S.col_exact_b.extract 1 2, S.col_exact_c.extract 1 2],
  end,
  col_mono := begin
    intros j,
    dsimp only [snake_diagram],
    fin_cases j with [0, 1, 2]; simp,
    exacts [S.col_mono_a, S.col_mono_b, S.col_mono_c],
  end,
  col_epi := begin
    intros j,
    dsimp only [snake_diagram],
    fin_cases j with [0, 1, 2]; simp,
    exacts [S.col_epi_a, S.col_epi_b, S.col_epi_c],
  end,
  row_mono := by { dsimp only [snake_diagram], simp, exact S.row_mono },
  row_epi := by { dsimp only [snake_diagram], simpa using S.row_epi } }

def snake_input : snake_input 𝒜 := ⟨S.snake_diagram, S.is_snake_input⟩

def δ : C₀ ⟶ A₃ := S.is_snake_input.δ

lemma six_term_exact_seq : exact_seq 𝒜 [f₀, g₀, S.δ, f₃, g₃] :=
begin
  have := S.is_snake_input.six_term_exact_seq,
  dsimp only [snake_diagram] at this,
  simpa only [snake_diagram.mk_functor_map_f0, snake_diagram.mk_functor_map_g0,
    snake_diagram.mk_functor_map_f3, snake_diagram.mk_functor_map_g3],
end

end snake

lemma mono_of_exact_of_eq_zero (hfg : exact f₁ g₁) (h : f₁ = 0) : mono g₁ :=
by rwa [(abelian.tfae_mono A₁ g₁).out 0 2, ← h]

lemma cokernel.map_mono_of_epi_of_mono (sq : f₁ ≫ b₁ = a₁ ≫ f₂)
  [epi a₁] [mono b₁] [mono f₂] :
  mono (cokernel.map f₁ f₂ a₁ b₁ sq) :=
begin
  have S := snake.mk_of_sequence_hom A₁ B₁ (cokernel f₁) A₂ B₂ (cokernel f₂)
    f₁ (cokernel.π _) a₁ b₁ (cokernel.map f₁ f₂ a₁ b₁ sq) f₂ (cokernel.π _) sq.symm (by simp)
    (abelian.exact_cokernel _) (abelian.exact_cokernel _),
  apply (S.col_exact_c).pair.mono_of_is_zero,
  exact (S.six_term_exact_seq.drop 1).pair.is_zero_of_is_zero_is_zero
    (is_zero_kernel_of_mono _) (is_zero_cokernel_of_epi _),
end

end category_theory


-- deletion tactics for G&G prover

import meta.expr
open tactic expr

universes u v w
def list.mchoose {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m (option β)) : list α → m (list β)
| []       := return []
| (h :: t) := pure (λ (h : option β) (t : list β), option.rec_on h t (λ h, h :: t)) <*> f h <*> list.mchoose t

def list.some {α : Type u} (p : α -> bool) : list α -> bool
| [] := false
| (h :: t) := p h || list.some t

namespace exprset
meta def exprset := rbmap expr unit expr.lt_prop
meta def from_list (l : list expr) : exprset := rbmap.from_list $ list.map (λ x, ⟨x,unit.star⟩) l
meta def to_list (d : exprset) : list expr := list.map prod.fst $ rbmap.to_list d
meta def empty : exprset := mk_rbmap expr unit expr.lt_prop
meta def union : exprset -> exprset -> exprset := rbmap.fold(λ x u a, rbmap.insert a x u)
meta def contains : exprset -> expr -> bool := rbmap.contains
end exprset

open exprset

meta def get_local_consts (e : expr) : exprset := from_list $ expr.list_local_const $ e

meta structure formula :=
(term : expr)
(type : expr)
(deps : exprset)

meta def as_prop (h : expr) : tactic $ option formula :=
do
    y <- infer_type h,
    p <- is_prop y,
    let deps := get_local_consts y in
    return $ if p then some ⟨h, y, deps⟩ else none

/--Get all of the context entries which are propositions along with their types.-/
meta def local_hypotheses : tactic $ list formula :=
local_context >>= list.mchoose as_prop

/--Get the goals which are propositions along with their types -/
meta def local_targets : tactic $ list formula :=
get_goals >>= list.mchoose as_prop

meta def find_dangling : exprset -> list formula -> list formula -> list formula
| d acc [] := acc
| d acc  (h :: hs) :=
    find_dangling (union d h.deps) (
        if list.some (λ h, (not $ contains d h) && list.all hs (λ h', not $ contains h'.deps h)) $ to_list h.deps
        then h :: acc else acc
    ) (hs)

meta def deleteDangling : tactic unit :=
do
    hyps <- local_hypotheses,
    targets <- local_targets,
    target_deps <- return $ list.foldl union empty $ list.map (λ t : formula, t.deps) targets,
    list.mmap' (λ (h : formula), clear h.term) $ find_dangling target_deps [] hyps

variables a b c : Prop
example : a -> (a -> b) -> c -> b :=
begin
  intros,
  deleteDangling,
  sorry
end