/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/

import category_theory.sites.spaces
import topology.sheaves.sheaf
import category_theory.sites.dense_subsite

/-!

# The sheaf condition in terms of sites.

The theory of sheaves on sites is developed independently from sheaves on spaces in
`category_theory/sites`. In this file, we connect the two theories: We show that for a topological
space `X`, a presheaf `F : (opens X)ᵒᵖ ⥤ C` is a sheaf on the site `opens X` if and only if it is
a sheaf on `X` in the usual sense.

Recall that a presheaf `F : (opens X)ᵒᵖ ⥤ C` is called a *sheaf* on the space `X`, if for every
family of opens `U : ι → opens X`, the object `F.obj (op (supr U))` is the limit of some fork
diagram. On the other hand, `F` is called a *sheaf* on the site `opens X`, if for every open set
`U : opens X` and every presieve `R : presieve U`, the object `F.obj (op U)` is the limit of a
very similar fork diagram. In this file, we will construct the two functions `covering_of_presieve`
and `presieve_of_covering`, which translate between the two concepts. We then prove a bunch of
naturality lemmas relating the two fork diagrams to each other.

## Main statements
* `is_sheaf_sites_iff_is_sheaf_spaces`. A presheaf `F : (opens X)ᵒᵖ ⥤ C` is a sheaf on the site
  `opens X` if and only if it is a sheaf on the space `X`.
* `Sheaf_sites_eq_sheaf_spaces`. The type of sheaves on the site `opens X` is *equal* to the type
  of sheaves on the space `X`.

-/

noncomputable theory

universes u v w

namespace Top.presheaf

open category_theory topological_space Top category_theory.limits opposite
open Top.presheaf.sheaf_condition_equalizer_products

variables {C : Type u} [category.{v} C] [has_products.{v} C]
variables {X : Top.{v}} (F : presheaf C X)

