import algebraic_topology.simplex_category
import algebraic_topology.simplicial_set
import algebraic_topology.simplicial_object
import category_theory.arrow
import category_theory.discrete_category
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.presheaf
import category_theory.limits.preserves.shapes.equalizers

import simplex_category
import alt_horn

open category_theory

noncomputable theory

open_locale simplicial

universe u

variable n : ℕ
variable k : fin (n + 3)

def horn_has_filler {X : sSet} (f : Λ[n+2, k] ⟶ X) :=
  ∃ f' : Δ[n+2] ⟶ X, sSet.horn_inclusion (n + 2) k ≫ f' = f

def kan_complex (X : sSet) := ∀ (n k), ∀ f : Λ[n+2, k] ⟶ X, horn_has_filler n k f

def extension_condition (X : sSet) := ∀ (n k), ∀ y : (excluded_part n k) -> X _[n+1],
  (matching_faces n k X y) -> ∃ y' : X _[n+2], ∀ idx : excluded_part n k, X.δ idx.i y' = y idx

lemma kan_complex_impl_extension_condition (X : sSet) : kan_complex X -> extension_condition X :=
begin
  simp [kan_complex, extension_condition, matching_faces, horn_has_filler],
  intros kan n k y faces,
  set yₘ : excluded_end n k ⟶ X := limits.sigma.desc (λ idx, yoneda_equiv.inv_fun (y idx)),
  set y' : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k) := limits.cofork.of_π yₘ (by {
    rewrite [morph_horn_1, morph_horn_2],
    apply limits.colimit.hom_ext,
    simp only [limits.cofan.mk_ι_app, limits.colimit.ι_desc, limits.colimit.ι_desc_assoc, coe_coe,
      equiv.inv_fun_as_coe, category.assoc],
    intro idx,
    rw [←equiv.apply_eq_iff_eq yoneda_equiv],
    rw [←yoneda_equiv_naturality, ←yoneda_equiv_naturality],
    rw [equiv.apply_symm_apply, equiv.apply_symm_apply],
    exact faces idx,
  }),
  set f := (horn_colim n k).desc y',
  specialize kan n k f,
  cases kan,
  use (yoneda_equiv kan_w),
  intro idx,
  dsimp only [simplicial_object.δ],
  rw [yoneda_equiv_naturality],
  rw [equiv.apply_eq_iff_eq_symm_apply yoneda_equiv],

  have h' : (horn_morphism_i n k idx ≫ sSet.horn_inclusion (n + 2) k) ≫ kan_w = horn_morphism_i n k idx ≫ f
    := by simp [kan_h],
  simp [horn_morphism_i_incl, f] at h',

  have h'' := (horn_colim n k).fac y' limits.walking_parallel_pair.one,
  dsimp [horn_fork, limits.cofork.π_of_π] at h'',

  have h''' : ((limits.sigma.ι (excluded_f n k) idx) ≫ horn_morphism n k) ≫ (horn_colim n k).desc y'
    = (limits.sigma.ι (excluded_f n k) idx) ≫ yₘ := by simp [h''],
  simp [horn_morphism, limits.colimit.ι_desc] at h''',

  rwa [←h'''],
end

lemma extension_condition_impl_kan_complex (X : sSet) : extension_condition X -> kan_complex X :=
begin
  simp [kan_complex, extension_condition, matching_faces, horn_has_filler],
  intros face n k f,

  set y : excluded_part n k → X.obj (opposite.op [n + 1]) :=
    λ idx, yoneda_equiv (horn_morphism_i n k idx ≫ f),
  specialize face n k y,
  specialize face (by {
    intro idx,
    have h : limits.sigma.ι (horn_f n k) idx ≫ (morph_horn_1 n k ≫ horn_morphism n k) ≫ f =
      limits.sigma.ι (horn_f n k) idx ≫ (morph_horn_2 n k ≫ horn_morphism n k) ≫ f := by rw [horn_coeq],
    dsimp [morph_horn_1, morph_horn_2, horn_morphism, horn_morphism_i] at h,
    simp at h,
    rw [←equiv.apply_eq_iff_eq yoneda_equiv] at h,
    rw [←yoneda_equiv_naturality, ←yoneda_equiv_naturality] at h,
    dsimp [simplicial_object.δ, y],
    simp [yoneda_equiv] at h,
    exact h,
  }),

  cases face,
  use yoneda_equiv.inv_fun face_w,

  dsimp only [y] at face_h,
  apply limits.cofork.is_colimit.hom_ext (horn_colim n k),
  dsimp [horn_fork],
  dsimp only [horn_morphism],

  apply limits.colimit.hom_ext,
  simp only [limits.cofan.mk_ι_app, limits.colimit.ι_desc, limits.colimit.ι_desc_assoc, coe_coe,
    equiv.inv_fun_as_coe, category.assoc],
  intro idx,
  specialize face_h idx,
  rw [←category.assoc, horn_morphism_i_incl n k idx, ←equiv.apply_eq_iff_eq yoneda_equiv],
  rw [←yoneda_equiv_naturality, equiv.apply_symm_apply],
  exact face_h,
end

lemma kan_complex_iff_extension_conditions {X : sSet} : kan_complex X ↔ extension_condition X
  := ⟨kan_complex_impl_extension_condition X, extension_condition_impl_kan_complex X⟩


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel

! This file was ported from Lean 3 source module category_theory.abelian.non_preadditive
! leanprover-community/mathlib commit 829895f162a1f29d0133f4b3538f4cd1fb5bffd3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathlib.CategoryTheory.Limits.Shapes.Kernels
import Mathlib.CategoryTheory.Limits.Shapes.NormalMono.Equalizers
import Mathlib.CategoryTheory.Abelian.Images
import Mathlib.CategoryTheory.Preadditive.Basic

/-!
# Every NonPreadditiveAbelian category is preadditive

In mathlib, we define an abelian category as a preadditive category with a zero object,
kernels and cokernels, products and coproducts and in which every monomorphism and epimorphis is
normal.

While virtually every interesting abelian category has a natural preadditive structure (which is why
it is included in the definition), preadditivity is not actually needed: Every category that has
all of the other properties appearing in the definition of an abelian category admits a preadditive
structure. This is the construction we carry out in this file.

The proof proceeds in roughly five steps:
1. Prove some results (for example that all equalizers exist) that would be trivial if we already
   had the preadditive structure but are a bit of work without it.
2. Develop images and coimages to show that every monomorphism is the kernel of its cokernel.

The results of the first two steps are also useful for the "normal" development of abelian
categories, and will be used there.

3. For every object `A`, define a "subtraction" morphism `σ : A ⨯ A ⟶ A` and use it to define
   subtraction on morphisms as `f - g := prod.lift f g ≫ σ`.
4. Prove a small number of identities about this subtraction from the definition of `σ`.
5. From these identities, prove a large number of other identities that imply that defining
   `f + g := f - (0 - g)` indeed gives an abelian group structure on morphisms such that composition
   is bilinear.

The construction is non-trivial and it is quite remarkable that this abelian group structure can
be constructed purely from the existence of a few limits and colimits. Even more remarkably,
since abelian categories admit exactly one preadditive structure (see
`subsingletonPreadditiveOfHasBinaryBiproducts`), the construction manages to exactly
reconstruct any natural preadditive structure the category may have.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

-/

noncomputable section

open CategoryTheory

open CategoryTheory.Limits

namespace CategoryTheory

section

universe v u

variable (C : Type u) [Category.{v} C]

/-- We call a category `NonPreadditiveAbelian` if it has a zero object, kernels, cokernels, binary
    products and coproducts, and every monomorphism and every epimorphism is normal. -/
class NonPreadditiveAbelian extends HasZeroMorphisms C, NormalMonoCategory C,
  NormalEpiCategory C where
  [has_zero_object : HasZeroObject C]
  [has_kernels : HasKernels C]
  [has_cokernels : HasCokernels C]
  [has_finite_products : HasFiniteProducts C]
  [has_finite_coproducts : HasFiniteCoproducts C]
#align category_theory.non_preadditive_abelian CategoryTheory.NonPreadditiveAbelian

attribute [instance] NonPreadditiveAbelian.has_zero_object

attribute [instance] NonPreadditiveAbelian.has_kernels

attribute [instance] NonPreadditiveAbelian.has_cokernels

attribute [instance] NonPreadditiveAbelian.has_finite_products

attribute [instance] NonPreadditiveAbelian.has_finite_coproducts

end

end CategoryTheory

open CategoryTheory

universe v u

variable {C : Type u} [Category.{v} C] [NonPreadditiveAbelian C]

namespace CategoryTheory.NonPreadditiveAbelian

section Factor

variable {P Q : C} (f : P ⟶ Q)

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : Epi (Abelian.factorThruImage f) :=
  let I := Abelian.image f
  let p := Abelian.factorThruImage f
  let i := kernel.ι (cokernel.π f)
  -- It will suffice to consider some g : I ⟶ R such that p ≫ g = 0 and show that g = 0.
  NormalMonoCategory.epi_of_zero_cancel
  _ fun R (g : I ⟶ R) (hpg : p ≫ g = 0) => by
  -- Since C is abelian, u := ker g ≫ i is the kernel of some morphism h.
  let u := kernel.ι g ≫ i
  haveI : Mono u := mono_comp _ _
  haveI hu := normalMonoOfMono u
  let h := hu.g
  -- By hypothesis, p factors through the kernel of g via some t.
  obtain ⟨t, ht⟩ := kernel.lift' g p hpg
  have fh : f ≫ h = 0
  calc
    f ≫ h = (p ≫ i) ≫ h := (Abelian.image.fac f).symm ▸ rfl
    _ = ((t ≫ kernel.ι g) ≫ i) ≫ h := (ht ▸ rfl)
    _ = t ≫ u ≫ h := by simp only [Category.assoc]
    _ = t ≫ 0 := (hu.w ▸ rfl)
    _ = 0 := HasZeroMorphisms.comp_zero _ _
  -- h factors through the cokernel of f via some l.
  obtain ⟨l, hl⟩ := cokernel.desc' f h fh
  have hih : i ≫ h = 0
  calc
    i ≫ h = i ≫ cokernel.π f ≫ l := hl ▸ rfl
    _ = 0 ≫ l := by rw [← Category.assoc, kernel.condition]
    _ = 0 := zero_comp
  -- i factors through u = ker h via some s.
  obtain ⟨s, hs⟩ := NormalMono.lift' u i hih
  have hs' : (s ≫ kernel.ι g) ≫ i = 𝟙 I ≫ i := by rw [Category.assoc, hs, Category.id_comp]
  haveI : Epi (kernel.ι g) := epi_of_epi_fac ((cancel_mono _).1 hs')
  -- ker g is an epimorphism, but ker g ≫ g = 0 = ker g ≫ 0, so g = 0 as required.
  exact zero_of_epi_comp _ (kernel.condition g)

instance isIso_factorThruImage [Mono f] : IsIso (Abelian.factorThruImage f) :=
  isIso_of_mono_of_epi <| Abelian.factorThruImage f
#align category_theory.non_preadditive_abelian.is_iso_factor_thru_image CategoryTheory.NonPreadditiveAbelian.isIso_factorThruImage

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : Mono (Abelian.factorThruCoimage f) :=
  let I := Abelian.coimage f
  let i := Abelian.factorThruCoimage f
  let p := cokernel.π (kernel.ι f)
  NormalEpiCategory.mono_of_cancel_zero _ fun R (g : R ⟶ I) (hgi : g ≫ i = 0) => by
    -- Since C is abelian, u := p ≫ coker g is the cokernel of some morphism h.
    let u := p ≫ cokernel.π g
    haveI : Epi u := epi_comp _ _
    haveI hu := normalEpiOfEpi u
    let h := hu.g
    -- By hypothesis, i factors through the cokernel of g via some t.
    obtain ⟨t, ht⟩ := cokernel.desc' g i hgi
    have hf : h ≫ f = 0
    calc
      h ≫ f = h ≫ p ≫ i := (Abelian.coimage.fac f).symm ▸ rfl
      _ = h ≫ p ≫ cokernel.π g ≫ t := (ht ▸ rfl)
      _ = h ≫ u ≫ t := by simp only [Category.assoc]
      _ = 0 ≫ t := by rw [← Category.assoc, hu.w]
      _ = 0 := zero_comp
    -- h factors through the kernel of f via some l.
    obtain ⟨l, hl⟩ := kernel.lift' f h hf
    have hhp : h ≫ p = 0
    calc
      h ≫ p = (l ≫ kernel.ι f) ≫ p := hl ▸ rfl
      _ = l ≫ 0 := by rw [Category.assoc, cokernel.condition]
      _ = 0 := comp_zero
    -- p factors through u = coker h via some s.
    obtain ⟨s, hs⟩ := NormalEpi.desc' u p hhp
    have hs' : p ≫ cokernel.π g ≫ s = p ≫ 𝟙 I := by rw [← Category.assoc, hs, Category.comp_id]
    haveI : Mono (cokernel.π g) := mono_of_mono_fac ((cancel_epi _).1 hs')
    -- coker g is a monomorphism, but g ≫ coker g = 0 = 0 ≫ coker g, so g = 0 as required.
    exact zero_of_comp_mono _ (cokernel.condition g)

instance isIso_factorThruCoimage [Epi f] : IsIso (Abelian.factorThruCoimage f) :=
  isIso_of_mono_of_epi _
#align category_theory.non_preadditive_abelian.is_iso_factor_thru_coimage CategoryTheory.NonPreadditiveAbelian.isIso_factorThruCoimage

end Factor

section CokernelOfKernel

variable {X Y : C} {f : X ⟶ Y}

/-- In a `NonPreadditiveAbelian` category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `Fork.ι s`. -/
def epiIsCokernelOfKernel [Epi f] (s : Fork f 0) (h : IsLimit s) :
    IsColimit (CokernelCofork.ofπ f (KernelFork.condition s)) :=
  IsCokernel.cokernelIso _ _
    (cokernel.ofIsoComp _ _ (Limits.IsLimit.conePointUniqueUpToIso (limit.isLimit _) h)
      (ConeMorphism.w (Limits.IsLimit.uniqueUpToIso (limit.isLimit _) h).hom _))
    (asIso <| Abelian.factorThruCoimage f) (Abelian.coimage.fac f)
#align category_theory.non_preadditive_abelian.epi_is_cokernel_of_kernel CategoryTheory.NonPreadditiveAbelian.epiIsCokernelOfKernel

/-- In a `NonPreadditiveAbelian` category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `Cofork.π s`. -/
def monoIsKernelOfCokernel [Mono f] (s : Cofork f 0) (h : IsColimit s) :
    IsLimit (KernelFork.ofι f (CokernelCofork.condition s)) :=
  IsKernel.isoKernel _ _
    (kernel.ofCompIso _ _ (Limits.IsColimit.coconePointUniqueUpToIso h (colimit.isColimit _))
      (CoconeMorphism.w (Limits.IsColimit.uniqueUpToIso h <| colimit.isColimit _).hom _))
    (asIso <| Abelian.factorThruImage f) (Abelian.image.fac f)
#align category_theory.non_preadditive_abelian.mono_is_kernel_of_cokernel CategoryTheory.NonPreadditiveAbelian.monoIsKernelOfCokernel

end CokernelOfKernel

section

/-- The composite `A ⟶ A ⨯ A ⟶ cokernel (Δ A)`, where the first map is `(𝟙 A, 0)` and the second map
    is the canonical projection into the cokernel. -/
abbrev r (A : C) : A ⟶ cokernel (diag A) :=
  prod.lift (𝟙 A) 0 ≫ cokernel.π (diag A)
#align category_theory.non_preadditive_abelian.r CategoryTheory.NonPreadditiveAbelian.r

instance mono_Δ {A : C} : Mono (diag A) :=
  mono_of_mono_fac <| prod.lift_fst _ _
#align category_theory.non_preadditive_abelian.mono_Δ CategoryTheory.NonPreadditiveAbelian.mono_Δ

instance mono_r {A : C} : Mono (r A) := by
  let hl : IsLimit (KernelFork.ofι (diag A) (cokernel.condition (diag A))) :=
    monoIsKernelOfCokernel _ (colimit.isColimit _)
  apply NormalEpiCategory.mono_of_cancel_zero
  intro Z x hx
  have hxx : (x ≫ prod.lift (𝟙 A) (0 : A ⟶ A)) ≫ cokernel.π (diag A) = 0 := by
    rw [Category.assoc, hx]
  obtain ⟨y, hy⟩ := KernelFork.IsLimit.lift' hl _ hxx
  rw [KernelFork.ι_ofι] at hy
  have hyy : y = 0 := by
    erw [← Category.comp_id y, ← Limits.prod.lift_snd (𝟙 A) (𝟙 A), ← Category.assoc, hy,
      Category.assoc, prod.lift_snd, HasZeroMorphisms.comp_zero]
  haveI : Mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _)
  apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1
  rw [← hy, hyy, zero_comp, zero_comp]
#align category_theory.non_preadditive_abelian.mono_r CategoryTheory.NonPreadditiveAbelian.mono_r

instance epi_r {A : C} : Epi (r A) := by
  have hlp : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ Limits.prod.snd = 0 := prod.lift_snd _ _
  let hp1 : IsLimit (KernelFork.ofι (prod.lift (𝟙 A) (0 : A ⟶ A)) hlp) := by
    refine' Fork.IsLimit.mk _ (fun s => Fork.ι s ≫ Limits.prod.fst) _ _
    · intro s
      apply prod.hom_ext <;> simp
    · intro s m h
      haveI : Mono (prod.lift (𝟙 A) (0 : A ⟶ A)) := mono_of_mono_fac (prod.lift_fst _ _)
      apply (cancel_mono (prod.lift (𝟙 A) (0 : A ⟶ A))).1
      convert h
      apply prod.hom_ext <;> simp
  let hp2 : IsColimit (CokernelCofork.ofπ (Limits.prod.snd : A ⨯ A ⟶ A) hlp) :=
    epiIsCokernelOfKernel _ hp1
  apply NormalMonoCategory.epi_of_zero_cancel
  intro Z z hz
  have h : prod.lift (𝟙 A) (0 : A ⟶ A) ≫ cokernel.π (diag A) ≫ z = 0 := by rw [← Category.assoc, hz]
  obtain ⟨t, ht⟩ := CokernelCofork.IsColimit.desc' hp2 _ h
  rw [CokernelCofork.π_ofπ] at ht
  have htt : t = 0 := by
    rw [← Category.id_comp t]
    change 𝟙 A ≫ t = 0
    rw [← Limits.prod.lift_snd (𝟙 A) (𝟙 A), Category.assoc, ht, ← Category.assoc,
      cokernel.condition, zero_comp]
  apply (cancel_epi (cokernel.π (diag A))).1
  rw [← ht, htt, comp_zero, comp_zero]
#align category_theory.non_preadditive_abelian.epi_r CategoryTheory.NonPreadditiveAbelian.epi_r

instance isIso_r {A : C} : IsIso (r A) :=
  isIso_of_mono_of_epi _
#align category_theory.non_preadditive_abelian.is_iso_r CategoryTheory.NonPreadditiveAbelian.isIso_r

/-- The composite `A ⨯ A ⟶ cokernel (diag A) ⟶ A` given by the natural projection into the cokernel
    followed by the inverse of `r`. In the category of modules, using the normal kernels and
    cokernels, this map is equal to the map `(a, b) ↦ a - b`, hence the name `σ` for
    "subtraction". -/
abbrev σ {A : C} : A ⨯ A ⟶ A :=
  cokernel.π (diag A) ≫ inv (r A)
#align category_theory.non_preadditive_abelian.σ CategoryTheory.NonPreadditiveAbelian.σ

end

-- Porting note: simp can prove these
@[reassoc]
theorem diag_σ {X : C} : diag X ≫ σ = 0 := by rw [cokernel.condition_assoc, zero_comp]
#align category_theory.non_preadditive_abelian.diag_σ CategoryTheory.NonPreadditiveAbelian.diag_σ

@[reassoc (attr := simp)]
theorem lift_σ {X : C} : prod.lift (𝟙 X) 0 ≫ σ = 𝟙 X := by rw [← Category.assoc, IsIso.hom_inv_id]
#align category_theory.non_preadditive_abelian.lift_σ CategoryTheory.NonPreadditiveAbelian.lift_σ

@[reassoc]
theorem lift_map {X Y : C} (f : X ⟶ Y) :
    prod.lift (𝟙 X) 0 ≫ Limits.prod.map f f = f ≫ prod.lift (𝟙 Y) 0 := by simp
#align category_theory.non_preadditive_abelian.lift_map CategoryTheory.NonPreadditiveAbelian.lift_map

/-- σ is a cokernel of Δ X. -/
def isColimitσ {X : C} : IsColimit (CokernelCofork.ofπ (σ : X ⨯ X ⟶  X) diag_σ) :=
  cokernel.cokernelIso _ σ (asIso (r X)).symm (by rw [Iso.symm_hom, asIso_inv])
#align category_theory.non_preadditive_abelian.is_colimit_σ CategoryTheory.NonPreadditiveAbelian.isColimitσ

/-- This is the key identity satisfied by `σ`. -/
theorem σ_comp {X Y : C} (f : X ⟶ Y) : σ ≫ f = Limits.prod.map f f ≫ σ := by
  obtain ⟨g, hg⟩ :=
    CokernelCofork.IsColimit.desc' isColimitσ (Limits.prod.map f f ≫ σ) (by
      rw [prod.diag_map_assoc, diag_σ, comp_zero])
  suffices hfg : f = g
  · rw [← hg, Cofork.π_ofπ, hfg]
  calc
    f = f ≫ prod.lift (𝟙 Y) 0 ≫ σ := by rw [lift_σ, Category.comp_id]
    _ = prod.lift (𝟙 X) 0 ≫ Limits.prod.map f f ≫ σ := by rw [lift_map_assoc]
    _ = prod.lift (𝟙 X) 0 ≫ σ ≫ g := by rw [← hg, CokernelCofork.π_ofπ]
    _ = g := by rw [← Category.assoc, lift_σ, Category.id_comp]

#align category_theory.non_preadditive_abelian.σ_comp CategoryTheory.NonPreadditiveAbelian.σ_comp

section

-- We write `f - g` for `prod.lift f g ≫ σ`.
/-- Subtraction of morphisms in a `NonPreadditiveAbelian` category. -/
def hasSub {X Y : C} : Sub (X ⟶ Y) :=
  ⟨fun f g => prod.lift f g ≫ σ⟩
#align category_theory.non_preadditive_abelian.has_sub CategoryTheory.NonPreadditiveAbelian.hasSub

attribute [local instance] hasSub

-- We write `-f` for `0 - f`.
/-- Negation of morphisms in a `NonPreadditiveAbelian` category. -/
def hasNeg {X Y : C} : Neg (X ⟶ Y) where
  neg := fun f => 0 - f
#align category_theory.non_preadditive_abelian.has_neg CategoryTheory.NonPreadditiveAbelian.hasNeg

attribute [local instance] hasNeg

-- We write `f + g` for `f - (-g)`.
/-- Addition of morphisms in a `NonPreadditiveAbelian` category. -/
def hasAdd {X Y : C} : Add (X ⟶ Y) :=
  ⟨fun f g => f - -g⟩
#align category_theory.non_preadditive_abelian.has_add CategoryTheory.NonPreadditiveAbelian.hasAdd

attribute [local instance] hasAdd

theorem sub_def {X Y : C} (a b : X ⟶ Y) : a - b = prod.lift a b ≫ σ := rfl
#align category_theory.non_preadditive_abelian.sub_def CategoryTheory.NonPreadditiveAbelian.sub_def

theorem add_def {X Y : C} (a b : X ⟶ Y) : a + b = a - -b := rfl
#align category_theory.non_preadditive_abelian.add_def CategoryTheory.NonPreadditiveAbelian.add_def

theorem neg_def {X Y : C} (a : X ⟶ Y) : -a = 0 - a := rfl
#align category_theory.non_preadditive_abelian.neg_def CategoryTheory.NonPreadditiveAbelian.neg_def

theorem sub_zero {X Y : C} (a : X ⟶ Y) : a - 0 = a := by
  rw [sub_def]
  conv_lhs =>
    congr; congr; rw [← Category.comp_id a]
    case a.g => rw [show 0 = a ≫ (0 : Y ⟶ Y) by simp]
  rw [← prod.comp_lift, Category.assoc, lift_σ, Category.comp_id]
#align category_theory.non_preadditive_abelian.sub_zero CategoryTheory.NonPreadditiveAbelian.sub_zero

theorem sub_self {X Y : C} (a : X ⟶ Y) : a - a = 0 := by
  rw [sub_def, ← Category.comp_id a, ← prod.comp_lift, Category.assoc, diag_σ, comp_zero]
#align category_theory.non_preadditive_abelian.sub_self CategoryTheory.NonPreadditiveAbelian.sub_self

theorem lift_sub_lift {X Y : C} (a b c d : X ⟶ Y) :
    prod.lift a b - prod.lift c d = prod.lift (a - c) (b - d) := by
  simp only [sub_def]
  apply prod.hom_ext
  · rw [Category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_fst, prod.lift_fst, prod.lift_fst]
  · rw [Category.assoc, σ_comp, prod.lift_map_assoc, prod.lift_snd, prod.lift_snd, prod.lift_snd]
#align category_theory.non_preadditive_abelian.lift_sub_lift CategoryTheory.NonPreadditiveAbelian.lift_sub_lift

theorem sub_sub_sub {X Y : C} (a b c d : X ⟶ Y) : a - c - (b - d) = a - b - (c - d) := by
  rw [sub_def, ← lift_sub_lift, sub_def, Category.assoc, σ_comp, prod.lift_map_assoc]; rfl
#align category_theory.non_preadditive_abelian.sub_sub_sub CategoryTheory.NonPreadditiveAbelian.sub_sub_sub

theorem neg_sub {X Y : C} (a b : X ⟶ Y) : -a - b = -b - a := by
  conv_lhs => rw [neg_def, ← sub_zero b, sub_sub_sub, sub_zero, ← neg_def]
#align category_theory.non_preadditive_abelian.neg_sub CategoryTheory.NonPreadditiveAbelian.neg_sub

theorem neg_neg {X Y : C} (a : X ⟶ Y) : - -a = a := by
  rw [neg_def, neg_def]
  conv_lhs =>
    congr; rw [← sub_self a]
  rw [sub_sub_sub, sub_zero, sub_self, sub_zero]
#align category_theory.non_preadditive_abelian.neg_neg CategoryTheory.NonPreadditiveAbelian.neg_neg

theorem add_comm {X Y : C} (a b : X ⟶ Y) : a + b = b + a := by
  rw [add_def]
  conv_lhs => rw [← neg_neg a]
  rw [neg_def, neg_def, neg_def, sub_sub_sub]
  conv_lhs =>
    congr
    next => skip
    rw [← neg_def, neg_sub]
  rw [sub_sub_sub, add_def, ← neg_def, neg_neg b, neg_def]
#align category_theory.non_preadditive_abelian.add_comm CategoryTheory.NonPreadditiveAbelian.add_comm

theorem add_neg {X Y : C} (a b : X ⟶ Y) : a + -b = a - b := by rw [add_def, neg_neg]
#align category_theory.non_preadditive_abelian.add_neg CategoryTheory.NonPreadditiveAbelian.add_neg

theorem add_neg_self {X Y : C} (a : X ⟶ Y) : a + -a = 0 := by rw [add_neg, sub_self]
#align category_theory.non_preadditive_abelian.add_neg_self CategoryTheory.NonPreadditiveAbelian.add_neg_self

theorem neg_sub' {X Y : C} (a b : X ⟶ Y) : -(a - b) = -a + b := by
  rw [neg_def, neg_def]
  conv_lhs => rw [← sub_self (0 : X ⟶ Y)]
  rw [sub_sub_sub, add_def, neg_def]
#align category_theory.non_preadditive_abelian.neg_sub' CategoryTheory.NonPreadditiveAbelian.neg_sub'

theorem neg_add {X Y : C} (a b : X ⟶ Y) : -(a + b) = -a - b := by rw [add_def, neg_sub', add_neg]
#align category_theory.non_preadditive_abelian.neg_add CategoryTheory.NonPreadditiveAbelian.neg_add

theorem sub_add {X Y : C} (a b c : X ⟶ Y) : a - b + c = a - (b - c) := by
  rw [add_def, neg_def, sub_sub_sub, sub_zero]
#align category_theory.non_preadditive_abelian.sub_add CategoryTheory.NonPreadditiveAbelian.sub_add

theorem add_assoc {X Y : C} (a b c : X ⟶ Y) : a + b + c = a + (b + c) := by
  conv_lhs =>
    congr; rw [add_def]
  rw [sub_add, ← add_neg, neg_sub', neg_neg]
#align category_theory.non_preadditive_abelian.add_assoc CategoryTheory.NonPreadditiveAbelian.add_assoc

theorem add_zero {X Y : C} (a : X ⟶ Y) : a + 0 = a := by rw [add_def, neg_def, sub_self, sub_zero]
#align category_theory.non_preadditive_abelian.add_zero CategoryTheory.NonPreadditiveAbelian.add_zero

theorem comp_sub {X Y Z : C} (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g - h) = f ≫ g - f ≫ h := by
  rw [sub_def, ← Category.assoc, prod.comp_lift, sub_def]
#align category_theory.non_preadditive_abelian.comp_sub CategoryTheory.NonPreadditiveAbelian.comp_sub

theorem sub_comp {X Y Z : C} (f g : X ⟶ Y) (h : Y ⟶ Z) : (f - g) ≫ h = f ≫ h - g ≫ h := by
  rw [sub_def, Category.assoc, σ_comp, ← Category.assoc, prod.lift_map, sub_def]
#align category_theory.non_preadditive_abelian.sub_comp CategoryTheory.NonPreadditiveAbelian.sub_comp

theorem comp_add (X Y Z : C) (f : X ⟶ Y) (g h : Y ⟶ Z) : f ≫ (g + h) = f ≫ g + f ≫ h := by
  rw [add_def, comp_sub, neg_def, comp_sub, comp_zero, add_def, neg_def]
#align category_theory.non_preadditive_abelian.comp_add CategoryTheory.NonPreadditiveAbelian.comp_add

theorem add_comp (X Y Z : C) (f g : X ⟶ Y) (h : Y ⟶ Z) : (f + g) ≫ h = f ≫ h + g ≫ h := by
  rw [add_def, sub_comp, neg_def, sub_comp, zero_comp, add_def, neg_def]
#align category_theory.non_preadditive_abelian.add_comp CategoryTheory.NonPreadditiveAbelian.add_comp

/-- Every `NonPreadditiveAbelian` category is preadditive. -/
def preadditive : Preadditive C where
  homGroup X Y :=
    { add := (· + ·)
      add_assoc := add_assoc
      zero := 0
      zero_add := neg_neg
      add_zero := add_zero
      neg := fun f => -f
      add_left_neg := neg_add_self
      sub_eq_add_neg  := fun f g => (add_neg f g).symm -- Porting note: autoParam failed
      add_comm := add_comm }
  add_comp := add_comp
  comp_add := comp_add
#align category_theory.non_preadditive_abelian.preadditive CategoryTheory.NonPreadditiveAbelian.preadditive

end

end CategoryTheory.NonPreadditiveAbelian


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Kalle Kytölä
-/

import analysis.normed.normed_field
import analysis.convex.basic
import linear_algebra.sesquilinear_form
import topology.algebra.module.weak_dual

/-!
# Polar set

In this file we define the polar set. There are different notions of the polar, we will define the
*absolute polar*. The advantage over the real polar is that we can define the absolute polar for
any bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`, where `𝕜` is a normed commutative ring and
`E` and `F` are modules over `𝕜`.

## Main definitions

* `linear_map.polar`: The polar of a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`.

## Main statements

* `linear_map.polar_eq_Inter`: The polar as an intersection.
* `linear_map.subset_bipolar`: The polar is a subset of the bipolar.
* `linear_map.polar_weak_closed`: The polar is closed in the weak topology induced by `B.flip`.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

polar
-/

variables {𝕜 E F : Type*}

namespace linear_map

section normed_ring

variables [normed_comm_ring 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

/-- The (absolute) polar of `s : set E` is given by the set of all `y : F` such that `∥B x y∥ ≤ 1`
for all `x ∈ s`.-/
def polar (s : set E) : set F :=
  {y : F | ∀ x ∈ s, ∥B x y∥ ≤ 1 }

lemma polar_mem_iff (s : set E) (y : F) :
  y ∈ B.polar s ↔ ∀ x ∈ s, ∥B x y∥ ≤ 1 := iff.rfl

lemma polar_mem (s : set E) (y : F) (hy : y ∈ B.polar s) :
  ∀ x ∈ s, ∥B x y∥ ≤ 1 := hy

@[simp] lemma zero_mem_polar (s : set E) :
  (0 : F) ∈ B.polar s :=
λ _ _, by simp only [map_zero, norm_zero, zero_le_one]

lemma polar_eq_Inter {s : set E} :
  B.polar s = ⋂ x ∈ s, {y : F | ∥B x y∥ ≤ 1} :=
by { ext, simp only [polar_mem_iff, set.mem_Inter, set.mem_set_of_eq] }

/-- The map `B.polar : set E → set F` forms an order-reversing Galois connection with
`B.flip.polar : set F → set E`. We use `order_dual.to_dual` and `order_dual.of_dual` to express
that `polar` is order-reversing. -/
lemma polar_gc : galois_connection (order_dual.to_dual ∘ B.polar)
  (B.flip.polar ∘ order_dual.of_dual) :=
λ s t, ⟨λ h _ hx _ hy, h hy _ hx, λ h _ hx _ hy, h hy _ hx⟩

@[simp] lemma polar_Union {ι} {s : ι → set E} : B.polar (⋃ i, s i) = ⋂ i, B.polar (s i) :=
B.polar_gc.l_supr

@[simp] lemma polar_union {s t : set E} : B.polar (s ∪ t) = B.polar s ∩ B.polar t :=
B.polar_gc.l_sup

lemma polar_antitone : antitone (B.polar : set E → set F) := B.polar_gc.monotone_l

@[simp] lemma polar_empty : B.polar ∅ = set.univ := B.polar_gc.l_bot

@[simp]

lemma subset_bipolar (s : set E) : s ⊆ B.flip.polar (B.polar s) :=
λ x hx y hy, by { rw B.flip_apply, exact hy x hx }

@[simp] lemma tripolar_eq_polar (s : set E) : B.polar (B.flip.polar (B.polar s)) = B.polar s :=
begin
  refine (B.polar_antitone (B.subset_bipolar s)).antisymm _,
  convert subset_bipolar B.flip (B.polar s),
  exact B.flip_flip.symm,
end

/-- The polar set is closed in the weak topology induced by `B.flip`. -/
lemma polar_weak_closed (s : set E) :
  @is_closed _ (weak_bilin.topological_space B.flip) (B.polar s) :=
begin
  rw polar_eq_Inter,
  refine is_closed_Inter (λ x, is_closed_Inter (λ _, _)),
  exact is_closed_le (eval_continuous B.flip x).norm continuous_const,
end

end normed_ring

section nondiscrete_normed_field

variables [nondiscrete_normed_field 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

lemma polar_univ (h : separating_right B) :
  B.polar set.univ = {(0 : F)} :=
begin
  rw set.eq_singleton_iff_unique_mem,
  refine ⟨by simp only [zero_mem_polar], λ y hy, h _ (λ x, _)⟩,
  refine norm_le_zero_iff.mp (le_of_forall_le_of_dense $ λ ε hε, _),
  rcases normed_field.exists_norm_lt 𝕜 hε with ⟨c, hc, hcε⟩,
  calc ∥B x y∥ = ∥c∥ * ∥B (c⁻¹ • x) y∥ :
    by rw [B.map_smul, linear_map.smul_apply, algebra.id.smul_eq_mul, norm_mul, norm_inv,
      mul_inv_cancel_left₀ hc.ne']
  ... ≤ ε * 1 : mul_le_mul hcε.le (hy _ trivial) (norm_nonneg _) hε.le
  ... = ε : mul_one _
end

end nondiscrete_normed_field

end linear_map


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.variables
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Multivariate polynomials over a ring

Many results about polynomials hold when the coefficient ring is a commutative semiring.
Some stronger results can be derived when we assume this semiring is a ring.

This file does not define any new operations, but proves some of these stronger results.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_ring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

-/

namespace mv_polynomial

protected instance comm_ring {R : Type u} {σ : Type u_1} [comm_ring R] :
    comm_ring (mv_polynomial σ R) :=
  add_monoid_algebra.comm_ring

protected instance C.is_ring_hom {R : Type u} {σ : Type u_1} [comm_ring R] : is_ring_hom ⇑C :=
  is_ring_hom.of_semiring ⇑C

@[simp] theorem C_sub {R : Type u} (σ : Type u_1) (a : R) (a' : R) [comm_ring R] :
    coe_fn C (a - a') = coe_fn C a - coe_fn C a' :=
  is_ring_hom.map_sub ⇑C

@[simp] theorem C_neg {R : Type u} (σ : Type u_1) (a : R) [comm_ring R] :
    coe_fn C (-a) = -coe_fn C a :=
  is_ring_hom.map_neg ⇑C

@[simp] theorem coeff_neg {R : Type u} (σ : Type u_1) [comm_ring R] (m : σ →₀ ℕ)
    (p : mv_polynomial σ R) : coeff m (-p) = -coeff m p :=
  finsupp.neg_apply

@[simp] theorem coeff_sub {R : Type u} (σ : Type u_1) [comm_ring R] (m : σ →₀ ℕ)
    (p : mv_polynomial σ R) (q : mv_polynomial σ R) : coeff m (p - q) = coeff m p - coeff m q :=
  finsupp.sub_apply

protected instance coeff.is_add_group_hom {R : Type u} (σ : Type u_1) [comm_ring R] (m : σ →₀ ℕ) :
    is_add_group_hom (coeff m) :=
  is_add_group_hom.mk

theorem degrees_neg {R : Type u} {σ : Type u_1} [comm_ring R] (p : mv_polynomial σ R) :
    degrees (-p) = degrees p :=
  sorry

theorem degrees_sub {R : Type u} {σ : Type u_1} [comm_ring R] (p : mv_polynomial σ R)
    (q : mv_polynomial σ R) : degrees (p - q) ≤ degrees p ⊔ degrees q :=
  sorry

@[simp] theorem vars_neg {R : Type u} {σ : Type u_1} [comm_ring R] (p : mv_polynomial σ R) :
    vars (-p) = vars p :=
  sorry

theorem vars_sub_subset {R : Type u} {σ : Type u_1} [comm_ring R] (p : mv_polynomial σ R)
    (q : mv_polynomial σ R) : vars (p - q) ⊆ vars p ∪ vars q :=
  sorry

@[simp] theorem vars_sub_of_disjoint {R : Type u} {σ : Type u_1} [comm_ring R]
    {p : mv_polynomial σ R} {q : mv_polynomial σ R} (hpq : disjoint (vars p) (vars q)) :
    vars (p - q) = vars p ∪ vars q :=
  sorry

@[simp] theorem eval₂_sub {R : Type u} {S : Type v} {σ : Type u_1} [comm_ring R]
    (p : mv_polynomial σ R) {q : mv_polynomial σ R} [comm_ring S] (f : R →+* S) (g : σ → S) :
    eval₂ f g (p - q) = eval₂ f g p - eval₂ f g q :=
  ring_hom.map_sub (eval₂_hom f g) p q

@[simp] theorem eval₂_neg {R : Type u} {S : Type v} {σ : Type u_1} [comm_ring R]
    (p : mv_polynomial σ R) [comm_ring S] (f : R →+* S) (g : σ → S) :
    eval₂ f g (-p) = -eval₂ f g p :=
  ring_hom.map_neg (eval₂_hom f g) p

theorem hom_C {S : Type v} {σ : Type u_1} [comm_ring S] (f : mv_polynomial σ ℤ → S) [is_ring_hom f]
    (n : ℤ) : f (coe_fn C n) = ↑n :=
  ring_hom.eq_int_cast (ring_hom.comp (ring_hom.of f) (ring_hom.of ⇑C)) n

/-- A ring homomorphism f : Z[X_1, X_2, ...] → R
is determined by the evaluations f(X_1), f(X_2), ... -/
@[simp] theorem eval₂_hom_X {S : Type v} [comm_ring S] {R : Type u} (c : ℤ →+* S)
    (f : mv_polynomial R ℤ →+* S) (x : mv_polynomial R ℤ) : eval₂ c (⇑f ∘ X) x = coe_fn f x :=
  sorry

/-- Ring homomorphisms out of integer polynomials on a type `σ` are the same as
functions out of the type `σ`, -/
def hom_equiv {S : Type v} {σ : Type u_1} [comm_ring S] : (mv_polynomial σ ℤ →+* S) ≃ (σ → S) :=
  equiv.mk (fun (f : mv_polynomial σ ℤ →+* S) => ⇑f ∘ X)
    (fun (f : σ → S) => eval₂_hom (int.cast_ring_hom S) f) sorry sorry

@[simp] theorem total_degree_neg {R : Type u} {σ : Type u_1} [comm_ring R] (a : mv_polynomial σ R) :
    total_degree (-a) = total_degree a :=
  sorry

theorem total_degree_sub {R : Type u} {σ : Type u_1} [comm_ring R] (a : mv_polynomial σ R)
    (b : mv_polynomial σ R) : total_degree (a - b) ≤ max (total_degree a) (total_degree b) :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Keeley Hoek, Patrick Massot, Scott Morrison
-/
import Mathlib.Lean.Expr.Basic
import Mathlib.Order.Monotone.Basic

/-!
# The `apply_fun` tactic.

Apply a function to an equality or inequality in either a local hypothesis or the goal.

## Porting notes
When the `mono` tactic has been ported we can attempt to automatically discharge `Monotone f` goals.

When `Logic.Equiv.Basic` and `Order.Hom.Basic` have been ported some additional testing is required.
-/

namespace Mathlib.Tactic
open Lean Parser Tactic Elab Tactic Meta

initialize registerTraceClass `apply_fun

/-- Apply a function to a hypothesis. -/
def applyFunHyp (f : TSyntax `term) (using? : Option Expr) (h : FVarId) (g : MVarId) :
    TacticM (List MVarId) := do
  let d ← h.getDecl
  let (prf, newGoals) ← match (← whnfR (← instantiateMVars d.type)).getAppFnArgs with
  | (``Eq, #[_, lhs, rhs]) => do
    let (eq', gs) ← withCollectingNewGoalsFrom (tagSuffix := `apply_fun) <|
      withoutRecover <| runTermElab <| do
        let f ← Term.elabTerm f none
        let lhs' ← Term.elabAppArgs f #[] #[.expr lhs] none false false
        let rhs' ← Term.elabAppArgs f #[] #[.expr rhs] none false false
        unless ← isDefEq (← inferType lhs') (← inferType rhs') do
          let msg ← mkHasTypeButIsExpectedMsg (← inferType rhs') (← inferType lhs')
          throwError "In generated equality, right-hand side {msg}"
        let eq ← mkEq lhs'.headBeta rhs'.headBeta
        Term.synthesizeSyntheticMVarsUsingDefault
        instantiateMVars eq
    let mvar ← mkFreshExprMVar eq'
    let [] ← mvar.mvarId!.congrN! | throwError "`apply_fun` could not construct congruence"
    pure (mvar, gs)
  | (``LE.le, _) =>
    let (monotone_f, newGoals) ← match using? with
    -- Use the expression passed with `using`
    | some r => pure (r, [])
    -- Create a new `Monotone f` goal
    | none => do
      let f ← elabTermForApply f
      let ng ← mkFreshExprMVar (← mkAppM ``Monotone #[f])
      -- TODO attempt to solve this goal using `mono` when it has been ported,
      -- via `synthesizeUsing`.
      pure (ng, [ng.mvarId!])
    pure (← mkAppM' monotone_f #[d.toExpr], newGoals)
  | _ => throwError "apply_fun can only handle hypotheses of the form `a = b` or `a ≤ b`."

  let g ← g.clear h
  let (_, g) ← g.note d.userName prf
  return g :: newGoals

/-- Failure message for `applyFunTarget`. -/
def applyFunTargetFailure (f : Expr) : MetaM (List MVarId) := do
  throwError "`apply_fun` could not apply `{f}` to the main goal."

/-- Apply a function to the main goal. -/
def applyFunTarget (f : Expr) (using? : Option Expr) (g : MVarId) : MetaM (List MVarId) := do
  match (← g.getType).getAppFnArgs with
  | (``Ne, #[_, _, _]) => g.apply (← mkAppM ``ne_of_apply_ne #[f])
  | (``Not, #[p]) => match p.getAppFnArgs with
    | (``Eq, #[_, _, _]) => g.apply (← mkAppM ``ne_of_apply_ne #[f])
    | _ => applyFunTargetFailure f
  -- TODO Once `Order.Hom.Basic` has been ported, verify these work.
  -- | (``LE.le, _) => g.apply (← mkAppM ``OrderIso.le_iff_le #[f])
  -- | (``GE.ge, _) => g.apply (← mkAppM ``OrderIso.le_iff_le #[f])
  -- | (``LT.lt, _) => g.apply (← mkAppM ``OrderIso.lt_iff_lt #[f])
  -- | (``GT.gt, _) => g.apply (← mkAppM ``OrderIso.lt_iff_lt #[f])
  | (``Eq, #[_, _, _]) => do
    let ng ← mkFreshExprMVar (← mkAppM ``Function.Injective #[f])
    -- Try the `using` clause
    if let some u := using? then _ ← isDefEq ng u
    -- Try an assumption
    try ng.mvarId!.assumption catch _ =>
      -- TODO Once `Logic.Equiv.Basic` has been ported, verify this works.
      -- try return ← ng.mvarId!.apply (mkConst ``Equiv.injective) catch _ =>
      pure ()
    g.apply ng
  | _ => applyFunTargetFailure f

/--
Apply a function to an equality or inequality in either a local hypothesis or the goal.

* If we have `h : a = b`, then `apply_fun f at h` will replace this with `h : f a = f b`.
* If we have `h : a ≤ b`, then `apply_fun f at h` will replace this with `h : f a ≤ f b`,
  and create a subsidiary goal `Monotone f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using `mono`,
  or an explicit solution can be provided with `apply_fun f at h using P`, where `P : monotone f`.
* If the goal is `a ≠ b`, `apply_fun f` will replace this with `f a ≠ f b`.
* If the goal is `a = b`, `apply_fun f` will replace this with `f a = f b`,
  and create a subsidiary goal `injective f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using local hypotheses,
  or if `f` is actually an `Equiv`,
  or an explicit solution can be provided with `apply_fun f using P`, where `P : Injective f`.
* If the goal is `a ≤ b` (or similarly for `a < b`), and `f` is actually an `OrderIso`,
  `apply_fun f` will replace the goal with `f a ≤ f b`.
  If `f` is anything else (e.g. just a function, or an `Equiv`), `apply_fun` will fail.

Typical usage is:
```lean
open Function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : Injective <| g ∘ f) :
    Injective f := by
  intros x x' h
  apply_fun g at h
  exact H h
```
 -/
syntax (name := applyFun) "apply_fun " term (ppSpace location)? (" using " term)? : tactic

elab_rules : tactic | `(tactic| apply_fun $f $[$loc]? $[using $P]?) => do
  let P ← P.mapM (elabTerm · none)
  withLocation (expandOptLocation (Lean.mkOptionalNode loc))
    (atLocal := fun h ↦ do replaceMainGoal <| ← applyFunHyp f P h (← getMainGoal))
    (atTarget := withMainContext do
      let f ← elabTermForApply f
      liftMetaTactic fun g => applyFunTarget f P g)
    (failed := fun _ ↦ throwError "apply_fun failed")


/-
Copyright (c) 2022 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen, Mantas Bakšys

! This file was ported from Lean 3 source module number_theory.multiplicity
! leanprover-community/mathlib commit 76de8ae01554c3b37d66544866659ff174e66e1f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GeomSum
import Mathbin.Data.Int.Parity
import Mathbin.Data.Zmod.Basic
import Mathbin.NumberTheory.Padics.PadicVal
import Mathbin.RingTheory.Ideal.QuotientOperations

/-!
# Multiplicity in Number Theory

This file contains results in number theory relating to multiplicity.

## Main statements

* `multiplicity.int.pow_sub_pow` is the lifting the exponent lemma for odd primes.
  We also prove several variations of the lemma.

## References

* [Wikipedia, *Lifting-the-exponent lemma*]
  (https://en.wikipedia.org/wiki/Lifting-the-exponent_lemma)
-/

open Ideal Ideal.Quotient Finset

open BigOperators

variable {R : Type _} {n : ℕ}

section CommRing

variable [CommRing R] {a b x y : R}

theorem dvd_geom_sum₂_iff_of_dvd_sub {x y p : R} (h : p ∣ x - y) :
    (p ∣ ∑ i in range n, x ^ i * y ^ (n - 1 - i)) ↔ p ∣ n * y ^ (n - 1) :=
  by
  rw [← mem_span_singleton, ← Ideal.Quotient.eq] at h
  simp only [← mem_span_singleton, ← eq_zero_iff_mem, RingHom.map_geom_sum₂, h, geom_sum₂_self,
    _root_.map_mul, map_pow, map_natCast]
#align dvd_geom_sum₂_iff_of_dvd_sub dvd_geom_sum₂_iff_of_dvd_sub

theorem dvd_geom_sum₂_iff_of_dvd_sub' {x y p : R} (h : p ∣ x - y) :
    (p ∣ ∑ i in range n, x ^ i * y ^ (n - 1 - i)) ↔ p ∣ n * x ^ (n - 1) := by
  rw [geom_sum₂_comm, dvd_geom_sum₂_iff_of_dvd_sub] <;> simpa using (dvd_neg _ _).mpr h
#align dvd_geom_sum₂_iff_of_dvd_sub' dvd_geom_sum₂_iff_of_dvd_sub'

theorem dvd_geom_sum₂_self {x y : R} (h : ↑n ∣ x - y) :
    ↑n ∣ ∑ i in range n, x ^ i * y ^ (n - 1 - i) :=
  (dvd_geom_sum₂_iff_of_dvd_sub h).mpr (dvd_mul_right _ _)
#align dvd_geom_sum₂_self dvd_geom_sum₂_self

theorem sq_dvd_add_pow_sub_sub (p x : R) (n : ℕ) :
    p ^ 2 ∣ (x + p) ^ n - x ^ (n - 1) * p * n - x ^ n :=
  by
  cases n
  · simp only [pow_zero, Nat.cast_zero, MulZeroClass.mul_zero, sub_zero, sub_self, dvd_zero]
  · simp only [Nat.succ_sub_succ_eq_sub, tsub_zero, Nat.cast_succ, add_pow, Finset.sum_range_succ,
      Nat.choose_self, Nat.succ_sub _, tsub_self, pow_one, Nat.choose_succ_self_right, pow_zero,
      mul_one, Nat.cast_zero, zero_add, Nat.succ_eq_add_one]
    suffices p ^ 2 ∣ ∑ i : ℕ in range n, x ^ i * p ^ (n + 1 - i) * ↑((n + 1).choose i) by
      convert this <;> abel
    · apply Finset.dvd_sum
      intro y hy
      calc
        p ^ 2 ∣ p ^ (n + 1 - y) :=
          pow_dvd_pow p (le_tsub_of_add_le_left (by linarith [finset.mem_range.mp hy]))
        _ ∣ x ^ y * p ^ (n + 1 - y) * ↑((n + 1).choose y) :=
          dvd_mul_of_dvd_left (dvd_mul_left _ _) ((n + 1).choose y)

#align sq_dvd_add_pow_sub_sub sq_dvd_add_pow_sub_sub

theorem not_dvd_geom_sum₂ {p : R} (hp : Prime p) (hxy : p ∣ x - y) (hx : ¬p ∣ x) (hn : ¬p ∣ n) :
    ¬p ∣ ∑ i in range n, x ^ i * y ^ (n - 1 - i) := fun h =>
  hx <|
    hp.dvd_of_dvd_pow <| (hp.dvd_or_dvd <| (dvd_geom_sum₂_iff_of_dvd_sub' hxy).mp h).resolve_left hn
#align not_dvd_geom_sum₂ not_dvd_geom_sum₂

variable {p : ℕ} (a b)

theorem odd_sq_dvd_geom_sum₂_sub (hp : Odd p) :
    ↑p ^ 2 ∣ (∑ i in range p, (a + p * b) ^ i * a ^ (p - 1 - i)) - p * a ^ (p - 1) :=
  by
  have h1 : ∀ i, ↑p ^ 2 ∣ (a + ↑p * b) ^ i - (a ^ (i - 1) * (↑p * b) * ↑i + a ^ i) :=
    by
    intro i
    calc
      ↑p ^ 2 ∣ (↑p * b) ^ 2 := by simp only [mul_pow, dvd_mul_right]
      _ ∣ (a + ↑p * b) ^ i - (a ^ (i - 1) * (↑p * b) * ↑i + a ^ i) := by
        simp only [sq_dvd_add_pow_sub_sub (↑p * b) a i, ← sub_sub]

  simp_rw [← mem_span_singleton, ← Ideal.Quotient.eq] at *
  calc
    Ideal.Quotient.mk (span {↑p ^ 2}) (∑ i in range p, (a + ↑p * b) ^ i * a ^ (p - 1 - i)) =
        ∑ i : ℕ in Finset.range p,
          mk (span {↑p ^ 2}) ((a ^ (i - 1) * (↑p * b) * ↑i + a ^ i) * a ^ (p - 1 - i)) :=
      by simp_rw [RingHom.map_geom_sum₂, ← map_pow, h1, ← _root_.map_mul]
    _ =
        mk (span {↑p ^ 2})
            (∑ x : ℕ in Finset.range p, a ^ (x - 1) * (a ^ (p - 1 - x) * (↑p * (b * ↑x)))) +
          mk (span {↑p ^ 2}) (∑ x : ℕ in Finset.range p, a ^ (x + (p - 1 - x))) :=
      by
      ring
      simp only [← pow_add, map_add, Finset.sum_add_distrib, ← map_sum]
    _ =
        mk (span {↑p ^ 2})
            (∑ x : ℕ in Finset.range p, a ^ (x - 1) * (a ^ (p - 1 - x) * (↑p * (b * ↑x)))) +
          mk (span {↑p ^ 2}) (∑ x : ℕ in Finset.range p, a ^ (p - 1)) :=
      by
      rw [add_right_inj, Finset.sum_congr rfl]
      intro x hx
      rw [← Nat.add_sub_assoc _ x, Nat.add_sub_cancel_left]
      exact Nat.le_pred_of_lt (finset.mem_range.mp hx)
    _ =
        mk (span {↑p ^ 2})
            (∑ x : ℕ in Finset.range p, a ^ (x - 1) * (a ^ (p - 1 - x) * (↑p * (b * ↑x)))) +
          mk (span {↑p ^ 2}) (↑p * a ^ (p - 1)) :=
      by simp only [add_right_inj, Finset.sum_const, Finset.card_range, nsmul_eq_mul]
    _ =
        mk (span {↑p ^ 2}) (↑p * b * ∑ x : ℕ in Finset.range p, a ^ (p - 2) * x) +
          mk (span {↑p ^ 2}) (↑p * a ^ (p - 1)) :=
      by
      simp only [Finset.mul_sum, ← mul_assoc, ← pow_add]
      rw [Finset.sum_congr rfl]
      rintro (⟨⟩ | ⟨x⟩) hx
      · rw [Nat.cast_zero, MulZeroClass.mul_zero, MulZeroClass.mul_zero]
      · have : x.succ - 1 + (p - 1 - x.succ) = p - 2 :=
          by
          rw [← Nat.add_sub_assoc (Nat.le_pred_of_lt (finset.mem_range.mp hx))]
          exact congr_arg Nat.pred (Nat.add_sub_cancel_left _ _)
        rw [this]
        ring1
    _ = mk (span {↑p ^ 2}) (↑p * a ^ (p - 1)) :=
      by
      simp only [add_left_eq_self, ← Finset.mul_sum]
      norm_cast
      simp only [Finset.sum_range_id, Nat.cast_mul, _root_.map_mul,
        Nat.mul_div_assoc _ (even_iff_two_dvd.mp (Nat.Odd.sub_odd hp odd_one))]
      ring
      simp only [← map_pow, mul_eq_zero_of_left, Ideal.Quotient.eq_zero_iff_mem, mem_span_singleton]

#align odd_sq_dvd_geom_sum₂_sub odd_sq_dvd_geom_sum₂_sub

namespace multiplicity

section IntegralDomain

variable [IsDomain R] [@DecidableRel R (· ∣ ·)]

theorem pow_sub_pow_of_prime {p : R} (hp : Prime p) {x y : R} (hxy : p ∣ x - y) (hx : ¬p ∣ x)
    {n : ℕ} (hn : ¬p ∣ n) : multiplicity p (x ^ n - y ^ n) = multiplicity p (x - y) := by
  rw [← geom_sum₂_mul, multiplicity.mul hp, multiplicity_eq_zero.2 (not_dvd_geom_sum₂ hp hxy hx hn),
    zero_add]
#align multiplicity.pow_sub_pow_of_prime multiplicity.pow_sub_pow_of_prime

variable (hp : Prime (p : R)) (hp1 : Odd p) (hxy : ↑p ∣ x - y) (hx : ¬↑p ∣ x)

include hp hp1 hxy hx

theorem geom_sum₂_eq_one : multiplicity (↑p) (∑ i in range p, x ^ i * y ^ (p - 1 - i)) = 1 :=
  by
  rw [← Nat.cast_one]
  refine' multiplicity.eq_coe_iff.2 ⟨_, _⟩
  · rw [pow_one]
    exact dvd_geom_sum₂_self hxy
  rw [dvd_iff_dvd_of_dvd_sub hxy] at hx
  cases' hxy with k hk
  rw [one_add_one_eq_two, eq_add_of_sub_eq' hk]
  refine' mt (dvd_iff_dvd_of_dvd_sub (@odd_sq_dvd_geom_sum₂_sub _ _ y k _ hp1)).mp _
  rw [pow_two, mul_dvd_mul_iff_left hp.ne_zero]
  exact mt hp.dvd_of_dvd_pow hx
#align multiplicity.geom_sum₂_eq_one multiplicity.geom_sum₂_eq_one

theorem pow_prime_sub_pow_prime :
    multiplicity (↑p) (x ^ p - y ^ p) = multiplicity (↑p) (x - y) + 1 := by
  rw [← geom_sum₂_mul, multiplicity.mul hp, geom_sum₂_eq_one hp hp1 hxy hx, add_comm]
#align multiplicity.pow_prime_sub_pow_prime multiplicity.pow_prime_sub_pow_prime

theorem pow_prime_pow_sub_pow_prime_pow (a : ℕ) :
    multiplicity (↑p) (x ^ p ^ a - y ^ p ^ a) = multiplicity (↑p) (x - y) + a :=
  by
  induction' a with a h_ind
  · rw [Nat.cast_zero, add_zero, pow_zero, pow_one, pow_one]
  rw [← Nat.add_one, Nat.cast_add, Nat.cast_one, ← add_assoc, ← h_ind, pow_succ', pow_mul, pow_mul]
  apply pow_prime_sub_pow_prime hp hp1
  · rw [← geom_sum₂_mul]
    exact dvd_mul_of_dvd_right hxy _
  · exact fun h => hx (hp.dvd_of_dvd_pow h)
#align multiplicity.pow_prime_pow_sub_pow_prime_pow multiplicity.pow_prime_pow_sub_pow_prime_pow

end IntegralDomain

section LiftingTheExponent

variable (hp : Nat.Prime p) (hp1 : Odd p)

include hp hp1

/-- **Lifting the exponent lemma** for odd primes. -/
theorem Int.pow_sub_pow {x y : ℤ} (hxy : ↑p ∣ x - y) (hx : ¬↑p ∣ x) (n : ℕ) :
    multiplicity (↑p) (x ^ n - y ^ n) = multiplicity (↑p) (x - y) + multiplicity p n :=
  by
  cases n
  · simp only [multiplicity.zero, add_top, pow_zero, sub_self]
  have h : (multiplicity _ _).Dom := finite_nat_iff.mpr ⟨hp.ne_one, n.succ_pos⟩
  rcases eq_coe_iff.mp (PartENat.natCast_get h).symm with ⟨⟨k, hk⟩, hpn⟩
  conv_lhs => rw [hk, pow_mul, pow_mul]
  rw [Nat.prime_iff_prime_int] at hp
  rw [pow_sub_pow_of_prime hp, pow_prime_pow_sub_pow_prime_pow hp hp1 hxy hx, PartENat.natCast_get]
  · rw [← geom_sum₂_mul]
    exact dvd_mul_of_dvd_right hxy _
  · exact fun h => hx (hp.dvd_of_dvd_pow h)
  · rw [Int.coe_nat_dvd]
    rintro ⟨c, rfl⟩
    refine' hpn ⟨c, _⟩
    rwa [pow_succ', mul_assoc]
#align multiplicity.int.pow_sub_pow multiplicity.Int.pow_sub_pow

theorem Int.pow_add_pow {x y : ℤ} (hxy : ↑p ∣ x + y) (hx : ¬↑p ∣ x) {n : ℕ} (hn : Odd n) :
    multiplicity (↑p) (x ^ n + y ^ n) = multiplicity (↑p) (x + y) + multiplicity p n :=
  by
  rw [← sub_neg_eq_add] at hxy
  rw [← sub_neg_eq_add, ← sub_neg_eq_add, ← Odd.neg_pow hn]
  exact int.pow_sub_pow hp hp1 hxy hx n
#align multiplicity.int.pow_add_pow multiplicity.Int.pow_add_pow

theorem Nat.pow_sub_pow {x y : ℕ} (hxy : p ∣ x - y) (hx : ¬p ∣ x) (n : ℕ) :
    multiplicity p (x ^ n - y ^ n) = multiplicity p (x - y) + multiplicity p n :=
  by
  obtain hyx | hyx := le_total y x
  · iterate 2 rw [← int.coe_nat_multiplicity]
    rw [Int.ofNat_sub (Nat.pow_le_pow_of_le_left hyx n)]
    rw [← Int.coe_nat_dvd] at hxy hx
    push_cast at *
    exact int.pow_sub_pow hp hp1 hxy hx n
  ·
    simp only [nat.sub_eq_zero_iff_le.mpr hyx,
      nat.sub_eq_zero_iff_le.mpr (Nat.pow_le_pow_of_le_left hyx n), multiplicity.zero,
      PartENat.top_add]
#align multiplicity.nat.pow_sub_pow multiplicity.Nat.pow_sub_pow

theorem Nat.pow_add_pow {x y : ℕ} (hxy : p ∣ x + y) (hx : ¬p ∣ x) {n : ℕ} (hn : Odd n) :
    multiplicity p (x ^ n + y ^ n) = multiplicity p (x + y) + multiplicity p n :=
  by
  iterate 2 rw [← int.coe_nat_multiplicity]
  rw [← Int.coe_nat_dvd] at hxy hx
  push_cast at *
  exact int.pow_add_pow hp hp1 hxy hx hn
#align multiplicity.nat.pow_add_pow multiplicity.Nat.pow_add_pow

end LiftingTheExponent

end multiplicity

end CommRing

theorem pow_two_pow_sub_pow_two_pow [CommRing R] {x y : R} (n : ℕ) :
    x ^ 2 ^ n - y ^ 2 ^ n = (∏ i in Finset.range n, x ^ 2 ^ i + y ^ 2 ^ i) * (x - y) :=
  by
  induction' n with d hd
  · simp only [pow_zero, pow_one, Finset.range_zero, Finset.prod_empty, one_mul]
  · suffices x ^ 2 ^ d.succ - y ^ 2 ^ d.succ = (x ^ 2 ^ d + y ^ 2 ^ d) * (x ^ 2 ^ d - y ^ 2 ^ d) by
      rw [this, hd, Finset.prod_range_succ, ← mul_assoc, mul_comm (x ^ 2 ^ d + y ^ 2 ^ d)]
    · ring1
#align pow_two_pow_sub_pow_two_pow pow_two_pow_sub_pow_two_pow

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Misc2.lean:80:4: warning: unsupported fin_cases 'using hy' clause -/
theorem Int.sq_mod_four_eq_one_of_odd {x : ℤ} : Odd x → x ^ 2 % 4 = 1 :=
  by
  intro hx
  -- Replace `x : ℤ` with `y : zmod 4`
  replace hx : x % (2 : ℕ) = 1 % (2 : ℕ);
  · rw [Int.odd_iff] at hx
    norm_num [hx]
  calc
    x ^ 2 % (4 : ℕ) = 1 % (4 : ℕ) := _
    _ = 1 := by norm_num

  rw [← ZMod.int_cast_eq_int_cast_iff'] at hx⊢
  push_cast
  rw [← map_intCast (ZMod.castHom (show 2 ∣ 4 by norm_num) (ZMod 2)) x] at hx
  set y : ZMod 4 := x
  change ZMod.castHom _ (ZMod 2) y = _ at hx
  -- Now we can just consider each of the 4 possible values for y
        fin_cases y <;>
        rw [hy] at hx⊢ <;>
      revert hx <;>
    decide
#align int.sq_mod_four_eq_one_of_odd Int.sq_mod_four_eq_one_of_odd

theorem Int.two_pow_two_pow_add_two_pow_two_pow {x y : ℤ} (hx : ¬2 ∣ x) (hxy : 4 ∣ x - y) (i : ℕ) :
    multiplicity 2 (x ^ 2 ^ i + y ^ 2 ^ i) = ↑(1 : ℕ) :=
  by
  have hx_odd : Odd x := by rwa [Int.odd_iff_not_even, even_iff_two_dvd]
  have hxy_even : Even (x - y) := even_iff_two_dvd.mpr (dvd_trans (by norm_num) hxy)
  have hy_odd : Odd y := by simpa using hx_odd.sub_even hxy_even
  refine' multiplicity.eq_coe_iff.mpr ⟨_, _⟩
  · rw [pow_one, ← even_iff_two_dvd]
    exact hx_odd.pow.add_odd hy_odd.pow
  cases' i with i
  · intro hxy'
    have : 2 * 2 ∣ 2 * x := by
      convert dvd_add hxy hxy'
      ring
    have : 2 ∣ x := (mul_dvd_mul_iff_left (by norm_num)).mp this
    contradiction
  suffices ∀ x : ℤ, Odd x → x ^ 2 ^ (i + 1) % 4 = 1
    by
    rw [show (2 ^ (1 + 1) : ℤ) = 4 by norm_num, Int.dvd_iff_emod_eq_zero, Int.add_emod,
      this _ hx_odd, this _ hy_odd]
    norm_num
  intro x hx
  rw [pow_succ, mul_comm, pow_mul, Int.sq_mod_four_eq_one_of_odd hx.pow]
#align int.two_pow_two_pow_add_two_pow_two_pow Int.two_pow_two_pow_add_two_pow_two_pow

theorem Int.two_pow_two_pow_sub_pow_two_pow {x y : ℤ} (n : ℕ) (hxy : 4 ∣ x - y) (hx : ¬2 ∣ x) :
    multiplicity 2 (x ^ 2 ^ n - y ^ 2 ^ n) = multiplicity 2 (x - y) + n := by
  simp only [pow_two_pow_sub_pow_two_pow n, multiplicity.mul Int.prime_two,
    multiplicity.Finset.prod Int.prime_two, add_comm, Nat.cast_one, Finset.sum_const,
    Finset.card_range, nsmul_one, Int.two_pow_two_pow_add_two_pow_two_pow hx hxy]
#align int.two_pow_two_pow_sub_pow_two_pow Int.two_pow_two_pow_sub_pow_two_pow

theorem Int.two_pow_sub_pow' {x y : ℤ} (n : ℕ) (hxy : 4 ∣ x - y) (hx : ¬2 ∣ x) :
    multiplicity 2 (x ^ n - y ^ n) = multiplicity 2 (x - y) + multiplicity (2 : ℤ) n :=
  by
  have hx_odd : Odd x := by rwa [Int.odd_iff_not_even, even_iff_two_dvd]
  have hxy_even : Even (x - y) := even_iff_two_dvd.mpr (dvd_trans (by norm_num) hxy)
  have hy_odd : Odd y := by simpa using hx_odd.sub_even hxy_even
  cases n
  · simp only [pow_zero, sub_self, multiplicity.zero, Int.ofNat_zero, PartENat.add_top]
  have h : (multiplicity 2 n.succ).Dom := multiplicity.finite_nat_iff.mpr ⟨by norm_num, n.succ_pos⟩
  rcases multiplicity.eq_coe_iff.mp (PartENat.natCast_get h).symm with ⟨⟨k, hk⟩, hpn⟩
  rw [hk, pow_mul, pow_mul, multiplicity.pow_sub_pow_of_prime,
    Int.two_pow_two_pow_sub_pow_two_pow _ hxy hx, ← hk, PartENat.natCast_get]
  · norm_cast
  · exact Int.prime_two
  · simpa only [even_iff_two_dvd] using hx_odd.pow.sub_odd hy_odd.pow
  · simpa only [even_iff_two_dvd, Int.odd_iff_not_even] using hx_odd.pow
  erw [Int.coe_nat_dvd]
  -- `erw` to deal with `2 : ℤ` vs `(2 : ℕ) : ℤ`
  contrapose! hpn
  rw [pow_succ']
  conv_rhs => rw [hk]
  exact mul_dvd_mul_left _ hpn
#align int.two_pow_sub_pow' Int.two_pow_sub_pow'

/-- **Lifting the exponent lemma** for `p = 2` -/
theorem Int.two_pow_sub_pow {x y : ℤ} {n : ℕ} (hxy : 2 ∣ x - y) (hx : ¬2 ∣ x) (hn : Even n) :
    multiplicity 2 (x ^ n - y ^ n) + 1 =
      multiplicity 2 (x + y) + multiplicity 2 (x - y) + multiplicity (2 : ℤ) n :=
  by
  have hy : Odd y := by
    rw [← even_iff_two_dvd, ← Int.odd_iff_not_even] at hx
    replace hxy := (@even_neg _ _ (x - y)).mpr (even_iff_two_dvd.mpr hxy)
    convert Even.add_odd hxy hx
    abel
  cases' hn with d hd
  subst hd
  simp only [← two_mul, pow_mul]
  have hxy4 : 4 ∣ x ^ 2 - y ^ 2 :=
    by
    rw [Int.dvd_iff_emod_eq_zero, Int.sub_emod, Int.sq_mod_four_eq_one_of_odd _,
      Int.sq_mod_four_eq_one_of_odd hy]
    · norm_num
    · simp only [Int.odd_iff_not_even, even_iff_two_dvd, hx, not_false_iff]
  rw [Int.two_pow_sub_pow' d hxy4 _, sq_sub_sq, ← Int.ofNat_mul_out, multiplicity.mul Int.prime_two,
    multiplicity.mul Int.prime_two]
  suffices multiplicity (2 : ℤ) ↑(2 : ℕ) = 1 by rw [this, add_comm (1 : PartENat), ← add_assoc]
  · norm_cast
    rw [multiplicity.multiplicity_self _ _]
    · apply Prime.not_unit
      simp only [← Nat.prime_iff, Nat.prime_two]
    · exact two_ne_zero
  · rw [← even_iff_two_dvd, ← Int.odd_iff_not_even]
    apply Odd.pow
    simp only [Int.odd_iff_not_even, even_iff_two_dvd, hx, not_false_iff]
#align int.two_pow_sub_pow Int.two_pow_sub_pow

theorem Nat.two_pow_sub_pow {x y : ℕ} (hxy : 2 ∣ x - y) (hx : ¬2 ∣ x) {n : ℕ} (hn : Even n) :
    multiplicity 2 (x ^ n - y ^ n) + 1 =
      multiplicity 2 (x + y) + multiplicity 2 (x - y) + multiplicity 2 n :=
  by
  obtain hyx | hyx := le_total y x
  · iterate 3 rw [← multiplicity.Int.coe_nat_multiplicity]
    have hxyn : y ^ n ≤ x ^ n := pow_le_pow_of_le_left' hyx _
    simp only [Int.ofNat_sub hyx, Int.ofNat_sub (pow_le_pow_of_le_left' hyx _), Int.ofNat_add,
      Int.coe_nat_pow]
    rw [← Int.coe_nat_dvd] at hx
    rw [← Int.coe_nat_dvd, Int.ofNat_sub hyx] at hxy
    convert Int.two_pow_sub_pow hxy hx hn using 2
    rw [← multiplicity.Int.coe_nat_multiplicity]
    rfl
  ·
    simp only [nat.sub_eq_zero_iff_le.mpr hyx,
      nat.sub_eq_zero_iff_le.mpr (pow_le_pow_of_le_left' hyx n), multiplicity.zero,
      PartENat.top_add, PartENat.add_top]
#align nat.two_pow_sub_pow Nat.two_pow_sub_pow

namespace padicValNat

variable {x y : ℕ}

theorem pow_two_sub_pow (hyx : y < x) (hxy : 2 ∣ x - y) (hx : ¬2 ∣ x) {n : ℕ} (hn : 0 < n)
    (hneven : Even n) :
    padicValNat 2 (x ^ n - y ^ n) + 1 =
      padicValNat 2 (x + y) + padicValNat 2 (x - y) + padicValNat 2 n :=
  by
  simp only [← PartENat.natCast_inj, Nat.cast_add]
  iterate 4 rw [padicValNat_def, PartENat.natCast_get]
  · convert Nat.two_pow_sub_pow hxy hx hneven using 2
  · exact hn
  · exact Nat.sub_pos_of_lt hyx
  · linarith
  · simp only [tsub_pos_iff_lt, pow_lt_pow_of_lt_left hyx (@zero_le' _ y _) hn]
#align padic_val_nat.pow_two_sub_pow padicValNat.pow_two_sub_pow

variable {p : ℕ} [hp : Fact p.Prime] (hp1 : Odd p)

include hp hp1

theorem pow_sub_pow (hyx : y < x) (hxy : p ∣ x - y) (hx : ¬p ∣ x) {n : ℕ} (hn : 0 < n) :
    padicValNat p (x ^ n - y ^ n) = padicValNat p (x - y) + padicValNat p n :=
  by
  rw [← PartENat.natCast_inj, Nat.cast_add]
  iterate 3 rw [padicValNat_def, PartENat.natCast_get]
  · exact multiplicity.Nat.pow_sub_pow hp.out hp1 hxy hx n
  · exact hn
  · exact Nat.sub_pos_of_lt hyx
  · exact Nat.sub_pos_of_lt (Nat.pow_lt_pow_of_lt_left hyx hn)
#align padic_val_nat.pow_sub_pow padicValNat.pow_sub_pow

theorem pow_add_pow (hxy : p ∣ x + y) (hx : ¬p ∣ x) {n : ℕ} (hn : Odd n) :
    padicValNat p (x ^ n + y ^ n) = padicValNat p (x + y) + padicValNat p n :=
  by
  cases y
  · have := dvd_zero p
    contradiction
  rw [← PartENat.natCast_inj, Nat.cast_add]
  iterate 3 rw [padicValNat_def, PartENat.natCast_get]
  · exact multiplicity.Nat.pow_add_pow hp.out hp1 hxy hx hn
  · exact Odd.pos hn
  · simp only [add_pos_iff, Nat.succ_pos', or_true_iff]
  · exact Nat.lt_add_left _ _ _ (pow_pos y.succ_pos _)
#align padic_val_nat.pow_add_pow padicValNat.pow_add_pow

end padicValNat


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

import order.complete_lattice
import category_theory.over
import category_theory.yoneda
import category_theory.limits.shapes.pullbacks
import data.set.lattice

/-!
# Theory of sieves

- For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X`
  which is closed under left-composition.
- The complete lattice structure on sieves is given, as well as the Galois insertion
  given by downward-closing.
- A `sieve X` (functorially) induces a presheaf on `C` together with a monomorphism to
  the yoneda embedding of `X`.

## Tags

sieve, pullback
-/

universes v₁ v₂ v₃ u₁ u₂ u₃
namespace category_theory

open category limits

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D] (F : C ⥤ D)
variables {X Y Z : C} (f : Y ⟶ X)

/-- A set of arrows all with codomain `X`. -/
@[derive complete_lattice]
def presieve (X : C) := Π ⦃Y⦄, set (Y ⟶ X)

namespace presieve

instance : inhabited (presieve X) := ⟨⊤⟩

/--
Given a set of arrows `S` all with codomain `X`, and a set of arrows with codomain `Y` for each
`f : Y ⟶ X` in `S`, produce a set of arrows with codomain `X`:
`{ g ≫ f | (f : Y ⟶ X) ∈ S, (g : Z ⟶ Y) ∈ R f }`.
-/
def bind (S : presieve X) (R : Π ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → presieve Y) :
  presieve X :=
λ Z h, ∃ (Y : C) (g : Z ⟶ Y) (f : Y ⟶ X) (H : S f), R H g ∧ g ≫ f = h

@[simp]
lemma bind_comp {S : presieve X}
  {R : Π ⦃Y : C⦄ ⦃f : Y ⟶ X⦄, S f → presieve Y} {g : Z ⟶ Y} (h₁ : S f) (h₂ : R h₁ g) :
bind S R (g ≫ f) :=
⟨_, _, _, h₁, h₂, rfl⟩

/-- The singleton presieve.  -/
-- Note we can't make this into `has_singleton` because of the out-param.
inductive singleton : presieve X
| mk : singleton f

@[simp] lemma singleton_eq_iff_domain (f g : Y ⟶ X) : singleton f g ↔ f = g :=
begin
  split,
  { rintro ⟨a, rfl⟩,
    refl },
  { rintro rfl,
    apply singleton.mk, }
end

lemma singleton_self : singleton f f := singleton.mk

/--
Pullback a set of arrows with given codomain along a fixed map, by taking the pullback in the
category.
This is not the same as the arrow set of `sieve.pullback`, but there is a relation between them
in `pullback_arrows_comm`.
-/
inductive pullback_arrows [has_pullbacks C] (R : presieve X) :
  presieve Y
| mk (Z : C) (h : Z ⟶ X) : R h → pullback_arrows (pullback.snd : pullback h f ⟶ Y)

lemma pullback_singleton [has_pullbacks C] (g : Z ⟶ X) :
 pullback_arrows f (singleton g) = singleton (pullback.snd : pullback g f ⟶ _) :=
begin
  ext W h,
  split,
  { rintro ⟨W, _, _, _⟩,
    exact singleton.mk },
  { rintro ⟨_⟩,
    exact pullback_arrows.mk Z g singleton.mk }
end

/-- Construct the presieve given by the family of arrows indexed by `ι`. -/
inductive of_arrows {ι : Type*} (Y : ι → C) (f : Π i, Y i ⟶ X) : presieve X
| mk (i : ι) : of_arrows (f i)

lemma of_arrows_punit :
  of_arrows _ (λ _ : punit, f) = singleton f :=
begin
  ext Y g,
  split,
  { rintro ⟨_⟩,
    apply singleton.mk },
  { rintro ⟨_⟩,
    exact of_arrows.mk punit.star },
end

lemma of_arrows_pullback [has_pullbacks C] {ι : Type*}
  (Z : ι → C) (g : Π (i : ι), Z i ⟶ X) :
  of_arrows (λ i, pullback (g i) f) (λ i, pullback.snd) =
    pullback_arrows f (of_arrows Z g) :=
begin
  ext T h,
  split,
  { rintro ⟨hk⟩,
   exact pullback_arrows.mk _ _ (of_arrows.mk hk) },
  { rintro ⟨W, k, hk₁⟩,
    cases hk₁ with i hi,
    apply of_arrows.mk },
end

lemma of_arrows_bind {ι : Type*} (Z : ι → C) (g : Π (i : ι), Z i ⟶ X)
  (j : Π ⦃Y⦄ (f : Y ⟶ X), of_arrows Z g f → Type*)
  (W : Π ⦃Y⦄ (f : Y ⟶ X) H, j f H → C)
  (k : Π ⦃Y⦄ (f : Y ⟶ X) H i, W f H i ⟶ Y) :
  (of_arrows Z g).bind (λ Y f H, of_arrows (W f H) (k f H)) =
    of_arrows (λ (i : Σ i, j _ (of_arrows.mk i)), W (g i.1) _ i.2)
      (λ ij, k (g ij.1) _ ij.2 ≫ g ij.1) :=
begin
  ext Y f,
  split,
  { rintro ⟨_, _, _, ⟨i⟩, ⟨i'⟩, rfl⟩,
    exact of_arrows.mk (sigma.mk _ _) },
  { rintro ⟨i⟩,
    exact bind_comp _ (of_arrows.mk _) (of_arrows.mk _) }
end

/-- Given a presieve on `F(X)`, we can define a presieve on `X` by taking the preimage via `F`. -/
def functor_pullback (R : presieve (F.obj X)) : presieve X := λ _ f, R (F.map f)

@[simp] lemma functor_pullback_mem (R : presieve (F.obj X)) {Y} (f : Y ⟶ X) :
  R.functor_pullback F f ↔ R (F.map f) := iff.rfl

@[simp] lemma functor_pullback_id (R : presieve X) : R.functor_pullback (𝟭 _) = R := rfl

section functor_pushforward
variables {E : Type u₃} [category.{v₃} E] (G : D ⥤ E)

/--
Given a presieve on `X`, we can define a presieve on `F(X)` (which is actually a sieve)
by taking the sieve generated by the image via `F`.
-/
def functor_pushforward (S : presieve X) : presieve (F.obj X) :=
λ Y f, ∃ (Z : C) (g : Z ⟶ X) (h : Y ⟶ F.obj Z), S g ∧ f = h ≫ F.map g

/--
An auxillary definition in order to fix the choice of the preimages between various definitions.
-/
@[nolint has_inhabited_instance]
structure functor_pushforward_structure (S : presieve X) {Y} (f : Y ⟶ F.obj X) :=
(preobj : C) (premap : preobj ⟶ X) (lift : Y ⟶ F.obj preobj)
(cover : S premap) (fac : f = lift ≫ F.map premap)

/-- The fixed choice of a preimage. -/
noncomputable def get_functor_pushforward_structure {F : C ⥤ D} {S : presieve X} {Y : D}
  {f : Y ⟶ F.obj X} (h : S.functor_pushforward F f) : functor_pushforward_structure F S f :=
by { choose Z f' g h₁ h using h, exact ⟨Z, f', g, h₁, h⟩ }

lemma functor_pushforward_comp (R : presieve X) :
  R.functor_pushforward (F ⋙ G) = (R.functor_pushforward F).functor_pushforward G :=
begin
  ext x f,
  split,
  { rintro ⟨X, f₁, g₁, h₁, rfl⟩, exact ⟨F.obj X, F.map f₁, g₁, ⟨X, f₁, 𝟙 _, h₁, by simp⟩, rfl⟩ },
  { rintro ⟨X, f₁, g₁, ⟨X', f₂, g₂, h₁, rfl⟩, rfl⟩, use ⟨X', f₂, g₁ ≫ G.map g₂, h₁, by simp⟩ }
end

lemma image_mem_functor_pushforward (R : presieve X) {f : Y ⟶ X} (h : R f) :
  R.functor_pushforward F (F.map f) := ⟨Y, f, 𝟙 _, h, by simp⟩

end functor_pushforward
end presieve

/--
For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X` which is closed under
left-composition.
-/
structure sieve {C : Type u₁} [category.{v₁} C] (X : C) :=
(arrows : presieve X)
(downward_closed' : ∀ {Y Z f} (hf : arrows f) (g : Z ⟶ Y), arrows (g ≫ f))

namespace sieve

instance : has_coe_to_fun (sieve X) (λ _, presieve X) := ⟨sieve.arrows⟩

initialize_simps_projections sieve (arrows → apply)

variables {S R : sieve X}

@[simp, priority 100] lemma downward_closed (S : sieve X) {f : Y ⟶ X} (hf : S f)
  (g : Z ⟶ Y) : S (g ≫ f) :=
S.downward_closed' hf g

lemma arrows_ext : Π {R S : sieve X}, R.arrows = S.arrows → R = S
| ⟨Ra, _⟩ ⟨Sa, _⟩ rfl := rfl

@[ext]
protected lemma ext {R S : sieve X}
  (h : ∀ ⦃Y⦄ (f : Y ⟶ X), R f ↔ S f) :
  R = S :=
arrows_ext $ funext $ λ x, funext $ λ f, propext $ h f

protected lemma ext_iff {R S : sieve X} :
  R = S ↔ (∀ ⦃Y⦄ (f : Y ⟶ X), R f ↔ S f) :=
⟨λ h Y f, h ▸ iff.rfl, sieve.ext⟩

open lattice

/-- The supremum of a collection of sieves: the union of them all. -/
protected def Sup (𝒮 : set (sieve X)) : (sieve X) :=
{ arrows := λ Y, {f | ∃ S ∈ 𝒮, sieve.arrows S f},
  downward_closed' := λ Y Z f, by { rintro ⟨S, hS, hf⟩ g, exact ⟨S, hS, S.downward_closed hf _⟩ } }

/-- The infimum of a collection of sieves: the intersection of them all. -/
protected def Inf (𝒮 : set (sieve X)) : (sieve X) :=
{ arrows := λ Y, {f | ∀ S ∈ 𝒮, sieve.arrows S f},
  downward_closed' := λ Y Z f hf g S H, S.downward_closed (hf S H) g }

/-- The union of two sieves is a sieve. -/
protected def union (S R : sieve X) : sieve X :=
{ arrows := λ Y f, S f ∨ R f,
  downward_closed' := by { rintros Y Z f (h | h) g; simp [h] } }

/-- The intersection of two sieves is a sieve. -/
protected def inter (S R : sieve X) : sieve X :=
{ arrows := λ Y f, S f ∧ R f,
  downward_closed' := by { rintros Y Z f ⟨h₁, h₂⟩ g, simp [h₁, h₂] } }

/--
Sieves on an object `X` form a complete lattice.
We generate this directly rather than using the galois insertion for nicer definitional properties.
-/
instance : complete_lattice (sieve X) :=
{ le           := λ S R, ∀ ⦃Y⦄ (f : Y ⟶ X), S f → R f,
  le_refl      := λ S f q, id,
  le_trans     := λ S₁ S₂ S₃ S₁₂ S₂₃ Y f h, S₂₃ _ (S₁₂ _ h),
  le_antisymm  := λ S R p q, sieve.ext (λ Y f, ⟨p _, q _⟩),
  top          := { arrows := λ _, set.univ, downward_closed' := λ Y Z f g h, ⟨⟩ },
  bot          := { arrows := λ _, ∅, downward_closed' := λ _ _ _ p _, false.elim p },
  sup          := sieve.union,
  inf          := sieve.inter,
  Sup          := sieve.Sup,
  Inf          := sieve.Inf,
  le_Sup       := λ 𝒮 S hS Y f hf, ⟨S, hS, hf⟩,
  Sup_le       := λ ℰ S hS Y f, by { rintro ⟨R, hR, hf⟩, apply hS R hR _ hf },
  Inf_le       := λ _ _ hS _ _ h, h _ hS,
  le_Inf       := λ _ _ hS _ _ hf _ hR, hS _ hR _ hf,
  le_sup_left  := λ _ _ _ _, or.inl,
  le_sup_right := λ _ _ _ _, or.inr,
  sup_le       := λ _ _ _ a b _ _ hf, hf.elim (a _) (b _),
  inf_le_left  := λ _ _ _ _, and.left,
  inf_le_right := λ _ _ _ _, and.right,
  le_inf       := λ _ _ _ p q _ _ z, ⟨p _ z, q _ z⟩,
  le_top       := λ _ _ _ _, trivial,
  bot_le       := λ _ _ _, false.elim }

/-- The maximal sieve always exists. -/
instance sieve_inhabited : inhabited (sieve X) := ⟨⊤⟩

@[simp]
lemma Inf_apply {Ss : set (sieve X)} {Y} (f : Y ⟶ X) :
  Inf Ss f ↔ ∀ (S : sieve X) (H : S ∈ Ss), S f :=
iff.rfl

@[simp]
lemma Sup_apply {Ss : set (sieve X)} {Y} (f : Y ⟶ X) :
  Sup Ss f ↔ ∃ (S : sieve X) (H : S ∈ Ss), S f :=
iff.rfl

@[simp]
lemma inter_apply {R S : sieve X} {Y} (f : Y ⟶ X) :
  (R ⊓ S) f ↔ R f ∧ S f :=
iff.rfl

@[simp]
lemma union_apply {R S : sieve X} {Y} (f : Y ⟶ X) :
  (R ⊔ S) f ↔ R f ∨ S f :=
iff.rfl

@[simp]
lemma top_apply (f : Y ⟶ X) : (⊤ : sieve X) f := trivial

/-- Generate the smallest sieve containing the given set of arrows. -/
@[simps]
def generate (R : presieve X) : sieve X :=
{ arrows := λ Z f, ∃ Y (h : Z ⟶ Y) (g : Y ⟶ X), R g ∧ h ≫ g = f,
  downward_closed' :=
  begin
    rintro Y Z _ ⟨W, g, f, hf, rfl⟩ h,
    exact ⟨_, h ≫ g, _, hf, by simp⟩,
  end }

/--
Given a presieve on `X`, and a sieve on each domain of an arrow in the presieve, we can bind to
produce a sieve on `X`.
-/
@[simps]
def bind (S : presieve X) (R : Π ⦃Y⦄ ⦃f : Y ⟶ X⦄, S f → sieve Y) : sieve X :=
{ arrows := S.bind (λ Y f h, R h),
  downward_closed' :=
  begin
    rintro Y Z f ⟨W, f, h, hh, hf, rfl⟩ g,
    exact ⟨_, g ≫ f, _, hh, by simp [hf]⟩,
  end }

open order lattice

lemma sets_iff_generate (R : presieve X) (S : sieve X) :
  generate R ≤ S ↔ R ≤ S :=
⟨λ H Y g hg, H _ ⟨_, 𝟙 _, _, hg, category.id_comp _⟩,
 λ ss Y f,
  begin
    rintro ⟨Z, f, g, hg, rfl⟩,
    exact S.downward_closed (ss Z hg) f,
  end⟩

/-- Show that there is a galois insertion (generate, set_over). -/
def gi_generate : galois_insertion (generate : presieve X → sieve X) arrows :=
{ gc := sets_iff_generate,
  choice := λ 𝒢 _, generate 𝒢,
  choice_eq := λ _ _, rfl,
  le_l_u := λ S Y f hf, ⟨_, 𝟙 _, _, hf, category.id_comp _⟩ }

lemma le_generate (R : presieve X) : R ≤ generate R :=
gi_generate.gc.le_u_l R

@[simp] lemma generate_sieve (S : sieve X) : generate S = S :=
gi_generate.l_u_eq S

/-- If the identity arrow is in a sieve, the sieve is maximal. -/
lemma id_mem_iff_eq_top : S (𝟙 X) ↔ S = ⊤ :=
⟨λ h, top_unique $ λ Y f _, by simpa using downward_closed _ h f,
 λ h, h.symm ▸ trivial⟩

/-- If an arrow set contains a split epi, it generates the maximal sieve. -/
lemma generate_of_contains_split_epi {R : presieve X} (f : Y ⟶ X) [split_epi f]
  (hf : R f) : generate R = ⊤ :=
begin
  rw ← id_mem_iff_eq_top,
  exact ⟨_, section_ f, f, hf, by simp⟩,
end

@[simp]
lemma generate_of_singleton_split_epi (f : Y ⟶ X) [split_epi f] :
  generate (presieve.singleton f) = ⊤ :=
generate_of_contains_split_epi f (presieve.singleton_self _)

@[simp]
lemma generate_top : generate (⊤ : presieve X) = ⊤ :=
generate_of_contains_split_epi (𝟙 _) ⟨⟩

/-- Given a morphism `h : Y ⟶ X`, send a sieve S on X to a sieve on Y
    as the inverse image of S with `_ ≫ h`.
    That is, `sieve.pullback S h := (≫ h) '⁻¹ S`. -/
@[simps]
def pullback (h : Y ⟶ X) (S : sieve X) : sieve Y :=
{ arrows := λ Y sl, S (sl ≫ h),
  downward_closed' := λ Z W f g h, by simp [g] }

@[simp]
lemma pullback_id : S.pullback (𝟙 _) = S :=
by simp [sieve.ext_iff]

@[simp]
lemma pullback_top {f : Y ⟶ X} : (⊤ : sieve X).pullback f = ⊤ :=
top_unique (λ _ g, id)

lemma pullback_comp {f : Y ⟶ X} {g : Z ⟶ Y} (S : sieve X) :
  S.pullback (g ≫ f) = (S.pullback f).pullback g :=
by simp [sieve.ext_iff]

@[simp]
lemma pullback_inter {f : Y ⟶ X} (S R : sieve X) :
 (S ⊓ R).pullback f = S.pullback f ⊓ R.pullback f :=
by simp [sieve.ext_iff]

lemma pullback_eq_top_iff_mem (f : Y ⟶ X) : S f ↔ S.pullback f = ⊤ :=
by rw [← id_mem_iff_eq_top, pullback_apply, category.id_comp]

lemma pullback_eq_top_of_mem (S : sieve X) {f : Y ⟶ X} : S f → S.pullback f = ⊤ :=
(pullback_eq_top_iff_mem f).1

/--
Push a sieve `R` on `Y` forward along an arrow `f : Y ⟶ X`: `gf : Z ⟶ X` is in the sieve if `gf`
factors through some `g : Z ⟶ Y` which is in `R`.
-/
@[simps]
def pushforward (f : Y ⟶ X) (R : sieve Y) : sieve X :=
{ arrows := λ Z gf, ∃ g, g ≫ f = gf ∧ R g,
  downward_closed' := λ Z₁ Z₂ g ⟨j, k, z⟩ h, ⟨h ≫ j, by simp [k], by simp [z]⟩ }

lemma pushforward_apply_comp {R : sieve Y} {Z : C} {g : Z ⟶ Y} (hg : R g) (f : Y ⟶ X) :
  R.pushforward f (g ≫ f) :=
⟨g, rfl, hg⟩

lemma pushforward_comp {f : Y ⟶ X} {g : Z ⟶ Y} (R : sieve Z) :
  R.pushforward (g ≫ f) = (R.pushforward g).pushforward f :=
sieve.ext (λ W h, ⟨λ ⟨f₁, hq, hf₁⟩, ⟨f₁ ≫ g, by simpa, f₁, rfl, hf₁⟩,
                   λ ⟨y, hy, z, hR, hz⟩, ⟨z, by rwa reassoc_of hR, hz⟩⟩)

lemma galois_connection (f : Y ⟶ X) : galois_connection (sieve.pushforward f) (sieve.pullback f) :=
λ S R, ⟨λ hR Z g hg, hR _ ⟨g, rfl, hg⟩, λ hS Z g ⟨h, hg, hh⟩, hg ▸ hS h hh⟩

lemma pullback_monotone (f : Y ⟶ X) : monotone (sieve.pullback f) :=
(galois_connection f).monotone_u

lemma pushforward_monotone (f : Y ⟶ X) : monotone (sieve.pushforward f) :=
(galois_connection f).monotone_l

lemma le_pushforward_pullback (f : Y ⟶ X) (R : sieve Y) :
  R ≤ (R.pushforward f).pullback f :=
(galois_connection f).le_u_l _

lemma pullback_pushforward_le (f : Y ⟶ X) (R : sieve X) :
  (R.pullback f).pushforward f ≤ R :=
(galois_connection f).l_u_le _

lemma pushforward_union {f : Y ⟶ X} (S R : sieve Y) :
  (S ⊔ R).pushforward f = S.pushforward f ⊔ R.pushforward f :=
(galois_connection f).l_sup

lemma pushforward_le_bind_of_mem (S : presieve X)
  (R : Π ⦃Y : C⦄ ⦃f : Y ⟶ X⦄, S f → sieve Y) (f : Y ⟶ X) (h : S f) :
  (R h).pushforward f ≤ bind S R :=
begin
  rintro Z _ ⟨g, rfl, hg⟩,
  exact ⟨_, g, f, h, hg, rfl⟩,
end

lemma le_pullback_bind (S : presieve X) (R : Π ⦃Y : C⦄ ⦃f : Y ⟶ X⦄, S f → sieve Y)
  (f : Y ⟶ X) (h : S f) :
  R h ≤ (bind S R).pullback f :=
begin
  rw ← galois_connection f,
  apply pushforward_le_bind_of_mem,
end

/-- If `f` is a monomorphism, the pushforward-pullback adjunction on sieves is coreflective. -/
def galois_coinsertion_of_mono (f : Y ⟶ X) [mono f] :
  galois_coinsertion (sieve.pushforward f) (sieve.pullback f) :=
begin
  apply (galois_connection f).to_galois_coinsertion,
  rintros S Z g ⟨g₁, hf, hg₁⟩,
  rw cancel_mono f at hf,
  rwa ← hf,
end

/-- If `f` is a split epi, the pushforward-pullback adjunction on sieves is reflective. -/
def galois_insertion_of_split_epi (f : Y ⟶ X) [split_epi f] :
  galois_insertion (sieve.pushforward f) (sieve.pullback f) :=
begin
  apply (galois_connection f).to_galois_insertion,
  intros S Z g hg,
  refine ⟨g ≫ section_ f, by simpa⟩,
end

lemma pullback_arrows_comm [has_pullbacks C] {X Y : C} (f : Y ⟶ X)
  (R : presieve X) :
  sieve.generate (R.pullback_arrows f) = (sieve.generate R).pullback f :=
begin
  ext Z g,
  split,
  { rintro ⟨_, h, k, hk, rfl⟩,
    cases hk with W g hg,
    change (sieve.generate R).pullback f (h ≫ pullback.snd),
    rw [sieve.pullback_apply, assoc, ← pullback.condition, ← assoc],
    exact sieve.downward_closed _ (sieve.le_generate R W hg) (h ≫ pullback.fst)},
  { rintro ⟨W, h, k, hk, comm⟩,
    exact ⟨_, _, _, presieve.pullback_arrows.mk _ _ hk, pullback.lift_snd _ _ comm⟩ },
end

section functor
variables {E : Type u₃} [category.{v₃} E] (G : D ⥤ E)

/--
If `R` is a sieve, then the `category_theory.presieve.functor_pullback` of `R` is actually a sieve.
-/
@[simps] def functor_pullback (R : sieve (F.obj X)) : sieve X :=
{ arrows := presieve.functor_pullback F R,
  downward_closed' := λ _ _ f hf g,
  begin
    unfold presieve.functor_pullback,
    rw F.map_comp,
    exact R.downward_closed hf (F.map g),
  end }

@[simp] lemma functor_pullback_arrows (R : sieve (F.obj X)) :
  (R.functor_pullback F).arrows = R.arrows.functor_pullback F := rfl

@[simp] lemma functor_pullback_id (R : sieve X) : R.functor_pullback (𝟭 _) = R :=
by { ext, refl }

lemma functor_pullback_comp (R : sieve ((F ⋙ G).obj X)) :
  R.functor_pullback (F ⋙ G) = (R.functor_pullback G).functor_pullback F := by { ext, refl }

lemma functor_pushforward_extend_eq {R : presieve X} :
  (generate R).arrows.functor_pushforward F = R.functor_pushforward F :=
begin
  ext Y f, split,
  { rintro ⟨X', g, f', ⟨X'', g', f'', h₁, rfl⟩, rfl⟩,
    exact ⟨X'', f'', f' ≫ F.map g', h₁, by simp⟩ },
  { rintro ⟨X', g, f', h₁, h₂⟩, exact ⟨X', g, f', le_generate R _ h₁, h₂⟩ }
end

/-- The sieve generated by the image of `R` under `F`. -/
@[simps] def functor_pushforward (R : sieve X) : sieve (F.obj X) :=
{ arrows := R.arrows.functor_pushforward F,
  downward_closed' := λ Y Z f h g, by
  { obtain ⟨X, α, β, hα, rfl⟩ := h,
    exact ⟨X, α, g ≫ β, hα, by simp⟩ } }

@[simp] lemma functor_pushforward_id (R : sieve X) :
  R.functor_pushforward (𝟭 _) = R :=
begin
  ext X f,
  split,
  { intro hf,
    obtain ⟨X, g, h, hg, rfl⟩ := hf,
    exact R.downward_closed hg h, },
  { intro hf,
    exact ⟨X, f, 𝟙 _, hf, by simp⟩ }
end

lemma functor_pushforward_comp (R : sieve X) :
  R.functor_pushforward (F ⋙ G) = (R.functor_pushforward F).functor_pushforward G :=
by { ext, simpa [R.arrows.functor_pushforward_comp F G] }

lemma functor_galois_connection (X : C) :
  _root_.galois_connection
    (sieve.functor_pushforward F : sieve X → sieve (F.obj X))
    (sieve.functor_pullback F) :=
begin
  intros R S,
  split,
  { intros hle X f hf,
    apply hle,
    refine ⟨X, f, 𝟙 _, hf, _⟩,
    rw category.id_comp, },
  { rintros hle Y f ⟨X, g, h, hg, rfl⟩,
    apply sieve.downward_closed S,
    exact hle g hg, }
end

lemma functor_pullback_monotone (X : C) :
  monotone (sieve.functor_pullback F : sieve (F.obj X) → sieve X) :=
(functor_galois_connection F X).monotone_u

lemma functor_pushforward_monotone (X : C) :
  monotone (sieve.functor_pushforward F : sieve X → sieve (F.obj X)) :=
(functor_galois_connection F X).monotone_l

lemma le_functor_pushforward_pullback (R : sieve X) :
  R ≤ (R.functor_pushforward F).functor_pullback F :=
(functor_galois_connection F X).le_u_l _

lemma functor_pullback_pushforward_le (R : sieve (F.obj X)) :
  (R.functor_pullback F).functor_pushforward F ≤ R :=
(functor_galois_connection F X).l_u_le _

lemma functor_pushforward_union (S R : sieve X) :
  (S ⊔ R).functor_pushforward F = S.functor_pushforward F ⊔ R.functor_pushforward F :=
(functor_galois_connection F X).l_sup

lemma functor_pullback_union (S R : sieve (F.obj X)) :
  (S ⊔ R).functor_pullback F = S.functor_pullback F ⊔ R.functor_pullback F := rfl

lemma functor_pullback_inter (S R : sieve (F.obj X)) :
  (S ⊓ R).functor_pullback F = S.functor_pullback F ⊓ R.functor_pullback F := rfl

@[simp] lemma functor_pushforward_bot (F : C ⥤ D) (X : C) :
  (⊥ : sieve X).functor_pushforward F = ⊥ := (functor_galois_connection F X).l_bot

@[simp] lemma functor_pushforward_top (F : C ⥤ D) (X : C) :
  (⊤ : sieve X).functor_pushforward F = ⊤ :=
  begin
    refine (generate_sieve _).symm.trans _,
    apply generate_of_contains_split_epi (𝟙 (F.obj X)),
    refine ⟨X, 𝟙 _, 𝟙 _, trivial, by simp⟩
  end

@[simp] lemma functor_pullback_bot (F : C ⥤ D) (X : C) :
  (⊥ : sieve (F.obj X)).functor_pullback F = ⊥ := rfl

@[simp] lemma functor_pullback_top (F : C ⥤ D) (X : C) :
  (⊤ : sieve (F.obj X)).functor_pullback F = ⊤ := rfl

lemma image_mem_functor_pushforward (R : sieve X) {V} {f : V ⟶ X} (h : R f) :
  R.functor_pushforward F (F.map f) := ⟨V, f, 𝟙 _, h, by simp⟩

/-- When `F` is essentially surjective and full, the galois connection is a galois insertion. -/
def ess_surj_full_functor_galois_insertion [ess_surj F] [full F] (X : C) :
  galois_insertion
    (sieve.functor_pushforward F : sieve X → sieve (F.obj X))
    (sieve.functor_pullback F) :=
begin
  apply (functor_galois_connection F X).to_galois_insertion,
  intros S Y f hf,
  refine ⟨_, F.preimage ((F.obj_obj_preimage_iso Y).hom ≫ f), (F.obj_obj_preimage_iso Y).inv, _⟩,
  simpa using S.downward_closed hf _,
end

/-- When `F` is fully faithful, the galois connection is a galois coinsertion. -/
def fully_faithful_functor_galois_coinsertion [full F] [faithful F] (X : C) :
  galois_coinsertion
    (sieve.functor_pushforward F : sieve X → sieve (F.obj X))
    (sieve.functor_pullback F) :=
begin
  apply (functor_galois_connection F X).to_galois_coinsertion,
  rintros S Y f ⟨Z, g, h, h₁, h₂⟩,
  rw [←F.image_preimage h, ←F.map_comp] at h₂,
  rw F.map_injective h₂,
  exact S.downward_closed h₁ _,
end

end functor

/-- A sieve induces a presheaf. -/
@[simps]
def functor (S : sieve X) : Cᵒᵖ ⥤ Type v₁ :=
{ obj := λ Y, {g : Y.unop ⟶ X // S g},
  map := λ Y Z f g, ⟨f.unop ≫ g.1, downward_closed _ g.2 _⟩ }

/--
If a sieve S is contained in a sieve T, then we have a morphism of presheaves on their induced
presheaves.
-/
@[simps]
def nat_trans_of_le {S T : sieve X} (h : S ≤ T) : S.functor ⟶ T.functor :=
{ app := λ Y f, ⟨f.1, h _ f.2⟩ }.

/-- The natural inclusion from the functor induced by a sieve to the yoneda embedding. -/
@[simps]
def functor_inclusion (S : sieve X) : S.functor ⟶ yoneda.obj X :=
{ app := λ Y f, f.1 }.

lemma nat_trans_of_le_comm {S T : sieve X} (h : S ≤ T) :
  nat_trans_of_le h ≫ functor_inclusion _ = functor_inclusion _ :=
rfl

/-- The presheaf induced by a sieve is a subobject of the yoneda embedding. -/
instance functor_inclusion_is_mono : mono S.functor_inclusion :=
⟨λ Z f g h, by { ext Y y, apply congr_fun (nat_trans.congr_app h Y) y }⟩

/--
A natural transformation to a representable functor induces a sieve. This is the left inverse of
`functor_inclusion`, shown in `sieve_of_functor_inclusion`.
-/
-- TODO: Show that when `f` is mono, this is right inverse to `functor_inclusion` up to isomorphism.
@[simps]
def sieve_of_subfunctor {R} (f : R ⟶ yoneda.obj X) : sieve X :=
{ arrows := λ Y g, ∃ t, f.app (opposite.op Y) t = g,
  downward_closed' := λ Y Z _,
  begin
    rintro ⟨t, rfl⟩ g,
    refine ⟨R.map g.op t, _⟩,
    rw functor_to_types.naturality _ _ f,
    simp,
  end }

lemma sieve_of_subfunctor_functor_inclusion : sieve_of_subfunctor S.functor_inclusion = S :=
begin
  ext,
  simp only [functor_inclusion_app, sieve_of_subfunctor_apply, subtype.val_eq_coe],
  split,
  { rintro ⟨⟨f, hf⟩, rfl⟩,
    exact hf },
  { intro hf,
    exact ⟨⟨_, hf⟩, rfl⟩ }
end

instance functor_inclusion_top_is_iso : is_iso ((⊤ : sieve X).functor_inclusion) :=
⟨⟨{ app := λ Y a, ⟨a, ⟨⟩⟩ }, by tidy⟩⟩

end sieve
end category_theory


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.Frm

/-!
# The category of locales

This file defines `Locale`, the category of locales. This is the opposite of the category of frames.
-/

universes u

open category_theory opposite order topological_space

/-- The category of locales. -/
@[derive large_category] def Locale := Frmᵒᵖ

namespace Locale

instance : has_coe_to_sort Locale Type* := ⟨λ X, X.unop⟩
instance (X : Locale) : frame X := X.unop.str

/-- Construct a bundled `Locale` from a `frame`. -/
def of (α : Type*) [frame α] : Locale := op $ Frm.of α

@[simp] lemma coe_of (α : Type*) [frame α] : ↥(of α) = α := rfl

instance : inhabited Locale := ⟨of punit⟩

end Locale

/-- The forgetful functor from `Top` to `Locale` which forgets that the space has "enough points".
-/
@[simps] def Top_to_Locale : Top ⥤ Locale := Top_op_to_Frame.right_op

-- Note, `CompHaus` is too strong. We only need `t0_space`.
instance CompHaus_to_Locale.faithful : faithful (CompHaus_to_Top ⋙ Top_to_Locale.{u}) :=
⟨λ X Y f g h, by { dsimp at h, exact opens.comap_injective (quiver.hom.op_inj h) }⟩


-- Leibniz equality: two objects are equal if they satisfy the
-- same properties

universe u

def leibnizEq : ∀ { a : Type u }, (x y : a) → Type (u + 1)
  | a, x, y => ∀ {P : a → Type u}, P x → P y

macro_rules | `($x ·= $y)  => `(leibnizEq $x $y)

theorem LeiEq.refl : ∀ {x : Type u }, x ·= x := λx => x

theorem LeiEq.trans : ∀ { x y z : Type u }, x ·= y → y ·= z → x ·= z
  | _, _, _, h1, h2 => λx => h2 (h1 x)