/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import data.rat.defs
import data.int.cast.lemmas
import data.int.div
import algebra.group_with_zero.units.lemmas
import tactic.nth_rewrite

/-!
# Further lemmas for the Rational Numbers

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

-/

namespace rat
open_locale rat

theorem num_dvd (a) {b : ℤ} (b0 : b ≠ 0) : (a /. b).num ∣ a :=
begin
  cases e : a /. b with n d h c,
  rw [rat.num_denom', rat.mk_eq b0
    (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.nat_abs_dvd.1 $ int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $
    c.dvd_of_dvd_mul_right _),
  have := congr_arg int.nat_abs e,
  simp only [int.nat_abs_mul, int.nat_abs_of_nat] at this, simp [this]
end

theorem denom_dvd (a b : ℤ) : ((a /. b).denom : ℤ) ∣ b :=
begin
  by_cases b0 : b = 0, {simp [b0]},
  cases e : a /. b with n d h c,
  rw [num_denom', mk_eq b0 (ne_of_gt (int.coe_nat_pos.2 h))] at e,
  refine (int.dvd_nat_abs.1 $ int.coe_nat_dvd.2 $ c.symm.dvd_of_dvd_mul_left _),
  rw [← int.nat_abs_mul, ← int.coe_nat_dvd, int.dvd_nat_abs, ← e], simp
end

lemma num_denom_mk {q : ℚ} {n d : ℤ} (hd : d ≠ 0) (qdf : q = n /. d) :
  ∃ c : ℤ, n = c * q.num ∧ d = c * q.denom :=
begin
  obtain rfl|hn := eq_or_ne n 0,
  { simp [qdf] },
  have : q.num * d = n * ↑(q.denom),
  { refine (rat.mk_eq _ hd).mp _,
    { exact int.coe_nat_ne_zero.mpr (rat.denom_ne_zero _) },
    { rwa [num_denom] } },
  have hqdn : q.num ∣ n,
  { rw qdf, exact rat.num_dvd _ hd },
  refine ⟨n / q.num, _, _⟩,
  { rw int.div_mul_cancel hqdn },
  { refine int.eq_mul_div_of_mul_eq_mul_of_dvd_left _ hqdn this,
    rw qdf,
    exact rat.num_ne_zero_of_ne_zero ((mk_ne_zero hd).mpr hn) }
end

theorem mk_pnat_num (n : ℤ) (d : ℕ+) :
  (mk_pnat n d).num = n / nat.gcd n.nat_abs d :=
by cases d; refl

theorem mk_pnat_denom (n : ℤ) (d : ℕ+) :
  (mk_pnat n d).denom = d / nat.gcd n.nat_abs d :=
by cases d; refl

lemma num_mk (n d : ℤ) :
  (n /. d).num = d.sign * n / n.gcd d :=
begin
  rcases d with ((_ | _) | _);
    simp [rat.mk, mk_nat, mk_pnat, nat.succ_pnat, int.sign, int.gcd,
      -nat.cast_succ, -int.coe_nat_succ, int.zero_div]
end

lemma denom_mk (n d : ℤ) :
  (n /. d).denom = if d = 0 then 1 else d.nat_abs / n.gcd d :=
begin
  rcases d with ((_ | _) | _);
  simp [rat.mk, mk_nat, mk_pnat, nat.succ_pnat, int.sign, int.gcd,
    -nat.cast_succ, -int.coe_nat_succ]
end

theorem mk_pnat_denom_dvd (n : ℤ) (d : ℕ+) :
  (mk_pnat n d).denom ∣ d.1 :=
begin
  rw mk_pnat_denom,
  apply nat.div_dvd_of_dvd,
  apply nat.gcd_dvd_right
end

theorem mul_denom_dvd (q₁ q₂ : ℚ) : (q₁ * q₂).denom ∣ q₁.denom * q₂.denom :=
by { cases q₁, cases q₂, apply mk_pnat_denom_dvd }

theorem mul_num (q₁ q₂ : ℚ) : (q₁ * q₂).num =
  (q₁.num * q₂.num) / nat.gcd (q₁.num * q₂.num).nat_abs (q₁.denom * q₂.denom) :=
by cases q₁; cases q₂; refl

theorem mul_denom (q₁ q₂ : ℚ) : (q₁ * q₂).denom =
  (q₁.denom * q₂.denom) / nat.gcd (q₁.num * q₂.num).nat_abs (q₁.denom * q₂.denom) :=
by cases q₁; cases q₂; refl

theorem mul_self_num (q : ℚ) : (q * q).num = q.num * q.num :=
by rw [mul_num, int.nat_abs_mul, nat.coprime.gcd_eq_one, int.coe_nat_one, int.div_one];
exact (q.cop.mul_right q.cop).mul (q.cop.mul_right q.cop)

theorem mul_self_denom (q : ℚ) : (q * q).denom = q.denom * q.denom :=
by rw [rat.mul_denom, int.nat_abs_mul, nat.coprime.gcd_eq_one, nat.div_one];
exact (q.cop.mul_right q.cop).mul (q.cop.mul_right q.cop)

lemma add_num_denom (q r : ℚ) : q + r =
  ((q.num * r.denom + q.denom * r.num : ℤ)) /. (↑q.denom * ↑r.denom : ℤ) :=
have hqd : (q.denom : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 q.3,
have hrd : (r.denom : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 r.3,
by conv_lhs { rw [←@num_denom q, ←@num_denom r, rat.add_def hqd hrd] };
  simp [mul_comm]

section casts

lemma exists_eq_mul_div_num_and_eq_mul_div_denom (n : ℤ) {d : ℤ} (d_ne_zero : d ≠ 0) :
  ∃ (c : ℤ), n = c * ((n : ℚ) / d).num ∧ (d : ℤ) = c * ((n : ℚ) / d).denom :=
begin
  have : ((n : ℚ) / d) = rat.mk n d, by rw [←rat.mk_eq_div],
  exact rat.num_denom_mk d_ne_zero this
end

lemma mul_num_denom' (q r : ℚ) :
  (q * r).num * q.denom * r.denom = q.num * r.num * (q * r).denom :=
begin
  let s := (q.num * r.num) /. (q.denom * r.denom : ℤ),
  have hs : (q.denom * r.denom : ℤ) ≠ 0 := int.coe_nat_ne_zero_iff_pos.mpr (mul_pos q.pos r.pos),
  obtain ⟨c, ⟨c_mul_num, c_mul_denom⟩⟩ :=
    exists_eq_mul_div_num_and_eq_mul_div_denom (q.num * r.num) hs,
  rw [c_mul_num, mul_assoc, mul_comm],
  nth_rewrite 0 c_mul_denom,
  repeat {rw mul_assoc},
  apply mul_eq_mul_left_iff.2,
  rw or_iff_not_imp_right,
  intro c_pos,
  have h : _ = s := @mul_def q.num q.denom r.num r.denom
    (int.coe_nat_ne_zero_iff_pos.mpr q.pos)
    (int.coe_nat_ne_zero_iff_pos.mpr  r.pos),
  rw [num_denom, num_denom] at h,
  rw h,
  rw mul_comm,
  apply rat.eq_iff_mul_eq_mul.mp,
  rw ←mk_eq_div,
end

lemma add_num_denom' (q r : ℚ) :
  (q + r).num * q.denom * r.denom = (q.num * r.denom + r.num * q.denom) * (q + r).denom :=
begin
  let s := mk (q.num * r.denom + r.num * q.denom) (q.denom * r.denom : ℤ),
  have hs : (q.denom * r.denom : ℤ) ≠ 0 := int.coe_nat_ne_zero_iff_pos.mpr (mul_pos q.pos r.pos),
  obtain ⟨c, ⟨c_mul_num, c_mul_denom⟩⟩ := exists_eq_mul_div_num_and_eq_mul_div_denom
    (q.num * r.denom + r.num * q.denom) hs,
  rw [c_mul_num, mul_assoc, mul_comm],
  nth_rewrite 0 c_mul_denom,
  repeat {rw mul_assoc},
  apply mul_eq_mul_left_iff.2,
  rw or_iff_not_imp_right,
  intro c_pos,
  have h : _ = s := @add_def q.num q.denom r.num r.denom
    (int.coe_nat_ne_zero_iff_pos.mpr q.pos)
    (int.coe_nat_ne_zero_iff_pos.mpr  r.pos),
  rw [num_denom, num_denom] at h,
  rw h,
  rw mul_comm,
  apply rat.eq_iff_mul_eq_mul.mp,
  rw ←mk_eq_div,
end

lemma substr_num_denom' (q r : ℚ) :
  (q - r).num * q.denom * r.denom = (q.num * r.denom - r.num * q.denom) * (q - r).denom :=
by rw [sub_eq_add_neg, sub_eq_add_neg, ←neg_mul, ←num_neg_eq_neg_num, ←denom_neg_eq_denom r,
  add_num_denom' q (-r)]

end casts

lemma inv_def' {q : ℚ} : q⁻¹ = (q.denom : ℚ) / q.num :=
by { conv_lhs { rw ←@num_denom q }, rw [inv_def, mk_eq_div, int.cast_coe_nat] }

protected lemma inv_neg (q : ℚ) : (-q)⁻¹ = -q⁻¹ := by { rw ←@num_denom q, simp [-num_denom] }

@[simp] lemma mul_denom_eq_num {q : ℚ} : q * q.denom = q.num :=
begin
  suffices : mk (q.num) ↑(q.denom) * mk ↑(q.denom) 1 = mk (q.num) 1, by
  { conv { for q [1] { rw ←(@num_denom q) }}, rwa [coe_int_eq_mk, coe_nat_eq_mk] },
  have : (q.denom : ℤ) ≠ 0, from ne_of_gt (by exact_mod_cast q.pos),
  rw [(rat.mul_def this one_ne_zero), (mul_comm (q.denom : ℤ) 1), (div_mk_div_cancel_left this)]
end

lemma denom_div_cast_eq_one_iff (m n : ℤ) (hn : n ≠ 0) :
  ((m : ℚ) / n).denom = 1 ↔ n ∣ m :=
begin
  replace hn : (n:ℚ) ≠ 0, by rwa [ne.def, ← int.cast_zero, coe_int_inj],
  split,
  { intro h,
    lift ((m : ℚ) / n) to ℤ using h with k hk,
    use k,
    rwa [eq_div_iff_mul_eq hn, ← int.cast_mul, mul_comm, eq_comm, coe_int_inj] at hk },
  { rintros ⟨d, rfl⟩,
    rw [int.cast_mul, mul_comm, mul_div_cancel _ hn, rat.coe_int_denom] }
end

lemma num_div_eq_of_coprime {a b : ℤ} (hb0 : 0 < b) (h : nat.coprime a.nat_abs b.nat_abs) :
  (a / b : ℚ).num = a :=
begin
  lift b to ℕ using le_of_lt hb0,
  norm_cast at hb0 h,
  rw [← rat.mk_eq_div, ← rat.mk_pnat_eq a b hb0, rat.mk_pnat_num, pnat.mk_coe, h.gcd_eq_one,
    int.coe_nat_one, int.div_one]
end

lemma denom_div_eq_of_coprime {a b : ℤ} (hb0 : 0 < b) (h : nat.coprime a.nat_abs b.nat_abs) :
  ((a / b : ℚ).denom : ℤ) = b :=
begin
  lift b to ℕ using le_of_lt hb0,
  norm_cast at hb0 h,
  rw [← rat.mk_eq_div, ← rat.mk_pnat_eq a b hb0, rat.mk_pnat_denom, pnat.mk_coe, h.gcd_eq_one,
    nat.div_one]
end

lemma div_int_inj {a b c d : ℤ} (hb0 : 0 < b) (hd0 : 0 < d)
  (h1 : nat.coprime a.nat_abs b.nat_abs) (h2 : nat.coprime c.nat_abs d.nat_abs)
  (h : (a : ℚ) / b = (c : ℚ) / d) : a = c ∧ b = d :=
begin
  apply and.intro,
  { rw [← (num_div_eq_of_coprime hb0 h1), h, num_div_eq_of_coprime hd0 h2] },
  { rw [← (denom_div_eq_of_coprime hb0 h1), h, denom_div_eq_of_coprime hd0 h2] }
end

@[norm_cast] lemma coe_int_div_self (n : ℤ) : ((n / n : ℤ) : ℚ) = n / n :=
begin
  by_cases hn : n = 0,
  { subst hn, simp only [int.cast_zero, int.zero_div, zero_div] },
  { have : (n : ℚ) ≠ 0, { rwa ← coe_int_inj at hn },
    simp only [int.div_self hn, int.cast_one, ne.def, not_false_iff, div_self this] }
end

@[norm_cast] lemma coe_nat_div_self (n : ℕ) : ((n / n : ℕ) : ℚ) = n / n :=
coe_int_div_self n

lemma coe_int_div (a b : ℤ) (h : b ∣ a) : ((a / b : ℤ) : ℚ) = a / b :=
begin
  rcases h with ⟨c, rfl⟩,
  simp only [mul_comm b, int.mul_div_assoc c (dvd_refl b), int.cast_mul, mul_div_assoc,
    coe_int_div_self]
end

lemma coe_nat_div (a b : ℕ) (h : b ∣ a) : ((a / b : ℕ) : ℚ) = a / b :=
begin
  rcases h with ⟨c, rfl⟩,
  simp only [mul_comm b, nat.mul_div_assoc c (dvd_refl b), nat.cast_mul, mul_div_assoc,
    coe_nat_div_self]
end

lemma inv_coe_int_num_of_pos {a : ℤ} (ha0 : 0 < a) : (a : ℚ)⁻¹.num = 1 :=
begin
  rw [rat.inv_def', rat.coe_int_num, rat.coe_int_denom, nat.cast_one, ←int.cast_one],
  apply num_div_eq_of_coprime ha0,
  rw int.nat_abs_one,
  exact nat.coprime_one_left _,
end

lemma inv_coe_nat_num_of_pos {a : ℕ} (ha0 : 0 < a) : (a : ℚ)⁻¹.num = 1 :=
inv_coe_int_num_of_pos (by exact_mod_cast ha0 : 0 < (a : ℤ))

lemma inv_coe_int_denom_of_pos {a : ℤ} (ha0 : 0 < a) : ((a : ℚ)⁻¹.denom : ℤ) = a :=
begin
  rw [rat.inv_def', rat.coe_int_num, rat.coe_int_denom, nat.cast_one, ←int.cast_one],
  apply denom_div_eq_of_coprime ha0,
  rw int.nat_abs_one,
  exact nat.coprime_one_left _,
end

lemma inv_coe_nat_denom_of_pos {a : ℕ} (ha0 : 0 < a) : (a : ℚ)⁻¹.denom = a :=
begin
  rw [← int.coe_nat_eq_coe_nat_iff, ← int.cast_coe_nat a, inv_coe_int_denom_of_pos],
  rwa [← nat.cast_zero, nat.cast_lt]
end

@[simp] lemma inv_coe_int_num (a : ℤ) : (a : ℚ)⁻¹.num = int.sign a :=
begin
  induction a using int.induction_on;
  simp [←int.neg_succ_of_nat_coe', int.neg_succ_of_nat_coe, -neg_add_rev, rat.inv_neg,
        int.coe_nat_add_one_out, -nat.cast_succ, inv_coe_nat_num_of_pos, -int.cast_neg_succ_of_nat,
        @eq_comm ℤ 1, int.sign_eq_one_of_pos]
end

@[simp] lemma inv_coe_nat_num (a : ℕ) : (a : ℚ)⁻¹.num = int.sign a :=
inv_coe_int_num a

@[simp] lemma inv_coe_int_denom (a : ℤ) : (a : ℚ)⁻¹.denom = if a = 0 then 1 else a.nat_abs :=
begin
  induction a using int.induction_on;
  simp [←int.neg_succ_of_nat_coe', int.neg_succ_of_nat_coe, -neg_add_rev, rat.inv_neg,
        int.coe_nat_add_one_out, -nat.cast_succ, inv_coe_nat_denom_of_pos,
        -int.cast_neg_succ_of_nat]
end

@[simp] lemma inv_coe_nat_denom (a : ℕ) : (a : ℚ)⁻¹.denom = if a = 0 then 1 else a :=
by simpa using inv_coe_int_denom a

protected lemma «forall» {p : ℚ → Prop} : (∀ r, p r) ↔ ∀ a b : ℤ, p (a / b) :=
⟨λ h _ _, h _,
  λ h q, (show q = q.num / q.denom, from by simp [rat.div_num_denom]).symm ▸ (h q.1 q.2)⟩

protected lemma «exists» {p : ℚ → Prop} : (∃ r, p r) ↔ ∃ a b : ℤ, p (a / b) :=
⟨λ ⟨r, hr⟩, ⟨r.num, r.denom, by rwa [← mk_eq_div, num_denom]⟩, λ ⟨a, b, h⟩, ⟨_, h⟩⟩

/-!
### Denominator as `ℕ+`
-/
section pnat_denom

/-- Denominator as `ℕ+`. -/
def pnat_denom (x : ℚ) : ℕ+ := ⟨x.denom, x.pos⟩

@[simp] lemma coe_pnat_denom (x : ℚ) : (x.pnat_denom : ℕ) = x.denom := rfl

@[simp] lemma mk_pnat_pnat_denom_eq (x : ℚ) : mk_pnat x.num x.pnat_denom = x :=
by rw [pnat_denom, mk_pnat_eq, num_denom]

lemma pnat_denom_eq_iff_denom_eq {x : ℚ} {n : ℕ+} : x.pnat_denom = n ↔ x.denom = ↑n :=
subtype.ext_iff

@[simp] lemma pnat_denom_one : (1 : ℚ).pnat_denom = 1 := rfl

@[simp] lemma pnat_denom_zero : (0 : ℚ).pnat_denom = 1 := rfl

end pnat_denom

end rat


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

! This file was ported from Lean 3 source module topology.sheaves.stalks
! leanprover-community/mathlib commit e2e38c005fc6f715502490da6cb0ec84df9ed228
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Category.Top.OpenNhds
import Mathbin.Topology.Sheaves.Presheaf
import Mathbin.Topology.Sheaves.SheafCondition.UniqueGluing
import Mathbin.CategoryTheory.Adjunction.Evaluation
import Mathbin.CategoryTheory.Limits.Types
import Mathbin.CategoryTheory.Limits.Preserves.Filtered
import Mathbin.CategoryTheory.Limits.Final
import Mathbin.Tactic.Elementwise
import Mathbin.Algebra.Category.Ring.Colimits
import Mathbin.CategoryTheory.Sites.Pushforward

/-!
# Stalks

For a presheaf `F` on a topological space `X`, valued in some category `C`, the *stalk* of `F`
at the point `x : X` is defined as the colimit of the composition of the inclusion of categories
`(nhds x)ᵒᵖ ⥤ (opens X)ᵒᵖ` and the functor `F : (opens X)ᵒᵖ ⥤ C`.
For an open neighborhood `U` of `x`, we define the map `F.germ x : F.obj (op U) ⟶ F.stalk x` as the
canonical morphism into this colimit.

Taking stalks is functorial: For every point `x : X` we define a functor `stalk_functor C x`,
sending presheaves on `X` to objects of `C`. Furthermore, for a map `f : X ⟶ Y` between
topological spaces, we define `stalk_pushforward` as the induced map on the stalks
`(f _* ℱ).stalk (f x) ⟶ ℱ.stalk x`.

Some lemmas about stalks and germs only hold for certain classes of concrete categories. A basic
property of forgetful functors of categories of algebraic structures (like `Mon`, `CommRing`,...)
is that they preserve filtered colimits. Since stalks are filtered colimits, this ensures that
the stalks of presheaves valued in these categories behave exactly as for `Type`-valued presheaves.
For example, in `germ_exist` we prove that in such a category, every element of the stalk is the
germ of a section.

Furthermore, if we require the forgetful functor to reflect isomorphisms and preserve limits (as
is the case for most algebraic structures), we have access to the unique gluing API and can prove
further properties. Most notably, in `is_iso_iff_stalk_functor_map_iso`, we prove that in such
a category, a morphism of sheaves is an isomorphism if and only if all of its stalk maps are
isomorphisms.

See also the definition of "algebraic structures" in the stacks project:
https://stacks.math.columbia.edu/tag/007L

-/

noncomputable section

universe v u v' u'

open CategoryTheory

open TopCat

open CategoryTheory.Limits

open TopologicalSpace

open Opposite

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

variable [HasColimits.{v} C]

variable {X Y Z : TopCat.{v}}

namespace TopCat.Presheaf

variable (C)

/-- Stalks are functorial with respect to morphisms of presheaves over a fixed `X`. -/
def stalkFunctor (x : X) : X.Presheaf C ⥤ C :=
  (whiskeringLeft _ _ C).obj (OpenNhds.inclusion x).op ⋙ colim
#align Top.presheaf.stalk_functor TopCat.Presheaf.stalkFunctor

variable {C}

/-- The stalk of a presheaf `F` at a point `x` is calculated as the colimit of the functor
nbhds x ⥤ opens F.X ⥤ C
-/
def stalk (ℱ : X.Presheaf C) (x : X) : C :=
  (stalkFunctor C x).obj ℱ
#align Top.presheaf.stalk TopCat.Presheaf.stalk

-- -- colimit ((open_nhds.inclusion x).op ⋙ ℱ)
@[simp]
theorem stalkFunctor_obj (ℱ : X.Presheaf C) (x : X) : (stalkFunctor C x).obj ℱ = ℱ.stalk x :=
  rfl
#align Top.presheaf.stalk_functor_obj TopCat.Presheaf.stalkFunctor_obj

/-- The germ of a section of a presheaf over an open at a point of that open.
-/
def germ (F : X.Presheaf C) {U : Opens X} (x : U) : F.obj (op U) ⟶ stalk F x :=
  colimit.ι ((OpenNhds.inclusion x.1).op ⋙ F) (op ⟨U, x.2⟩)
#align Top.presheaf.germ TopCat.Presheaf.germ

@[simp, elementwise]
theorem germ_res (F : X.Presheaf C) {U V : Opens X} (i : U ⟶ V) (x : U) :
    F.map i.op ≫ germ F x = germ F (i x : V) :=
  let i' : (⟨U, x.2⟩ : OpenNhds x.1) ⟶ ⟨V, (i x : V).2⟩ := i
  colimit.w ((OpenNhds.inclusion x.1).op ⋙ F) i'.op
#align Top.presheaf.germ_res TopCat.Presheaf.germ_res

/-- A morphism from the stalk of `F` at `x` to some object `Y` is completely determined by its
composition with the `germ` morphisms.
-/
theorem stalk_hom_ext (F : X.Presheaf C) {x} {Y : C} {f₁ f₂ : F.stalk x ⟶ Y}
    (ih : ∀ (U : Opens X) (hxU : x ∈ U), F.germ ⟨x, hxU⟩ ≫ f₁ = F.germ ⟨x, hxU⟩ ≫ f₂) : f₁ = f₂ :=
  colimit.hom_ext fun U => by
    induction U using Opposite.rec
    cases' U with U hxU
    exact ih U hxU
#align Top.presheaf.stalk_hom_ext TopCat.Presheaf.stalk_hom_ext

@[simp, reassoc.1, elementwise]
theorem stalkFunctor_map_germ {F G : X.Presheaf C} (U : Opens X) (x : U) (f : F ⟶ G) :
    germ F x ≫ (stalkFunctor C x.1).map f = f.app (op U) ≫ germ G x :=
  colimit.ι_map (whiskerLeft (OpenNhds.inclusion x.1).op f) (op ⟨U, x.2⟩)
#align Top.presheaf.stalk_functor_map_germ TopCat.Presheaf.stalkFunctor_map_germ

variable (C)

/-- For a presheaf `F` on a space `X`, a continuous map `f : X ⟶ Y` induces a morphisms between the
stalk of `f _ * F` at `f x` and the stalk of `F` at `x`.
-/
def stalkPushforward (f : X ⟶ Y) (F : X.Presheaf C) (x : X) : (f _* F).stalk (f x) ⟶ F.stalk x :=
  by
  -- This is a hack; Lean doesn't like to elaborate the term written directly.
  trans
  swap
  exact colimit.pre _ (open_nhds.map f x).op
  exact colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) F)
#align Top.presheaf.stalk_pushforward TopCat.Presheaf.stalkPushforward

@[simp, elementwise, reassoc.1]
theorem stalkPushforward_germ (f : X ⟶ Y) (F : X.Presheaf C) (U : Opens Y)
    (x : (Opens.map f).obj U) : (f _* F).germ ⟨f x, x.2⟩ ≫ F.stalkPushforward C f x = F.germ x :=
  by
  rw [stalk_pushforward, germ, colimit.ι_map_assoc, colimit.ι_pre, whisker_right_app]
  erw [CategoryTheory.Functor.map_id, category.id_comp]
  rfl
#align Top.presheaf.stalk_pushforward_germ TopCat.Presheaf.stalkPushforward_germ

-- Here are two other potential solutions, suggested by @fpvandoorn at
-- <https://github.com/leanprover-community/mathlib/pull/1018#discussion_r283978240>
-- However, I can't get the subsequent two proofs to work with either one.
-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- colim.map ((functor.associator _ _ _).inv ≫
--   whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op
-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- (colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) :
--   colim.obj ((open_nhds.inclusion (f x) ⋙ opens.map f).op ⋙ ℱ) ⟶ _) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op
namespace StalkPushforward

attribute [local tidy] tactic.op_induction'

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic tactic.op_induction' -/
@[simp]
theorem id (ℱ : X.Presheaf C) (x : X) :
    ℱ.stalkPushforward C (𝟙 X) x = (stalkFunctor C x).map (Pushforward.id ℱ).Hom :=
  by
  dsimp [stalk_pushforward, stalk_functor]
  ext1
  run_tac
    tactic.op_induction'
  rcases j with ⟨⟨_, _⟩, _⟩
  rw [colimit.ι_map_assoc, colimit.ι_map, colimit.ι_pre, whisker_left_app, whisker_right_app,
    pushforward.id_hom_app, eq_to_hom_map, eq_to_hom_refl]
  dsimp
  -- FIXME A simp lemma which unfortunately doesn't fire:
  erw [CategoryTheory.Functor.map_id]
#align Top.presheaf.stalk_pushforward.id TopCat.Presheaf.stalkPushforward.id

-- This proof is sadly not at all robust:
-- having to use `erw` at all is a bad sign.
@[simp]
theorem comp (ℱ : X.Presheaf C) (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
    ℱ.stalkPushforward C (f ≫ g) x =
      (f _* ℱ).stalkPushforward C g (f x) ≫ ℱ.stalkPushforward C f x :=
  by
  dsimp [stalk_pushforward, stalk_functor]
  ext U
  induction U using Opposite.rec
  rcases U with ⟨⟨_, _⟩, _⟩
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc, whisker_right_app, category.assoc]
  dsimp
  -- FIXME: Some of these are simp lemmas, but don't fire successfully:
  erw [CategoryTheory.Functor.map_id, category.id_comp, category.id_comp, category.id_comp,
    colimit.ι_pre, colimit.ι_pre]
  rfl
#align Top.presheaf.stalk_pushforward.comp TopCat.Presheaf.stalkPushforward.comp

theorem stalkPushforward_iso_of_openEmbedding {f : X ⟶ Y} (hf : OpenEmbedding f) (F : X.Presheaf C)
    (x : X) : IsIso (F.stalkPushforward _ f x) :=
  by
  haveI := functor.initial_of_adjunction (hf.is_open_map.adjunction_nhds x)
  convert is_iso.of_iso
      ((functor.final.colimit_iso (hf.is_open_map.functor_nhds x).op
              ((open_nhds.inclusion (f x)).op ⋙ f _* F) :
            _).symm ≪≫
        colim.map_iso _)
  swap
  · fapply nat_iso.of_components
    · intro U
      refine' F.map_iso (eq_to_iso _)
      dsimp only [functor.op]
      exact congr_arg op (opens.ext <| Set.preimage_image_eq (unop U).1.1 hf.inj)
    · intro U V i
      erw [← F.map_comp, ← F.map_comp]
      congr
  · ext U
    rw [← iso.comp_inv_eq]
    erw [colimit.ι_map_assoc]
    rw [colimit.ι_pre, category.assoc]
    erw [colimit.ι_map_assoc, colimit.ι_pre, ← F.map_comp_assoc]
    apply colimit.w ((open_nhds.inclusion (f x)).op ⋙ f _* F) _
    dsimp only [functor.op]
    refine' ((hom_of_le _).op : op (unop U) ⟶ _)
    exact Set.image_preimage_subset _ _
#align Top.presheaf.stalk_pushforward.stalk_pushforward_iso_of_open_embedding TopCat.Presheaf.stalkPushforward.stalkPushforward_iso_of_openEmbedding

end StalkPushforward

section StalkPullback

/-- The morphism `ℱ_{f x} ⟶ (f⁻¹ℱ)ₓ` that factors through `(f_*f⁻¹ℱ)_{f x}`. -/
def stalkPullbackHom (f : X ⟶ Y) (F : Y.Presheaf C) (x : X) :
    F.stalk (f x) ⟶ (pullbackObj f F).stalk x :=
  (stalkFunctor _ (f x)).map ((pushforwardPullbackAdjunction C f).Unit.app F) ≫
    stalkPushforward _ _ _ x
#align Top.presheaf.stalk_pullback_hom TopCat.Presheaf.stalkPullbackHom

/-- The morphism `(f⁻¹ℱ)(U) ⟶ ℱ_{f(x)}` for some `U ∋ x`. -/
def germToPullbackStalk (f : X ⟶ Y) (F : Y.Presheaf C) (U : Opens X) (x : U) :
    (pullbackObj f F).obj (op U) ⟶ F.stalk (f x) :=
  colimit.desc (Lan.diagram (Opens.map f).op F (op U))
    { pt := F.stalk (f x)
      ι :=
        { app := fun V => F.germ ⟨f x, V.Hom.unop.le x.2⟩
          naturality' := fun _ _ i => by
            erw [category.comp_id]
            exact F.germ_res i.left.unop _ } }
#align Top.presheaf.germ_to_pullback_stalk TopCat.Presheaf.germToPullbackStalk

/-- The morphism `(f⁻¹ℱ)ₓ ⟶ ℱ_{f(x)}`. -/
def stalkPullbackInv (f : X ⟶ Y) (F : Y.Presheaf C) (x : X) :
    (pullbackObj f F).stalk x ⟶ F.stalk (f x) :=
  colimit.desc ((OpenNhds.inclusion x).op ⋙ Presheaf.pullbackObj f F)
    { pt := F.stalk (f x)
      ι :=
        { app := fun U => F.germToPullbackStalk _ f (unop U).1 ⟨x, (unop U).2⟩
          naturality' := fun _ _ _ =>
            by
            erw [colimit.pre_desc, category.comp_id]
            congr } }
#align Top.presheaf.stalk_pullback_inv TopCat.Presheaf.stalkPullbackInv

/-- The isomorphism `ℱ_{f(x)} ≅ (f⁻¹ℱ)ₓ`. -/
def stalkPullbackIso (f : X ⟶ Y) (F : Y.Presheaf C) (x : X) :
    F.stalk (f x) ≅ (pullbackObj f F).stalk x
    where
  Hom := stalkPullbackHom _ _ _ _
  inv := stalkPullbackInv _ _ _ _
  hom_inv_id' :=
    by
    delta
      stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward germ_to_pullback_stalk germ
    ext j
    induction j using Opposite.rec
    cases j
    simp only [TopologicalSpace.OpenNhds.inclusionMapIso_inv, whisker_right_app, whisker_left_app,
      whiskering_left_obj_map, functor.comp_map, colimit.ι_map_assoc, nat_trans.op_id, Lan_obj_map,
      pushforward_pullback_adjunction_unit_app_app, category.assoc, colimit.ι_pre_assoc]
    erw [colimit.ι_desc, colimit.pre_desc, colimit.ι_desc, category.comp_id]
    simpa
  inv_hom_id' :=
    by
    delta stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward
    ext (U j)
    induction U using Opposite.rec
    cases U; cases j; rcases j_right with ⟨⟨⟩⟩
    erw [colimit.map_desc, colimit.map_desc, colimit.ι_desc_assoc, colimit.ι_desc_assoc,
      colimit.ι_desc, category.comp_id]
    simp only [cocone.whisker_ι, colimit.cocone_ι, open_nhds.inclusion_map_iso_inv,
      cocones.precompose_obj_ι, whisker_right_app, whisker_left_app, nat_trans.comp_app,
      whiskering_left_obj_map, nat_trans.op_id, Lan_obj_map,
      pushforward_pullback_adjunction_unit_app_app]
    erw [←
      colimit.w _
        (@hom_of_le (open_nhds x) _ ⟨_, U_property⟩
            ⟨(opens.map f).obj (unop j_left), j_hom.unop.le U_property⟩ j_hom.unop.le).op]
    erw [colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _)]
    erw [colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _)]
    congr
    simp only [category.assoc, costructured_arrow.map_mk]
    delta costructured_arrow.mk
    congr
#align Top.presheaf.stalk_pullback_iso TopCat.Presheaf.stalkPullbackIso

end StalkPullback

section StalkSpecializes

variable {C}

/-- If `x` specializes to `y`, then there is a natural map `F.stalk y ⟶ F.stalk x`. -/
noncomputable def stalkSpecializes (F : X.Presheaf C) {x y : X} (h : x ⤳ y) :
    F.stalk y ⟶ F.stalk x := by
  refine' colimit.desc _ ⟨_, fun U => _, _⟩
  ·
    exact
      colimit.ι ((open_nhds.inclusion x).op ⋙ F)
        (op ⟨(unop U).1, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩)
  · intro U V i
    dsimp
    rw [category.comp_id]
    let U' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩
    let V' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop V).1.2 (unop V).2 : _)⟩
    exact colimit.w ((open_nhds.inclusion x).op ⋙ F) (show V' ⟶ U' from i.unop).op
#align Top.presheaf.stalk_specializes TopCat.Presheaf.stalkSpecializes

@[simp, reassoc.1, elementwise]
theorem germ_stalkSpecializes (F : X.Presheaf C) {U : Opens X} {y : U} {x : X} (h : x ⤳ y) :
    F.germ y ≫ F.stalkSpecializes h = F.germ (⟨x, h.mem_open U.IsOpen y.Prop⟩ : U) :=
  colimit.ι_desc _ _
#align Top.presheaf.germ_stalk_specializes TopCat.Presheaf.germ_stalkSpecializes

@[simp, reassoc.1, elementwise]
theorem germ_stalk_specializes' (F : X.Presheaf C) {U : Opens X} {x y : X} (h : x ⤳ y)
    (hy : y ∈ U) : F.germ ⟨y, hy⟩ ≫ F.stalkSpecializes h = F.germ ⟨x, h.mem_open U.IsOpen hy⟩ :=
  colimit.ι_desc _ _
#align Top.presheaf.germ_stalk_specializes' TopCat.Presheaf.germ_stalk_specializes'

@[simp]
theorem stalkSpecializes_refl {C : Type _} [Category C] [Limits.HasColimits C] {X : TopCat}
    (F : X.Presheaf C) (x : X) : F.stalkSpecializes (specializes_refl x) = 𝟙 _ :=
  F.stalk_hom_ext fun _ _ => by
    dsimp
    simpa
#align Top.presheaf.stalk_specializes_refl TopCat.Presheaf.stalkSpecializes_refl

@[simp, reassoc.1, elementwise]
theorem stalkSpecializes_comp {C : Type _} [Category C] [Limits.HasColimits C] {X : TopCat}
    (F : X.Presheaf C) {x y z : X} (h : x ⤳ y) (h' : y ⤳ z) :
    F.stalkSpecializes h' ≫ F.stalkSpecializes h = F.stalkSpecializes (h.trans h') :=
  F.stalk_hom_ext fun _ _ => by simp
#align Top.presheaf.stalk_specializes_comp TopCat.Presheaf.stalkSpecializes_comp

@[simp, reassoc.1, elementwise]
theorem stalkSpecializes_stalkFunctor_map {F G : X.Presheaf C} (f : F ⟶ G) {x y : X} (h : x ⤳ y) :
    F.stalkSpecializes h ≫ (stalkFunctor C x).map f =
      (stalkFunctor C y).map f ≫ G.stalkSpecializes h :=
  by
  ext
  delta stalk_functor
  simpa [stalk_specializes]
#align Top.presheaf.stalk_specializes_stalk_functor_map TopCat.Presheaf.stalkSpecializes_stalkFunctor_map

@[simp, reassoc.1, elementwise]
theorem stalkSpecializes_stalkPushforward (f : X ⟶ Y) (F : X.Presheaf C) {x y : X} (h : x ⤳ y) :
    (f _* F).stalkSpecializes (f.map_specializes h) ≫ F.stalkPushforward _ f x =
      F.stalkPushforward _ f y ≫ F.stalkSpecializes h :=
  by
  ext
  delta stalk_pushforward
  simpa [stalk_specializes]
#align Top.presheaf.stalk_specializes_stalk_pushforward TopCat.Presheaf.stalkSpecializes_stalkPushforward

/-- The stalks are isomorphic on inseparable points -/
@[simps]
def stalkCongr {X : TopCat} {C : Type _} [Category C] [HasColimits C] (F : X.Presheaf C) {x y : X}
    (e : Inseparable x y) : F.stalk x ≅ F.stalk y :=
  ⟨F.stalkSpecializes e.ge, F.stalkSpecializes e.le, by simp, by simp⟩
#align Top.presheaf.stalk_congr TopCat.Presheaf.stalkCongr

end StalkSpecializes

section Concrete

variable {C}

variable [ConcreteCategory.{v} C]

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

@[ext]
theorem germ_ext (F : X.Presheaf C) {U V : Opens X} {x : X} {hxU : x ∈ U} {hxV : x ∈ V}
    (W : Opens X) (hxW : x ∈ W) (iWU : W ⟶ U) (iWV : W ⟶ V) {sU : F.obj (op U)} {sV : F.obj (op V)}
    (ih : F.map iWU.op sU = F.map iWV.op sV) : F.germ ⟨x, hxU⟩ sU = F.germ ⟨x, hxV⟩ sV := by
  erw [← F.germ_res iWU ⟨x, hxW⟩, ← F.germ_res iWV ⟨x, hxW⟩, comp_apply, comp_apply, ih]
#align Top.presheaf.germ_ext TopCat.Presheaf.germ_ext

variable [PreservesFilteredColimits (forget C)]

/--
For presheaves valued in a concrete category whose forgetful functor preserves filtered colimits,
every element of the stalk is the germ of a section.
-/
theorem germ_exist (F : X.Presheaf C) (x : X) (t : stalk F x) :
    ∃ (U : Opens X)(m : x ∈ U)(s : F.obj (op U)), F.germ ⟨x, m⟩ s = t :=
  by
  obtain ⟨U, s, e⟩ :=
    Types.jointly_surjective.{v, v} _ (is_colimit_of_preserves (forget C) (colimit.is_colimit _)) t
  revert s e
  rw [show U = op (unop U) from rfl]
  generalize unop U = V; clear U
  cases' V with V m
  intro s e
  exact ⟨V, m, s, e⟩
#align Top.presheaf.germ_exist TopCat.Presheaf.germ_exist

theorem germ_eq (F : X.Presheaf C) {U V : Opens X} (x : X) (mU : x ∈ U) (mV : x ∈ V)
    (s : F.obj (op U)) (t : F.obj (op V)) (h : germ F ⟨x, mU⟩ s = germ F ⟨x, mV⟩ t) :
    ∃ (W : Opens X)(m : x ∈ W)(iU : W ⟶ U)(iV : W ⟶ V), F.map iU.op s = F.map iV.op t :=
  by
  obtain ⟨W, iU, iV, e⟩ :=
    (Types.FilteredColimit.isColimit_eq_iff.{v, v} _
          (is_colimit_of_preserves _ (colimit.is_colimit ((open_nhds.inclusion x).op ⋙ F)))).mp
      h
  exact ⟨(unop W).1, (unop W).2, iU.unop, iV.unop, e⟩
#align Top.presheaf.germ_eq TopCat.Presheaf.germ_eq

theorem stalkFunctor_map_injective_of_app_injective {F G : Presheaf C X} (f : F ⟶ G)
    (h : ∀ U : Opens X, Function.Injective (f.app (op U))) (x : X) :
    Function.Injective ((stalkFunctor C x).map f) := fun s t hst =>
  by
  rcases germ_exist F x s with ⟨U₁, hxU₁, s, rfl⟩
  rcases germ_exist F x t with ⟨U₂, hxU₂, t, rfl⟩
  simp only [stalk_functor_map_germ_apply _ ⟨x, _⟩] at hst
  obtain ⟨W, hxW, iWU₁, iWU₂, heq⟩ := G.germ_eq x hxU₁ hxU₂ _ _ hst
  rw [← comp_apply, ← comp_apply, ← f.naturality, ← f.naturality, comp_apply, comp_apply] at heq
  replace heq := h W HEq
  convert congr_arg (F.germ ⟨x, hxW⟩) HEq
  exacts[(F.germ_res_apply iWU₁ ⟨x, hxW⟩ s).symm, (F.germ_res_apply iWU₂ ⟨x, hxW⟩ t).symm]
#align Top.presheaf.stalk_functor_map_injective_of_app_injective TopCat.Presheaf.stalkFunctor_map_injective_of_app_injective

variable [HasLimits C] [PreservesLimits (forget C)] [ReflectsIsomorphisms (forget C)]

/-- Let `F` be a sheaf valued in a concrete category, whose forgetful functor reflects isomorphisms,
preserves limits and filtered colimits. Then two sections who agree on every stalk must be equal.
-/
theorem section_ext (F : Sheaf C X) (U : Opens X) (s t : F.1.obj (op U))
    (h : ∀ x : U, F.Presheaf.germ x s = F.Presheaf.germ x t) : s = t :=
  by
  -- We use `germ_eq` and the axiom of choice, to pick for every point `x` a neighbourhood
  -- `V x`, such that the restrictions of `s` and `t` to `V x` coincide.
  choose V m i₁ i₂ heq using fun x : U => F.presheaf.germ_eq x.1 x.2 x.2 s t (h x)
  -- Since `F` is a sheaf, we can prove the equality locally, if we can show that these
  -- neighborhoods form a cover of `U`.
  apply F.eq_of_locally_eq' V U i₁
  · intro x hxU
    rw [opens.mem_supr]
    exact ⟨⟨x, hxU⟩, m ⟨x, hxU⟩⟩
  · intro x
    rw [HEq, Subsingleton.elim (i₁ x) (i₂ x)]
#align Top.presheaf.section_ext TopCat.Presheaf.section_ext

/-
Note that the analogous statement for surjectivity is false: Surjectivity on stalks does not
imply surjectivity of the components of a sheaf morphism. However it does imply that the morphism
is an epi, but this fact is not yet formalized.
-/
theorem app_injective_of_stalkFunctor_map_injective {F : Sheaf C X} {G : Presheaf C X} (f : F.1 ⟶ G)
    (U : Opens X) (h : ∀ x : U, Function.Injective ((stalkFunctor C x.val).map f)) :
    Function.Injective (f.app (op U)) := fun s t hst =>
  section_ext F _ _ _ fun x =>
    h x <| by rw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply, hst]
#align Top.presheaf.app_injective_of_stalk_functor_map_injective TopCat.Presheaf.app_injective_of_stalkFunctor_map_injective

theorem app_injective_iff_stalkFunctor_map_injective {F : Sheaf C X} {G : Presheaf C X}
    (f : F.1 ⟶ G) :
    (∀ x : X, Function.Injective ((stalkFunctor C x).map f)) ↔
      ∀ U : Opens X, Function.Injective (f.app (op U)) :=
  ⟨fun h U => app_injective_of_stalkFunctor_map_injective f U fun x => h x.1,
    stalkFunctor_map_injective_of_app_injective f⟩
#align Top.presheaf.app_injective_iff_stalk_functor_map_injective TopCat.Presheaf.app_injective_iff_stalkFunctor_map_injective

instance stalkFunctor_preserves_mono (x : X) :
    Functor.PreservesMonomorphisms (Sheaf.forget C X ⋙ stalkFunctor C x) :=
  ⟨fun 𝓐 𝓑 f m =>
    ConcreteCategory.mono_of_injective _ <|
      (app_injective_iff_stalkFunctor_map_injective f.1).mpr
        (fun c =>
          (@ConcreteCategory.mono_iff_injective_of_preservesPullback _ _ (f.1.app (op c)) _).mp
            ((NatTrans.mono_iff_mono_app _ f.1).mp
                (@CategoryTheory.presheaf_mono_of_mono _ _ _ _ _ _ _ _ _ _ _ m) <|
              op c))
        x⟩
#align Top.presheaf.stalk_functor_preserves_mono TopCat.Presheaf.stalkFunctor_preserves_mono

theorem stalk_mono_of_mono {F G : Sheaf C X} (f : F ⟶ G) [Mono f] :
    ∀ x, Mono <| (stalkFunctor C x).map f.1 := fun x => by
  convert functor.map_mono (Sheaf.forget.{v} C X ⋙ stalk_functor C x) f
#align Top.presheaf.stalk_mono_of_mono TopCat.Presheaf.stalk_mono_of_mono

theorem mono_of_stalk_mono {F G : Sheaf C X} (f : F ⟶ G) [∀ x, Mono <| (stalkFunctor C x).map f.1] :
    Mono f :=
  (Sheaf.Hom.mono_iff_presheaf_mono _ _ _).mpr <|
    (NatTrans.mono_iff_mono_app _ _).mpr fun U =>
      (ConcreteCategory.mono_iff_injective_of_preservesPullback _).mpr <|
        app_injective_of_stalkFunctor_map_injective f.1 U.unop fun ⟨x, hx⟩ =>
          (ConcreteCategory.mono_iff_injective_of_preservesPullback _).mp <| inferInstance
#align Top.presheaf.mono_of_stalk_mono TopCat.Presheaf.mono_of_stalk_mono

theorem mono_iff_stalk_mono {F G : Sheaf C X} (f : F ⟶ G) :
    Mono f ↔ ∀ x, Mono ((stalkFunctor C x).map f.1) :=
  ⟨by
    intro m
    exact stalk_mono_of_mono _, by
    intro m
    exact mono_of_stalk_mono _⟩
#align Top.presheaf.mono_iff_stalk_mono TopCat.Presheaf.mono_iff_stalk_mono

/-- For surjectivity, we are given an arbitrary section `t` and need to find a preimage for it.
We claim that it suffices to find preimages *locally*. That is, for each `x : U` we construct
a neighborhood `V ≤ U` and a section `s : F.obj (op V))` such that `f.app (op V) s` and `t`
agree on `V`. -/
theorem app_surjective_of_injective_of_locally_surjective {F G : Sheaf C X} (f : F ⟶ G)
    (U : Opens X) (hinj : ∀ x : U, Function.Injective ((stalkFunctor C x.1).map f.1))
    (hsurj :
      ∀ (t) (x : U),
        ∃ (V : Opens X)(m : x.1 ∈ V)(iVU : V ⟶ U)(s : F.1.obj (op V)),
          f.1.app (op V) s = G.1.map iVU.op t) :
    Function.Surjective (f.1.app (op U)) := by
  intro t
  -- We use the axiom of choice to pick around each point `x` an open neighborhood `V` and a
  -- preimage under `f` on `V`.
  choose V mV iVU sf heq using hsurj t
  -- These neighborhoods clearly cover all of `U`.
  have V_cover : U ≤ supᵢ V := by
    intro x hxU
    rw [opens.mem_supr]
    exact ⟨⟨x, hxU⟩, mV ⟨x, hxU⟩⟩
  -- Since `F` is a sheaf, we can glue all the local preimages together to get a global preimage.
  obtain ⟨s, s_spec, -⟩ := F.exists_unique_gluing' V U iVU V_cover sf _
  · use s
    apply G.eq_of_locally_eq' V U iVU V_cover
    intro x
    rw [← comp_apply, ← f.1.naturality, comp_apply, s_spec, HEq]
  · intro x y
    -- What's left to show here is that the secions `sf` are compatible, i.e. they agree on
    -- the intersections `V x ⊓ V y`. We prove this by showing that all germs are equal.
    apply section_ext
    intro z
    -- Here, we need to use injectivity of the stalk maps.
    apply hinj ⟨z, (iVU x).le ((inf_le_left : V x ⊓ V y ≤ V x) z.2)⟩
    dsimp only
    erw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply]
    simp_rw [← comp_apply, f.1.naturality, comp_apply, HEq, ← comp_apply, ← G.1.map_comp]
    rfl
#align Top.presheaf.app_surjective_of_injective_of_locally_surjective TopCat.Presheaf.app_surjective_of_injective_of_locally_surjective

theorem app_surjective_of_stalkFunctor_map_bijective {F G : Sheaf C X} (f : F ⟶ G) (U : Opens X)
    (h : ∀ x : U, Function.Bijective ((stalkFunctor C x.val).map f.1)) :
    Function.Surjective (f.1.app (op U)) :=
  by
  refine' app_surjective_of_injective_of_locally_surjective f U (fun x => (h x).1) fun t x => _
  -- Now we need to prove our initial claim: That we can find preimages of `t` locally.
  -- Since `f` is surjective on stalks, we can find a preimage `s₀` of the germ of `t` at `x`
  obtain ⟨s₀, hs₀⟩ := (h x).2 (G.presheaf.germ x t)
  -- ... and this preimage must come from some section `s₁` defined on some open neighborhood `V₁`
  obtain ⟨V₁, hxV₁, s₁, hs₁⟩ := F.presheaf.germ_exist x.1 s₀
  subst hs₁; rename' hs₀ => hs₁
  erw [stalk_functor_map_germ_apply V₁ ⟨x.1, hxV₁⟩ f.1 s₁] at hs₁
  -- Now, the germ of `f.app (op V₁) s₁` equals the germ of `t`, hence they must coincide on
  -- some open neighborhood `V₂`.
  obtain ⟨V₂, hxV₂, iV₂V₁, iV₂U, heq⟩ := G.presheaf.germ_eq x.1 hxV₁ x.2 _ _ hs₁
  -- The restriction of `s₁` to that neighborhood is our desired local preimage.
  use V₂, hxV₂, iV₂U, F.1.map iV₂V₁.op s₁
  rw [← comp_apply, f.1.naturality, comp_apply, HEq]
#align Top.presheaf.app_surjective_of_stalk_functor_map_bijective TopCat.Presheaf.app_surjective_of_stalkFunctor_map_bijective

theorem app_bijective_of_stalkFunctor_map_bijective {F G : Sheaf C X} (f : F ⟶ G) (U : Opens X)
    (h : ∀ x : U, Function.Bijective ((stalkFunctor C x.val).map f.1)) :
    Function.Bijective (f.1.app (op U)) :=
  ⟨app_injective_of_stalkFunctor_map_injective f.1 U fun x => (h x).1,
    app_surjective_of_stalkFunctor_map_bijective f U h⟩
#align Top.presheaf.app_bijective_of_stalk_functor_map_bijective TopCat.Presheaf.app_bijective_of_stalkFunctor_map_bijective

theorem app_isIso_of_stalkFunctor_map_iso {F G : Sheaf C X} (f : F ⟶ G) (U : Opens X)
    [∀ x : U, IsIso ((stalkFunctor C x.val).map f.1)] : IsIso (f.1.app (op U)) :=
  by
  -- Since the forgetful functor of `C` reflects isomorphisms, it suffices to see that the
  -- underlying map between types is an isomorphism, i.e. bijective.
  suffices is_iso ((forget C).map (f.1.app (op U))) by
    exact is_iso_of_reflects_iso (f.1.app (op U)) (forget C)
  rw [is_iso_iff_bijective]
  apply app_bijective_of_stalk_functor_map_bijective
  intro x
  apply (is_iso_iff_bijective _).mp
  exact functor.map_is_iso (forget C) ((stalk_functor C x.1).map f.1)
#align Top.presheaf.app_is_iso_of_stalk_functor_map_iso TopCat.Presheaf.app_isIso_of_stalkFunctor_map_iso

-- Making this an instance would cause a loop in typeclass resolution with `functor.map_is_iso`
/-- Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then if the stalk maps of a morphism
`f : F ⟶ G` are all isomorphisms, `f` must be an isomorphism.
-/
theorem isIso_of_stalkFunctor_map_iso {F G : Sheaf C X} (f : F ⟶ G)
    [∀ x : X, IsIso ((stalkFunctor C x).map f.1)] : IsIso f :=
  by
  -- Since the inclusion functor from sheaves to presheaves is fully faithful, it suffices to
  -- show that `f`, as a morphism between _presheaves_, is an isomorphism.
  suffices is_iso ((sheaf.forget C X).map f) by exact is_iso_of_fully_faithful (sheaf.forget C X) f
  -- We show that all components of `f` are isomorphisms.
  suffices ∀ U : (opens X)ᵒᵖ, is_iso (f.1.app U) by
    exact @nat_iso.is_iso_of_is_iso_app _ _ _ _ F.1 G.1 f.1 this
  intro U
  induction U using Opposite.rec
  apply app_is_iso_of_stalk_functor_map_iso
#align Top.presheaf.is_iso_of_stalk_functor_map_iso TopCat.Presheaf.isIso_of_stalkFunctor_map_iso

/-- Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then a morphism `f : F ⟶ G` is an
isomorphism if and only if all of its stalk maps are isomorphisms.
-/
theorem isIso_iff_stalkFunctor_map_iso {F G : Sheaf C X} (f : F ⟶ G) :
    IsIso f ↔ ∀ x : X, IsIso ((stalkFunctor C x).map f.1) :=
  by
  constructor
  · intro h x
    skip
    exact @functor.map_is_iso _ _ _ _ _ _ (stalk_functor C x) f.1 ((sheaf.forget C X).map_isIso f)
  · intro h
    exact is_iso_of_stalk_functor_map_iso f
#align Top.presheaf.is_iso_iff_stalk_functor_map_iso TopCat.Presheaf.isIso_iff_stalkFunctor_map_iso

end Concrete

instance (F : X.Presheaf CommRingCat) {U : Opens X} (x : U) : Algebra (F.obj <| op U) (F.stalk x) :=
  (F.germ x).toAlgebra

@[simp]
theorem stalk_open_algebraMap {X : TopCat} (F : X.Presheaf CommRingCat) {U : Opens X} (x : U) :
    algebraMap (F.obj <| op U) (F.stalk x) = F.germ x :=
  rfl
#align Top.presheaf.stalk_open_algebra_map TopCat.Presheaf.stalk_open_algebraMap

end TopCat.Presheaf


import challenge_notations
import challenge_prerequisites

/-!
# Liquid Tensor Experiment

## The main challenge

The main challenge of the liquid tensor experiment is
a formalisation of the first theorem in Peter Scholze's blogpost
https://xenaproject.wordpress.com/2020/12/05/liquid-tensor-experiment/

Theorem 1.1 (Clausen--Scholze)
Let `0 < p' < p ≤ 1` be real numbers, let `S` be a profinite set, and let `V` be a `p`-Banach space.
Let `ℳ p' S` be the space of `p'`-measures on `S`. Then
$$ Ext^i (ℳ p' S, V) = 0 $$
for `i ≥ 1`.

-/

noncomputable theory

open_locale liquid_tensor_experiment nnreal zero_object
open liquid_tensor_experiment category_theory category_theory.limits

variables (p' p : ℝ≥0) [fact (0 < p')] [fact (p' < p)] [fact (p ≤ 1)]

theorem liquid_tensor_experiment (S : Profinite.{0}) (V : pBanach.{0} p) :
  ∀ i > 0, Ext i (ℳ_{p'} S) V ≅ 0 :=
begin
  intros i hi,
  apply is_zero.iso_zero,
  revert i,
  haveI : fact (0 < (p:ℝ)) := ⟨lt_trans (fact.out _ : 0 < p') (fact.out _)⟩,
  haveI : fact (p' < 1) := ⟨lt_of_lt_of_le (fact.out _ : p' < p) (fact.out _)⟩,
  erw is_zero_iff_epi_and_is_iso _ _ (V : Condensed.{0 1 2} Ab) (laurent_measures.short_exact p' S),
  let := pBanach.choose_semi_normed_group V,
  let := pBanach.choose_normed_with_aut V 2⁻¹,
  haveI : fact (0 < (2⁻¹ : ℝ≥0) ^ (p : ℝ)) := r_pos',
  convert laurent_measures.epi_and_is_iso p' p S ⟨V⟩ _ using 1,
  intro v,
  rw [pBanach.choose_normed_with_aut_T_inv, inv_inv, two_smul, two_nsmul],
end


import data.finsupp data.support
import data.setoid.partition tactic

noncomputable theory

open_locale classical big_operators

noncomputable def finsum {ι M} [add_comm_monoid M] (f : ι → M) : M :=
if h : (function.support f).finite then ∑ x in h.to_finset, f x else 0

section finsum2

-- we might not need this section

noncomputable def finsum2 {ι M} [add_comm_monoid M] (f : ι → M) : M :=
if h : ∃ f' : ι →₀ M, f = f' then (classical.some h).sum (λ _ a, a) else 0

theorem finsum_eq_finsum2 {ι M} [add_comm_monoid M] (f : ι → M) : finsum f = finsum2 f :=
begin
  unfold finsum,
  unfold finsum2,
  symmetry,
  split_ifs with h1 h2 h3,
  { unfold finsupp.sum,
    congr',
    { ext x,
      rw finsupp.mem_support_iff,
      rw (classical.some_spec h1).symm,
      rw set.finite.mem_to_finset,
      refl },
    { exact (classical.some_spec h1).symm } },
  { exfalso,
    apply h2,
    clear h2,
    rcases h1 with ⟨h1, rfl⟩,
    exact h1.finite_supp },
  { exfalso,
    apply h1,
    clear h1,
    let f' : ι →₀ M :=
    { support := h3.to_finset,
      to_fun := f,
      mem_support_to_fun := begin
        intro i,
        simp only [function.mem_support, set.finite.mem_to_finset],
      end },
    use f',
    refl },
  { refl }
end .

end finsum2

noncomputable def finsum_in {ι M} [add_comm_monoid M] (s : set ι) (f : ι → M) : M :=
finsum (λ i, if i ∈ s then f i else 0)

notation `∑' ` binders ` in ` s `, ` r:(scoped:67 f, finsum_in s f) := r
notation `∑' ` binders `, ` r:(scoped:67 f, finsum f) := r

-- lemma is_finite_supp {M β} [has_zero β] (f : M →₀ β) : is_finite {a // f a ≠ 0} :=
-- f.finite_supp

universes u v

variables {ι : Type u} {M : Type v} [add_comm_monoid M]
variables {f : ι → M}

def finset.univ' (ι : Type*) : finset ι := if h : nonempty (fintype ι) then
  (classical.choice h).elems else ∅

open finset finsupp

lemma univ'_eq_univ_of_fintype [h : fintype ι] : univ' ι = univ :=
begin
  unfold univ', unfold univ,
  convert dif_pos (nonempty.intro h)
end

lemma mem_univ' [fintype ι] (x : ι) : x ∈ univ' ι :=
begin
  rw univ'_eq_univ_of_fintype,
  exact mem_univ _
end

noncomputable def to_finsupp (f : ι → M) : ι →₀ M :=
{ support := filter (λ x, f x ≠ 0) $ univ' ι,
  to_fun := λ x, if h : x ∈ univ' ι then f x else 0,
  mem_support_to_fun := begin
    intros,
    split_ifs,
    { simp only [*, true_and, mem_filter]},
    { simp only [*, mem_filter, eq_self_iff_true, not_true, ne.def, false_and]}
  end }

@[simp] lemma eq_finsupp [fintype ι] (f : ι → M) :
  (to_finsupp f : ι → M) = f :=
funext (λ x, dif_pos (mem_univ' x))

-- lemma finsum_def_of_finite (f : ι → M) :
--   finsum f = (finsupp_of_is_finite f).sum (λ _ a, a) :=
-- begin
--   unfold finsum,
--   have h : ∃ (f' : ι →₀ M), f = f' := ⟨finsupp_of_is_finite f, rfl⟩,
--   rw dif_pos h,
--   congr, ext, rw finsupp_of_is_finite_eq,
--   solve_by_elim [(classical.some_spec h).symm],
-- end

-- (on_finset s f hf).sum g = ∑ a in s, g a (f a) :=

lemma finsum_in_eq_finset_sum (f : ι → M) (s : finset ι) :
  ∑' x in ↑s, f x = s.sum f :=
begin
  unfold finsum_in, unfold finsum,
  rw dif_pos,
  { rw [finset.sum_ite, sum_const_zero, add_zero],
    refine finset.sum_subset _ _,
    { apply set.finite.subset (s.finite_to_set),
      rintro x h,
      rw function.mem_support at h,
      split_ifs at h, assumption, contradiction },
    { intro _, simp only [and_imp, mem_filter, imp_self, mem_coe, forall_true_iff] },
    { simp only [function.mem_support, mem_filter, and_true, if_true,
        set.finite.mem_to_finset, mem_coe, eq_self_iff_true,
        classical.not_not, forall_true_iff] { contextual := tt } } },
end

lemma finsum_in_eq_finsum (f : ι → M) (s : set ι) :
  ∑' x in s, f x = ∑' x : s, f x :=
begin
  unfold finsum_in,
  unfold finsum,
  split_ifs,
  { rw [sum_ite, sum_const_zero, add_zero],
    convert (sum_subtype_eq_sum_filter f).symm,
    ext x,
    cases x with x hx,
    simp [function.support]; split_ifs, refl },
  { exfalso,
    apply h_1, clear h_1,
    apply set.finite_of_finite_image (_ : set.inj_on (subtype.val : s → ι) _) _,
    { apply function.injective.inj_on, exact subtype.val_injective },
    apply set.finite.subset h,
    rintro _ ⟨⟨a, ha⟩, hf, rfl⟩,
    rw function.mem_support at hf ⊢,
    rw if_pos ha,
    exact hf },
  { exfalso,
    apply h, clear h,
    convert set.finite.image (λ (x : s), x.1) h_1,
    ext x,
    rw function.mem_support,
    split,
    { intro h,
      split_ifs at h,
      { use ⟨x, h_2⟩,
        rw function.mem_support,
        use h },
      { contradiction } },
    { rintro ⟨i, hi, rfl⟩,
      rw if_pos i.2,
      exact hi } },
  { refl }
end

/- lemma finite_support_of_fintype [fintype ι] (f : ι → M) :
(function.support f).finite := set.finite.of_fintype (function.support f) -/

lemma finsum_in_def_of_finite' {f : ι → M} (s : set ι)
  (hf : (function.support f).finite) :
  ∑' x in s, f x = (filter (∈ s) hf.to_finset).sum f :=
begin
  unfold finsum_in, unfold finsum,
  rw dif_pos,
    { rw [sum_ite, sum_const_zero, add_zero],
      refine finset.sum_subset _ _,
        { refine set.finite.subset hf (λ x hx, _),
          rw function.mem_support at ⊢ hx,
          intro h, apply hx,
          split_ifs, exact h, refl },
        { intros x hx,
          rw mem_filter at ⊢ hx,
          cases hx with hx₀ hx₁,
          refine ⟨_, hx₁⟩,
          rw [set.finite.mem_to_finset, function.mem_support, if_pos hx₁] at hx₀,
          rw set.finite.mem_to_finset, exact hx₀ },
    { simp [function.mem_support] {contextual := tt} } }
end .

-- ↓ Rewrite below as a corollary of `finsum_in_def_of_finite'`
lemma finsum_in_def_of_finite [fintype ι] (f : ι → M) (s : set ι) :
  ∑' x in s, f x = s.to_finset.sum f :=
begin
  unfold finsum_in,
  unfold finsum,
  rw dif_pos (set.finite.of_fintype (_ : set ι)),
  rw [finset.sum_ite, sum_const_zero, add_zero],
  refine finset.sum_subset _ _,
  { intro x, simp only [and_imp, mem_filter,
                        imp_self, set.mem_to_finset, forall_true_iff]},
  { simp only [function.mem_support, mem_filter, and_true, if_true,
               set.finite.mem_to_finset, set.mem_to_finset, eq_self_iff_true,
 classical.not_not, forall_true_iff] {contextual := tt} }
end

lemma finsum_in_def_of_finite''' (f : ι → M) {s : set ι} (h : s.finite) :
  ∑' x in s, f x = h.to_finset.sum f :=
begin
  rw ←finsum_in_eq_finset_sum f,
  congr, simp,
end

lemma finsum_def_of_finite [h : fintype ι] (f : ι → M) :
  ∑' x : ι, f x = (finset.univ' ι).sum f :=
begin
  unfold finsum,
  rw dif_pos (set.finite.of_fintype (_ : set ι)),
  refine finset.sum_subset (λ _ _, mem_univ' _) _,
    intros _ _ hx,
    rw ←function.nmem_support,
    simpa using hx,
end

lemma finsum_def_of_finite' {f : ι → M} (hf : (function.support f).finite) :
  ∑' x : ι, f x = hf.to_finset.sum f :=
begin
  unfold finsum,
  rw dif_pos hf
end

lemma finsum_def_of_infinite {f : ι → M} (hf : ¬(function.support f).finite) :
  ∑' x : ι, f x = 0 :=
begin
  unfold finsum,
  rw dif_neg hf
end

lemma finsum_eq_finsum_in_univ (f : ι → M) :
  ∑' x : ι, f x = ∑' x in set.univ, f x :=
begin
  by_cases ((function.support f).finite),
    { rw [finsum_def_of_finite' h, finsum_in_def_of_finite' _ h], simp },
    { unfold finsum_in,
      rw [finsum_def_of_infinite h, finsum_def_of_infinite], simpa }
end

lemma finsum_ext {s t : set ι} {f₁ f₂ : ι → M} (h₀ : s = t)
  (h₁ : ∀ x ∈ t, f₁ x = f₂ x) : ∑' x in s, f₁ x = ∑' x in t, f₂ x :=
begin
  subst h₀,
  unfold finsum_in,
  congr',
  ext x,
  split_ifs,
  { exact h₁ x h },
  { refl },
end

lemma finsum_union [fintype ι] {s t : set ι} {f : ι → M} (h : disjoint s t) :
  ∑' x in (s ∪ t), f x = ∑' x in s, f x + ∑' x in t, f x :=
begin
  iterate 3 { rw finsum_in_def_of_finite },
  rw ←finset.sum_union, congr',
    { ext, simp },
    { intros a ha,
      apply @h a,
      simpa using ha }
end

lemma finsum_bind {γ} [fintype γ] [fintype ι] {s : set γ} {t : γ → set ι}
  (f : ι → M) (h : ∀ x ∈ s, ∀ y ∈ s, x ≠ y → disjoint (t x) (t y)) :
  (∑' x in (⋃ x ∈ s, t x), f x) = ∑' x in s, ∑' i in t x, f i :=
begin
  iterate 2 { rw finsum_in_def_of_finite },
  conv_rhs { congr, skip, funext, rw finsum_in_def_of_finite },
    { convert @sum_bind _ _ _ f _ _ s.to_finset (λ x, (t x).to_finset)
      (begin
        intros x hx y hy hxy a ha,
        specialize h x (set.mem_to_finset.1 hx) y (set.mem_to_finset.1 hy) hxy,
        apply @h a, simpa using ha end),
      { ext, rw [mem_bind, set.mem_to_finset, set.mem_bUnion_iff],
        split; intro ha; rcases ha with ⟨x, hx₀, hx₁⟩,
          exact ⟨x, set.mem_to_finset.2 hx₀, set.mem_to_finset.2 hx₁⟩,
          exact ⟨x, set.mem_to_finset.1 hx₀, set.mem_to_finset.1 hx₁⟩ } },
end

-- def fincard (X : Type*) : ℕ :=
-- if h : nonempty (fintype X) then @fintype.card X (classical.choice h) else 0

def fincard (X : Type u) : ℕ := finset.card $ finset.univ' X

namespace fincard

lemma eq_finset_card (X : Type u) [fintype X] :
  fincard X = finset.card (univ : finset X) :=
begin
  unfold fincard,
  congr',
  unfold univ',
  rw dif_pos,
  { congr' },
  { apply nonempty.intro,
    assumption },
end

lemma eq_finset_card' {X : Type u} [fintype X] (s : set X) :
  fincard s = s.to_finset.card :=
by rw [eq_finset_card, set.to_finset_card]; refl

theorem card_eq_fincard (X : Type*) [h : fintype X] : fintype.card X = fincard X :=
begin
  simp only [fincard, univ', nonempty.intro h, dif_pos],
  congr,
end

theorem fincard_eq_zero {X : Type*} (h : ¬nonempty (fintype X)) : fincard X = 0 :=
congr_arg finset.card (dif_neg h)

@[simp] lemma empty : fincard empty = 0 :=
begin
  rw ←card_eq_fincard,
  simp,
end

lemma of_equiv {X Y : Type*} (h : X ≃ Y) : fincard X = fincard Y :=
begin
  by_cases h2 : nonempty (fintype X),
  { cases h2,
    resetI,
    letI : fintype Y := fintype.of_equiv X h,
    rw [←card_eq_fincard X, ←card_eq_fincard Y, fintype.of_equiv_card] },
  { have h3 : ¬nonempty (fintype Y),
    { rintros ⟨_⟩,
      exactI h2 ⟨fintype.of_equiv _ h.symm⟩ },
    simp [fincard_eq_zero, *] }
end

theorem of_empty {X : Type*} (hX : X → false) : fincard X = 0 :=
by simp [fincard.of_equiv (equiv.equiv_empty hX)]

theorem card_eq_zero_iff {X : Type*} [fintype X] (s : set X) :
  fincard s = 0 ↔ s = ∅ :=
begin
  rw [eq_finset_card', finset.card_eq_zero, ←set.to_finset_empty],
  apply set.to_finset_inj
end

lemma card_eq_sum_one_of_fintype {X : Type u} [h : fintype X] :
  fincard X = ∑' x : X, 1 :=
begin
  rw [eq_finset_card, finset.card_univ, finsum_def_of_finite],
  unfold univ',
  rw dif_pos (nonempty.intro h),
  simp only [mul_one, nat.cast_id, nsmul_eq_mul, sum_const],
  congr'
end

lemma card_eq_sum_one_of_nfintype {X : Type u} (h : ¬ nonempty (fintype X)) :
  fincard X = ∑' x : X, 1 :=
begin
  unfold finsum,
  rw dif_neg, exact fincard_eq_zero h,
  suffices : function.support (λ (x : X), 1) = set.univ,
    rw this, intro h',
    exact h (nonempty.intro
      ⟨h'.to_finset, λ x, set.finite.mem_to_finset.2 (set.mem_univ _)⟩),
  rw set.eq_univ_iff_forall,
  intro x, rw function.mem_support, norm_num,
end

lemma card_eq_sum_one {X : Type u} : fincard X = ∑' x : X, 1 :=
begin
  by_cases (nonempty (fintype X)),
    { haveI := classical.choice h,
      exact card_eq_sum_one_of_fintype },
    { exact card_eq_sum_one_of_nfintype h }
end

lemma eq_finset_card'' {X : Type u} {s : set X} (h : s.finite) :
  fincard s = h.to_finset.card :=
begin
  rw [card_eq_sum_one, ←finsum_in_eq_finsum (λ _, 1),
      finsum_in_def_of_finite''', finset.card_eq_sum_ones],
end

end fincard

lemma fintype.of_finite_support {X : Type u}
  (h : (function.support (λ _ : X, 1)).finite) :
  nonempty $ fintype X :=
begin
  unfold function.support at h,
  replace h : (@set.univ X).finite, simpa using h,
  exact nonempty.intro
    (@fintype.of_equiv X (set.univ) (classical.choice h) (equiv.set.univ X))
end

namespace fincard

lemma card_eq_zero_of_infinite {X : Type u} {s : set X} (h : ¬ s.finite) :
  fincard s = 0 :=
begin
  rw card_eq_sum_one,
  exact finsum_def_of_infinite (λ h', h $ fintype.of_finite_support h')
end

@[simp] theorem card_singleton_eq_one {X : Type*} {x : X} :
  fincard ({x} : set X) = 1 :=
begin
  rw [eq_finset_card'' (set.finite_singleton x), set.finite.to_finset, finset.card_eq_one],
  refine ⟨x, _⟩, ext; simp
end

theorem card_eq_one_iff_singleton {X : Type*} {s : set X} :
  fincard s = 1 ↔ ∃ x : X, s = {x} :=
begin
  split,
    { by_cases h : s.finite,
        { rw [eq_finset_card'' h, finset.card_eq_one],
          rintro ⟨x, hx⟩,
          refine ⟨x, _⟩,
          rw ←@set.finite.coe_to_finset _ s h, simp [hx] },
        { finish [card_eq_zero_of_infinite h] } },
    { rintro ⟨_, rfl⟩,
      exact card_singleton_eq_one }
end

end fincard

-- Is this really not in the library?
lemma set.eq_singleton_iff_unique_mem {X : Type*} {x : X} {s : set X} :
  s = {x} ↔ x ∈ s ∧ ∀ y ∈ s, x = y :=
begin
  split,
    { rintro rfl, simp },
    { rintro ⟨h₀, h₁⟩,
      ext, split; finish }
end

namespace fincard

theorem card_eq_one_iff_unique_mem {X : Type*} {s : set X} :
  fincard s = 1 ↔ ∃! x : X, x ∈ s :=
begin
  rw card_eq_one_iff_singleton,
  unfold exists_unique,
  split,
    rintro ⟨_, _⟩, finish,
    rintro ⟨x, _, _⟩, refine ⟨x, _⟩,
    finish [set.eq_singleton_iff_unique_mem],
end

private theorem prod_of_empty_left {X : Type*} (h : X → false) (Y : Type*) :
  fincard (X × Y) = fincard X * fincard Y :=
by rw [fincard.of_empty h, fincard.of_empty (h ∘ prod.fst), zero_mul]

private theorem prod_of_empty_right (X : Type*) {Y : Type*} (h : Y → false) :
  fincard (X × Y) = fincard X * fincard Y :=
by rw [fincard.of_empty h, fincard.of_empty (h ∘ prod.snd), mul_zero]

private theorem prod_of_finite {X Y : Type*}
  (hX : nonempty (fintype X)) (hY : nonempty (fintype Y)) :
fincard (X × Y) = fincard X * fincard Y :=
begin
  unfreezingI {cases hX with hX, cases hY with hY},
  -- change this to squeeze_simp and watch Lean time out
  simp [←card_eq_fincard],
end

private theorem prod_of_infinite_left {X Y : Type*}
  (hX : ¬nonempty (fintype X)) (hY : nonempty Y) :
fincard (X × Y) = fincard X * fincard Y :=
begin
  have h : ¬nonempty (fintype (X × Y)),
  { rw not_nonempty_fintype at ⊢ hX,
    unfreezingI {cases hY with y},
    apply infinite.of_injective (λ x, (x, y) : X → X × Y),
    rintros _ _ ⟨_, _⟩, refl
  },
  simp [fincard_eq_zero, *],
end

private theorem prod_of_infinite_right {X Y : Type*}
  (hX : nonempty X) (hY : ¬nonempty (fintype Y)) :
fincard (X × Y) = fincard X * fincard Y :=
begin
  have h : ¬nonempty (fintype (X × Y)),
  { rw not_nonempty_fintype at ⊢ hY,
    unfreezingI {cases hX with x},
    apply infinite.of_injective (prod.mk x : Y → X × Y),
    rintros _ _ ⟨_, _⟩, refl
  },
  simp [fincard_eq_zero, *],
end

theorem prod (X Y : Sort*) : fincard (X × Y) = fincard X * fincard Y :=
begin
  by_cases hX : X → false,
  { exact prod_of_empty_left hX _},
  rw [←not_nonempty_iff_imp_false, not_not] at hX,
  by_cases hY : Y → false,
  { exact prod_of_empty_right _ hY},
  rw [←not_nonempty_iff_imp_false, not_not] at hY,
  by_cases hX2 : nonempty (fintype X),
  { by_cases hY2 : nonempty (fintype Y),
    { exact prod_of_finite hX2 hY2},
    { exact prod_of_infinite_right hX hY2},
  },
  { exact prod_of_infinite_left hX2 hY}
end

end fincard

lemma finsum_const {X Y : Type} [fintype X] [add_comm_monoid Y]
  (s : set X) (m : Y) : ∑' x in s, m = fincard s •ℕ m :=
by rw [finsum_in_def_of_finite, finset.sum_const m, ←fincard.eq_finset_card' s]

lemma finsum_const_nat {X : Type} [fintype X] {s : set X} {m : ℕ} {f : X → ℕ}
  (h : ∀ x ∈ s, f x = m) : ∑' x in s, f x = fincard s * m :=
begin
  rw [←nat.nsmul_eq_mul, ←(finsum_const s m)],
  exact finsum_ext rfl h
end

namespace fincard

theorem card_eq_finsum_partition {X : Type} [h : fintype X] {s : set (set X)}
  (hS : setoid.is_partition s) : fincard X = ∑' x in s, fincard x :=
begin
  conv_rhs { congr, skip, funext, rw card_eq_sum_one },
  simp_rw ←finsum_in_eq_finsum (λ _, 1),
  rw [←finsum_bind _, card_eq_sum_one, finsum_def_of_finite, finsum_in_def_of_finite],
    { congr, unfold univ',
      rw [dif_pos (nonempty.intro h), ←set.sUnion_eq_bUnion,
        setoid.is_partition.sUnion_eq_univ hS],
      ext, simp [fintype.complete] },
    { exact hS.pairwise_disjoint },
    all_goals { apply_instance }
end

lemma preimage_is_partition {X Y : Type} [fintype X] (f : X → Y) :
  setoid.is_partition $ (λ y, f⁻¹' {y}) '' (set.range f) :=
begin
  split,
  { intro h,
    rw set.mem_image at h,
    rcases h with ⟨y, ⟨x, rfl⟩, hy⟩,
    apply set.not_mem_empty x,
    rw ←hy,
    simp },
  { intro x,
    use f⁻¹' {f x},
    split,
    { suffices : ∃ (a : X), f ⁻¹' {f a} = f ⁻¹' {f x},
        simpa,
      use x
    },
    {
      rintro _ ⟨⟨t, h1, rfl⟩, h2, h3⟩,
      change f x = t at h2,
      subst h2 } }
end

lemma finset.ne_empty_iff_exists_mem {M : Type u} {s : finset M} : s ≠ ∅ ↔ ∃ x : M, x ∈ s :=
begin
  rw ←nonempty_iff_ne_empty,
  refl
end

lemma finsum_fibres {X Y : Type} [fintype X] (f : X → Y) :
  ∑' y : Y, fincard (f⁻¹' {y}) = fincard X :=
begin
  simp_rw eq_finset_card',
  unfold fincard,
  rw univ'_eq_univ_of_fintype,
  rw finset.card_eq_sum_ones,
  rw sum_comp (λ y, 1) f,
  simp,
  unfold finsum,
  split_ifs,
  { congr',
    ext x,
    rw set.finite.mem_to_finset,
    rw function.mem_support,
    split,
    { rintro h,
      have h2 : (filter (λ (x_1 : X), f x_1 = x) univ) ≠ ∅,
      { intro h3,
        apply h,
        rwa card_eq_zero,
      },
      rw ←nonempty_iff_ne_empty at h2,
      cases h2 with a ha,
      rw mem_image,
      use a,
      use mem_univ a,
      simpa using ha },
    { rw mem_image,
      rintro ⟨a, ha, rfl⟩,
      apply card_ne_zero_of_mem,
      simp },
  },
  { exfalso,
    apply h, clear h,
    convert set.finite.image f set.finite_univ,
    ext x,
    rw function.mem_support,
    rw ←nat.pos_iff_ne_zero,
    rw card_pos,
    split,
    { rintro ⟨a, ha⟩,
      use a,
      use set.mem_univ a,
      simpa using ha },
    { rintro ⟨a, _, rfl⟩,
      use a,
      simp } },
end

lemma card_classes (S : Type) [fintype S] {h : setoid S} :
  fincard S = ∑' i : quotient h, fincard ((quotient.mk : S → quotient h) ⁻¹' {i}) :=
(finsum_fibres (quotient.mk : S → quotient h)).symm

lemma finsum_in_filter [fintype ι] (s : set ι) (p : ι → Prop) (f : ι → M) :
  ∑' i in {i ∈ s | p i}, f i + ∑' i in {i ∈ s | ¬ p i}, f i = ∑' i in s, f i :=
begin
  -- change to finset.sum then use corresponding lemma
  convert (finsum_union (_ : (disjoint {i ∈ s | p i} _))).symm,
  { ext x; by_cases p x; finish }, -- case split shouldn't be needed I guess
  { intro x, finish }
end

lemma finsum_nsmul [fintype ι] (s : set ι) (n : ℕ) (f : ι → M) :
  (∑' x in s, n •ℕ (f x)) = n •ℕ ((∑' x in s, f x)) :=
begin
  iterate 2 { rw finsum_in_def_of_finite },
  exact finset.sum_nsmul _ _ _
end

lemma finsum_divisible_by [fintype ι] (s : set ι) (k : ℕ) (f : ι → ℕ)
  (hf : ∀ x ∈ s, k ∣ f x) : k ∣ ∑' x in s, f x :=
begin
  rw finsum_in_def_of_finite,
  apply dvd_sum, simpa,
end

lemma card_eq_image_of_injective {α β} (f : α → β) (hf : function.injective f)
  (s : set α) : fincard s = fincard (f '' s) :=
begin
  apply of_equiv, unfold function.injective at hf,
  refine equiv.of_bijective (λ s, ⟨f s.1, ⟨s.1, s.2, rfl⟩⟩) _,
  split,
    { rintros ⟨x, hx⟩ ⟨y, hy⟩ hxy, rw subtype.mk_eq_mk,
      exact hf (show f x = f y, by simpa using hxy)  },
    { rintros ⟨y, ⟨x, hx, rfl⟩⟩,
      refine ⟨⟨x, hx⟩, by simp⟩ }
end

lemma card_sdiff_eq_sub_of_subset [fintype ι] {s t : set ι} (hst : s ⊆ t) :
  fincard (t \ s : set ι) = fincard t - fincard s :=
begin
  iterate 3 { rw eq_finset_card' },
  rw ← finset.card_sdiff,
  congr, ext, split; finish,
  intros x hx, rw set.mem_to_finset at *, exact hst hx,
end

lemma eq_of_card_eq_subset [fintype ι] {s t : set ι} (hst : s ⊆ t)
  (hcard : fincard s = fincard t) : s = t :=
begin
  suffices : t \ s = ∅,
    rw set.diff_eq_empty at this,
    exact set.subset.antisymm hst this,
  rw [← card_eq_zero_iff, card_sdiff_eq_sub_of_subset hst], omega,
end

end fincard