/--
Given a presieve `R` on `U`, we obtain a covering family of open sets in `X`, by taking as index
type the type of dependent pairs `(V, f)`, where `f : V ⟶ U` is in `R`.
-/
def covering_of_presieve (U : opens X) (R : presieve U) : (Σ V, {f : V ⟶ U // R f}) → opens X :=
λ f, f.1

@[simp]
lemma covering_of_presieve_apply (U : opens X) (R : presieve U) (f : Σ V, {f : V ⟶ U // R f}) :
  covering_of_presieve U R f = f.1 := rfl

namespace covering_of_presieve

variables (U : opens X) (R : presieve U)

/-!
In this section, we will relate two different fork diagrams to each other.

The first one is the defining fork diagram for the sheaf condition in terms of sites, applied to
the presieve `R`. It will henceforth be called the _sites diagram_. Its objects are called
`presheaf.first_obj` and `presheaf.second_obj` and its morphisms are `presheaf.first_map` and
`presheaf.second_obj`. The fork map into this diagram is called `presheaf.fork_map`.

The second one is the defining fork diagram for the sheaf condition in terms of spaces, applied to
the family of opens `covering_of_presieve U R`. It will henceforth be called the _spaces diagram_.
Its objects are called `pi_opens` and `pi_inters` and its morphisms are `left_res` and `right_res`.
The fork map into this diagram is called `res`.

-/

/--
If `R` is a presieve in the grothendieck topology on `opens X`, the covering family associated to
`R` really is _covering_, i.e. the union of all open sets equals `U`.
-/
lemma supr_eq_of_mem_grothendieck (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  supr (covering_of_presieve U R) = U :=
begin
  apply le_antisymm,
  { refine supr_le _,
    intro f,
    exact f.2.1.le, },
  intros x hxU,
  rw [opens.mem_coe, opens.mem_supr],
  obtain ⟨V, iVU, ⟨W, iVW, iWU, hiWU, -⟩, hxV⟩ := hR x hxU,
  exact ⟨⟨W, ⟨iWU, hiWU⟩⟩, iVW.le hxV⟩,
end

/--
The first object in the sites diagram is isomorphic to the first object in the spaces diagram.
Actually, they are even definitionally equal, but it is convenient to give this isomorphism a name.
-/
def first_obj_iso_pi_opens : presheaf.first_obj R F ≅ pi_opens F (covering_of_presieve U R) :=
eq_to_iso rfl

/--
The isomorphism `first_obj_iso_pi_opens` is compatible with canonical projections out of the
product.
-/
lemma first_obj_iso_pi_opens_π (f : Σ V, {f : V ⟶ U // R f}) :
  (first_obj_iso_pi_opens F U R).hom ≫ pi.π _ f = pi.π _ f :=
category.id_comp _

/--
The second object in the sites diagram is isomorphic to the second object in the spaces diagram.
-/
def second_obj_iso_pi_inters :
  presheaf.second_obj R F ≅ pi_inters F (covering_of_presieve U R) :=
has_limit.iso_of_nat_iso $ discrete.nat_iso $ λ i,
  F.map_iso (eq_to_iso (complete_lattice.pullback_eq_inf _ _).symm).op

/--
The isomorphism `second_obj_iso_pi_inters` is compatible with canonical projections out of the
product. Here, we have to insert an `eq_to_hom` arrow to pass from
`F.obj (op (pullback f.2.1 g.2.1))` to `F.obj (op (f.1 ⊓ g.1))`.
-/
lemma second_obj_iso_pi_inters_π (f g : Σ V, {f : V ⟶ U // R f}) :
  (second_obj_iso_pi_inters F U R).hom ≫ pi.π _ (f, g) =
  pi.π _ (f, g) ≫ F.map (eq_to_hom (complete_lattice.pullback_eq_inf f.2.1 g.2.1).symm).op :=
begin
  dunfold second_obj_iso_pi_inters,
  rw has_limit.iso_of_nat_iso_hom_π,
  refl,
end

/--
Composing the fork map of the sites diagram with the isomorphism `first_obj_iso_pi_opens` is the
same as the fork map of the spaces diagram (modulo an `eq_to_hom` arrow).
-/
lemma fork_map_comp_first_obj_iso_pi_opens_eq
  (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  presheaf.fork_map R F ≫ (first_obj_iso_pi_opens F U R).hom =
  F.map (eq_to_hom (supr_eq_of_mem_grothendieck U R hR)).op ≫ res F (covering_of_presieve U R) :=
begin
  ext ⟨f⟩,
  rw [category.assoc, category.assoc, first_obj_iso_pi_opens_π],
  dunfold presheaf.fork_map res,
  rw [limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app, ← F.map_comp],
  congr,
end

/--
First naturality condition. Under the isomorphisms `first_obj_iso_pi_opens` and
`second_obj_iso_pi_inters`, the map `presheaf.first_map` corresponds to `left_res`.
-/
lemma first_obj_iso_comp_left_res_eq :
  presheaf.first_map R F ≫ (second_obj_iso_pi_inters F U R).hom =
  (first_obj_iso_pi_opens F U R).hom ≫ left_res F (covering_of_presieve U R) :=
begin
  ext ⟨f, g⟩,
  rw [category.assoc, category.assoc, second_obj_iso_pi_inters_π],
  dunfold left_res presheaf.first_map,
  rw [limit.lift_π, fan.mk_π_app, limit.lift_π_assoc, fan.mk_π_app, ← category.assoc],
  erw [first_obj_iso_pi_opens_π, category.assoc, ← F.map_comp],
  refl,
end

/--
Second naturality condition. Under the isomorphisms `first_obj_iso_pi_opens` and
`second_obj_iso_pi_inters`, the map `presheaf.second_map` corresponds to `right_res`.
-/
lemma first_obj_iso_comp_right_res_eq :
  presheaf.second_map R F ≫ (second_obj_iso_pi_inters F U R).hom =
  (first_obj_iso_pi_opens F U R).hom ≫ right_res F (covering_of_presieve U R) :=
begin
  ext ⟨f, g⟩,
  dunfold right_res presheaf.second_map,
  rw [category.assoc, category.assoc, second_obj_iso_pi_inters_π, limit.lift_π, fan.mk_π_app,
    limit.lift_π_assoc, fan.mk_π_app, ← category.assoc, first_obj_iso_pi_opens_π, category.assoc,
    ← F.map_comp],
  refl,
end

/-- The natural isomorphism between the sites diagram and the spaces diagram. -/
@[simps]
def diagram_nat_iso : parallel_pair (presheaf.first_map R F) (presheaf.second_map R F) ≅
  diagram F (covering_of_presieve U R) :=
nat_iso.of_components
  (λ i, walking_parallel_pair.cases_on i
    (first_obj_iso_pi_opens F U R)
    (second_obj_iso_pi_inters F U R)) $
begin
  intros i j f,
  cases i,
  { cases j,
    { cases f, simp },
    { cases f,
      { exact first_obj_iso_comp_left_res_eq F U R, },
      { exact first_obj_iso_comp_right_res_eq F U R, } } },
  { cases j,
    { cases f, },
    { cases f, simp } },
end

/--
Postcomposing the given fork of the _sites_ diagram with the natural isomorphism between the
diagrams gives us a fork of the _spaces_ diagram. We construct a morphism from this fork to the
given fork of the _spaces_ diagram. This is shown to be an isomorphism below.
-/
@[simps]
def postcompose_diagram_fork_hom (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  (cones.postcompose (diagram_nat_iso F U R).hom).obj (fork.of_ι _ (presheaf.w R F)) ⟶
  fork F (covering_of_presieve U R) :=
fork.mk_hom (F.map (eq_to_hom (supr_eq_of_mem_grothendieck U R hR)).op)
  (fork_map_comp_first_obj_iso_pi_opens_eq F U R hR).symm

instance is_iso_postcompose_diagram_fork_hom_hom
  (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  is_iso (postcompose_diagram_fork_hom F U R hR).hom :=
begin
  rw [postcompose_diagram_fork_hom_hom, eq_to_hom_map],
  apply eq_to_hom.is_iso,
end

instance is_iso_postcompose_diagram_fork_hom
  (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  is_iso (postcompose_diagram_fork_hom F U R hR) :=
cones.cone_iso_of_hom_iso _

/-- See `postcompose_diagram_fork_hom`. -/
def postcompose_diagram_fork_iso (hR : sieve.generate R ∈ opens.grothendieck_topology X U) :
  (cones.postcompose (diagram_nat_iso F U R).hom).obj (fork.of_ι _ (presheaf.w R F)) ≅
  fork F (covering_of_presieve U R) :=
as_iso (postcompose_diagram_fork_hom F U R hR)

end covering_of_presieve

lemma is_sheaf_sites_of_is_sheaf_spaces (Fsh : F.is_sheaf) :
  presheaf.is_sheaf (opens.grothendieck_topology X) F :=
begin
  rw presheaf.is_sheaf_iff_is_sheaf',
  intros U R hR,
  refine ⟨_⟩,
  apply (is_limit.of_cone_equiv (cones.postcompose_equivalence
    (covering_of_presieve.diagram_nat_iso F U R : _))).to_fun,
  apply (is_limit.equiv_iso_limit
    (covering_of_presieve.postcompose_diagram_fork_iso F U R hR)).inv_fun,
  exact (Fsh (covering_of_presieve U R)).some,
end

/--
Given a family of opens `U : ι → opens X` and any open `Y : opens X`, we obtain a presieve
on `Y` by declaring that a morphism `f : V ⟶ Y` is a member of the presieve if and only if
there exists an index `i : ι` such that `V = U i`.
-/
def presieve_of_covering_aux {ι : Type v} (U : ι → opens X) (Y : opens X) : presieve Y :=
λ V f, ∃ i, V = U i

/-- Take `Y` to be `supr U` and obtain a presieve over `supr U`. -/
def presieve_of_covering {ι : Type v} (U : ι → opens X) : presieve (supr U) :=
presieve_of_covering_aux U (supr U)

/-- Given a presieve `R` on `Y`, if we take its associated family of opens via
    `covering_of_presieve` (which may not cover `Y` if `R` is not covering), and take
    the presieve on `Y` associated to the family of opens via `presieve_of_covering_aux`,
    then we get back the original presieve `R`. -/
@[simp] lemma covering_presieve_eq_self {Y : opens X} (R : presieve Y) :
  presieve_of_covering_aux (covering_of_presieve Y R) Y = R :=
by { ext Z f, exact ⟨λ ⟨⟨_,_,h⟩,rfl⟩, by convert h, λ h, ⟨⟨Z,f,h⟩,rfl⟩⟩ }

namespace presieve_of_covering

/-!
In this section, we will relate two different fork diagrams to each other.

The first one is the defining fork diagram for the sheaf condition in terms of spaces, applied to
the family of opens `U`. It will henceforth be called the _spaces diagram_. Its objects are called
`pi_opens` and `pi_inters` and its morphisms are `left_res` and `right_res`. The fork map into this
diagram is called `res`.

The second one is the defining fork diagram for the sheaf condition in terms of sites, applied to
the presieve `presieve_of_covering U`. It will henceforth be called the _sites diagram_. Its objects
are called `presheaf.first_obj` and `presheaf.second_obj` and its morphisms are `presheaf.first_map`
and `presheaf.second_obj`. The fork map into this diagram is called `presheaf.fork_map`.

-/

variables {ι : Type v} (U : ι → opens X)

/--
The sieve generated by `presieve_of_covering U` is a member of the grothendieck topology.
-/
lemma mem_grothendieck_topology :
  sieve.generate (presieve_of_covering U) ∈ opens.grothendieck_topology X (supr U) :=
begin
  intros x hx,
  obtain ⟨i, hxi⟩ := opens.mem_supr.mp hx,
  exact ⟨U i, opens.le_supr U i, ⟨U i, 𝟙 _, opens.le_supr U i, ⟨i, rfl⟩, category.id_comp _⟩, hxi⟩,
end

/--
An index `i : ι` can be turned into a dependent pair `(V, f)`, where `V` is an open set and
`f : V ⟶ supr U` is a member of `presieve_of_covering U f`.
-/
def hom_of_index (i : ι) : Σ V, {f : V ⟶ supr U // presieve_of_covering U f} :=
⟨U i, opens.le_supr U i, i, rfl⟩

/--
By using the axiom of choice, a dependent pair `(V, f)` where `f : V ⟶ supr U` is a member of
`presieve_of_covering U f` can be turned into an index `i : ι`, such that `V = U i`.
-/
def index_of_hom (f : Σ V, {f : V ⟶ supr U // presieve_of_covering U f}) : ι := f.2.2.some

lemma index_of_hom_spec (f : Σ V, {f : V ⟶ supr U // presieve_of_covering U f}) :
  f.1 = U (index_of_hom U f) := f.2.2.some_spec

/--
The canonical morphism from the first object in the sites diagram to the first object in the
spaces diagram. Note that this is *not* an isomorphism, as the product `pi_opens F U` may contain
duplicate factors, i.e. `U : ι → opens X` may not be injective.
-/
def first_obj_to_pi_opens : presheaf.first_obj (presieve_of_covering U) F ⟶ pi_opens F U :=
pi.lift (λ i, pi.π _ (hom_of_index U i))

/--
The canonical morphism from the first object in the spaces diagram to the first object in the
sites diagram. Note that this is *not* an isomorphism, as the product `pi_opens F U` may contain
duplicate factors, i.e. `U : ι → opens X` may not be injective.
-/
def pi_opens_to_first_obj : pi_opens F U ⟶
  presheaf.first_obj.{v v u} (presieve_of_covering U) F :=
pi.lift (λ f, pi.π _ (index_of_hom U f) ≫ F.map (eq_to_hom (index_of_hom_spec U f)).op)

/--
Even though `first_obj_to_pi_opens` and `pi_opens_to_first_obj` are not inverse to each other,
applying them both after a fork map `s.ι` does nothing. The intuition here is that a compatible
family `s : Π i : ι, F.obj (op (U i))` does not care about duplicate open sets:
If `U i = U j` the compatible family coincides on the intersection `U i ⊓ U j = U i = U j`,
hence `s i = s j` (module an `eq_to_hom` arrow).
-/
lemma fork_ι_comp_pi_opens_to_first_obj_to_pi_opens_eq
  (s : limits.fork (left_res F U) (right_res F U)) :
  s.ι ≫ pi_opens_to_first_obj F U ≫ first_obj_to_pi_opens F U = s.ι :=
begin
  ext ⟨j⟩,
  dunfold first_obj_to_pi_opens pi_opens_to_first_obj,
  rw [category.assoc, category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app],
  -- The issue here is that `index_of_hom U (hom_of_index U j)` need not be equal to `j`.
  -- But `U j = U (index_of_hom U (hom_of_index U j))` and hence we obtain the following
  -- `eq_to_hom` arrow:
  have i_eq : U j ⟶ U j ⊓ U (index_of_hom U (hom_of_index U j)),
  { apply eq_to_hom, rw ← index_of_hom_spec U, exact inf_idem.symm, },
  -- Since `s` is a fork, we know that `s.ι ≫ left_res F U = s.ι ≫ right_res F U`.
  -- We compose both sides of this equality with the canonical projection at the index pair
  -- `(j, index_of_hom U (hom_of_index U j)` and the restriction along `i_eq`.
  have := congr_arg (λ f, f ≫
    pi.π (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2))) (j, index_of_hom U (hom_of_index U j)) ≫
    F.map i_eq.op) s.condition,
  dsimp at this,
  rw [category.assoc, category.assoc] at this,
  symmetry,
  -- We claim that this is equality is our goal
  convert this using 2,
  { dunfold left_res,
    rw [limit.lift_π_assoc, fan.mk_π_app, category.assoc, ← F.map_comp],
    erw F.map_id,
    rw category.comp_id },
  { dunfold right_res,
    rw [limit.lift_π_assoc, fan.mk_π_app, category.assoc, ← F.map_comp],
    congr, }
end

/--
The canonical morphism from the second object of the spaces diagram to the second object of the
sites diagram.
-/
def pi_inters_to_second_obj : pi_inters F U ⟶
  presheaf.second_obj.{v v u} (presieve_of_covering U) F :=
pi.lift (λ f, pi.π _ (index_of_hom U f.fst, index_of_hom U f.snd) ≫
  F.map (eq_to_hom
    (by rw [complete_lattice.pullback_eq_inf, ← index_of_hom_spec U, ← index_of_hom_spec U])).op)

lemma pi_opens_to_first_obj_comp_fist_map_eq :
  pi_opens_to_first_obj F U ≫ presheaf.first_map (presieve_of_covering U) F =
  left_res F U ≫ pi_inters_to_second_obj F U :=
begin
  ext ⟨f, g⟩,
  dunfold pi_opens_to_first_obj presheaf.first_map left_res pi_inters_to_second_obj,
  rw [category.assoc, category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app,
    ← category.assoc, ← category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app,
    category.assoc, category.assoc, ← F.map_comp, ← F.map_comp],
  refl,
end

lemma pi_opens_to_first_obj_comp_second_map_eq :
  pi_opens_to_first_obj F U ≫ presheaf.second_map (presieve_of_covering U) F =
  right_res F U ≫ pi_inters_to_second_obj F U :=
begin
  ext ⟨f, g⟩,
  dunfold pi_opens_to_first_obj presheaf.second_map right_res pi_inters_to_second_obj,
  rw [category.assoc, category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app,
    ← category.assoc, ← category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app,
    category.assoc, category.assoc, ← F.map_comp, ← F.map_comp],
  refl,
end

lemma fork_map_comp_first_map_to_pi_opens_eq :
  presheaf.fork_map (presieve_of_covering U) F ≫ first_obj_to_pi_opens F U = res F U :=
begin
  ext i,
  dsimp [presheaf.fork_map, first_obj_to_pi_opens, res],
  rw [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app,
    limit.lift_π, fan.mk_π_app],
  refl,
end

lemma res_comp_pi_opens_to_first_obj_eq :
  res F U ≫ pi_opens_to_first_obj F U = presheaf.fork_map (presieve_of_covering U) F :=
begin
  ext f,
  dunfold res pi_opens_to_first_obj presheaf.fork_map,
  rw [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π, fan.mk_π_app, ← category.assoc,
    limit.lift_π, fan.mk_π_app, ← F.map_comp],
  congr,
end

end presieve_of_covering

open presieve_of_covering

lemma is_sheaf_spaces_of_is_sheaf_sites
  (Fsh : presheaf.is_sheaf (opens.grothendieck_topology X) F) :
  F.is_sheaf :=
begin
  intros ι U,
  rw presheaf.is_sheaf_iff_is_sheaf' at Fsh,
  -- We know that the sites diagram for `presieve_of_covering U` is a limit fork
  obtain ⟨h_limit⟩ := Fsh (supr U) (presieve_of_covering U)
    (presieve_of_covering.mem_grothendieck_topology U),
  refine ⟨fork.is_limit.mk' _ _⟩,
  -- Here, we are given an arbitrary fork of the spaces diagram and need to show that it factors
  -- uniquely through our limit fork.
  intro s,
  -- Composing `s.ι` with `pi_opens_to_first_obj F U` gives a fork of the sites diagram, which
  -- must factor through `presheaf.fork_map`.
  obtain ⟨l, hl⟩ := fork.is_limit.lift' h_limit (s.ι ≫ pi_opens_to_first_obj F U) _,
  swap,
  { rw [category.assoc, category.assoc, pi_opens_to_first_obj_comp_fist_map_eq,
    pi_opens_to_first_obj_comp_second_map_eq, ← category.assoc, ← category.assoc, s.condition] },
  -- We claim that `l` also gives a factorization of `s.ι`
  refine ⟨l, _, _⟩,
  { rw [← fork_ι_comp_pi_opens_to_first_obj_to_pi_opens_eq F U s, ← category.assoc, ← hl,
    category.assoc, fork.ι_of_ι, fork_map_comp_first_map_to_pi_opens_eq], refl },
  { intros m hm,
    apply fork.is_limit.hom_ext h_limit,
    rw [hl, fork.ι_of_ι],
    simp_rw ← res_comp_pi_opens_to_first_obj_eq,
    erw [← category.assoc, hm], },
end

lemma is_sheaf_sites_iff_is_sheaf_spaces :
  presheaf.is_sheaf (opens.grothendieck_topology X) F ↔ F.is_sheaf :=
iff.intro (is_sheaf_spaces_of_is_sheaf_sites F) (is_sheaf_sites_of_is_sheaf_spaces F)

variables (C X)

/-- Turn a sheaf on the site `opens X` into a sheaf on the space `X`. -/
@[simps]
def Sheaf_sites_to_sheaf_spaces : Sheaf (opens.grothendieck_topology X) C ⥤ sheaf C X :=
{ obj := λ F, ⟨F.1, is_sheaf_spaces_of_is_sheaf_sites F.1 F.2⟩,
  map := λ F G f, f.val }

/-- Turn a sheaf on the space `X` into a sheaf on the site `opens X`. -/
@[simps]
def Sheaf_spaces_to_sheaf_sites : sheaf C X ⥤ Sheaf (opens.grothendieck_topology X) C :=
{ obj := λ F, ⟨F.1, is_sheaf_sites_of_is_sheaf_spaces F.1 F.2⟩,
  map := λ F G f, ⟨f⟩ }

/--
The equivalence of categories between sheaves on the site `opens X` and sheaves on the space `X`.
-/
@[simps]
def Sheaf_spaces_equiv_sheaf_sites : Sheaf (opens.grothendieck_topology X) C ≌ sheaf C X :=
{ functor := Sheaf_sites_to_sheaf_spaces C X,
  inverse := Sheaf_spaces_to_sheaf_sites C X,
  unit_iso := nat_iso.of_components (λ t, ⟨⟨𝟙 _⟩, ⟨𝟙 _⟩, by { ext1, simp }, by { ext1, simp }⟩) $
    by { intros, ext1, dsimp, simp },
  counit_iso := nat_iso.of_components (λ t, ⟨𝟙 _, 𝟙 _, by { ext, simp }, by { ext, simp }⟩) $
    by { intros, ext, dsimp, simp } }

/-- The two forgetful functors are isomorphic via `Sheaf_spaces_equiv_sheaf_sites`. -/
def Sheaf_spaces_equiv_sheaf_sites_functor_forget :
  (Sheaf_spaces_equiv_sheaf_sites C X).functor ⋙ sheaf.forget C X ≅ Sheaf_to_presheaf _ _ :=
nat_iso.of_components (λ F, (iso.refl F.1))
  (λ F G f, by { erw [category.comp_id, category.id_comp], refl })

/-- The two forgetful functors are isomorphic via `Sheaf_spaces_equiv_sheaf_sites`. -/
def Sheaf_spaces_equiv_sheaf_sites_inverse_forget :
  (Sheaf_spaces_equiv_sheaf_sites C X).inverse ⋙ Sheaf_to_presheaf _ _ ≅ sheaf.forget C X :=
nat_iso.of_components (λ F, (iso.refl F.1))
  (λ F G f, by { erw [category.comp_id, category.id_comp], refl })

end Top.presheaf

namespace Top.opens

open category_theory topological_space

variables {X : Top} {ι : Type*}

lemma cover_dense_iff_is_basis [category ι] (B : ι ⥤ opens X) :
  cover_dense (opens.grothendieck_topology X) B ↔ opens.is_basis (set.range B.obj) :=
begin
  rw opens.is_basis_iff_nbhd,
  split, intros hd U x hx, rcases hd.1 U x hx with ⟨V,f,⟨i,f₁,f₂,hc⟩,hV⟩,
  exact ⟨B.obj i, ⟨i,rfl⟩, f₁.le hV, f₂.le⟩,
  intro hb, split, intros U x hx, rcases hb hx with ⟨_,⟨i,rfl⟩,hx,hi⟩,
  exact ⟨B.obj i, ⟨⟨hi⟩⟩, ⟨⟨i, 𝟙 _, ⟨⟨hi⟩⟩, rfl⟩⟩, hx⟩,
end

lemma cover_dense_induced_functor {B : ι → opens X} (h : opens.is_basis (set.range B)) :
  cover_dense (opens.grothendieck_topology X) (induced_functor B) :=
(cover_dense_iff_is_basis _).2 h

end Top.opens

namespace Top.sheaf

open category_theory topological_space Top opposite

variables {C : Type u} [category.{v} C] [limits.has_products.{v} C]
variables {X : Top.{v}} {ι : Type*} {B : ι → opens X}
variables (F : presheaf C X) (F' : sheaf C X) (h : opens.is_basis (set.range B))

/-- The empty component of a sheaf is terminal -/
def is_terminal_of_empty (F : sheaf C X) : limits.is_terminal (F.val.obj (op ∅)) :=
((presheaf.Sheaf_spaces_to_sheaf_sites C X).obj F).is_terminal_of_bot_cover ∅ (by tidy)

/-- A variant of `is_terminal_of_empty` that is easier to `apply`. -/
def is_terminal_of_eq_empty (F : X.sheaf C) {U : opens X} (h : U = ∅) :
  limits.is_terminal (F.val.obj (op U)) :=
by convert F.is_terminal_of_empty

/-- If a family `B` of open sets forms a basis of the topology on `X`, and if `F'`
    is a sheaf on `X`, then a homomorphism between a presheaf `F` on `X` and `F'`
    is equivalent to a homomorphism between their restrictions to the indexing type
    `ι` of `B`, with the induced category structure on `ι`. -/
def restrict_hom_equiv_hom :
  ((induced_functor B).op ⋙ F ⟶ (induced_functor B).op ⋙ F'.1) ≃ (F ⟶ F'.1) :=
@cover_dense.restrict_hom_equiv_hom _ _ _ _ _ _ _ _ (opens.cover_dense_induced_functor h)
  _ F ((presheaf.Sheaf_spaces_to_sheaf_sites C X).obj F')

@[simp] lemma extend_hom_app (α : ((induced_functor B).op ⋙ F ⟶ (induced_functor B).op ⋙ F'.1))
  (i : ι) : (restrict_hom_equiv_hom F F' h α).app (op (B i)) = α.app (op i) :=
by { nth_rewrite 1 ← (restrict_hom_equiv_hom F F' h).left_inv α, refl }

include h
lemma hom_ext {α β : F ⟶ F'.1} (he : ∀ i, α.app (op (B i)) = β.app (op (B i))) : α = β :=
by { apply (restrict_hom_equiv_hom F F' h).symm.injective, ext i, exact he i.unop }

end Top.sheaf


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import order.rel_iso.set
import data.fintype.lattice
import data.multiset.sort
import data.list.nodup_equiv_fin

/-!
# Construct a sorted list from a finset.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

namespace finset

open multiset nat
variables {α β : Type*}

/-! ### sort -/
section sort
variables (r : α → α → Prop) [decidable_rel r]
  [is_trans α r] [is_antisymm α r] [is_total α r]

/-- `sort s` constructs a sorted list from the unordered set `s`.
  (Uses merge sort algorithm.) -/
def sort (s : finset α) : list α := sort r s.1

@[simp] theorem sort_sorted (s : finset α) : list.sorted r (sort r s) :=
sort_sorted _ _

@[simp] theorem sort_eq (s : finset α) : ↑(sort r s) = s.1 :=
sort_eq _ _

@[simp] theorem sort_nodup (s : finset α) : (sort r s).nodup :=
(by rw sort_eq; exact s.2 : @multiset.nodup α (sort r s))

@[simp] theorem sort_to_finset [decidable_eq α] (s : finset α) : (sort r s).to_finset = s :=
list.to_finset_eq (sort_nodup r s) ▸ eq_of_veq (sort_eq r s)

@[simp] theorem mem_sort {s : finset α} {a : α} : a ∈ sort r s ↔ a ∈ s :=
multiset.mem_sort _

@[simp] theorem length_sort {s : finset α} : (sort r s).length = s.card :=
multiset.length_sort _

@[simp] theorem sort_empty : sort r ∅ = [] :=
multiset.sort_zero r

@[simp] theorem sort_singleton (a : α) : sort r {a} = [a] :=
multiset.sort_singleton r a

lemma sort_perm_to_list (s : finset α) : sort r s ~ s.to_list :=
by { rw ←multiset.coe_eq_coe, simp only [coe_to_list, sort_eq] }

end sort

section sort_linear_order

variables [linear_order α]

theorem sort_sorted_lt (s : finset α) : list.sorted (<) (sort (≤) s) :=
(sort_sorted _ _).imp₂ (@lt_of_le_of_ne _ _) (sort_nodup _ _)

lemma sorted_zero_eq_min'_aux (s : finset α) (h : 0 < (s.sort (≤)).length) (H : s.nonempty) :
  (s.sort (≤)).nth_le 0 h = s.min' H :=
begin
  let l := s.sort (≤),
  apply le_antisymm,
  { have : s.min' H ∈ l := (finset.mem_sort (≤)).mpr (s.min'_mem H),
    obtain ⟨i, i_lt, hi⟩ : ∃ i (hi : i < l.length), l.nth_le i hi = s.min' H :=
      list.mem_iff_nth_le.1 this,
    rw ← hi,
    exact (s.sort_sorted (≤)).rel_nth_le_of_le _ _ (nat.zero_le i) },
  { have : l.nth_le 0 h ∈ s := (finset.mem_sort (≤)).1 (list.nth_le_mem l 0 h),
    exact s.min'_le _ this }
end

lemma sorted_zero_eq_min' {s : finset α} {h : 0 < (s.sort (≤)).length} :
  (s.sort (≤)).nth_le 0 h = s.min' (card_pos.1 $ by rwa length_sort at h) :=
sorted_zero_eq_min'_aux _ _ _

lemma min'_eq_sorted_zero {s : finset α} {h : s.nonempty} :
  s.min' h = (s.sort (≤)).nth_le 0 (by { rw length_sort, exact card_pos.2 h }) :=
(sorted_zero_eq_min'_aux _ _ _).symm

lemma sorted_last_eq_max'_aux (s : finset α) (h : (s.sort (≤)).length - 1 < (s.sort (≤)).length)
  (H : s.nonempty) : (s.sort (≤)).nth_le ((s.sort (≤)).length - 1) h = s.max' H :=
begin
  let l := s.sort (≤),
  apply le_antisymm,
  { have : l.nth_le ((s.sort (≤)).length - 1) h ∈ s :=
      (finset.mem_sort (≤)).1 (list.nth_le_mem l _ h),
    exact s.le_max' _ this },
  { have : s.max' H ∈ l := (finset.mem_sort (≤)).mpr (s.max'_mem H),
    obtain ⟨i, i_lt, hi⟩ : ∃ i (hi : i < l.length), l.nth_le i hi = s.max' H :=
      list.mem_iff_nth_le.1 this,
    rw ← hi,
    have : i ≤ l.length - 1 := nat.le_pred_of_lt i_lt,
    exact (s.sort_sorted (≤)).rel_nth_le_of_le _ _ (nat.le_pred_of_lt i_lt) },
end

lemma sorted_last_eq_max' {s : finset α} {h : (s.sort (≤)).length - 1 < (s.sort (≤)).length} :
  (s.sort (≤)).nth_le ((s.sort (≤)).length - 1) h =
  s.max' (by { rw length_sort at h, exact card_pos.1 (lt_of_le_of_lt bot_le h) }) :=
sorted_last_eq_max'_aux _ _ _

lemma max'_eq_sorted_last {s : finset α} {h : s.nonempty} :
  s.max' h = (s.sort (≤)).nth_le ((s.sort (≤)).length - 1)
    (by simpa using nat.sub_lt (card_pos.mpr h) zero_lt_one) :=
(sorted_last_eq_max'_aux _ _ _).symm

/-- Given a finset `s` of cardinality `k` in a linear order `α`, the map `order_iso_of_fin s h`
is the increasing bijection between `fin k` and `s` as an `order_iso`. Here, `h` is a proof that
the cardinality of `s` is `k`. We use this instead of an iso `fin s.card ≃o s` to avoid
casting issues in further uses of this function. -/
def order_iso_of_fin (s : finset α) {k : ℕ} (h : s.card = k) : fin k ≃o s :=
order_iso.trans (fin.cast ((length_sort (≤)).trans h).symm) $
  (s.sort_sorted_lt.nth_le_iso _).trans $ order_iso.set_congr _ _ $
    set.ext $ λ x, mem_sort _

/-- Given a finset `s` of cardinality `k` in a linear order `α`, the map `order_emb_of_fin s h` is
the increasing bijection between `fin k` and `s` as an order embedding into `α`. Here, `h` is a
proof that the cardinality of `s` is `k`. We use this instead of an embedding `fin s.card ↪o α` to
avoid casting issues in further uses of this function. -/
def order_emb_of_fin (s : finset α) {k : ℕ} (h : s.card = k) : fin k ↪o α :=
(order_iso_of_fin s h).to_order_embedding.trans (order_embedding.subtype _)

@[simp] lemma coe_order_iso_of_fin_apply (s : finset α) {k : ℕ} (h : s.card = k) (i : fin k) :
  ↑(order_iso_of_fin s h i) = order_emb_of_fin s h i :=
rfl

lemma order_iso_of_fin_symm_apply (s : finset α) {k : ℕ} (h : s.card = k) (x : s) :
  ↑((s.order_iso_of_fin h).symm x) = (s.sort (≤)).index_of x :=
rfl

lemma order_emb_of_fin_apply (s : finset α) {k : ℕ} (h : s.card = k) (i : fin k) :
  s.order_emb_of_fin h i = (s.sort (≤)).nth_le i (by { rw [length_sort, h], exact i.2 }) :=
rfl

@[simp] lemma order_emb_of_fin_mem (s : finset α) {k : ℕ} (h : s.card = k) (i : fin k) :
  s.order_emb_of_fin h i ∈ s :=
(s.order_iso_of_fin h i).2

@[simp] lemma range_order_emb_of_fin (s : finset α) {k : ℕ} (h : s.card = k) :
  set.range (s.order_emb_of_fin h) = s :=
by simp only [order_emb_of_fin, set.range_comp coe (s.order_iso_of_fin h), rel_embedding.coe_trans,
 set.image_univ,
 finset.order_emb_of_fin.equations._eqn_1,
 rel_iso.range_eq,
 order_embedding.subtype_apply,
 order_iso.coe_to_order_embedding,
 eq_self_iff_true,
 subtype.range_coe_subtype,
 finset.set_of_mem,
 finset.coe_inj]

/-- The bijection `order_emb_of_fin s h` sends `0` to the minimum of `s`. -/
lemma order_emb_of_fin_zero {s : finset α} {k : ℕ} (h : s.card = k) (hz : 0 < k) :
  order_emb_of_fin s h ⟨0, hz⟩ = s.min' (card_pos.mp (h.symm ▸ hz)) :=
by simp only [order_emb_of_fin_apply, fin.coe_mk, sorted_zero_eq_min']

/-- The bijection `order_emb_of_fin s h` sends `k-1` to the maximum of `s`. -/
lemma order_emb_of_fin_last {s : finset α} {k : ℕ} (h : s.card = k) (hz : 0 < k) :
  order_emb_of_fin s h ⟨k-1, buffer.lt_aux_2 hz⟩ = s.max' (card_pos.mp (h.symm ▸ hz)) :=
by simp [order_emb_of_fin_apply, max'_eq_sorted_last, h]

/-- `order_emb_of_fin {a} h` sends any argument to `a`. -/
@[simp] lemma order_emb_of_fin_singleton (a : α) (i : fin 1) :
  order_emb_of_fin {a} (card_singleton a) i = a :=
by rw [subsingleton.elim i ⟨0, zero_lt_one⟩, order_emb_of_fin_zero _ zero_lt_one, min'_singleton]

/-- Any increasing map `f` from `fin k` to a finset of cardinality `k` has to coincide with
the increasing bijection `order_emb_of_fin s h`. -/
lemma order_emb_of_fin_unique {s : finset α} {k : ℕ} (h : s.card = k) {f : fin k → α}
  (hfs : ∀ x, f x ∈ s) (hmono : strict_mono f) : f = s.order_emb_of_fin h :=
begin
  apply fin.strict_mono_unique hmono (s.order_emb_of_fin h).strict_mono,
  rw [range_order_emb_of_fin, ← set.image_univ, ← coe_univ, ← coe_image, coe_inj],
  refine eq_of_subset_of_card_le (λ x hx, _) _,
  { rcases mem_image.1 hx with ⟨x, hx, rfl⟩, exact hfs x },
  { rw [h, card_image_of_injective _ hmono.injective, card_univ, fintype.card_fin] }
end

/-- An order embedding `f` from `fin k` to a finset of cardinality `k` has to coincide with
the increasing bijection `order_emb_of_fin s h`. -/
lemma order_emb_of_fin_unique' {s : finset α} {k : ℕ} (h : s.card = k) {f : fin k ↪o α}
  (hfs : ∀ x, f x ∈ s) : f = s.order_emb_of_fin h :=
rel_embedding.ext $ function.funext_iff.1 $ order_emb_of_fin_unique h hfs f.strict_mono

/-- Two parametrizations `order_emb_of_fin` of the same set take the same value on `i` and `j` if
and only if `i = j`. Since they can be defined on a priori not defeq types `fin k` and `fin l`
(although necessarily `k = l`), the conclusion is rather written `(i : ℕ) = (j : ℕ)`. -/
@[simp] lemma order_emb_of_fin_eq_order_emb_of_fin_iff
  {k l : ℕ} {s : finset α} {i : fin k} {j : fin l} {h : s.card = k} {h' : s.card = l} :
  s.order_emb_of_fin h i = s.order_emb_of_fin h' j ↔ (i : ℕ) = (j : ℕ) :=
begin
  substs k l,
  exact (s.order_emb_of_fin rfl).eq_iff_eq.trans fin.ext_iff
end

/-- Given a finset `s` of size at least `k` in a linear order `α`, the map `order_emb_of_card_le`
is an order embedding from `fin k` to `α` whose image is contained in `s`. Specifically, it maps
`fin k` to an initial segment of `s`. -/
def order_emb_of_card_le (s : finset α) {k : ℕ} (h : k ≤ s.card) : fin k ↪o α :=
(fin.cast_le h).trans (s.order_emb_of_fin rfl)

lemma order_emb_of_card_le_mem (s : finset α) {k : ℕ} (h : k ≤ s.card) (a) :
  order_emb_of_card_le s h a ∈ s :=
by simp only [order_emb_of_card_le, rel_embedding.coe_trans, finset.order_emb_of_fin_mem]

end sort_linear_order

meta instance [has_repr α] : has_repr (finset α) := ⟨λ s, repr s.1⟩

end finset


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

! This file was ported from Lean 3 source module data.finsupp.multiset
! leanprover-community/mathlib commit 59694bd07f0a39c5beccba34bd9f413a160782bf
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finsupp.Basic
import Mathlib.Data.Finsupp.Order

/-!
# Equivalence between `Multiset` and `ℕ`-valued finitely supported functions

This defines `Finsupp.toMultiset` the equivalence between `α →₀ ℕ` and `Multiset α`, along
with `Multiset.toFinsupp` the reverse equivalence and `Finsupp.orderIsoMultiset` the equivalence
promoted to an order isomorphism.
-/

open Finset

open BigOperators Classical

noncomputable section

variable {α β ι : Type _}

namespace Finsupp
/-- Given `f : α →₀ ℕ`, `f.toMultiset` is the multiset with multiplicities given by the values of
`f` on the elements of `α`. We define this function as an `AddEquiv`. -/
def toMultiset : (α →₀ ℕ) ≃+ Multiset α where
  toFun f := Finsupp.sum f fun a n => n • {a}
  invFun s := ⟨s.toFinset, fun a => s.count a, fun a => by simp⟩
  left_inv f :=
    ext fun a => by
      simp only [sum, Multiset.count_sum', Multiset.count_singleton, mul_boole, coe_mk,
        mem_support_iff, Multiset.count_nsmul, Finset.sum_ite_eq, ite_not, ite_eq_right_iff]
      exact Eq.symm
  right_inv s := by simp only [sum, coe_mk, Multiset.toFinset_sum_count_nsmul_eq]
  -- Porting note: times out if h is not specified
  map_add' f g := sum_add_index' (h := fun a n => n • ({a} : Multiset α))
    (fun _ ↦ zero_nsmul _) (fun _ ↦ add_nsmul _)
#align finsupp.to_multiset Finsupp.toMultiset

theorem toMultiset_zero : toMultiset (0 : α →₀ ℕ) = 0 :=
  rfl
#align finsupp.to_multiset_zero Finsupp.toMultiset_zero

theorem toMultiset_add (m n : α →₀ ℕ) : toMultiset (m + n) = toMultiset m + toMultiset n :=
  toMultiset.map_add m n
#align finsupp.to_multiset_add Finsupp.toMultiset_add

theorem toMultiset_apply (f : α →₀ ℕ) : toMultiset f = f.sum fun a n => n • {a} :=
  rfl
#align finsupp.to_multiset_apply Finsupp.toMultiset_apply

@[simp]
theorem toMultiset_symm_apply [DecidableEq α] (s : Multiset α) (x : α) :
    Finsupp.toMultiset.symm s x = s.count x := by
    -- Porting note: proof used to be `convert rfl`
    have : Finsupp.toMultiset.symm s x = Finsupp.toMultiset.invFun s x := rfl
    simp_rw [this, toMultiset, coe_mk]
    congr
#align finsupp.to_multiset_symm_apply Finsupp.toMultiset_symm_apply

@[simp]
theorem toMultiset_single (a : α) (n : ℕ) : toMultiset (single a n) = n • {a} := by
  rw [toMultiset_apply, sum_single_index]; apply zero_nsmul
#align finsupp.to_multiset_single Finsupp.toMultiset_single

theorem toMultiset_sum {f : ι → α →₀ ℕ} (s : Finset ι) :
    Finsupp.toMultiset (∑ i in s, f i) = ∑ i in s, Finsupp.toMultiset (f i) :=
  map_sum _ _ _
#align finsupp.to_multiset_sum Finsupp.toMultiset_sum

theorem toMultiset_sum_single (s : Finset ι) (n : ℕ) :
    Finsupp.toMultiset (∑ i in s, single i n) = n • s.val := by
  simp_rw [toMultiset_sum, Finsupp.toMultiset_single, sum_nsmul, sum_multiset_singleton]
#align finsupp.to_multiset_sum_single Finsupp.toMultiset_sum_single

theorem card_toMultiset (f : α →₀ ℕ) : Multiset.card (toMultiset f) = f.sum fun _ => id := by
  simp [toMultiset_apply, map_finsupp_sum, Function.id_def]
#align finsupp.card_to_multiset Finsupp.card_toMultiset

theorem toMultiset_map (f : α →₀ ℕ) (g : α → β) :
    f.toMultiset.map g = toMultiset (f.mapDomain g) := by
  refine' f.induction _ _
  · rw [toMultiset_zero, Multiset.map_zero, mapDomain_zero, toMultiset_zero]
  · intro a n f _ _ ih
    rw [toMultiset_add, Multiset.map_add, ih, mapDomain_add, mapDomain_single,
      toMultiset_single, toMultiset_add, toMultiset_single, ← Multiset.coe_mapAddMonoidHom,
      (Multiset.mapAddMonoidHom g).map_nsmul]
    rfl
#align finsupp.to_multiset_map Finsupp.toMultiset_map

@[simp]
theorem prod_toMultiset [CommMonoid α] (f : α →₀ ℕ) :
    f.toMultiset.prod = f.prod fun a n => a ^ n := by
  refine' f.induction _ _
  · rw [toMultiset_zero, Multiset.prod_zero, Finsupp.prod_zero_index]
  · intro a n f _ _ ih
    rw [toMultiset_add, Multiset.prod_add, ih, toMultiset_single, Multiset.prod_nsmul,
      Finsupp.prod_add_index' pow_zero pow_add, Finsupp.prod_single_index, Multiset.prod_singleton]
    · exact pow_zero a
#align finsupp.prod_to_multiset Finsupp.prod_toMultiset

@[simp]
theorem toFinset_toMultiset [DecidableEq α] (f : α →₀ ℕ) : f.toMultiset.toFinset = f.support := by
  refine' f.induction _ _
  · rw [toMultiset_zero, Multiset.toFinset_zero, support_zero]
  · intro a n f ha hn ih
    rw [toMultiset_add, Multiset.toFinset_add, ih, toMultiset_single, support_add_eq,
      support_single_ne_zero _ hn, Multiset.toFinset_nsmul _ _ hn, Multiset.toFinset_singleton]
    refine' Disjoint.mono_left support_single_subset _
    rwa [Finset.disjoint_singleton_left]
#align finsupp.to_finset_to_multiset Finsupp.toFinset_toMultiset

@[simp]
theorem count_toMultiset [DecidableEq α] (f : α →₀ ℕ) (a : α) : (toMultiset f).count a = f a :=
  calc
    (toMultiset f).count a = Finsupp.sum f (fun x n => (n • {x} : Multiset α).count a) :=
      by rw [toMultiset_apply]; exact map_sum (Multiset.countAddMonoidHom a) _ f.support
    _ = f.sum fun x n => n * ({x} : Multiset α).count a := by simp only [Multiset.count_nsmul]
    _ = f a * ({a} : Multiset α).count a :=
      sum_eq_single _
        (fun a' _ H => by simp only [Multiset.count_singleton, if_false, H.symm, mul_zero]) fun H =>
        by simp only [not_mem_support_iff.1 H, zero_mul]
    _ = f a := by rw [Multiset.count_singleton_self, mul_one]

#align finsupp.count_to_multiset Finsupp.count_toMultiset

@[simp]
theorem mem_toMultiset (f : α →₀ ℕ) (i : α) : i ∈ toMultiset f ↔ i ∈ f.support := by
  rw [← Multiset.count_ne_zero, Finsupp.count_toMultiset, Finsupp.mem_support_iff]
#align finsupp.mem_to_multiset Finsupp.mem_toMultiset

end Finsupp

namespace Multiset

/-- Given a multiset `s`, `s.toFinsupp` returns the finitely supported function on `ℕ` given by
the multiplicities of the elements of `s`. -/
def toFinsupp : Multiset α ≃+ (α →₀ ℕ) :=
  Finsupp.toMultiset.symm
#align multiset.to_finsupp Multiset.toFinsupp

@[simp]
theorem toFinsupp_support [DecidableEq α] (s : Multiset α) : s.toFinsupp.support = s.toFinset := by
  -- Porting note: used to be `convert rfl`
  ext
  simp [toFinsupp]
#align multiset.to_finsupp_support Multiset.toFinsupp_support

@[simp]
theorem toFinsupp_apply [DecidableEq α] (s : Multiset α) (a : α) : toFinsupp s a = s.count a := by
  -- Porting note: used to be `convert rfl`
  exact Finsupp.toMultiset_symm_apply s a
#align multiset.to_finsupp_apply Multiset.toFinsupp_apply

theorem toFinsupp_zero : toFinsupp (0 : Multiset α) = 0 :=
  AddEquiv.map_zero _
#align multiset.to_finsupp_zero Multiset.toFinsupp_zero

theorem toFinsupp_add (s t : Multiset α) : toFinsupp (s + t) = toFinsupp s + toFinsupp t :=
  toFinsupp.map_add s t
#align multiset.to_finsupp_add Multiset.toFinsupp_add

@[simp]
theorem toFinsupp_singleton (a : α) : toFinsupp ({a} : Multiset α) = Finsupp.single a 1 :=
  Finsupp.toMultiset.symm_apply_eq.2 <| by simp
#align multiset.to_finsupp_singleton Multiset.toFinsupp_singleton

@[simp]
theorem toFinsupp_toMultiset (s : Multiset α) : Finsupp.toMultiset (toFinsupp s) = s :=
  Finsupp.toMultiset.apply_symm_apply s
#align multiset.to_finsupp_to_multiset Multiset.toFinsupp_toMultiset

theorem toFinsupp_eq_iff {s : Multiset α} {f : α →₀ ℕ} :
    toFinsupp s = f ↔ s = Finsupp.toMultiset f :=
  Finsupp.toMultiset.symm_apply_eq
#align multiset.to_finsupp_eq_iff Multiset.toFinsupp_eq_iff

end Multiset

@[simp]
theorem Finsupp.toMultiset_toFinsupp (f : α →₀ ℕ) :
    Multiset.toFinsupp (Finsupp.toMultiset f) = f :=
  Finsupp.toMultiset.symm_apply_apply f
#align finsupp.to_multiset_to_finsupp Finsupp.toMultiset_toFinsupp

/-! ### As an order isomorphism -/

namespace Finsupp
/-- `Finsupp.toMultiset` as an order isomorphism. -/
def orderIsoMultiset : (ι →₀ ℕ) ≃o Multiset ι where
  toEquiv := toMultiset.toEquiv
  map_rel_iff' := by
    -- Porting note: This proof used to be simp [Multiset.le_iff_count, le_def]
    intro f g
    -- Porting note: the following should probably be a simp lemma somewhere;
    -- maybe coe_toEquiv in Hom/Equiv/Basic?
    have : ⇑ (toMultiset (α := ι)).toEquiv = toMultiset := rfl
    simp [Multiset.le_iff_count, le_def, ← toMultiset_symm_apply, this]
#align finsupp.order_iso_multiset Finsupp.orderIsoMultiset

@[simp]
theorem coe_orderIsoMultiset : ⇑(@orderIsoMultiset ι) = toMultiset :=
  rfl
#align finsupp.coe_order_iso_multiset Finsupp.coe_orderIsoMultiset

@[simp]
theorem coe_orderIsoMultiset_symm : ⇑(@orderIsoMultiset ι).symm = Multiset.toFinsupp :=
  rfl
#align finsupp.coe_order_iso_multiset_symm Finsupp.coe_orderIsoMultiset_symm

theorem toMultiset_strictMono : StrictMono (@toMultiset ι) :=
  (@orderIsoMultiset ι).strictMono
#align finsupp.to_multiset_strict_mono Finsupp.toMultiset_strictMono

theorem sum_id_lt_of_lt (m n : ι →₀ ℕ) (h : m < n) : (m.sum fun _ => id) < n.sum fun _ => id := by
  rw [← card_toMultiset, ← card_toMultiset]
  apply Multiset.card_lt_of_lt
  exact toMultiset_strictMono h
#align finsupp.sum_id_lt_of_lt Finsupp.sum_id_lt_of_lt

variable (ι)

/-- The order on `ι →₀ ℕ` is well-founded. -/
theorem lt_wf : WellFounded (@LT.lt (ι →₀ ℕ) _) :=
  Subrelation.wf (sum_id_lt_of_lt _ _) <| InvImage.wf _ Nat.lt_wfRel.2
#align finsupp.lt_wf Finsupp.lt_wf

end Finsupp

theorem Multiset.toFinsupp_strictMono : StrictMono (@Multiset.toFinsupp ι) :=
  (@Finsupp.orderIsoMultiset ι).symm.strictMono
#align multiset.to_finsupp_strict_mono Multiset.toFinsupp_strictMono


lemma add_squared (a b : mynat) :
  (a + b) ^ (2 : mynat) = a ^ (2 : mynat) + b ^ (2 : mynat) + 2 * a * b :=
begin
rw two_eq_succ_one,
rw one_eq_succ_zero,
repeat {rw pow_succ},
repeat {rw pow_zero},
ring,
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.finset_ops
import data.multiset.fold

/-!
# Lattice operations on multisets
-/

namespace multiset
variables {α : Type*}

/-! ### sup -/
section sup
variables [semilattice_sup_bot α]

/-- Supremum of a multiset: `sup {a, b, c} = a ⊔ b ⊔ c` -/
def sup (s : multiset α) : α := s.fold (⊔) ⊥

@[simp] lemma sup_zero : (0 : multiset α).sup = ⊥ :=
fold_zero _ _

@[simp] lemma sup_cons (a : α) (s : multiset α) :
  (a ::ₘ s).sup = a ⊔ s.sup :=
fold_cons_left _ _ _ _

@[simp] lemma sup_singleton {a : α} : (a ::ₘ 0).sup = a := by simp

@[simp] lemma sup_add (s₁ s₂ : multiset α) : (s₁ + s₂).sup = s₁.sup ⊔ s₂.sup :=
eq.trans (by simp [sup]) (fold_add _ _ _ _ _)

lemma sup_le {s : multiset α} {a : α} : s.sup ≤ a ↔ (∀b ∈ s, b ≤ a) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib] {contextual := tt})

lemma le_sup {s : multiset α} {a : α} (h : a ∈ s) : a ≤ s.sup :=
sup_le.1 (le_refl _) _ h

lemma sup_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₁.sup ≤ s₂.sup :=
sup_le.2 $ assume b hb, le_sup (h hb)

variables [decidable_eq α]

@[simp] lemma sup_erase_dup (s : multiset α) : (erase_dup s).sup = s.sup :=
fold_erase_dup_idem _ _ _

@[simp] lemma sup_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).sup = s₁.sup ⊔ s₂.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_add]; simp

@[simp] lemma sup_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).sup = s₁.sup ⊔ s₂.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_add]; simp

@[simp] lemma sup_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).sup = a ⊔ s.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_cons]; simp

lemma nodup_sup_iff {α : Type*} [decidable_eq α] {m : multiset (multiset α) } :
  m.sup.nodup ↔ ∀ (a : multiset α), a ∈ m → a.nodup :=
begin
  apply m.induction_on,
  { simp },
  { intros a s h,
    simp [h] }
end

end sup

/-! ### inf -/
section inf
variables [semilattice_inf_top α]

/-- Infimum of a multiset: `inf {a, b, c} = a ⊓ b ⊓ c` -/
def inf (s : multiset α) : α := s.fold (⊓) ⊤

@[simp] lemma inf_zero : (0 : multiset α).inf = ⊤ :=
fold_zero _ _

@[simp]

@[simp] lemma inf_singleton {a : α} : (a ::ₘ 0).inf = a := by simp

@[simp] lemma inf_add (s₁ s₂ : multiset α) : (s₁ + s₂).inf = s₁.inf ⊓ s₂.inf :=
eq.trans (by simp [inf]) (fold_add _ _ _ _ _)

lemma le_inf {s : multiset α} {a : α} : a ≤ s.inf ↔ (∀b ∈ s, a ≤ b) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib] {contextual := tt})

lemma inf_le {s : multiset α} {a : α} (h : a ∈ s) : s.inf ≤ a :=
le_inf.1 (le_refl _) _ h

lemma inf_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₂.inf ≤ s₁.inf :=
le_inf.2 $ assume b hb, inf_le (h hb)

variables [decidable_eq α]

@[simp] lemma inf_erase_dup (s : multiset α) : (erase_dup s).inf = s.inf :=
fold_erase_dup_idem _ _ _

@[simp] lemma inf_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).inf = s₁.inf ⊓ s₂.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_add]; simp

@[simp] lemma inf_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).inf = s₁.inf ⊓ s₂.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_add]; simp

@[simp] lemma inf_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).inf = a ⊓ s.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_cons]; simp

end inf

end multiset


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.int.order.basic
import algebra.group_with_zero.divisibility
import algebra.order.ring.abs

/-!
# Further lemmas about the integers

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
The distinction between this file and `data.int.order.basic` is not particularly clear.
They are separated by now to minimize the porting requirements for tactics during the transition to
mathlib4. After `data.rat.order` has been ported, please feel free to reorganize these two files.
-/

open nat

namespace int

/-! ### nat abs -/

variables {a b : ℤ} {n : ℕ}

lemma nat_abs_eq_iff_mul_self_eq {a b : ℤ} : a.nat_abs = b.nat_abs ↔ a * a = b * b :=
begin
  rw [← abs_eq_iff_mul_self_eq, abs_eq_nat_abs, abs_eq_nat_abs],
  exact int.coe_nat_inj'.symm
end

lemma eq_nat_abs_iff_mul_eq_zero : a.nat_abs = n ↔ (a - n) * (a + n) = 0 :=
by rw [nat_abs_eq_iff, mul_eq_zero, sub_eq_zero, add_eq_zero_iff_eq_neg]

lemma nat_abs_lt_iff_mul_self_lt {a b : ℤ} : a.nat_abs < b.nat_abs ↔ a * a < b * b :=
begin
  rw [← abs_lt_iff_mul_self_lt, abs_eq_nat_abs, abs_eq_nat_abs],
  exact int.coe_nat_lt.symm
end

lemma nat_abs_le_iff_mul_self_le {a b : ℤ} : a.nat_abs ≤ b.nat_abs ↔ a * a ≤ b * b :=
begin
  rw [← abs_le_iff_mul_self_le, abs_eq_nat_abs, abs_eq_nat_abs],
  exact int.coe_nat_le.symm
end

lemma dvd_div_of_mul_dvd {a b c : ℤ} (h : a * b ∣ c) : b ∣ c / a :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { simp only [int.div_zero, dvd_zero] },
  rcases h with ⟨d, rfl⟩,
  refine ⟨d, _⟩,
  rw [mul_assoc, int.mul_div_cancel_left _ ha],
end

/-! ### units -/

lemma eq_zero_of_abs_lt_dvd {m x : ℤ} (h1 : m ∣ x) (h2 : | x | < m) : x = 0 :=
begin
  by_cases hm : m = 0, { subst m, exact zero_dvd_iff.mp h1, },
  rcases h1 with ⟨d, rfl⟩,
  apply mul_eq_zero_of_right,
  rw [←abs_lt_one_iff, ←mul_lt_iff_lt_one_right (abs_pos.mpr hm), ←abs_mul],
  exact lt_of_lt_of_le h2 (le_abs_self m),
end

end int


/-
This file defines finite sequences from {0, ..., n} to ℕ
-/

import data.fin
import tactic
import ..Intuitionism.nat_seq

@[ext] structure fin_seq := mk :: (len : ℕ) (seq : fin len → ℕ)

namespace fin_seq

def finitize (a : 𝒩) (n : ℕ) : fin_seq := {
    len := n,
    seq := λ i, a i.val
}

lemma finitize_len (a : 𝒩) (n : ℕ) : (finitize a n).len = n := rfl

def is_initial_of (a : fin_seq) (b : 𝒩) : Prop := ∀ i : fin a.len, a.seq i = b i

infix `⊑`:50 := is_initial_of

lemma is_initial_of_self (a : 𝒩) {n : ℕ} : (finitize a n) ⊑ a :=
begin
    intro i,
    refl,
end

def shorten (a : fin_seq) (m : ℕ) (h : m ≤ a.len) : fin_seq := {
    len := m,
    seq := λ i, a.seq (fin.cast_le h i)
}

def extend (a b : fin_seq) : fin_seq := {
    len := a.len + b.len,
    seq := λ i, if h : i.val < a.len
                then a.seq (fin.cast_le h i)
                else b.seq (fin.sub_nat a.len (fin.cast (add_comm a.len b.len) i)
                    begin -- need to prove: a.len ≤ (fin.cast _ i).val
                        rw not_lt at h,
                        transitivity i.val,
                        exact h,
                        refl,
                    end),
}

def extend_inf (a : fin_seq) (b : 𝒩) : 𝒩 :=
    λ i, if h : i < a.len
        then a.seq (fin.cast_le h i)
        else b (i - a.len)

lemma extend_inf_eq {a : fin_seq} {b₁ b₂ : 𝒩} (h : b₁ =' b₂) : extend_inf a b₁ =' extend_inf a b₂ :=
begin
    intro n,
    rwa [extend_inf, extend_inf],
    dsimp only [],
    split_ifs,
    {-- case: n < a.len
        refl,
    },
    {-- case: ¬n < a.len
        exact h (n - a.len),
    }
end

lemma eq_extend_inf {a₁ a₂ : fin_seq} {b : 𝒩} (h₁ : a₁.len = a₂.len)
    (h₂ : ∀ i, a₁.seq i = a₂.seq (fin.cast h₁ i)) :
    extend_inf a₁ b =' extend_inf a₂ b :=
begin
    intro n,
    rwa [extend_inf, extend_inf],
    dsimp only [],
    split_ifs with g₁ g₂ g₃,
    {-- case: n < a₁.len ∧ n < a₂.len
        simp [h₂],
        refl,
    },
    {-- case: n < a₁.len ∧ ¬n < a₂.len
        exfalso,
        rw h₁ at g₁,
        exact g₂ g₁,
    },
    {-- case: ¬n < a₁.len ∧ n < a₂.len
        exfalso,
        rw h₁ at g₁,
        exact g₁ g₃,
    },
    {-- case: ¬n < a₁.len ∧ ¬n < a₂.len
        rw h₁,
    }
end

def empty_seq : fin_seq := {
    len := 0,
    seq := λ i, 0
}

lemma empty_seq_eq {a : fin_seq} (ha : a.len = 0) :
    ∀ i, empty_seq.seq i = a.seq (fin.cast (
        begin -- need to prove: empty_seq.len = a.len (note: both are 0)
            rw ha,
            refl,
        end
    ) i) :=
begin
    intro i,
    exfalso,
    have hi := i.is_lt,
    rw lt_iff_not_ge' at hi,
    apply hi,
    exact zero_le i.val,
end

lemma empty_extend_eq_self (a : 𝒩) : extend_inf empty_seq a =' a :=
begin
    intro i,
    simp [extend_inf],
    split_ifs,
    {-- case: i < empty_seq.len, impossible since empty_seq.len = 0
        exfalso,
        rw lt_iff_not_ge' at h,
        apply h,
        exact zero_le i,
    },
    {-- need to prove: a (i - empty_seq.len) = a i
        refl, -- uses: by definition, empty_seq.len = 0 and i - 0 = i
    }
end

def singleton (n : ℕ) : fin_seq := {
    len := 1,
    seq := λ i, n
}

theorem finitize_initial_iff_start_eq (a b : 𝒩) (n : ℕ) : finitize a n ⊑ b ↔ (∀ j : ℕ, j < n → a j = b j) :=
begin
    split,
    {-- need to prove: finitize a n ⊑ b → (∀ j : ℕ, j < n → a j = b j)
        intros h j hj,
        exact h (fin.mk j hj),
    },
    {-- need to prove: (∀ j : ℕ, j < n → a j = b j) → finitize a n ⊑ b
        intros h i,
        exact h i i.is_lt,
    }
end

theorem finitize_eq_iff_start_eq (a b : 𝒩) (n : ℕ) : finitize a n = finitize b n ↔ (∀ j : ℕ, j < n → a j = b j) :=
begin
    split,
    {-- need to prove: finitize a n = finitize b n → (∀ j : ℕ, j < n → a j = b j)
        intros h j hj,
        rwa [finitize, finitize] at h,
        simp at h,
        rw function.funext_iff at h,
        exact h (fin.mk j hj),
    },
    {-- finitize a n = finitize b n ← (∀ j : ℕ, j < n → a j = b j)
        intro h,
        rwa [finitize, finitize],
        simp,
        rw function.funext_iff,
        intro i,
        exact h i.val i.is_lt,
    }
end

lemma finitize_initial_iff_finitize_eq (a b : 𝒩) (n : ℕ) : finitize a n ⊑ b ↔ finitize a n = finitize b n :=
begin
    rw finitize_eq_iff_start_eq,
    rw finitize_initial_iff_start_eq,
end

/-
The tail of the sequence a
If a is the empty sequence, then the result will be the empty sequence
-/
def tail (a : fin_seq) : fin_seq := {
    len := a.len - 1,
    seq := λ i, a.seq (fin.cast_le (nat.pred_le (nat.sub a.len 0)) i)
}

lemma tail_singleton_len_zero : ∀ n : ℕ, (tail (singleton n)).len = 0 :=
begin
    intro n,
    refl,
end

end fin_seq

-- Finite sequences with a fixed length
def len_seq (n : ℕ) : Type := fin n → ℕ

namespace len_seq

def to_fin_seq {n : ℕ} : len_seq n → fin_seq := λ f, {
    len := n,
    seq := f,
}

lemma fin_len_eq {n : ℕ} {a : len_seq n} : (to_fin_seq a).seq = a :=
begin
    refl,
end

lemma len_fin_eq (a : fin_seq) : (to_fin_seq a.seq) = a :=
begin
    cases a,
    refl,
end

lemma len_seq_0_unique (x y : len_seq 0) : x = y :=
begin
    rw function.funext_iff,
    intro a,
    exfalso,
    have h : 0 ≤ a.val := zero_le a.val,
    rw ← not_lt at h,
    exact h a.is_lt,
end

end len_seq


/-
Copyright (c) 2021 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez
-/

import ring_theory.polynomial.cyclotomic.basic
import tactic.by_contra
import topology.algebra.polynomial
import number_theory.padics.padic_val
import analysis.complex.arg

/-!
# Evaluating cyclotomic polynomials
This file states some results about evaluating cyclotomic polynomials in various different ways.
## Main definitions
* `polynomial.eval(₂)_one_cyclotomic_prime(_pow)`: `eval 1 (cyclotomic p^k R) = p`.
* `polynomial.eval_one_cyclotomic_not_prime_pow`: Otherwise, `eval 1 (cyclotomic n R) = 1`.
* `polynomial.cyclotomic_pos` : `∀ x, 0 < eval x (cyclotomic n R)` if `2 < n`.
-/

namespace polynomial

open finset nat
open_locale big_operators

@[simp] lemma eval_one_cyclotomic_prime {R : Type*} [comm_ring R] {p : ℕ} [hn : fact p.prime] :
  eval 1 (cyclotomic p R) = p :=
by simp only [cyclotomic_eq_geom_sum hn.out, eval_X, one_pow, sum_const, eval_pow,
              eval_finset_sum, card_range, smul_one_eq_coe]

@[simp] lemma eval₂_one_cyclotomic_prime {R S : Type*} [comm_ring R] [semiring S] (f : R →+* S)
  {p : ℕ} [fact p.prime] : eval₂ f 1 (cyclotomic p R) = p :=
by simp

@[simp] lemma eval_one_cyclotomic_prime_pow {R : Type*} [comm_ring R] {p : ℕ} (k : ℕ)
  [hn : fact p.prime] : eval 1 (cyclotomic (p ^ (k + 1)) R) = p :=
by simp only [cyclotomic_prime_pow_eq_geom_sum hn.out, eval_X, one_pow, sum_const,
              eval_pow, eval_finset_sum, card_range, smul_one_eq_coe]

@[simp] lemma eval₂_one_cyclotomic_prime_pow {R S : Type*} [comm_ring R] [semiring S] (f : R →+* S)
  {p : ℕ} (k : ℕ) [fact p.prime] : eval₂ f 1 (cyclotomic (p ^ (k + 1)) R) = p :=
by simp

private lemma cyclotomic_neg_one_pos {n : ℕ} (hn : 2 < n) {R} [linear_ordered_comm_ring R] :
  0 < eval (-1 : R) (cyclotomic n R) :=
begin
  haveI := ne_zero.of_gt hn,
  rw [←map_cyclotomic_int, ←int.cast_one, ←int.cast_neg, eval_int_cast_map,
      int.coe_cast_ring_hom, int.cast_pos],
  suffices : 0 < eval ↑(-1 : ℤ) (cyclotomic n ℝ),
  { rw [←map_cyclotomic_int n ℝ, eval_int_cast_map, int.coe_cast_ring_hom] at this,
    exact_mod_cast this },
  simp only [int.cast_one, int.cast_neg],
  have h0 := cyclotomic_coeff_zero ℝ hn.le,
  rw coeff_zero_eq_eval_zero at h0,
  by_contra' hx,
  have := intermediate_value_univ (-1) 0 (cyclotomic n ℝ).continuous,
  obtain ⟨y, hy : is_root _ y⟩ := this (show (0 : ℝ) ∈ set.Icc _ _, by simpa [h0] using hx),
  rw is_root_cyclotomic_iff at hy,
  rw hy.eq_order_of at hn,
  exact hn.not_le linear_ordered_ring.order_of_le_two,
end

lemma cyclotomic_pos {n : ℕ} (hn : 2 < n) {R} [linear_ordered_comm_ring R] (x : R) :
  0 < eval x (cyclotomic n R) :=
begin
  induction n using nat.strong_induction_on with n ih,
  have hn'  : 0 < n := pos_of_gt hn,
  have hn'' : 1 < n := one_lt_two.trans hn,
  dsimp at ih,
  have := prod_cyclotomic_eq_geom_sum hn' R,
  apply_fun eval x at this,
  rw [divisors_eq_proper_divisors_insert_self_of_pos hn', insert_sdiff_of_not_mem,
      prod_insert, eval_mul, eval_geom_sum] at this,
  rotate,
  { simp only [lt_self_iff_false, mem_sdiff, not_false_iff, mem_proper_divisors, and_false,
      false_and]},
  { simpa only [mem_singleton] using hn''.ne' },
  rcases lt_trichotomy 0 (∑ i in range n, x ^ i) with h | h | h,
  { apply pos_of_mul_pos_right,
    { rwa this },
    rw eval_prod,
    refine prod_nonneg (λ i hi, _),
    simp only [mem_sdiff, mem_proper_divisors, mem_singleton] at hi,
    rw geom_sum_pos_iff hn'' at h,
    cases h with hk hx,
    { refine (ih _ hi.1.2 (nat.two_lt_of_ne _ hi.2 _)).le; rintro rfl,
      { exact hn'.ne' (zero_dvd_iff.mp hi.1.1) },
      { exact even_iff_not_odd.mp (even_iff_two_dvd.mpr hi.1.1) hk } },
    { rcases eq_or_ne i 2 with rfl | hk,
      { simpa only [eval_X, eval_one, cyclotomic_two, eval_add] using hx.le },
      refine (ih _ hi.1.2 (nat.two_lt_of_ne _ hi.2 hk)).le,
      rintro rfl,
      exact (hn'.ne' $ zero_dvd_iff.mp hi.1.1) } },
  { rw [eq_comm, geom_sum_eq_zero_iff_neg_one hn''] at h,
    exact h.1.symm ▸ cyclotomic_neg_one_pos hn },
  { apply pos_of_mul_neg_left,
    { rwa this },
    rw [geom_sum_neg_iff hn''] at h,
    have h2 : {2} ⊆ n.proper_divisors \ {1},
    { rw [singleton_subset_iff, mem_sdiff, mem_proper_divisors, not_mem_singleton],
      exact ⟨⟨even_iff_two_dvd.mp h.1, hn⟩, (nat.one_lt_bit0 one_ne_zero).ne'⟩ },
    rw [eval_prod, ←prod_sdiff h2, prod_singleton]; try { apply_instance },
    apply mul_nonpos_of_nonneg_of_nonpos,
    { refine prod_nonneg (λ i hi, le_of_lt _),
      simp only [mem_sdiff, mem_proper_divisors, mem_singleton] at hi,
      refine ih _ hi.1.1.2 (nat.two_lt_of_ne _ hi.1.2 hi.2),
      rintro rfl,
      rw zero_dvd_iff at hi,
      exact hn'.ne' hi.1.1.1 },
    { simpa only [eval_X, eval_one, cyclotomic_two, eval_add] using h.right.le } }
end

lemma cyclotomic_pos_and_nonneg (n : ℕ) {R} [linear_ordered_comm_ring R] (x : R) :
  (1 < x → 0 < eval x (cyclotomic n R)) ∧ (1 ≤ x → 0 ≤ eval x (cyclotomic n R)) :=
begin
  rcases n with _ | _ | _ | n;
  simp only [cyclotomic_zero, cyclotomic_one, cyclotomic_two, succ_eq_add_one,
    eval_X, eval_one, eval_add, eval_sub, sub_nonneg, sub_pos,
    zero_lt_one, zero_le_one, implies_true_iff, imp_self, and_self],
  { split; intro; linarith, },
  { have : 2 < n + 3 := dec_trivial,
    split; intro; [skip, apply le_of_lt]; apply cyclotomic_pos this, },
end

/-- Cyclotomic polynomials are always positive on inputs larger than one.
Similar to `cyclotomic_pos` but with the condition on the input rather than index of the
cyclotomic polynomial. -/
lemma cyclotomic_pos' (n : ℕ) {R} [linear_ordered_comm_ring R] {x : R} (hx : 1 < x) :
  0 < eval x (cyclotomic n R) :=
(cyclotomic_pos_and_nonneg n x).1 hx

/-- Cyclotomic polynomials are always nonnegative on inputs one or more. -/
lemma cyclotomic_nonneg (n : ℕ) {R} [linear_ordered_comm_ring R] {x : R} (hx : 1 ≤ x) :
  0 ≤ eval x (cyclotomic n R) :=
(cyclotomic_pos_and_nonneg n x).2 hx

lemma eval_one_cyclotomic_not_prime_pow {R : Type*} [ring R] {n : ℕ}
  (h : ∀ {p : ℕ}, p.prime → ∀ k : ℕ, p ^ k ≠ n) : eval 1 (cyclotomic n R) = 1 :=
begin
  rcases n.eq_zero_or_pos with rfl | hn',
  { simp },
  have hn : 1 < n := one_lt_iff_ne_zero_and_ne_one.mpr ⟨hn'.ne', (h nat.prime_two 0).symm⟩,
  suffices : eval 1 (cyclotomic n ℤ) = 1 ∨ eval 1 (cyclotomic n ℤ) = -1,
  { cases this with h h,
    { have := eval_int_cast_map (int.cast_ring_hom R) (cyclotomic n ℤ) 1,
      simpa only [map_cyclotomic, int.cast_one, h, ring_hom.eq_int_cast] using this },
    { exfalso,
      linarith [cyclotomic_nonneg n (le_refl (1 : ℤ))] }, },
  rw [←int.nat_abs_eq_nat_abs_iff, int.nat_abs_one, nat.eq_one_iff_not_exists_prime_dvd],
  intros p hp hpe,
  haveI := fact.mk hp,

  have hpn : p ∣ n,
  { apply hpe.trans,
    nth_rewrite 1 ←int.nat_abs_of_nat n,
    rw [int.nat_abs_dvd_iff_dvd, ←one_geom_sum, ←eval_geom_sum, ←prod_cyclotomic_eq_geom_sum hn'],
    apply eval_dvd,
    apply finset.dvd_prod_of_mem,
    simpa using and.intro hn'.ne' hn.ne' },

  have := prod_cyclotomic_eq_geom_sum hn' ℤ,
  apply_fun eval 1 at this,
  rw [eval_geom_sum, one_geom_sum, eval_prod, eq_comm,
      ←finset.prod_sdiff $ range_pow_padic_val_nat_subset_divisors' p, finset.prod_image] at this,
  simp_rw [eval_one_cyclotomic_prime_pow, finset.prod_const, finset.card_range, mul_comm] at this,
  rw [←finset.prod_sdiff $ show {n} ⊆ _, from _] at this,
  any_goals {apply_instance},
  swap,
  { simp only [not_exists, true_and, exists_prop, dvd_rfl, finset.mem_image, finset.mem_range,
    finset.mem_singleton, finset.singleton_subset_iff, finset.mem_sdiff, nat.mem_divisors, not_and],
    exact ⟨⟨hn'.ne', hn.ne'⟩, λ t _, h hp _⟩ },
  rw [←int.nat_abs_of_nat p, int.nat_abs_dvd_iff_dvd] at hpe,
  obtain ⟨t, ht⟩ := hpe,
  rw [finset.prod_singleton, ht, mul_left_comm, mul_comm, ←mul_assoc, mul_assoc] at this,
  have : (p ^ (padic_val_nat p n) * p : ℤ) ∣ n := ⟨_, this⟩,
  simp only [←pow_succ', ←int.nat_abs_dvd_iff_dvd, int.nat_abs_of_nat, int.nat_abs_pow] at this,
  exact pow_succ_padic_val_nat_not_dvd hn' this,
  { rintro x - y - hxy,
    apply nat.succ_injective,
    exact nat.pow_right_injective hp.two_le hxy }
end

lemma sub_one_pow_totient_lt_cyclotomic_eval {n : ℕ} {q : ℝ} (hn' : 2 ≤ n) (hq' : 1 < q) :
  (q - 1) ^ totient n < (cyclotomic n ℝ).eval q :=
begin
  have hn : 0 < n := pos_of_gt hn',
  have hq := zero_lt_one.trans hq',
  have hfor : ∀ ζ' ∈ primitive_roots n ℂ, q - 1 ≤ ∥↑q - ζ'∥,
  { intros ζ' hζ',
    rw mem_primitive_roots hn at hζ',
    convert norm_sub_norm_le (↑q) ζ',
    { rw [complex.norm_real, real.norm_of_nonneg hq.le], },
    { rw [hζ'.norm'_eq_one hn.ne'] } },
  let ζ := complex.exp (2 * ↑real.pi * complex.I / ↑n),
  have hζ : is_primitive_root ζ n := complex.is_primitive_root_exp n hn.ne',
  have hex : ∃ ζ' ∈ primitive_roots n ℂ, q - 1 < ∥↑q - ζ'∥,
  { refine ⟨ζ, (mem_primitive_roots hn).mpr hζ, _⟩,
    suffices : ¬ same_ray ℝ (q : ℂ) ζ,
    { convert lt_norm_sub_of_not_same_ray this;
      simp [real.norm_of_nonneg hq.le, hζ.norm'_eq_one hn.ne'] },
    rw complex.same_ray_iff,
    push_neg,
    refine ⟨by exact_mod_cast hq.ne', hζ.ne_zero hn.ne', _⟩,
    rw [complex.arg_of_real_of_nonneg hq.le, ne.def, eq_comm, hζ.arg_eq_zero_iff hn.ne'],
    clear_value ζ,
    rintro rfl,
    linarith [hζ.unique is_primitive_root.one] },
  have : ¬eval ↑q (cyclotomic n ℂ) = 0,
  { erw cyclotomic.eval_apply q n (algebra_map ℝ ℂ),
    simpa using (cyclotomic_pos' n hq').ne' },
  suffices : (units.mk0 (real.to_nnreal (q - 1)) (by simp [hq'])) ^ totient n
              < units.mk0 (∥(cyclotomic n ℂ).eval q∥₊) (by simp [this]),
  { simp only [←units.coe_lt_coe, units.coe_pow, units.coe_mk0, ← nnreal.coe_lt_coe, hq'.le,
               real.to_nnreal_lt_to_nnreal_iff_of_nonneg, coe_nnnorm, complex.norm_eq_abs,
               nnreal.coe_pow, real.coe_to_nnreal', max_eq_left, sub_nonneg] at this,
    convert this,
    erw [(cyclotomic.eval_apply q n (algebra_map ℝ ℂ)), eq_comm],
    simp [cyclotomic_nonneg n hq'.le], },
  simp only [cyclotomic_eq_prod_X_sub_primitive_roots hζ, eval_prod, eval_C,
             eval_X, eval_sub, nnnorm_prod, units.mk0_prod],
  convert prod_lt_prod' _ _,
  swap, { exact λ _, units.mk0 (real.to_nnreal (q - 1)) (by simp [hq']) },
  { simp [complex.card_primitive_roots] },
  { simp only [subtype.coe_mk, mem_attach, forall_true_left, subtype.forall, ←units.coe_le_coe,
      ← nnreal.coe_le_coe, complex.abs_nonneg, hq'.le, units.coe_mk0, real.coe_to_nnreal',
      coe_nnnorm, complex.norm_eq_abs, max_le_iff, tsub_le_iff_right],
    intros x hx,
    simpa using hfor x hx, },
  { simp only [subtype.coe_mk, mem_attach, exists_true_left, subtype.exists,
      ← nnreal.coe_lt_coe, ← units.coe_lt_coe, units.coe_mk0 _, coe_nnnorm],
    simpa [hq'.le] using hex, },
end

lemma cyclotomic_eval_lt_sub_one_pow_totient {n : ℕ} {q : ℝ} (hn' : 3 ≤ n) (hq' : 1 < q) :
  (cyclotomic n ℝ).eval q < (q + 1) ^ totient n :=
begin
  have hn : 0 < n := pos_of_gt hn',
  have hq := zero_lt_one.trans hq',
  have hfor : ∀ ζ' ∈ primitive_roots n ℂ, ∥↑q - ζ'∥ ≤ q + 1,
  { intros ζ' hζ',
    rw mem_primitive_roots hn at hζ',
    convert norm_sub_le (↑q) ζ',
    { rw [complex.norm_real, real.norm_of_nonneg (zero_le_one.trans_lt hq').le], },
    { rw [hζ'.norm'_eq_one hn.ne'] }, },
  let ζ := complex.exp (2 * ↑real.pi * complex.I / ↑n),
  have hζ : is_primitive_root ζ n := complex.is_primitive_root_exp n hn.ne',
  have hex : ∃ ζ' ∈ primitive_roots n ℂ, ∥↑q - ζ'∥ < q + 1,
  { refine ⟨ζ, (mem_primitive_roots hn).mpr hζ, _⟩,
    suffices : ¬ same_ray ℝ (q : ℂ) (-ζ),
    { convert norm_add_lt_of_not_same_ray this;
      simp [real.norm_of_nonneg hq.le, hζ.norm'_eq_one hn.ne', -complex.norm_eq_abs] },
    rw complex.same_ray_iff,
    push_neg,
    refine ⟨by exact_mod_cast hq.ne', neg_ne_zero.mpr $ hζ.ne_zero hn.ne', _⟩,
    rw [complex.arg_of_real_of_nonneg hq.le, ne.def, eq_comm],
    intro h,
    rw [complex.arg_eq_zero_iff, complex.neg_re, neg_nonneg, complex.neg_im, neg_eq_zero] at h,
    have hζ₀ : ζ ≠ 0,
    { clear_value ζ,
      rintro rfl,
      exact hn.ne' (hζ.unique is_primitive_root.zero) },
    have : ζ.re < 0 ∧ ζ.im = 0 := ⟨h.1.lt_of_ne _, h.2⟩,
    rw [←complex.arg_eq_pi_iff, hζ.arg_eq_pi_iff hn.ne'] at this,
    rw this at hζ,
    linarith [hζ.unique $ is_primitive_root.neg_one 0 two_ne_zero.symm],
    { contrapose! hζ₀,
      ext; simp [hζ₀, h.2] } },
  have : ¬eval ↑q (cyclotomic n ℂ) = 0,
  { erw cyclotomic.eval_apply q n (algebra_map ℝ ℂ),
    simp only [complex.coe_algebra_map, complex.of_real_eq_zero],
    exact (cyclotomic_pos' n hq').ne.symm, },
  suffices : units.mk0 (∥(cyclotomic n ℂ).eval q∥₊) (by simp [this])
           < (units.mk0 (real.to_nnreal (q + 1)) (by simp; linarith)) ^ totient n,
  { simp only [←units.coe_lt_coe, units.coe_pow, units.coe_mk0, ← nnreal.coe_lt_coe, hq'.le,
               real.to_nnreal_lt_to_nnreal_iff_of_nonneg, coe_nnnorm, complex.norm_eq_abs,
               nnreal.coe_pow, real.coe_to_nnreal', max_eq_left, sub_nonneg] at this,
    convert this,
    { erw [(cyclotomic.eval_apply q n (algebra_map ℝ ℂ)), eq_comm],
      simp [cyclotomic_nonneg n hq'.le] },
    rw [eq_comm, max_eq_left_iff],
    linarith },
  simp only [cyclotomic_eq_prod_X_sub_primitive_roots hζ, eval_prod, eval_C,
             eval_X, eval_sub, nnnorm_prod, units.mk0_prod],
  convert prod_lt_prod' _ _,
  swap, { exact λ _, units.mk0 (real.to_nnreal (q + 1)) (by simp; linarith only [hq']) },
  { simp [complex.card_primitive_roots], },
  { simp only [subtype.coe_mk, mem_attach, forall_true_left, subtype.forall, ←units.coe_le_coe,
      ← nnreal.coe_le_coe, complex.abs_nonneg, hq'.le, units.coe_mk0, real.coe_to_nnreal,
      coe_nnnorm, complex.norm_eq_abs, max_le_iff],
    intros x hx,
    have : complex.abs _ ≤ _ := hfor x hx,
    simp [this], },
  { simp only [subtype.coe_mk, mem_attach, exists_true_left, subtype.exists,
      ← nnreal.coe_lt_coe, ← units.coe_lt_coe, units.coe_mk0 _, coe_nnnorm],
    obtain ⟨ζ, hζ, hhζ : complex.abs _ < _⟩ := hex,
    exact ⟨ζ, hζ, by simp [hhζ]⟩ },
end

lemma sub_one_lt_nat_abs_cyclotomic_eval {n : ℕ} {q : ℕ} (hn' : 1 < n) (hq' : q ≠ 1) :
  q - 1 < ((cyclotomic n ℤ).eval ↑q).nat_abs :=
begin
  rcases q with _ | _ | q,
  iterate 2
  { rw [pos_iff_ne_zero, ne.def, int.nat_abs_eq_zero],
    intro h,
    have := degree_eq_one_of_irreducible_of_root (cyclotomic.irreducible (pos_of_gt hn')) h,
    rw [degree_cyclotomic, with_top.coe_eq_one, totient_eq_one_iff] at this,
    rcases this with rfl|rfl; simpa using h },
  suffices : (q.succ : ℝ) < (eval (↑q + 1 + 1) (cyclotomic n ℤ)).nat_abs,
  { exact_mod_cast this },
  calc _ ≤ ((q + 2 - 1) ^ n.totient : ℝ) : _
    ...  < _ : _,
  { norm_num,
    convert pow_mono (by simp : 1 ≤ (q : ℝ) + 1) (totient_pos (pos_of_gt hn') : 1 ≤ n.totient),
    { simp },
    { ring }, },
  convert sub_one_pow_totient_lt_cyclotomic_eval (show 2 ≤ n, by linarith)
                          (show (1 : ℝ) < q + 2, by {norm_cast, linarith}),
  norm_cast,
  erw cyclotomic.eval_apply (q + 2 : ℤ) n (algebra_map ℤ ℝ),
  simp only [int.coe_nat_succ, ring_hom.eq_int_cast],
  norm_cast,
  rw [int.coe_nat_abs_eq_normalize, int.normalize_of_nonneg],
  simp only [int.coe_nat_succ],
  exact cyclotomic_nonneg n (by linarith),
end

end polynomial


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.nat.interval
import data.pnat.defs

/-!
# Finite intervals of positive naturals

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file proves that `ℕ+` is a `locally_finite_order` and calculates the cardinality of its
intervals as finsets and fintypes.
-/

open finset pnat

instance : locally_finite_order ℕ+ := subtype.locally_finite_order _

namespace pnat
variables (a b : ℕ+)

lemma Icc_eq_finset_subtype : Icc a b = (Icc (a : ℕ) b).subtype (λ (n : ℕ), 0 < n) := rfl
lemma Ico_eq_finset_subtype : Ico a b = (Ico (a : ℕ) b).subtype (λ (n : ℕ), 0 < n) := rfl
lemma Ioc_eq_finset_subtype : Ioc a b = (Ioc (a : ℕ) b).subtype (λ (n : ℕ), 0 < n) := rfl
lemma Ioo_eq_finset_subtype : Ioo a b = (Ioo (a : ℕ) b).subtype (λ (n : ℕ), 0 < n) := rfl

lemma map_subtype_embedding_Icc : (Icc a b).map (function.embedding.subtype _) = Icc (a : ℕ) b :=
map_subtype_embedding_Icc _ _ _ (λ c _ x hx _ hc _, hc.trans_le hx)

lemma map_subtype_embedding_Ico : (Ico a b).map (function.embedding.subtype _) = Ico (a : ℕ) b :=
map_subtype_embedding_Ico _ _ _ (λ c _ x hx _ hc _, hc.trans_le hx)

lemma map_subtype_embedding_Ioc : (Ioc a b).map (function.embedding.subtype _) = Ioc (a : ℕ) b :=
map_subtype_embedding_Ioc _ _ _ (λ c _ x hx _ hc _, hc.trans_le hx)

lemma map_subtype_embedding_Ioo : (Ioo a b).map (function.embedding.subtype _) = Ioo (a : ℕ) b :=
map_subtype_embedding_Ioo _ _ _ (λ c _ x hx _ hc _, hc.trans_le hx)

@[simp] lemma card_Icc : (Icc a b).card = b + 1 - a :=
by rw [←nat.card_Icc, ←map_subtype_embedding_Icc, card_map]

@[simp] lemma card_Ico : (Ico a b).card = b - a :=
by rw [←nat.card_Ico, ←map_subtype_embedding_Ico, card_map]

@[simp] lemma card_Ioc : (Ioc a b).card = b - a :=
by rw [←nat.card_Ioc, ←map_subtype_embedding_Ioc, card_map]

@[simp] lemma card_Ioo : (Ioo a b).card = b - a - 1 :=
by rw [←nat.card_Ioo, ←map_subtype_embedding_Ioo, card_map]

@[simp] lemma card_fintype_Icc : fintype.card (set.Icc a b) = b + 1 - a :=
by rw [←card_Icc, fintype.card_of_finset]

@[simp] lemma card_fintype_Ico : fintype.card (set.Ico a b) = b - a :=
by rw [←card_Ico, fintype.card_of_finset]

@[simp] lemma card_fintype_Ioc : fintype.card (set.Ioc a b) = b - a :=
by rw [←card_Ioc, fintype.card_of_finset]

@[simp] lemma card_fintype_Ioo : fintype.card (set.Ioo a b) = b - a - 1 :=
by rw [←card_Ioo, fintype.card_of_finset]

end pnat