/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.isometry

/-!
# Metric space gluing

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

Gluing two metric spaces along a common subset. Formally, we are given

```
     Φ
  Z ---> X
  |
  |Ψ
  v
  Y
```
where `hΦ : isometry Φ` and `hΨ : isometry Ψ`.
We want to complete the square by a space `glue_space hΦ hΨ` and two isometries
`to_glue_l hΦ hΨ` and `to_glue_r hΦ hΨ` that make the square commute.
We start by defining a predistance on the disjoint union `X ⊕ Y`, for which
points `Φ p` and `Ψ p` are at distance 0. The (quotient) metric space associated
to this predistance is the desired space.

This is an instance of a more general construction, where `Φ` and `Ψ` do not have to be isometries,
but the distances in the image almost coincide, up to `2ε` say. Then one can almost glue the two
spaces so that the images of a point under `Φ` and `Ψ` are `ε`-close. If `ε > 0`, this yields a
metric space structure on `X ⊕ Y`, without the need to take a quotient. In particular,
this gives a natural metric space structure on `X ⊕ Y`, where the basepoints
are at distance 1, say, and the distances between other points are obtained by going through the two
basepoints.
(We also register the same metric space structure on a general disjoint union `Σ i, E i`).

We also define the inductive limit of metric spaces. Given
```
     f 0        f 1        f 2        f 3
X 0 -----> X 1 -----> X 2 -----> X 3 -----> ...
```
where the `X n` are metric spaces and `f n` isometric embeddings, we define the inductive
limit of the `X n`, also known as the increasing union of the `X n` in this context, if we
identify `X n` and `X (n+1)` through `f n`. This is a metric space in which all `X n` embed
isometrically and in a way compatible with `f n`.

-/

noncomputable theory

universes u v w
open function set
open_locale uniformity

namespace metric
section approx_gluing

variables {X : Type u} {Y : Type v} {Z : Type w}

variables [metric_space X] [metric_space Y]
          {Φ : Z → X} {Ψ : Z → Y} {ε : ℝ}
open _root_.sum (inl inr)

/-- Define a predistance on `X ⊕ Y`, for which `Φ p` and `Ψ p` are at distance `ε` -/
def glue_dist (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) : X ⊕ Y → X ⊕ Y → ℝ
| (inl x) (inl y) := dist x y
| (inr x) (inr y) := dist x y
| (inl x) (inr y) := (⨅ p, dist x (Φ p) + dist y (Ψ p)) + ε
| (inr x) (inl y) := (⨅ p, dist y (Φ p) + dist x (Ψ p)) + ε

private lemma glue_dist_self (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) : ∀ x, glue_dist Φ Ψ ε x x = 0
| (inl x) := dist_self _
| (inr x) := dist_self _

lemma glue_dist_glued_points [nonempty Z] (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) (p : Z) :
  glue_dist Φ Ψ ε (inl (Φ p)) (inr (Ψ p)) = ε :=
begin
  have : (⨅ q, dist (Φ p) (Φ q) + dist (Ψ p) (Ψ q)) = 0,
  { have A : ∀ q, 0 ≤ dist (Φ p) (Φ q) + dist (Ψ p) (Ψ q) :=
      λq, by rw ← add_zero (0 : ℝ); exact add_le_add dist_nonneg dist_nonneg,
    refine le_antisymm _ (le_cinfi A),
    have : 0 = dist (Φ p) (Φ p) + dist (Ψ p) (Ψ p), by simp,
    rw this,
    exact cinfi_le ⟨0, forall_range_iff.2 A⟩ p },
  rw [glue_dist, this, zero_add]
end

private lemma glue_dist_comm (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) :
  ∀ x y, glue_dist Φ Ψ ε x y = glue_dist Φ Ψ ε y x
| (inl x) (inl y) := dist_comm _ _
| (inr x) (inr y) := dist_comm _ _
| (inl x) (inr y) := rfl
| (inr x) (inl y) := rfl

variable [nonempty Z]

private lemma glue_dist_triangle (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ)
  (H : ∀ p q, |dist (Φ p) (Φ q) - dist (Ψ p) (Ψ q)| ≤ 2 * ε) :
  ∀ x y z, glue_dist Φ Ψ ε x z ≤ glue_dist Φ Ψ ε x y + glue_dist Φ Ψ ε y z
| (inl x) (inl y) (inl z) := dist_triangle _ _ _
| (inr x) (inr y) (inr z) := dist_triangle _ _ _
| (inr x) (inl y) (inl z) := begin
    have B : ∀ a b, bdd_below (range (λ (p : Z), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : (⨅ p, dist z (Φ p) + dist x (Ψ p)) ≤ (⨅ p, dist y (Φ p) + dist x (Ψ p)) + dist y z,
    { have : (⨅ p, dist y (Φ p) + dist x (Ψ p)) + dist y z =
            infi ((λt, t + dist y z) ∘ (λp, dist y (Φ p) + dist x (Ψ p))),
      { refine monotone.map_cinfi_of_continuous_at (continuous_at_id.add continuous_at_const) _
          (B _ _),
        intros x y hx, simpa },
      rw [this, comp],
      refine cinfi_mono (B _ _) (λp, _),
      calc
        dist z (Φ p) + dist x (Ψ p) ≤ (dist y z + dist y (Φ p)) + dist x (Ψ p) :
          add_le_add (dist_triangle_left _ _ _) le_rfl
        ... = dist y (Φ p) + dist x (Ψ p) + dist y z : by ring },
    linarith
  end
| (inr x) (inr y) (inl z) := begin
    have B : ∀ a b, bdd_below (range (λ (p : Z), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : (⨅ p, dist z (Φ p) + dist x (Ψ p)) ≤ dist x y + ⨅ p, dist z (Φ p) + dist y (Ψ p),
    { have : dist x y + (⨅ p, dist z (Φ p) + dist y (Ψ p)) =
            infi ((λt, dist x y + t) ∘ (λp, dist z (Φ p) + dist y (Ψ p))),
      { refine monotone.map_cinfi_of_continuous_at (continuous_at_const.add continuous_at_id) _
          (B _ _),
        intros x y hx, simpa },
      rw [this, comp],
      refine cinfi_mono (B _ _) (λp, _),
      calc
        dist z (Φ p) + dist x (Ψ p) ≤ dist z (Φ p) + (dist x y + dist y (Ψ p)) :
          add_le_add le_rfl (dist_triangle _ _ _)
        ... = dist x y + (dist z (Φ p) + dist y (Ψ p)) : by ring },
    linarith
  end
| (inl x) (inl y) (inr z) := begin
    have B : ∀ a b, bdd_below (range (λ (p : Z), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : (⨅ p, dist x (Φ p) + dist z (Ψ p)) ≤ dist x y + ⨅ p, dist y (Φ p) + dist z (Ψ p),
    { have : dist x y + (⨅ p, dist y (Φ p) + dist z (Ψ p)) =
            infi ((λt, dist x y + t) ∘ (λp, dist y (Φ p) + dist z (Ψ p))),
      { refine monotone.map_cinfi_of_continuous_at (continuous_at_const.add continuous_at_id) _
          (B _ _),
        intros x y hx, simpa },
      rw [this, comp],
      refine cinfi_mono (B _ _) (λp, _),
      calc
        dist x (Φ p) + dist z (Ψ p) ≤ (dist x y + dist y (Φ p)) + dist z (Ψ p) :
          add_le_add (dist_triangle _ _ _) le_rfl
        ... = dist x y + (dist y (Φ p) + dist z (Ψ p)) : by ring },
    linarith
  end
| (inl x) (inr y) (inr z) := begin
    have B : ∀ a b, bdd_below (range (λ (p : Z), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : (⨅ p, dist x (Φ p) + dist z (Ψ p)) ≤ (⨅ p, dist x (Φ p) + dist y (Ψ p)) + dist y z,
    { have : (⨅ p, dist x (Φ p) + dist y (Ψ p)) + dist y z =
            infi ((λt, t + dist y z) ∘ (λp, dist x (Φ p) + dist y (Ψ p))),
      { refine monotone.map_cinfi_of_continuous_at (continuous_at_id.add continuous_at_const) _
          (B _ _),
        intros x y hx, simpa },
      rw [this, comp],
      refine cinfi_mono (B _ _) (λp, _),
      calc
        dist x (Φ p) + dist z (Ψ p) ≤ dist x (Φ p) + (dist y z + dist y (Ψ p)) :
          add_le_add le_rfl (dist_triangle_left _ _ _)
        ... = dist x (Φ p) + dist y (Ψ p) + dist y z : by ring },
    linarith
  end
| (inl x) (inr y) (inl z) := le_of_forall_pos_le_add $ λδ δpos, begin
    obtain ⟨p, hp⟩ : ∃ p, dist x (Φ p) + dist y (Ψ p) < (⨅ p, dist x (Φ p) + dist y (Ψ p)) + δ / 2,
      from exists_lt_of_cinfi_lt (by linarith),
    obtain ⟨q, hq⟩ : ∃ q, dist z (Φ q) + dist y (Ψ q) < (⨅ p, dist z (Φ p) + dist y (Ψ p)) + δ / 2,
      from exists_lt_of_cinfi_lt (by linarith),
    have : dist (Φ p) (Φ q) ≤ dist (Ψ p) (Ψ q) + 2 * ε,
      { have := le_trans (le_abs_self _) (H p q), by linarith },
    calc dist x z ≤ dist x (Φ p) + dist (Φ p) (Φ q) + dist (Φ q) z : dist_triangle4 _ _ _ _
      ... ≤ dist x (Φ p) + dist (Ψ p) (Ψ q) + dist z (Φ q) + 2 * ε : by rw [dist_comm z]; linarith
      ... ≤ dist x (Φ p) + (dist y (Ψ p) + dist y (Ψ q)) + dist z (Φ q) + 2 * ε :
        add_le_add (add_le_add (add_le_add le_rfl (dist_triangle_left _ _ _)) le_rfl) le_rfl
      ... ≤ ((⨅ p, dist x (Φ p) + dist y (Ψ p)) + ε) +
            ((⨅ p, dist z (Φ p) + dist y (Ψ p)) + ε) + δ : by linarith
  end
| (inr x) (inl y) (inr z) := le_of_forall_pos_le_add $ λδ δpos, begin
    obtain ⟨p, hp⟩ : ∃ p, dist y (Φ p) + dist x (Ψ p) < (⨅ p, dist y (Φ p) + dist x (Ψ p)) + δ / 2,
      from exists_lt_of_cinfi_lt (by linarith),
    obtain ⟨q, hq⟩ : ∃ q, dist y (Φ q) + dist z (Ψ q) < (⨅ p, dist y (Φ p) + dist z (Ψ p)) + δ / 2,
      from exists_lt_of_cinfi_lt (by linarith),
    have : dist (Ψ p) (Ψ q) ≤ dist (Φ p) (Φ q) + 2 * ε,
      { have := le_trans (neg_le_abs_self _) (H p q), by linarith },
    calc dist x z ≤ dist x (Ψ p) + dist (Ψ p) (Ψ q) + dist (Ψ q) z : dist_triangle4 _ _ _ _
      ... ≤ dist x (Ψ p) + dist (Φ p) (Φ q) + dist z (Ψ q) + 2 * ε : by rw [dist_comm z]; linarith
      ... ≤ dist x (Ψ p) + (dist y (Φ p) + dist y (Φ q)) + dist z (Ψ q) + 2 * ε :
        add_le_add (add_le_add (add_le_add le_rfl (dist_triangle_left _ _ _)) le_rfl) le_rfl
      ... ≤ ((⨅ p, dist y (Φ p) + dist x (Ψ p)) + ε) +
            ((⨅ p, dist y (Φ p) + dist z (Ψ p)) + ε) + δ : by linarith
  end

private lemma glue_eq_of_dist_eq_zero (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) (ε0 : 0 < ε) :
  ∀ p q : X ⊕ Y, glue_dist Φ Ψ ε p q = 0 → p = q
| (inl x) (inl y) h := by rw eq_of_dist_eq_zero h
| (inl x) (inr y) h := begin
    have : 0 ≤ (⨅ p, dist x (Φ p) + dist y (Ψ p)) :=
      le_cinfi (λp, by simpa using add_le_add (@dist_nonneg _ _ x _) (@dist_nonneg _ _ y _)),
    have : 0 + ε ≤ glue_dist Φ Ψ ε (inl x) (inr y) := add_le_add this (le_refl ε),
    exfalso,
    linarith
  end
| (inr x) (inl y) h := begin
    have : 0 ≤ ⨅ p, dist y (Φ p) + dist x (Ψ p) :=
      le_cinfi (λp, by simpa [add_comm]
                         using add_le_add (@dist_nonneg _ _ x _) (@dist_nonneg _ _ y _)),
    have : 0 + ε ≤ glue_dist Φ Ψ ε (inr x) (inl y) := add_le_add this (le_refl ε),
    exfalso,
    linarith
  end
| (inr x) (inr y) h := by rw eq_of_dist_eq_zero h

/-- Given two maps `Φ` and `Ψ` intro metric spaces `X` and `Y` such that the distances between
`Φ p` and `Φ q`, and between `Ψ p` and `Ψ q`, coincide up to `2 ε` where `ε > 0`, one can almost
glue the two spaces `X` and `Y` along the images of `Φ` and `Ψ`, so that `Φ p` and `Ψ p` are
at distance `ε`. -/
def glue_metric_approx (Φ : Z → X) (Ψ : Z → Y) (ε : ℝ) (ε0 : 0 < ε)
  (H : ∀ p q, |dist (Φ p) (Φ q) - dist (Ψ p) (Ψ q)| ≤ 2 * ε) : metric_space (X ⊕ Y) :=
{ dist               := glue_dist Φ Ψ ε,
  dist_self          := glue_dist_self Φ Ψ ε,
  dist_comm          := glue_dist_comm Φ Ψ ε,
  dist_triangle      := glue_dist_triangle Φ Ψ ε H,
  eq_of_dist_eq_zero := glue_eq_of_dist_eq_zero Φ Ψ ε ε0 }

end approx_gluing

section sum
/- A particular case of the previous construction is when one uses basepoints in `X` and `Y` and one
glues only along the basepoints, putting them at distance 1. We give a direct definition of
the distance, without infi, as it is easier to use in applications, and show that it is equal to
the gluing distance defined above to take advantage of the lemmas we have already proved. -/

variables {X : Type u} {Y : Type v} {Z : Type w}
variables [metric_space X] [metric_space Y]
open sum (inl inr)

/-- Distance on a disjoint union. There are many (noncanonical) ways to put a distance compatible
with each factor.
If the two spaces are bounded, one can say for instance that each point in the first is at distance
`diam X + diam Y + 1` of each point in the second.
Instead, we choose a construction that works for unbounded spaces, but requires basepoints,
chosen arbitrarily.
We embed isometrically each factor, set the basepoints at distance 1,
arbitrarily, and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/
def sum.dist : X ⊕ Y → X ⊕ Y → ℝ
| (inl a) (inl a') := dist a a'
| (inr b) (inr b') := dist b b'
| (inl a) (inr b)  := dist a (nonempty.some ⟨a⟩) + 1 + dist (nonempty.some ⟨b⟩) b
| (inr b) (inl a)  := dist b (nonempty.some ⟨b⟩) + 1 + dist (nonempty.some ⟨a⟩) a

lemma sum.dist_eq_glue_dist {p q : X ⊕ Y} (x : X) (y : Y) :
  sum.dist p q = glue_dist (λ _ : unit, nonempty.some ⟨x⟩) (λ _ : unit, nonempty.some ⟨y⟩) 1 p q :=
by cases p; cases q; refl <|> simp [sum.dist, glue_dist, dist_comm, add_comm, add_left_comm]

private lemma sum.dist_comm (x y : X ⊕ Y) : sum.dist x y = sum.dist y x :=
by cases x; cases y; simp only [sum.dist, dist_comm, add_comm, add_left_comm]

lemma sum.one_dist_le {x : X} {y : Y} : 1 ≤ sum.dist (inl x) (inr y) :=
le_trans (le_add_of_nonneg_right dist_nonneg) $
add_le_add_right (le_add_of_nonneg_left dist_nonneg) _

lemma sum.one_dist_le' {x : X} {y : Y} : 1 ≤ sum.dist (inr y) (inl x) :=
by rw sum.dist_comm; exact sum.one_dist_le

private lemma sum.mem_uniformity (s : set ((X ⊕ Y) × (X ⊕ Y))) :
  s ∈ 𝓤 (X ⊕ Y) ↔ ∃ ε > 0, ∀ a b, sum.dist a b < ε → (a, b) ∈ s :=
begin
  split,
  { rintro ⟨hsX, hsY⟩,
    rcases mem_uniformity_dist.1 hsX with ⟨εX, εX0, hX⟩,
    rcases mem_uniformity_dist.1 hsY with ⟨εY, εY0, hY⟩,
    refine ⟨min (min εX εY) 1, lt_min (lt_min εX0 εY0) zero_lt_one, _⟩,
    rintro (a|a) (b|b) h,
    { exact hX (lt_of_lt_of_le h (le_trans (min_le_left _ _) (min_le_left _ _))) },
    { cases not_le_of_lt (lt_of_lt_of_le h (min_le_right _ _)) sum.one_dist_le },
    { cases not_le_of_lt (lt_of_lt_of_le h (min_le_right _ _)) sum.one_dist_le' },
    { exact hY (lt_of_lt_of_le h (le_trans (min_le_left _ _) (min_le_right _ _))) } },
  { rintro ⟨ε, ε0, H⟩,
    split; rw [filter.mem_sets, filter.mem_map, mem_uniformity_dist];
      exact ⟨ε, ε0, λ x y h, H _ _ (by exact h)⟩ }
end

/-- The distance on the disjoint union indeed defines a metric space. All the distance properties
follow from our choice of the distance. The harder work is to show that the uniform structure
defined by the distance coincides with the disjoint union uniform structure. -/
def metric_space_sum : metric_space (X ⊕ Y) :=
{ dist               := sum.dist,
  dist_self          := λx, by cases x; simp only [sum.dist, dist_self],
  dist_comm          := sum.dist_comm,
  dist_triangle      := λ p q r,
  begin
    cases p; cases q; cases r,
    { exact dist_triangle _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist p r],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist p q],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist p q],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist q p],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist q p],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { simp only [dist, sum.dist_eq_glue_dist r p],
      exact glue_dist_triangle _ _ _ (by norm_num) _ _ _ },
    { exact dist_triangle _ _ _ },
  end,
  eq_of_dist_eq_zero := λ p q,
  begin
    cases p; cases q,
    { simp only [sum.dist, dist_eq_zero, imp_self] },
    { assume h,
      simp only [dist, sum.dist_eq_glue_dist p q] at h,
      exact glue_eq_of_dist_eq_zero _ _ _ zero_lt_one _ _ h },
    { assume h,
      simp only [dist, sum.dist_eq_glue_dist q p] at h,
      exact glue_eq_of_dist_eq_zero _ _ _ zero_lt_one _ _ h },
    { simp only [sum.dist, dist_eq_zero, imp_self] },
  end,
  to_uniform_space   := sum.uniform_space,
  uniformity_dist    := uniformity_dist_of_mem_uniformity _ _ sum.mem_uniformity }

local attribute [instance] metric_space_sum

lemma sum.dist_eq {x y : X ⊕ Y} : dist x y = sum.dist x y := rfl

/-- The left injection of a space in a disjoint union is an isometry -/
lemma isometry_inl : isometry (sum.inl : X → (X ⊕ Y)) :=
isometry.of_dist_eq $ λ x y, rfl

/-- The right injection of a space in a disjoint union is an isometry -/
lemma isometry_inr : isometry (sum.inr : Y → (X ⊕ Y)) :=
isometry.of_dist_eq $ λ x y, rfl

end sum

namespace sigma
/- Copy of the previous paragraph, but for arbitrary disjoint unions instead of the disjoint union
of two spaces. I.e., work with sigma types instead of sum types. -/

variables {ι : Type*} {E : ι → Type*} [∀ i, metric_space (E i)]

open_locale classical

/-- Distance on a disjoint union. There are many (noncanonical) ways to put a distance compatible
with each factor.
We choose a construction that works for unbounded spaces, but requires basepoints,
chosen arbitrarily.
We embed isometrically each factor, set the basepoints at distance 1, arbitrarily,
and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/
protected def dist : (Σ i, E i) → (Σ i, E i) → ℝ
| ⟨i, x⟩ ⟨j, y⟩ :=
    if h : i = j then by { have : E j = E i, by rw h, exact has_dist.dist x (cast this y) }
    else has_dist.dist x (nonempty.some ⟨x⟩) + 1 + has_dist.dist (nonempty.some ⟨y⟩) y

/-- A `has_dist` instance on the disjoint union `Σ i, E i`.
We embed isometrically each factor, set the basepoints at distance 1, arbitrarily,
and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/
def has_dist : has_dist (Σ i, E i) :=
⟨sigma.dist⟩

local attribute [instance] sigma.has_dist

@[simp] lemma dist_same (i : ι) (x : E i) (y : E i) :
  dist (⟨i, x⟩ : Σ j, E j) ⟨i, y⟩ = dist x y :=
by simp [has_dist.dist, sigma.dist]

@[simp] lemma dist_ne {i j : ι} (h : i ≠ j) (x : E i) (y : E j) :
  dist (⟨i, x⟩ : Σ k, E k) ⟨j, y⟩ = dist x (nonempty.some ⟨x⟩) + 1 + dist (nonempty.some ⟨y⟩) y :=
by simp [has_dist.dist, sigma.dist, h]

lemma one_le_dist_of_ne {i j : ι} (h : i ≠ j) (x : E i) (y : E j) :
  1 ≤ dist (⟨i, x⟩ : Σ k, E k) ⟨j, y⟩ :=
begin
  rw sigma.dist_ne h x y,
  linarith [@dist_nonneg _ _ x (nonempty.some ⟨x⟩), @dist_nonneg _ _ (nonempty.some ⟨y⟩) y]
end

lemma fst_eq_of_dist_lt_one (x y : Σ i, E i) (h : dist x y < 1) :
  x.1 = y.1 :=
begin
  cases x, cases y,
  contrapose! h,
  apply one_le_dist_of_ne h,
end

protected lemma dist_triangle (x y z : Σ i, E i) :
  dist x z ≤ dist x y + dist y z :=
begin
  rcases x with ⟨i, x⟩, rcases y with ⟨j, y⟩, rcases z with ⟨k, z⟩,
  rcases eq_or_ne i k with rfl|hik,
  { rcases eq_or_ne i j with rfl|hij,
    { simpa using dist_triangle x y z },
    { simp only [hij, hij.symm, sigma.dist_same, sigma.dist_ne, ne.def, not_false_iff],
      calc dist x z ≤ dist x (nonempty.some ⟨x⟩) + 0 + 0 + (0 + 0 + dist (nonempty.some ⟨z⟩) z) :
        by simpa only [zero_add, add_zero] using dist_triangle _ _ _
      ... ≤ _ : by apply_rules [add_le_add, le_rfl, dist_nonneg, zero_le_one] } },
  { rcases eq_or_ne i j with rfl|hij,
    { simp only [hik, sigma.dist_ne, ne.def, not_false_iff, sigma.dist_same],
      calc dist x (nonempty.some ⟨x⟩) + 1 + dist (nonempty.some ⟨z⟩) z ≤
        (dist x y + dist y (nonempty.some ⟨y⟩) + 1 + dist (nonempty.some ⟨z⟩) z) :
          by apply_rules [add_le_add, le_rfl, dist_triangle]
      ... = _ : by abel },
    { rcases eq_or_ne j k with rfl|hjk,
      { simp only [hij, sigma.dist_ne, ne.def, not_false_iff, sigma.dist_same],
        calc dist x (nonempty.some ⟨x⟩) + 1 + dist (nonempty.some ⟨z⟩) z ≤
          dist x (nonempty.some ⟨x⟩) + 1 + (dist (nonempty.some ⟨z⟩) y + dist y z) :
            by apply_rules [add_le_add, le_rfl, dist_triangle]
        ... = _ : by abel },
      { simp only [hik, hij, hjk, sigma.dist_ne, ne.def, not_false_iff],
        calc dist x (nonempty.some ⟨x⟩) + 1 + dist (nonempty.some ⟨z⟩) z
          = dist x (nonempty.some ⟨x⟩) + 1 + 0 + (0 + 0 + dist (nonempty.some ⟨z⟩) z) :
            by simp only [add_zero, zero_add]
        ... ≤ _ :
          by apply_rules [add_le_add, zero_le_one, dist_nonneg, le_rfl] } } }
end

protected lemma is_open_iff (s : set (Σ i, E i)) :
  is_open s ↔ ∀ x ∈ s, ∃ ε > 0, ∀ y, dist x y < ε → y ∈ s :=
begin
  split,
  { rintros hs ⟨i, x⟩ hx,
    obtain ⟨ε, εpos, hε⟩ : ∃ (ε : ℝ) (H : ε > 0), ball x ε ⊆ sigma.mk i ⁻¹' s :=
      metric.is_open_iff.1 (is_open_sigma_iff.1 hs i) x hx,
    refine ⟨min ε 1, lt_min εpos zero_lt_one, _⟩,
    rintros ⟨j, y⟩ hy,
    rcases eq_or_ne i j with rfl|hij,
    { simp only [sigma.dist_same, lt_min_iff] at hy,
      exact hε (mem_ball'.2 hy.1) },
    { apply (lt_irrefl (1 : ℝ) _).elim,
      calc 1 ≤ sigma.dist ⟨i, x⟩ ⟨j, y⟩ : sigma.one_le_dist_of_ne hij _ _
      ... < 1 : hy.trans_le (min_le_right _ _) } },
  { assume H,
    apply is_open_sigma_iff.2 (λ i, _),
    apply metric.is_open_iff.2 (λ x hx, _),
    obtain ⟨ε, εpos, hε⟩ : ∃ (ε : ℝ) (H : ε > 0), ∀ y, dist (⟨i, x⟩ : Σ j, E j) y < ε → y ∈ s :=
      H ⟨i, x⟩ hx,
    refine ⟨ε, εpos, λ y hy, _⟩,
    apply hε ⟨i, y⟩,
    rw sigma.dist_same,
    exact mem_ball'.1 hy }
end

/-- A metric space structure on the disjoint union `Σ i, E i`.
We embed isometrically each factor, set the basepoints at distance 1, arbitrarily,
and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/
protected def metric_space : metric_space (Σ i, E i) :=
begin
  refine metric_space.of_dist_topology sigma.dist _ _ sigma.dist_triangle
    sigma.is_open_iff _,
  { rintros ⟨i, x⟩, simp [sigma.dist] },
  { rintros ⟨i, x⟩ ⟨j, y⟩,
    rcases eq_or_ne i j with rfl|h,
    { simp [sigma.dist, dist_comm] },
    { simp only [sigma.dist, dist_comm, h, h.symm, not_false_iff, dif_neg], abel } },
  { rintros ⟨i, x⟩ ⟨j, y⟩,
    rcases eq_or_ne i j with rfl|hij,
    { simp [sigma.dist] },
    { assume h,
      apply (lt_irrefl (1 : ℝ) _).elim,
      calc 1 ≤ sigma.dist (⟨i, x⟩ : Σ k, E k) ⟨j, y⟩ : sigma.one_le_dist_of_ne hij _ _
      ... < 1 : by { rw h, exact zero_lt_one } } }
end

local attribute [instance] sigma.metric_space

open_locale topology
open filter

/-- The injection of a space in a disjoint union is an isometry -/
lemma isometry_mk (i : ι) : isometry (sigma.mk i : E i → Σ k, E k) :=
isometry.of_dist_eq (λ x y, by simp)

/-- A disjoint union of complete metric spaces is complete. -/
protected lemma complete_space [∀ i, complete_space (E i)] : complete_space (Σ i, E i) :=
begin
  set s : ι → set (Σ i, E i) := λ i, (sigma.fst ⁻¹' {i}),
  set U := {p : (Σ k, E k) × (Σ k, E k) | dist p.1 p.2 < 1},
  have hc : ∀ i, is_complete (s i),
  { intro i,
    simp only [s, ← range_sigma_mk],
    exact (isometry_mk i).uniform_inducing.is_complete_range },
  have hd : ∀ i j (x ∈ s i) (y ∈ s j), (x, y) ∈ U → i = j,
    from λ i j x hx y hy hxy, (eq.symm hx).trans ((fst_eq_of_dist_lt_one _ _ hxy).trans hy),
  refine complete_space_of_is_complete_univ _,
  convert is_complete_Union_separated hc (dist_mem_uniformity zero_lt_one) hd,
  simp [s, ← preimage_Union]
end

end sigma

section gluing
/- Exact gluing of two metric spaces along isometric subsets. -/

variables {X : Type u} {Y : Type v} {Z : Type w}
variables [nonempty Z] [metric_space Z] [metric_space X] [metric_space Y]
          {Φ : Z → X} {Ψ : Z → Y} {ε : ℝ}
open _root_.sum (inl inr)
local attribute [instance] uniform_space.separation_setoid

/-- Given two isometric embeddings `Φ : Z → X` and `Ψ : Z → Y`, we define a pseudo metric space
structure on `X ⊕ Y` by declaring that `Φ x` and `Ψ x` are at distance `0`. -/
def glue_premetric (hΦ : isometry Φ) (hΨ : isometry Ψ) : pseudo_metric_space (X ⊕ Y) :=
{ dist          := glue_dist Φ Ψ 0,
  dist_self     := glue_dist_self Φ Ψ 0,
  dist_comm     := glue_dist_comm Φ Ψ 0,
  dist_triangle := glue_dist_triangle Φ Ψ 0 $ λp q, by rw [hΦ.dist_eq, hΨ.dist_eq]; simp }

/-- Given two isometric embeddings `Φ : Z → X` and `Ψ : Z → Y`, we define a
space  `glue_space hΦ hΨ` by identifying in `X ⊕ Y` the points `Φ x` and `Ψ x`. -/
@[derive metric_space]
def glue_space (hΦ : isometry Φ) (hΨ : isometry Ψ) : Type* :=
@uniform_space.separation_quotient _ (glue_premetric hΦ hΨ).to_uniform_space

/-- The canonical map from `X` to the space obtained by gluing isometric subsets in `X` and `Y`. -/
def to_glue_l (hΦ : isometry Φ) (hΨ : isometry Ψ) (x : X) : glue_space hΦ hΨ := quotient.mk' (inl x)

/-- The canonical map from `Y` to the space obtained by gluing isometric subsets in `X` and `Y`. -/
def to_glue_r (hΦ : isometry Φ) (hΨ : isometry Ψ) (y : Y) : glue_space hΦ hΨ := quotient.mk' (inr y)

instance inhabited_left (hΦ : isometry Φ) (hΨ : isometry Ψ) [inhabited X] :
  inhabited (glue_space hΦ hΨ) :=
⟨to_glue_l _ _ default⟩

instance inhabited_right (hΦ : isometry Φ) (hΨ : isometry Ψ) [inhabited Y] :
  inhabited (glue_space hΦ hΨ) :=
⟨to_glue_r _ _ default⟩

lemma to_glue_commute (hΦ : isometry Φ) (hΨ : isometry Ψ) :
  (to_glue_l hΦ hΨ) ∘ Φ = (to_glue_r hΦ hΨ) ∘ Ψ :=
begin
  letI i : pseudo_metric_space (X ⊕ Y) := glue_premetric hΦ hΨ,
  letI := i.to_uniform_space,
  funext,
  simp only [comp, to_glue_l, to_glue_r],
  refine uniform_space.separation_quotient.mk_eq_mk.2 (metric.inseparable_iff.2 _),
  exact glue_dist_glued_points Φ Ψ 0 x
end

lemma to_glue_l_isometry (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_l hΦ hΨ) :=
isometry.of_dist_eq $ λ_ _, rfl

lemma to_glue_r_isometry (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_r hΦ hΨ) :=
isometry.of_dist_eq $ λ_ _, rfl

end gluing --section

section inductive_limit
/- In this section, we define the inductive limit of
     f 0        f 1        f 2        f 3
X 0 -----> X 1 -----> X 2 -----> X 3 -----> ...
where the X n are metric spaces and f n isometric embeddings. We do it by defining a premetric
space structure on Σ n, X n, where the predistance dist x y is obtained by pushing x and y in a
common X k using composition by the f n, and taking the distance there. This does not depend on
the choice of k as the f n are isometries. The metric space associated to this premetric space
is the desired inductive limit.-/
open nat

variables {X : ℕ → Type u} [∀ n, metric_space (X n)] {f : Π n, X n → X (n+1)}

/-- Predistance on the disjoint union `Σ n, X n`. -/
def inductive_limit_dist (f : Π n, X n → X (n+1)) (x y : Σ n, X n) : ℝ :=
dist (le_rec_on (le_max_left  x.1 y.1) f x.2 : X (max x.1 y.1))
     (le_rec_on (le_max_right x.1 y.1) f y.2 : X (max x.1 y.1))

/-- The predistance on the disjoint union `Σ n, X n` can be computed in any `X k` for large
enough `k`. -/
lemma inductive_limit_dist_eq_dist (I : ∀ n, isometry (f n))
  (x y : Σ n, X n) (m : ℕ) : ∀ hx : x.1 ≤ m, ∀ hy : y.1 ≤ m,
  inductive_limit_dist f x y = dist (le_rec_on hx f x.2 : X m) (le_rec_on hy f y.2 : X m) :=
begin
  induction m with m hm,
  { assume hx hy,
    have A : max x.1 y.1 = 0, { rw [nonpos_iff_eq_zero.1 hx, nonpos_iff_eq_zero.1 hy], simp },
    unfold inductive_limit_dist,
    congr; simp only [A] },
  { assume hx hy,
    by_cases h : max x.1 y.1 = m.succ,
    { unfold inductive_limit_dist,
      congr; simp only [h] },
    { have : max x.1 y.1 ≤ succ m := by simp [hx, hy],
      have : max x.1 y.1 ≤ m := by simpa [h] using of_le_succ this,
      have xm : x.1 ≤ m := le_trans (le_max_left _ _) this,
      have ym : y.1 ≤ m := le_trans (le_max_right _ _) this,
      rw [le_rec_on_succ xm, le_rec_on_succ ym, (I m).dist_eq],
      exact hm xm ym }}
end

/-- Premetric space structure on `Σ n, X n`.-/
def inductive_premetric (I : ∀ n, isometry (f n)) :
  pseudo_metric_space (Σ n, X n) :=
{ dist          := inductive_limit_dist f,
  dist_self     := λx, by simp [dist, inductive_limit_dist],
  dist_comm     := λx y, begin
    let m := max x.1 y.1,
    have hx : x.1 ≤ m := le_max_left _ _,
    have hy : y.1 ≤ m := le_max_right _ _,
    unfold dist,
    rw [inductive_limit_dist_eq_dist I x y m hx hy, inductive_limit_dist_eq_dist I y x m hy hx,
        dist_comm]
  end,
  dist_triangle := λx y z, begin
    let m := max (max x.1 y.1) z.1,
    have hx : x.1 ≤ m := le_trans (le_max_left _ _) (le_max_left _ _),
    have hy : y.1 ≤ m := le_trans (le_max_right _ _) (le_max_left _ _),
    have hz : z.1 ≤ m := le_max_right _ _,
    calc inductive_limit_dist f x z
      = dist (le_rec_on hx f x.2 : X m) (le_rec_on hz f z.2 : X m) :
        inductive_limit_dist_eq_dist I x z m hx hz
      ... ≤ dist (le_rec_on hx f x.2 : X m) (le_rec_on hy f y.2 : X m)
          + dist (le_rec_on hy f y.2 : X m) (le_rec_on hz f z.2 : X m) :
        dist_triangle _ _ _
      ... = inductive_limit_dist f x y + inductive_limit_dist f y z :
         by rw [inductive_limit_dist_eq_dist I x y m hx hy,
                inductive_limit_dist_eq_dist I y z m hy hz]
  end }

local attribute [instance] inductive_premetric uniform_space.separation_setoid

/-- The type giving the inductive limit in a metric space context. -/
@[derive metric_space] def inductive_limit (I : ∀ n, isometry (f n)) : Type* :=
@uniform_space.separation_quotient _ (inductive_premetric I).to_uniform_space

/-- Mapping each `X n` to the inductive limit. -/
def to_inductive_limit (I : ∀ n, isometry (f n)) (n : ℕ) (x : X n) : metric.inductive_limit I :=
quotient.mk' (sigma.mk n x)

instance (I : ∀ n, isometry (f n)) [inhabited (X 0)] : inhabited (inductive_limit I) :=
⟨to_inductive_limit _ 0 default⟩

/-- The map `to_inductive_limit n` mapping `X n` to the inductive limit is an isometry. -/
lemma to_inductive_limit_isometry (I : ∀ n, isometry (f n)) (n : ℕ) :
  isometry (to_inductive_limit I n) := isometry.of_dist_eq $ λ x y,
begin
  change inductive_limit_dist f ⟨n, x⟩ ⟨n, y⟩ = dist x y,
  rw [inductive_limit_dist_eq_dist I ⟨n, x⟩ ⟨n, y⟩ n (le_refl n) (le_refl n),
      le_rec_on_self, le_rec_on_self]
end

/-- The maps `to_inductive_limit n` are compatible with the maps `f n`. -/
lemma to_inductive_limit_commute (I : ∀ n, isometry (f n)) (n : ℕ) :
  (to_inductive_limit I n.succ) ∘ (f n) = to_inductive_limit I n :=
begin
  letI := inductive_premetric I,
  funext,
  simp only [comp, to_inductive_limit],
  refine uniform_space.separation_quotient.mk_eq_mk.2 (metric.inseparable_iff.2 _),
  show inductive_limit_dist f ⟨n.succ, f n x⟩ ⟨n, x⟩ = 0,
  { rw [inductive_limit_dist_eq_dist I ⟨n.succ, f n x⟩ ⟨n, x⟩ n.succ,
        le_rec_on_self, le_rec_on_succ, le_rec_on_self, dist_self],
    exact le_rfl,
    exact le_rfl,
    exact le_succ _ }
end

end inductive_limit --section
end metric --namespace


-- The code from the first lecture

variables P Q R : Prop

#check P ∧ Q

#check P → Q

#check P ∨ Q

#check ¬ P

#check P ↔ Q

theorem I : P → P :=
begin
  assume h,
  exact h
end

theorem C : (P → Q) → (Q → R) → (P → R) :=
begin
  assume f,
  assume g,
  assume p,
  apply g,
  apply f,
  exact p,
end

theorem swap : (P → Q → R) → (Q → P → R) :=
begin
  assume f,
  assume q,
  assume p,
  apply f,
  exact p,
  exact q,
end


/-
Copyright (c) 2021 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying
-/
import measure_theory.measure.vector_measure
import measure_theory.function.ae_eq_of_integral

/-!

# Vector measure defined by an integral

Given a measure `μ` and an integrable function `f : α → E`, we can define a vector measure `v` such
that for all measurable set `s`, `v i = ∫ x in s, f x ∂μ`. This definition is useful for
the Radon-Nikodym theorem for signed measures.

## Main definitions

* `measure_theory.measure.with_densityᵥ`: the vector measure formed by integrating a function `f`
  with respect to a measure `μ` on some set if `f` is integrable, and `0` otherwise.

-/

noncomputable theory
open_locale classical measure_theory nnreal ennreal

variables {α β : Type*} {m : measurable_space α}

namespace measure_theory

open topological_space

variables {μ ν : measure α}
variables {E : Type*} [normed_group E] [measurable_space E] [second_countable_topology E]
  [normed_space ℝ E] [complete_space E] [borel_space E]

/-- Given a measure `μ` and an integrable function `f`, `μ.with_densityᵥ f` is
the vector measure which maps the set `s` to `∫ₛ f ∂μ`. -/
def measure.with_densityᵥ {m : measurable_space α} (μ : measure α) (f : α → E) :
  vector_measure α E :=
if hf : integrable f μ then
{ measure_of' := λ s, if measurable_set s then ∫ x in s, f x ∂μ else 0,
  empty' := by simp,
  not_measurable' := λ s hs, if_neg hs,
  m_Union' := λ s hs₁ hs₂,
  begin
    convert has_sum_integral_Union hs₁ hs₂ hf.integrable_on,
    { ext n, rw if_pos (hs₁ n) },
    { rw if_pos (measurable_set.Union hs₁) }
  end }
else 0

open measure

include m

variables {f g : α → E}

lemma with_densityᵥ_apply (hf : integrable f μ) {s : set α} (hs : measurable_set s) :
  μ.with_densityᵥ f s = ∫ x in s, f x ∂μ :=
by { rw [with_densityᵥ, dif_pos hf], exact dif_pos hs }

@[simp] lemma with_densityᵥ_zero : μ.with_densityᵥ (0 : α → E) = 0 :=
by { ext1 s hs, erw [with_densityᵥ_apply (integrable_zero α E μ) hs], simp, }

@[simp] lemma with_densityᵥ_neg : μ.with_densityᵥ (-f) = -μ.with_densityᵥ f :=
begin
  by_cases hf : integrable f μ,
  { ext1 i hi,
    rw [vector_measure.neg_apply, with_densityᵥ_apply hf hi,
        ← integral_neg, with_densityᵥ_apply hf.neg hi],
    refl },
  { rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg, neg_zero],
    rwa integrable_neg_iff }
end

lemma with_densityᵥ_neg' : μ.with_densityᵥ (λ x, -f x) = -μ.with_densityᵥ f :=
with_densityᵥ_neg

@[simp] lemma with_densityᵥ_add (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (f + g) = μ.with_densityᵥ f + μ.with_densityᵥ g :=
begin
  ext1 i hi,
  rw [with_densityᵥ_apply (hf.add hg) hi, vector_measure.add_apply,
      with_densityᵥ_apply hf hi, with_densityᵥ_apply hg hi],
  simp_rw [pi.add_apply],
  rw integral_add; rw ← integrable_on_univ,
  { exact hf.integrable_on.restrict measurable_set.univ },
  { exact hg.integrable_on.restrict measurable_set.univ }
end

lemma with_densityᵥ_add' (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (λ x, f x + g x) = μ.with_densityᵥ f + μ.with_densityᵥ g :=
with_densityᵥ_add hf hg

@[simp] lemma with_densityᵥ_sub (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (f - g) = μ.with_densityᵥ f - μ.with_densityᵥ g :=
by rw [sub_eq_add_neg, sub_eq_add_neg, with_densityᵥ_add hf hg.neg, with_densityᵥ_neg]

lemma with_densityᵥ_sub' (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (λ x, f x - g x) = μ.with_densityᵥ f - μ.with_densityᵥ g :=
with_densityᵥ_sub hf hg

@[simp] lemma with_densityᵥ_smul {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_space 𝕜 E]
  [smul_comm_class ℝ 𝕜 E] [measurable_space 𝕜] [opens_measurable_space 𝕜] (f : α → E) (r : 𝕜) :
  μ.with_densityᵥ (r • f) = r • μ.with_densityᵥ f :=
begin
  by_cases hf : integrable f μ,
  { ext1 i hi,
    rw [with_densityᵥ_apply (hf.smul r) hi, vector_measure.smul_apply,
        with_densityᵥ_apply hf hi, ← integral_smul r f],
    refl },
  { by_cases hr : r = 0,
    { rw [hr, zero_smul, zero_smul, with_densityᵥ_zero] },
    { rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg, smul_zero],
      rwa integrable_smul_iff hr f } }
end

lemma with_densityᵥ_smul' {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_space 𝕜 E]
  [smul_comm_class ℝ 𝕜 E] [measurable_space 𝕜] [opens_measurable_space 𝕜] (f : α → E) (r : 𝕜) :
  μ.with_densityᵥ (λ x, r • f x) = r • μ.with_densityᵥ f :=
with_densityᵥ_smul f r

lemma measure.with_densityᵥ_absolutely_continuous (μ : measure α) (f : α → ℝ) :
  μ.with_densityᵥ f ≪ᵥ μ.to_ennreal_vector_measure :=
begin
  by_cases hf : integrable f μ,
  { refine vector_measure.absolutely_continuous.mk (λ i hi₁ hi₂, _),
    rw to_ennreal_vector_measure_apply_measurable hi₁ at hi₂,
    rw [with_densityᵥ_apply hf hi₁, measure.restrict_zero_set hi₂, integral_zero_measure] },
  { rw [with_densityᵥ, dif_neg hf],
    exact vector_measure.absolutely_continuous.zero _ }
end

/-- Having the same density implies the underlying functions are equal almost everywhere. -/
lemma integrable.ae_eq_of_with_densityᵥ_eq {f g : α → E} (hf : integrable f μ) (hg : integrable g μ)
  (hfg : μ.with_densityᵥ f = μ.with_densityᵥ g) :
  f =ᵐ[μ] g :=
begin
  refine hf.ae_eq_of_forall_set_integral_eq f g hg (λ i hi _, _),
  rw [← with_densityᵥ_apply hf hi, hfg, with_densityᵥ_apply hg hi]
end

lemma with_densityᵥ_eq.congr_ae {f g : α → E} (h : f =ᵐ[μ] g) :
  μ.with_densityᵥ f = μ.with_densityᵥ g :=
begin
  by_cases hf : integrable f μ,
  { ext i hi,
    rw [with_densityᵥ_apply hf hi, with_densityᵥ_apply (hf.congr h) hi],
    exact integral_congr_ae (ae_restrict_of_ae h) },
  { have hg : ¬ integrable g μ,
    { intro hg, exact hf (hg.congr h.symm) },
    rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg hg] }
end

section signed_measure

lemma with_densityᵥ_to_real {f : α → ℝ≥0∞} (hfm : ae_measurable f μ) (hf : ∫⁻ x, f x ∂μ ≠ ∞) :
  μ.with_densityᵥ (λ x, (f x).to_real) =
  @to_signed_measure α _ (μ.with_density f) (is_finite_measure_with_density hf) :=
begin
  have hfi := integrable_to_real_of_lintegral_ne_top hfm hf,
  ext i hi,
  rw [with_densityᵥ_apply hfi hi, to_signed_measure_apply_measurable hi,
      with_density_apply _ hi, integral_to_real hfm.restrict],
  refine ae_lt_top' hfm.restrict (ne_top_of_le_ne_top hf _),
  conv_rhs { rw ← set_lintegral_univ },
  exact lintegral_mono_set (set.subset_univ _),
end

lemma with_densityᵥ_eq_with_density_pos_part_sub_with_density_neg_part
  {f : α → ℝ} (hfi : integrable f μ) :
  μ.with_densityᵥ f =
  @to_signed_measure α _ (μ.with_density (λ x, ennreal.of_real $ f x))
    (is_finite_measure_with_density_of_real hfi.2) -
  @to_signed_measure α _ (μ.with_density (λ x, ennreal.of_real $ -f x))
    (is_finite_measure_with_density_of_real hfi.neg.2) :=
begin
  ext i hi,
  rw [with_densityᵥ_apply hfi hi,
      integral_eq_lintegral_pos_part_sub_lintegral_neg_part hfi.integrable_on,
      vector_measure.sub_apply, to_signed_measure_apply_measurable hi,
      to_signed_measure_apply_measurable hi, with_density_apply _ hi, with_density_apply _ hi],
end

lemma integrable.with_densityᵥ_trim_eq_integral {m m0 : measurable_space α}
  {μ : measure α} (hm : m ≤ m0) {f : α → ℝ} (hf : integrable f μ)
  {i : set α} (hi : measurable_set[m] i) :
  (μ.with_densityᵥ f).trim hm i = ∫ x in i, f x ∂μ :=
by rw [vector_measure.trim_measurable_set_eq hm hi, with_densityᵥ_apply hf (hm _ hi)]

lemma integrable.with_densityᵥ_trim_absolutely_continuous
  {m m0 : measurable_space α} {μ : measure α} (hm : m ≤ m0) (hfi : integrable f μ) :
  (μ.with_densityᵥ f).trim hm ≪ᵥ (μ.trim hm).to_ennreal_vector_measure :=
begin
  refine vector_measure.absolutely_continuous.mk (λ j hj₁ hj₂, _),
  rw [measure.to_ennreal_vector_measure_apply_measurable hj₁, trim_measurable_set_eq hm hj₁] at hj₂,
  rw [vector_measure.trim_measurable_set_eq hm hj₁, with_densityᵥ_apply hfi (hm _ hj₁)],
  simp only [measure.restrict_eq_zero.mpr hj₂, integral_zero_measure]
end

end signed_measure

end measure_theory


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.diagonal
! leanprover-community/mathlib commit f6bab67886fb92c3e2f539cc90a83815f69a189d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.Pullbacks
import Mathlib.CategoryTheory.Limits.Shapes.KernelPair
import Mathlib.CategoryTheory.Limits.Shapes.CommSq

/-!
# The diagonal object of a morphism.

We provide various API and isomorphisms considering the diagonal object `Δ_{Y/X} := pullback f f`
of a morphism `f : X ⟶ Y`.

-/

open CategoryTheory

noncomputable section

namespace CategoryTheory.Limits

variable {C : Type _} [Category C] {X Y Z : C}

namespace pullback

section Diagonal

variable (f : X ⟶ Y) [HasPullback f f]

/-- The diagonal object of a morphism `f : X ⟶ Y` is `Δ_{X/Y} := pullback f f`. -/
abbrev diagonalObj : C :=
  pullback f f
#align category_theory.limits.pullback.diagonal_obj CategoryTheory.Limits.pullback.diagonalObj

/-- The diagonal morphism `X ⟶ Δ_{X/Y}` for a morphism `f : X ⟶ Y`. -/
def diagonal : X ⟶ diagonalObj f :=
  pullback.lift (𝟙 _) (𝟙 _) rfl
#align category_theory.limits.pullback.diagonal CategoryTheory.Limits.pullback.diagonal

@[reassoc (attr := simp)]
theorem diagonal_fst : diagonal f ≫ pullback.fst = 𝟙 _ :=
  pullback.lift_fst _ _ _
#align category_theory.limits.pullback.diagonal_fst CategoryTheory.Limits.pullback.diagonal_fst

@[reassoc (attr := simp)]
theorem diagonal_snd : diagonal f ≫ pullback.snd = 𝟙 _ :=
  pullback.lift_snd _ _ _
#align category_theory.limits.pullback.diagonal_snd CategoryTheory.Limits.pullback.diagonal_snd

instance : IsSplitMono (diagonal f) :=
  ⟨⟨⟨pullback.fst, diagonal_fst f⟩⟩⟩

instance : IsSplitEpi (pullback.fst : pullback f f ⟶ X) :=
  ⟨⟨⟨diagonal f, diagonal_fst f⟩⟩⟩

instance : IsSplitEpi (pullback.snd : pullback f f ⟶ X) :=
  ⟨⟨⟨diagonal f, diagonal_snd f⟩⟩⟩

instance [Mono f] : IsIso (diagonal f) := by
  rw [(IsIso.inv_eq_of_inv_hom_id (diagonal_fst f)).symm]
  infer_instance

/-- The two projections `Δ_{X/Y} ⟶ X` form a kernel pair for `f : X ⟶ Y`. -/
theorem diagonal_isKernelPair : IsKernelPair f (pullback.fst : diagonalObj f ⟶ _) pullback.snd :=
  IsPullback.of_hasPullback f f
#align category_theory.limits.pullback.diagonal_is_kernel_pair CategoryTheory.Limits.pullback.diagonal_isKernelPair

end Diagonal

end pullback

variable [HasPullbacks C]

open pullback

section

variable {U V₁ V₂ : C} (f : X ⟶ Y) (i : U ⟶ Y)

variable (i₁ : V₁ ⟶ pullback f i) (i₂ : V₂ ⟶ pullback f i)

@[reassoc (attr := simp)]
theorem pullback_diagonal_map_snd_fst_fst :
    (pullback.snd :
          pullback (diagonal f)
              (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i (by simp [condition])
                (by simp [condition])) ⟶
            _) ≫
        fst ≫ i₁ ≫ fst =
      pullback.fst := by
  conv_rhs => rw [← Category.comp_id pullback.fst]
  rw [← diagonal_fst f, pullback.condition_assoc, pullback.lift_fst]
#align category_theory.limits.pullback_diagonal_map_snd_fst_fst CategoryTheory.Limits.pullback_diagonal_map_snd_fst_fst

@[reassoc (attr := simp)]
theorem pullback_diagonal_map_snd_snd_fst :
    (pullback.snd :
          pullback (diagonal f)
              (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i (by simp [condition])
                (by simp [condition])) ⟶
            _) ≫
        snd ≫ i₂ ≫ fst =
      pullback.fst := by
  conv_rhs => rw [← Category.comp_id pullback.fst]
  rw [← diagonal_snd f, pullback.condition_assoc, pullback.lift_snd]
#align category_theory.limits.pullback_diagonal_map_snd_snd_fst CategoryTheory.Limits.pullback_diagonal_map_snd_snd_fst

variable [HasPullback i₁ i₂]

set_option maxHeartbeats 400000 in
/-- This iso witnesses the fact that
given `f : X ⟶ Y`, `i : U ⟶ Y`, and `i₁ : V₁ ⟶ X ×[Y] U`, `i₂ : V₂ ⟶ X ×[Y] U`, the diagram

V₁ ×[X ×[Y] U] V₂ ⟶ V₁ ×[U] V₂
        |                 |
        |                 |
        ↓                 ↓
        X         ⟶  X ×[Y] X

is a pullback square.
Also see `pullback_fst_map_snd_isPullback`.
-/
def pullbackDiagonalMapIso :
    pullback (diagonal f)
        (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i
          (by simp only [Category.assoc, condition])
          (by simp only [Category.assoc, condition])) ≅
      pullback i₁ i₂ where
  hom :=
    pullback.lift (pullback.snd ≫ pullback.fst) (pullback.snd ≫ pullback.snd) (by
      ext
      . simp [Category.assoc, pullback_diagonal_map_snd_fst_fst, pullback_diagonal_map_snd_snd_fst]
      . simp [Category.assoc, pullback.condition, pullback.condition_assoc])
  inv :=
    pullback.lift (pullback.fst ≫ i₁ ≫ pullback.fst)
      (pullback.map _ _ _ _ (𝟙 _) (𝟙 _) pullback.snd (Category.id_comp _).symm
        (Category.id_comp _).symm) (by
        ext
        . simp only [Category.assoc, diagonal_fst, Category.comp_id, limit.lift_π,
            PullbackCone.mk_pt, PullbackCone.mk_π_app, limit.lift_π_assoc, cospan_left]
        . simp only [condition_assoc, Category.assoc, diagonal_snd, Category.comp_id,
            limit.lift_π, PullbackCone.mk_pt, PullbackCone.mk_π_app,
            limit.lift_π_assoc, cospan_right])
#align category_theory.limits.pullback_diagonal_map_iso CategoryTheory.Limits.pullbackDiagonalMapIso

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIso_hom_fst :
    (pullbackDiagonalMapIso f i i₁ i₂).hom ≫ pullback.fst = pullback.snd ≫ pullback.fst := by
  delta pullbackDiagonalMapIso
  simp
#align category_theory.limits.pullback_diagonal_map_iso_hom_fst CategoryTheory.Limits.pullbackDiagonalMapIso_hom_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIso_hom_snd :
    (pullbackDiagonalMapIso f i i₁ i₂).hom ≫ pullback.snd = pullback.snd ≫ pullback.snd := by
  delta pullbackDiagonalMapIso
  simp
#align category_theory.limits.pullback_diagonal_map_iso_hom_snd CategoryTheory.Limits.pullbackDiagonalMapIso_hom_snd

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIso_inv_fst :
    (pullbackDiagonalMapIso f i i₁ i₂).inv ≫ pullback.fst = pullback.fst ≫ i₁ ≫ pullback.fst := by
  delta pullbackDiagonalMapIso
  simp
#align category_theory.limits.pullback_diagonal_map_iso_inv_fst CategoryTheory.Limits.pullbackDiagonalMapIso_inv_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIso_inv_snd_fst :
    (pullbackDiagonalMapIso f i i₁ i₂).inv ≫ pullback.snd ≫ pullback.fst = pullback.fst := by
  delta pullbackDiagonalMapIso
  simp
#align category_theory.limits.pullback_diagonal_map_iso_inv_snd_fst CategoryTheory.Limits.pullbackDiagonalMapIso_inv_snd_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIso_inv_snd_snd :
    (pullbackDiagonalMapIso f i i₁ i₂).inv ≫ pullback.snd ≫ pullback.snd = pullback.snd := by
  delta pullbackDiagonalMapIso
  simp
#align category_theory.limits.pullback_diagonal_map_iso_inv_snd_snd CategoryTheory.Limits.pullbackDiagonalMapIso_inv_snd_snd

theorem pullback_fst_map_snd_isPullback :
    IsPullback (fst ≫ i₁ ≫ fst)
      (map i₁ i₂ (i₁ ≫ snd) (i₂ ≫ snd) _ _ _ (Category.id_comp _).symm (Category.id_comp _).symm)
      (diagonal f)
      (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i (by simp [condition])
        (by simp [condition])) :=
  IsPullback.of_iso_pullback ⟨by ext <;> simp [condition_assoc]⟩
    (pullbackDiagonalMapIso f i i₁ i₂).symm (pullbackDiagonalMapIso_inv_fst f i i₁ i₂)
    (by aesop_cat)
#align category_theory.limits.pullback_fst_map_snd_is_pullback CategoryTheory.Limits.pullback_fst_map_snd_isPullback

end

section

variable {S T : C} (f : X ⟶ T) (g : Y ⟶ T) (i : T ⟶ S)

variable [HasPullback i i] [HasPullback f g] [HasPullback (f ≫ i) (g ≫ i)]

variable
  [HasPullback (diagonal i)
      (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _) (Category.comp_id _) (Category.comp_id _))]

/-- This iso witnesses the fact that
given `f : X ⟶ T`, `g : Y ⟶ T`, and `i : T ⟶ S`, the diagram

X ×ₜ Y ⟶ X ×ₛ Y
   |         |
   |         |
   ↓         ↓
   T   ⟶ T ×ₛ T

is a pullback square.
Also see `pullback_map_diagonal_isPullback`.
-/
def pullbackDiagonalMapIdIso :
    pullback (diagonal i)
        (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _) (Category.comp_id _) (Category.comp_id _)) ≅
      pullback f g := by
  refine' _ ≪≫
    pullbackDiagonalMapIso i (𝟙 _) (f ≫ inv pullback.fst) (g ≫ inv pullback.fst) ≪≫ _
  . refine' @asIso _ _ _ _ (pullback.map _ _ _ _ (𝟙 T) ((pullback.congrHom _ _).hom) (𝟙 _) _ _) ?_
    . rw [← Category.comp_id pullback.snd, ← condition, Category.assoc, IsIso.inv_hom_id_assoc]
    . rw [← Category.comp_id pullback.snd, ← condition, Category.assoc, IsIso.inv_hom_id_assoc]
    · rw [Category.comp_id, Category.id_comp]
    . ext <;> simp
    . infer_instance
  . refine' @asIso _ _ _ _ (pullback.map _ _ _ _ (𝟙 _) (𝟙 _) pullback.fst _ _) ?_
    . rw [Category.assoc, IsIso.inv_hom_id, Category.comp_id, Category.id_comp]
    . rw [Category.assoc, IsIso.inv_hom_id, Category.comp_id, Category.id_comp]
    . infer_instance
#align category_theory.limits.pullback_diagonal_map_id_iso CategoryTheory.Limits.pullbackDiagonalMapIdIso

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIdIso_hom_fst :
    (pullbackDiagonalMapIdIso f g i).hom ≫ pullback.fst = pullback.snd ≫ pullback.fst := by
  delta pullbackDiagonalMapIdIso
  simp
#align category_theory.limits.pullback_diagonal_map_id_iso_hom_fst CategoryTheory.Limits.pullbackDiagonalMapIdIso_hom_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIdIso_hom_snd :
    (pullbackDiagonalMapIdIso f g i).hom ≫ pullback.snd = pullback.snd ≫ pullback.snd := by
  delta pullbackDiagonalMapIdIso
  simp
#align category_theory.limits.pullback_diagonal_map_id_iso_hom_snd CategoryTheory.Limits.pullbackDiagonalMapIdIso_hom_snd

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIdIso_inv_fst :
    (pullbackDiagonalMapIdIso f g i).inv ≫ pullback.fst = pullback.fst ≫ f := by
  rw [Iso.inv_comp_eq, ← Category.comp_id pullback.fst, ← diagonal_fst i, pullback.condition_assoc]
  simp
#align category_theory.limits.pullback_diagonal_map_id_iso_inv_fst CategoryTheory.Limits.pullbackDiagonalMapIdIso_inv_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIdIso_inv_snd_fst :
    (pullbackDiagonalMapIdIso f g i).inv ≫ pullback.snd ≫ pullback.fst = pullback.fst := by
  rw [Iso.inv_comp_eq]
  simp
#align category_theory.limits.pullback_diagonal_map_id_iso_inv_snd_fst CategoryTheory.Limits.pullbackDiagonalMapIdIso_inv_snd_fst

@[reassoc (attr := simp)]
theorem pullbackDiagonalMapIdIso_inv_snd_snd :
    (pullbackDiagonalMapIdIso f g i).inv ≫ pullback.snd ≫ pullback.snd = pullback.snd := by
  rw [Iso.inv_comp_eq]
  simp
#align category_theory.limits.pullback_diagonal_map_id_iso_inv_snd_snd CategoryTheory.Limits.pullbackDiagonalMapIdIso_inv_snd_snd

theorem pullback.diagonal_comp (f : X ⟶ Y) (g : Y ⟶ Z) [HasPullback f f] [HasPullback g g]
    [HasPullback (f ≫ g) (f ≫ g)] :
    diagonal (f ≫ g) = diagonal f ≫ (pullbackDiagonalMapIdIso f f g).inv ≫ pullback.snd := by
  apply pullback.hom_ext <;> simp
#align category_theory.limits.pullback.diagonal_comp CategoryTheory.Limits.pullback.diagonal_comp

theorem pullback_map_diagonal_isPullback :
    IsPullback (pullback.fst ≫ f)
      (pullback.map f g (f ≫ i) (g ≫ i) _ _ i (Category.id_comp _).symm (Category.id_comp _).symm)
      (diagonal i)
      (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _) (Category.comp_id _) (Category.comp_id _)) := by
  apply IsPullback.of_iso_pullback _ (pullbackDiagonalMapIdIso f g i).symm
  · simp
  · apply pullback.hom_ext <;> simp
  · constructor
    apply pullback.hom_ext <;> simp [condition]
#align category_theory.limits.pullback_map_diagonal_is_pullback CategoryTheory.Limits.pullback_map_diagonal_isPullback

/-- The diagonal object of `X ×[Z] Y ⟶ X` is isomorphic to `Δ_{Y/Z} ×[Z] X`. -/
def diagonalObjPullbackFstIso {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    diagonalObj (pullback.fst : pullback f g ⟶ X) ≅
      pullback (pullback.snd ≫ g : diagonalObj g ⟶ Z) f :=
  pullbackRightPullbackFstIso _ _ _ ≪≫
    pullback.congrHom pullback.condition rfl ≪≫
      pullbackAssoc _ _ _ _ ≪≫ pullbackSymmetry _ _ ≪≫ pullback.congrHom pullback.condition rfl
#align category_theory.limits.diagonal_obj_pullback_fst_iso CategoryTheory.Limits.diagonalObjPullbackFstIso

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_hom_fst_fst {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).hom ≫ pullback.fst ≫ pullback.fst =
      pullback.fst ≫ pullback.snd := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_hom_fst_fst CategoryTheory.Limits.diagonalObjPullbackFstIso_hom_fst_fst

@[reassoc (attr := simp)]

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_hom_snd {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).hom ≫ pullback.snd = pullback.fst ≫ pullback.fst := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_hom_snd CategoryTheory.Limits.diagonalObjPullbackFstIso_hom_snd

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_inv_fst_fst {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).inv ≫ pullback.fst ≫ pullback.fst = pullback.snd := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_inv_fst_fst CategoryTheory.Limits.diagonalObjPullbackFstIso_inv_fst_fst

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_inv_fst_snd {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).inv ≫ pullback.fst ≫ pullback.snd =
      pullback.fst ≫ pullback.fst := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_inv_fst_snd CategoryTheory.Limits.diagonalObjPullbackFstIso_inv_fst_snd

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_inv_snd_fst {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).inv ≫ pullback.snd ≫ pullback.fst = pullback.snd := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_inv_snd_fst CategoryTheory.Limits.diagonalObjPullbackFstIso_inv_snd_fst

@[reassoc (attr := simp)]
theorem diagonalObjPullbackFstIso_inv_snd_snd {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    (diagonalObjPullbackFstIso f g).inv ≫ pullback.snd ≫ pullback.snd =
      pullback.fst ≫ pullback.snd := by
  delta diagonalObjPullbackFstIso
  simp
#align category_theory.limits.diagonal_obj_pullback_fst_iso_inv_snd_snd CategoryTheory.Limits.diagonalObjPullbackFstIso_inv_snd_snd

theorem diagonal_pullback_fst {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
    diagonal (pullback.fst : pullback f g ⟶ _) =
      (pullbackSymmetry _ _).hom ≫
        ((baseChange f).map
              (Over.homMk (diagonal g) (by simp) : Over.mk g ⟶ Over.mk (pullback.snd ≫ g))).left ≫
          (diagonalObjPullbackFstIso f g).inv := by
  apply pullback.hom_ext <;> apply pullback.hom_ext <;> dsimp <;> simp
#align category_theory.limits.diagonal_pullback_fst CategoryTheory.Limits.diagonal_pullback_fst

end

/-- Given the following diagram with `S ⟶ S'` a monomorphism,

    X  ⟶ X'
      ↘      ↘
        S  ⟶ S'
      ↗      ↗
    Y  ⟶ Y'

This iso witnesses the fact that

      X ×[S] Y ⟶ (X' ×[S'] Y') ×[Y'] Y
          |                  |
          |                  |
          ↓                  ↓
(X' ×[S'] Y') ×[X'] X ⟶ X' ×[S'] Y'

is a pullback square. The diagonal map of this square is `pullback.map`.
Also see `pullback_lift_map_is_pullback`.
-/
@[simps]
def pullbackFstFstIso {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S) (f' : X' ⟶ S') (g' : Y' ⟶ S')
    (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f') (e₂ : g ≫ i₃ = i₂ ≫ g')
    [Mono i₃] :
    pullback (pullback.fst : pullback (pullback.fst : pullback f' g' ⟶ _) i₁ ⟶ _)
        (pullback.fst : pullback (pullback.snd : pullback f' g' ⟶ _) i₂ ⟶ _) ≅
      pullback f g
    where
  hom :=
    pullback.lift (pullback.fst ≫ pullback.snd) (pullback.snd ≫ pullback.snd)
      (by
        rw [← cancel_mono i₃, Category.assoc, Category.assoc, Category.assoc, Category.assoc, e₁,
          e₂, ← pullback.condition_assoc, pullback.condition_assoc, pullback.condition,
          pullback.condition_assoc])
  inv :=
    pullback.lift
      (pullback.lift (pullback.map _ _ _ _ _ _ _ e₁ e₂) pullback.fst (pullback.lift_fst _ _ _))
      (pullback.lift (pullback.map _ _ _ _ _ _ _ e₁ e₂) pullback.snd (pullback.lift_snd _ _ _))
      (by rw [pullback.lift_fst, pullback.lift_fst])
  hom_inv_id := by
    apply pullback.hom_ext
    . apply pullback.hom_ext
      . apply pullback.hom_ext
        . simp only [Category.assoc, lift_fst, lift_fst_assoc, Category.id_comp]
          rw [condition]
        . simp [Category.assoc, lift_snd]
          rw [condition_assoc, condition]
      . simp only [Category.assoc, lift_fst_assoc, lift_snd, lift_fst, Category.id_comp]
    . apply pullback.hom_ext
      . apply pullback.hom_ext
        . simp only [Category.assoc, lift_snd_assoc, lift_fst_assoc, lift_fst, Category.id_comp]
          rw [← condition_assoc, condition]
        . simp only [Category.assoc, lift_snd, lift_fst_assoc, lift_snd_assoc, Category.id_comp]
          rw [condition]
      . simp only [Category.assoc, lift_snd_assoc, lift_snd, Category.id_comp]
  inv_hom_id := by
    apply pullback.hom_ext
    . simp only [Category.assoc, lift_fst, lift_fst_assoc, lift_snd, Category.id_comp]
    . simp only [Category.assoc, lift_snd, lift_snd_assoc, Category.id_comp]
#align category_theory.limits.pullback_fst_fst_iso CategoryTheory.Limits.pullbackFstFstIso

theorem pullback_map_eq_pullbackFstFstIso_inv {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S)
    (f' : X' ⟶ S') (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
    (e₂ : g ≫ i₃ = i₂ ≫ g') [Mono i₃] :
    pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂ =
      (pullbackFstFstIso f g f' g' i₁ i₂ i₃ e₁ e₂).inv ≫ pullback.snd ≫ pullback.fst := by
  simp only [pullbackFstFstIso_inv, lift_snd_assoc, lift_fst]
#align category_theory.limits.pullback_map_eq_pullback_fst_fst_iso_inv CategoryTheory.Limits.pullback_map_eq_pullbackFstFstIso_inv

theorem pullback_lift_map_isPullback {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S) (f' : X' ⟶ S')
    (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
    (e₂ : g ≫ i₃ = i₂ ≫ g') [Mono i₃] :
    IsPullback (pullback.lift (pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂) fst (lift_fst _ _ _))
      (pullback.lift (pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂) snd (lift_snd _ _ _)) pullback.fst
      pullback.fst :=
  IsPullback.of_iso_pullback ⟨by rw [lift_fst, lift_fst]⟩
    (pullbackFstFstIso f g f' g' i₁ i₂ i₃ e₁ e₂).symm (by simp) (by simp)
#align category_theory.limits.pullback_lift_map_is_pullback CategoryTheory.Limits.pullback_lift_map_isPullback

end CategoryTheory.Limits


import algebra.theory.free
import .basic .hom

/-!
 * Constructions and theorems on products of `binary_modules`.
-/

namespace binary_module

open binary_module

local attribute [instance] has_binary_add
attribute [instance] binary_module.has_trivial_init
attribute [instance] model.prod

@[reducible,inline]
definition prod_fst {α β : Type _} [model binary_module α] [model binary_module β] : hom (α×β) α := morphism.proj_fst binary_module

@[reducible,inline]
definition prod_snd {α β : Type _} [model binary_module α] [model binary_module β] : hom (α×β) β := morphism.proj_snd binary_module

@[reducible,inline]
definition prod_inl {α β : Type _} [model binary_module α] [model binary_module β] : hom α (α×β) := @model.prod_inl binary_module binary_module.has_trivial_init α β _ _

@[reducible,inline]
definition prod_inr {α β : Type _} [model binary_module α] [model binary_module β] : hom β (α×β) := @model.prod_inr binary_module binary_module.has_trivial_init α β _ _

lemma pair_is_sum {α β : Type _} [model binary_module α] [model binary_module β] : ∀ (x : α×β), x = (prod_inl.val x.fst) + (prod_inr.val x.snd) :=
  begin
    intros x,
    cases x,
    dsimp [prod_inl,prod_inr],
    dsimp [model.prod_inl,model.prod_inr,has_add.add],
    dsimp [binary_module.add],
    dsimp [premodel.act,prod.map],
    rw [vect.unzip_fst_is_map_fst,vect.unzip_snd_is_map_snd],
    dsimp [vect.map],
    repeat {rw [fixed_elem_is_zero]},
    let hfst := @binary_module.add_zero α _,
    let hsnd := @binary_module.zero_add β _,
    dsimp [binary_module.add] at hfst hsnd,
    rw [hfst,hsnd],
  end

/-!
 * Proof of the fact that the product of models of `binary_module` is simultaneously a coproduct.
--/

section

local infixl `●`:100 := hom.comp

--- Construct `hom (α×β) γ` from `hom α γ` and `hom β γ`.
definition co_zip {α β γ : Type _} [model binary_module α] [model binary_module β] [model binary_module γ] (f : hom α γ) (g : hom β γ) : hom (α×β) γ := (f ● prod_fst) + (g ● prod_snd)

--- Decompose `hom (α×β) γ` into `hom α γ` and `hom β γ`.
definition co_unzip {α β γ : Type _} [model binary_module α] [model binary_module β] [model binary_module γ] (f : hom (α×β) γ) : hom α γ × hom β γ :=
  (f ● prod_inl, f ● prod_inr)

--- `co_zip` after `co_unzip` recovers the original `hom (α×β) γ` pointwisely; i.e. the same as the original up to `funext`.
theorem co_zip_of_co_unzip_ptwise {α β γ : Type _} [model binary_module α] [model binary_module β] [model binary_module γ] (f : hom (α×β) γ) : ∀ x, (co_zip (co_unzip f).fst (co_unzip f).snd).val x = f.val x :=
  begin
    intros x; cases x with a b,
    dsimp [co_zip,co_unzip],
    dsimp [has_add.add,binary_module.add],
    dsimp [premodel.act],
    rw [vect.unzip_fam_eval],
    dsimp [vect.map],
    dsimp [hom.comp,morphism.comp,function.comp],
    let hf := λ x y, f.property ops.add ⁅x,y⁆,
    dunfold vect.map at hf,
    rw [←hf],
    dsimp [prod_fst,morphism.proj_fst,prod_inl,model.prod_inl],
    dsimp [prod_snd,morphism.proj_snd,prod_inr,model.prod_inr],
    csimp only [fixed_elem_is_zero],
    dsimp [premodel.act,prod.map,vect.unzip],
    let hadd_zero := binary_module.add_zero a,
    let hzero_add := binary_module.zero_add b,
    dsimp [binary_module.zero,binary_module.add] at hadd_zero hzero_add,
    rw [hadd_zero,hzero_add]
  end

theorem co_unzip_of_co_zip_ptwise {α β γ : Type _} [model binary_module α]  [model binary_module β] [model binary_module γ] (f : hom α γ) (g : hom β γ)  : (∀ a, (co_unzip (co_zip f g)).fst.val a = f.val a) ∧ (∀ b, (co_unzip (co_zip f g)).snd.val b = g.val b) :=
  begin
    split,
    show ∀ (a : α), (co_unzip (co_zip f g)).fst.val a = f.val a, {
      intros a,
      dsimp [co_zip,co_unzip],
      dsimp [hom.comp,morphism.comp,function.comp,subtype.val],
      dsimp [prod_inl,model.prod_inl],
      dsimp [vect.map],
      dsimp [premodel.act,vect.unzip_fam],
      dsimp [prod_fst,prod_snd, morphism.proj_fst, morphism.proj_snd],
      rw [fixed_elem_is_zero,g.property],
      dunfold vect.map,
      drefold binary_module.add _ _,
      rw [binary_module.add_zero]
    },
    show ∀ (b : β), (co_unzip (co_zip f g)).snd.val b = g.val b, {
      intros b,
      dsimp [co_zip,co_unzip],
      dsimp [hom.comp,morphism.comp,function.comp,subtype.val],
      dsimp [prod_inr,model.prod_inr],
      dsimp [vect.map],
      dsimp [premodel.act,vect.unzip_fam],
      dsimp [prod_fst,prod_snd, morphism.proj_fst, morphism.proj_snd],
      rw [fixed_elem_is_zero,f.property],
      dunfold vect.map,
      drefold binary_module.add _ _,
      rw [binary_module.zero_add]
    }
  end

end

/-!
 * Proof of the fact that the (co)product of free models of `binary_module` is again free.
--/

section

universe u

variables {α β : Sort _}
variables {φ ψ : Type _} [model binary_module φ] [model binary_module ψ]
variables (ja : α → φ) (jb : β → ψ)

local infixl `●`:100 := hom.comp

definition basis_sum : psum α β → φ×ψ
| (psum.inl a) := (ja a, binary_module.zero ψ)
| (psum.inr b) := (binary_module.zero φ, jb b)

--- the (co)product of free models of `binary_module` is again free.
theorem prod_free (ha : is_free.{u} binary_module ja) (hb : is_free.{u} binary_module jb) : is_free.{u} binary_module (basis_sum ja jb) :=
  begin
    intros γ mc f,
    let hfa := @ha γ mc (λ a, f (psum.inl a)),
    let hfb := @hb γ mc (λ b, f (psum.inr b)),
    cases h₁: hfa with f₁ hf₁,
    cases h₂: hfb with f₂ hf₂,
    existsi @co_zip φ ψ γ _ _ mc f₁ f₂,
    dsimp * at *,
    split,
    show ∀ (x : psum α β), (@co_zip φ ψ γ _ _ mc f₁ f₂).val (basis_sum ja jb x) = f x, {
      intros x; cases x with a b,
      case psum.inl {
        dunfold basis_sum,
        dunfold binary_module.zero,
        dunfold co_zip,
        dsimp [hom.comp,morphism.comp,function.comp],
        dsimp [has_add.add,binary_module.add],
        dsimp [premodel.act,vect.map],
        csimp only [vect.unzip_fam_eval,vect.map],
        dsimp [prod_fst,morphism.proj_fst],
        dsimp [prod_snd,morphism.proj_snd],
        rw [f₂.property],
        dunfold vect.map,
        let hz := @binary_module.add_zero γ mc,
        dsimp [binary_module.add, binary_module.zero] at hz,
        rw [hz],
        rw [hf₁.left]
      },
      case psum.inr {
        dunfold basis_sum,
        dunfold binary_module.zero,
        dunfold co_zip,
        dsimp [hom.comp,morphism.comp,function.comp],
        dsimp [has_add.add,binary_module.add],
        dsimp [premodel.act,vect.map],
        csimp only [vect.unzip_fam_eval,vect.map],
        dsimp [prod_fst,morphism.proj_fst],
        dsimp [prod_snd,morphism.proj_snd],
        rw [f₁.property],
        dunfold vect.map,
        let hz := @binary_module.zero_add γ mc,
        dsimp [binary_module.add, binary_module.zero] at hz,
        rw [hz],
        rw [hf₂.left]
      }
    },
    show ∀ (g : @hom (φ×ψ) γ _ mc), (∀ x, g.val (basis_sum ja jb x) = f x) → g = @co_zip φ ψ γ _ _ mc f₁ f₂, {
      intros g hg,
      apply subtype.eq,
      funext uv; cases uv with u v,
      rw [pair_is_sum (u,v)],
      dsimp [has_add.add,binary_module.add],
      rw [g.property],
      dsimp [vect.map],
      dunfold co_zip,
      dsimp [hom.comp,morphism.comp,function.comp],
      dsimp [has_add.add,binary_module.add],
      dsimp [premodel.act,vect.map,prod.map],
      rw [vect.unzip_fam_eval],
      rw [vect.unzip_fst_is_map_fst,vect.unzip_snd_is_map_snd],
      dsimp [vect.map],
      dsimp [prod_fst,morphism.proj_fst],
      dsimp [prod_inl,model.prod_inl],
      dsimp [prod_snd,morphism.proj_snd],
      dsimp [prod_inr,model.prod_inr],
      csimp only [fixed_elem_is_zero],
      let haz := @binary_module.add_zero φ _,
      let hza := @binary_module.zero_add ψ _,
      dsimp [binary_module.add,binary_module.zero] at haz hza,
      rw [haz,hza],
      suffices hgoal : (@hom.comp _ _ _ _ _ mc g prod_inl) = f₁ ∧ (@hom.comp _ _ _ _ _ mc g prod_inr) = f₂, {
        rw [←hgoal.left,←hgoal.right],
        refl
      },
      split,
      show (@hom.comp _ _ _ _ _ mc g prod_inl) = f₁, {
        apply hf₁.right _,
        intros a,
        exact hg (psum.inl a)
      },
      show (@hom.comp _ _ _ _ _ mc g prod_inr) = f₂, {
        apply hf₂.right _,
        intros b,
        exact hg (psum.inr b)
      }
    }
  end

#print axioms prod_free

end

end binary_module


-- La_equipotencia_es_una_relacion_simetrica.lean
-- La equipotencia es una relación simétrica
-- José A. Alonso Jiménez
-- Sevilla, 13 de agosto de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Dos conjuntos A y B son equipotentes (y se denota por A ≃ B) si
-- existe una aplicación biyectiva entre ellos. La equipotencia se puede
-- definir en Lean por
--    def es_equipotente (A B : Type*) :=
--      ∃ g : A → B, bijective g
--
--    infix ` ⋍ `: 50 := es_equipotente
--
-- Demostrar que la relación de equipotencia es simétrica.
-- ---------------------------------------------------------------------

import tactic
open function

def es_equipotente (A B : Type*) :=
  ∃ g : A → B, bijective g

infix ` ⋍ `: 50 := es_equipotente

variables {X Y : Type*}
variable  {f : X → Y}
variable  {g : Y → X}

def inversa (f : X → Y) (g : Y → X) :=
  (∀ x, (g ∘ f) x = x) ∧ (∀ y, (f ∘ g) y = y)

def tiene_inversa (f : X → Y) :=
  ∃ g, inversa g f

lemma aux1
  (hf : bijective f)
  : tiene_inversa f :=
begin
  cases (bijective_iff_has_inverse.mp hf) with g hg,
  by tidy,
end

lemma aux2
  (hf : bijective f)
  (hg : inversa g f)
  : bijective g :=
bijective_iff_has_inverse.mpr (by use [f, hg])

-- 1ª demostración
example : symmetric (⋍) :=
begin
  unfold symmetric,
  intros x y hxy,
  unfold es_equipotente at *,
  cases hxy with f hf,
  have h1 : tiene_inversa f := aux1 hf,
  cases h1 with g hg,
  use g,
  exact aux2 hf hg,
end

-- 2ª demostración
example : symmetric (⋍) :=
begin
  intros x y hxy,
  cases hxy with f hf,
  cases (aux1 hf) with g hg,
  use [g, aux2 hf hg],
end

-- 3ª demostración
example : symmetric (⋍) :=
begin
  rintros x y ⟨f, hf⟩,
  cases (aux1 hf) with g hg,
  use [g, aux2 hf hg],
end


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import data.list.nodup

/-!
# Finite products of types

This file defines the product of types over a list. For `l : list ι` and `α : ι → Type*` we define
`list.tprod α l = l.foldr (λ i β, α i × β) punit`.
This type should not be used if `Π i, α i` or `Π i ∈ l, α i` can be used instead
(in the last expression, we could also replace the list `l` by a set or a finset).
This type is used as an intermediary between binary products and finitary products.
The application of this type is finitary product measures, but it could be used in any
construction/theorem that is easier to define/prove on binary products than on finitary products.

* Once we have the construction on binary products (like binary product measures in
  `measure_theory.prod`), we can easily define a finitary version on the type `tprod l α`
  by iterating. Properties can also be easily extended from the binary case to the finitary case
  by iterating.
* Then we can use the equivalence `list.tprod.pi_equiv_tprod` below (or enhanced versions of it,
  like a `measurable_equiv` for product measures) to get the construction on `Π i : ι, α i`, at
  least when assuming `[fintype ι] [encodable ι]` (using `encodable.sorted_univ`).
  Using `local attribute [instance] fintype.to_encodable` we can get rid of the argument
  `[encodable ι]`.

## Main definitions

* We have the equivalence `tprod.pi_equiv_tprod : (Π i, α i) ≃ tprod α l`
  if `l` contains every element of `ι` exactly once.
* The product of sets is `set.tprod : (Π i, set (α i)) → set (tprod α l)`.
-/

open list function

variables {ι : Type*} {α : ι → Type*} {i j : ι} {l : list ι} {f : Π i, α i}

namespace list

variable (α)

/-- The product of a family of types over a list. -/
def tprod (l : list ι) : Type* :=
l.foldr (λ i β, α i × β) punit

variable {α}

namespace tprod

open list

/-- Turning a function `f : Π i, α i` into an element of the iterated product `tprod α l`. -/
protected def mk : ∀ (l : list ι) (f : Π i, α i), tprod α l
| []        := λ f, punit.star
| (i :: is) := λ f, (f i, mk is f)

instance [∀ i, inhabited (α i)] : inhabited (tprod α l) :=
⟨tprod.mk l default⟩

@[simp] lemma fst_mk (i : ι) (l : list ι) (f : Π i, α i) : (tprod.mk (i::l) f).1 = f i := rfl

@[simp]
lemma snd_mk (i : ι) (l : list ι) (f : Π i, α i) : (tprod.mk (i::l) f).2 = tprod.mk l f := rfl

variables [decidable_eq ι]

/-- Given an element of the iterated product `l.prod α`, take a projection into direction `i`.
  If `i` appears multiple times in `l`, this chooses the first component in direction `i`. -/
protected def elim : ∀ {l : list ι} (v : tprod α l) {i : ι} (hi : i ∈ l), α i
| (i :: is) v j hj :=
  if hji : j = i then by { subst hji, exact v.1 } else elim v.2 (hj.resolve_left hji)

@[simp] lemma elim_self (v : tprod α (i :: l)) : v.elim (l.mem_cons_self i) = v.1 :=
by simp [tprod.elim]

@[simp] lemma elim_of_ne (hj : j ∈ i :: l) (hji : j ≠ i) (v : tprod α (i :: l)) :
  v.elim hj = tprod.elim v.2 (hj.resolve_left hji) :=
by simp [tprod.elim, hji]

@[simp] lemma elim_of_mem (hl : (i :: l).nodup) (hj : j ∈ l) (v : tprod α (i :: l)) :
  v.elim (mem_cons_of_mem _ hj) = tprod.elim v.2 hj :=
by { apply elim_of_ne, rintro rfl, exact hl.not_mem hj }

lemma elim_mk : ∀ (l : list ι) (f : Π i, α i) {i : ι} (hi : i ∈ l),
  (tprod.mk l f).elim hi = f i
| (i :: is) f j hj := begin
      by_cases hji : j = i,
      { subst hji, simp },
      { rw [elim_of_ne _ hji, snd_mk, elim_mk] }
  end

@[ext] lemma ext : ∀ {l : list ι} (hl : l.nodup) {v w : tprod α l}
  (hvw : ∀ i (hi : i ∈ l), v.elim hi = w.elim hi), v = w
| []        hl v w hvw := punit.ext
| (i :: is) hl v w hvw := begin
    ext, rw [← elim_self v, hvw, elim_self],
    refine ext (nodup_cons.mp hl).2 (λ j hj, _),
    rw [← elim_of_mem hl, hvw, elim_of_mem hl]
  end

/-- A version of `tprod.elim` when `l` contains all elements. In this case we get a function into
  `Π i, α i`. -/
@[simp] protected def elim' (h : ∀ i, i ∈ l) (v : tprod α l) (i : ι) : α i :=
v.elim (h i)

lemma mk_elim (hnd : l.nodup) (h : ∀ i, i ∈ l) (v : tprod α l) : tprod.mk l (v.elim' h) = v :=
tprod.ext hnd (λ i hi, by simp [elim_mk])

/-- Pi-types are equivalent to iterated products. -/
def pi_equiv_tprod (hnd : l.nodup) (h : ∀ i, i ∈ l) : (Π i, α i) ≃ tprod α l :=
⟨tprod.mk l, tprod.elim' h, λ f, funext $ λ i, elim_mk l f (h i), mk_elim hnd h⟩

end tprod

end list

namespace set

open list
/-- A product of sets in `tprod α l`. -/
@[simp] protected def tprod : ∀ (l : list ι) (t : Π i, set (α i)), set (tprod α l)
| []        t := univ
| (i :: is) t := t i ×ˢ tprod is t

lemma mk_preimage_tprod : ∀ (l : list ι) (t : Π i, set (α i)),
  tprod.mk l ⁻¹' set.tprod l t = {i | i ∈ l}.pi t
| []        t := by simp [set.tprod]
| (i :: l) t := begin
  ext f,
  have : f ∈ tprod.mk l ⁻¹' set.tprod l t ↔ f ∈ {x | x ∈ l}.pi t, { rw [mk_preimage_tprod l t] },
  change tprod.mk l f ∈ set.tprod l t ↔ ∀ (i : ι), i ∈ l → f i ∈ t i at this,
  /- `simp [set.tprod, tprod.mk, this]` can close this goal but is slow. -/
  rw [set.tprod, tprod.mk, mem_preimage, mem_pi, prod_mk_mem_set_prod_eq],
  simp_rw [mem_set_of_eq, mem_cons_iff],
  rw [forall_eq_or_imp, and.congr_right_iff],
  exact λ _, this
end

lemma elim_preimage_pi [decidable_eq ι] {l : list ι} (hnd : l.nodup) (h : ∀ i, i ∈ l)
  (t : Π i, set (α i)) : tprod.elim' h ⁻¹' pi univ t = set.tprod l t :=
begin
  have : { i | i ∈ l} = univ, { ext i, simp [h] },
  rw [← this, ← mk_preimage_tprod, preimage_preimage],
  convert preimage_id, simp [tprod.mk_elim hnd h, id_def]
end

end set


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

! This file was ported from Lean 3 source module data.set.constructions
! leanprover-community/mathlib commit e04043d6bf7264a3c84bc69711dc354958ca4516
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Finset.Basic

/-!
# Constructions involving sets of sets.

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

## Finite Intersections

We define a structure `has_finite_inter` which asserts that a set `S` of subsets of `α` is
closed under finite intersections.

We define `finite_inter_closure` which, given a set `S` of subsets of `α`, is the smallest
set of subsets of `α` which is closed under finite intersections.

`finite_inter_closure S` is endowed with a term of type `has_finite_inter` using
`finite_inter_closure_has_finite_inter`.

-/

variable {α : Type _} (S : Set (Set α))

#print FiniteInter /-
/-- A structure encapsulating the fact that a set of sets is closed under finite intersection. -/
structure FiniteInter : Prop where
  univ_mem : Set.univ ∈ S
  inter_mem : ∀ ⦃s⦄, s ∈ S → ∀ ⦃t⦄, t ∈ S → s ∩ t ∈ S
#align has_finite_inter FiniteInter
-/

namespace FiniteInter

#print FiniteInter.finiteInterClosure /-
/-- The smallest set of sets containing `S` which is closed under finite intersections. -/
inductive finiteInterClosure : Set (Set α)
  | basic {s} : s ∈ S → finite_inter_closure s
  | univ : finite_inter_closure Set.univ
  | inter {s t} : finite_inter_closure s → finite_inter_closure t → finite_inter_closure (s ∩ t)
#align has_finite_inter.finite_inter_closure FiniteInter.finiteInterClosure
-/

#print FiniteInter.finiteInterClosure_finiteInter /-
theorem finiteInterClosure_finiteInter : FiniteInter (finiteInterClosure S) :=
  { univ_mem := finiteInterClosure.univ
    inter_mem := fun _ h _ => finiteInterClosure.inter h }
#align has_finite_inter.finite_inter_closure_has_finite_inter FiniteInter.finiteInterClosure_finiteInter
-/

variable {S}

#print FiniteInter.finiteInter_mem /-
theorem finiteInter_mem (cond : FiniteInter S) (F : Finset (Set α)) :
    ↑F ⊆ S → ⋂₀ (↑F : Set (Set α)) ∈ S := by
  classical
    refine' Finset.induction_on F (fun _ => _) _
    · simp [cond.univ_mem]
    · intro a s h1 h2 h3
      suffices a ∩ ⋂₀ ↑s ∈ S by simpa
      exact
        cond.inter_mem (h3 (Finset.mem_insert_self a s))
          (h2 fun x hx => h3 <| Finset.mem_insert_of_mem hx)
#align has_finite_inter.finite_inter_mem FiniteInter.finiteInter_mem
-/

/- warning: has_finite_inter.finite_inter_closure_insert -> FiniteInter.finiteInterClosure_insert is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {S : Set.{u1} (Set.{u1} α)} {A : Set.{u1} α}, (FiniteInter.{u1} α S) -> (forall (P : Set.{u1} α), (Membership.Mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.hasMem.{u1} (Set.{u1} α)) P (FiniteInter.finiteInterClosure.{u1} α (Insert.insert.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.hasInsert.{u1} (Set.{u1} α)) A S))) -> (Or (Membership.Mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.hasMem.{u1} (Set.{u1} α)) P S) (Exists.{succ u1} (Set.{u1} α) (fun (Q : Set.{u1} α) => Exists.{0} (Membership.Mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.hasMem.{u1} (Set.{u1} α)) Q S) (fun (H : Membership.Mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.hasMem.{u1} (Set.{u1} α)) Q S) => Eq.{succ u1} (Set.{u1} α) P (Inter.inter.{u1} (Set.{u1} α) (Set.hasInter.{u1} α) A Q))))))
but is expected to have type
  forall {α : Type.{u1}} {S : Set.{u1} (Set.{u1} α)} {A : Set.{u1} α}, (FiniteInter.{u1} α S) -> (forall (P : Set.{u1} α), (Membership.mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.instMembershipSet.{u1} (Set.{u1} α)) P (FiniteInter.finiteInterClosure.{u1} α (Insert.insert.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.instInsertSet.{u1} (Set.{u1} α)) A S))) -> (Or (Membership.mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.instMembershipSet.{u1} (Set.{u1} α)) P S) (Exists.{succ u1} (Set.{u1} α) (fun (Q : Set.{u1} α) => And (Membership.mem.{u1, u1} (Set.{u1} α) (Set.{u1} (Set.{u1} α)) (Set.instMembershipSet.{u1} (Set.{u1} α)) Q S) (Eq.{succ u1} (Set.{u1} α) P (Inter.inter.{u1} (Set.{u1} α) (Set.instInterSet.{u1} α) A Q))))))
Case conversion may be inaccurate. Consider using '#align has_finite_inter.finite_inter_closure_insert FiniteInter.finiteInterClosure_insertₓ'. -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (P «expr ∈ » finite_inter_closure[has_finite_inter.finite_inter_closure] (insert[has_insert.insert] A S)) -/
theorem finiteInterClosure_insert {A : Set α} (cond : FiniteInter S) (P)
    (_ : P ∈ finiteInterClosure (insert A S)) : P ∈ S ∨ ∃ Q ∈ S, P = A ∩ Q :=
  by
  induction' H with S h T1 T2 _ _ h1 h2
  · cases h
    · exact Or.inr ⟨Set.univ, cond.univ_mem, by simpa⟩
    · exact Or.inl h
  · exact Or.inl cond.univ_mem
  · rcases h1 with (h | ⟨Q, hQ, rfl⟩) <;> rcases h2 with (i | ⟨R, hR, rfl⟩)
    · exact Or.inl (cond.inter_mem h i)
    ·
      exact
        Or.inr ⟨T1 ∩ R, cond.inter_mem h hR, by simp only [← Set.inter_assoc, Set.inter_comm _ A]⟩
    · exact Or.inr ⟨Q ∩ T2, cond.inter_mem hQ i, by simp only [Set.inter_assoc]⟩
    ·
      exact
        Or.inr
          ⟨Q ∩ R, cond.inter_mem hQ hR, by
            ext x
            constructor <;> simp (config := { contextual := true })⟩
#align has_finite_inter.finite_inter_closure_insert FiniteInter.finiteInterClosure_insert

end FiniteInter


-- boilerplate -- ignore for now
import tactic
import linear_algebra.finite_dimensional

open vector_space
open finite_dimensional
open submodule

-- Let's prove that if V is a 9-dimensional vector space, and X and Y are 5-dimensional subspaces
-- then X ∩ Y is non-zero

universes u u'

-- mathlib PR
theorem finite_dimensional.dim_sup_add_dim_inf_eq {K : Type u} {V : Type u'} [field K]
  [add_comm_group V] [vector_space K V] [finite_dimensional K V] (s t : submodule K V) :
  findim K ↥(s ⊔ t) + findim K ↥(s ⊓ t) = findim K ↥s + findim K ↥t :=
begin
  have key : dim K ↥(s ⊔ t) + dim K ↥(s ⊓ t) = dim K s + dim K t := dim_sup_add_dim_inf_eq s t,
  repeat { rw ←findim_eq_dim at key },
  norm_cast at key,
  exact key
end

theorem five_inter_five_in_nine_is_nonzero
-- let K be a field
(K : Type) [field K]

-- let V be a finite-dimensional vector space over K
(V : Type) [add_comm_group V] [vector_space K V] [hVfin : finite_dimensional K V]

-- and let's assume V is 9-dimensional
-- (note that dim will return a cardinal! findim returns a natural number)
(hV : findim K V = 9)

-- Let X and Y be subspaces of V
(X Y : subspace K V)

-- and let's assume they're both 5-dimensional
(hX : findim K X = 5)
(hY : findim K Y = 5)

-- then X ∩ Y isn't 0
: X ⊓ Y ≠ ⊥

-- Proof
:= begin
-- I will give a proof which uses *the current state of mathlib*.
-- Note that mathlib can be changed, and other lemmas can be proved,
-- and notation can be created, which will make this proof much more
-- recognisable to undergraduates

-- The key lemma from the library we'll need is that dim(X + Y) + dim(X ∩ Y) = dim(X)+dim(Y)
have key : findim K ↥(X ⊔ Y) + findim K ↥(X ⊓ Y) = findim K X + findim K Y,
  exact finite_dimensional.dim_sup_add_dim_inf_eq X Y,

-- `key` is now a statement about natural numbers. It says dim(X+Y)+dim(X∩Y)=dim(X)+dim(Y)
-- Now let's substitute in the hypothesis that dim(X)=dim(Y)=5
rw hX at key, rw hY at key,

-- so now we know dim(X+Y)+dim(X∩Y)=10.

-- Let's now turn to the proof of the theorem.
-- Let's prove it by contradiction. Assume X∩Y is 0
intro hXY,

-- then we know dim(X+Y) + dim(0) = 10
rw hXY at key,

-- and dim(0) = 0
rw findim_bot at key,

-- so the dimension of X+Y is 10

norm_num at key,

-- But the dimension of a subspace is at most the dimension of a space

have key2 : findim K ↥(X ⊔ Y) ≤ findim K V := findim_le (X ⊔ Y),

-- and now we can get our contradiction by just doing linear arithmetic
linarith,

end

section lattice

variables (K : Type u) [field K] (V : Type u') [add_comm_group V]
  [vector_space K V]

lemma foo.exists : 2 + 2 = 4 := rfl

namespace bar

lemma «exists» : 2 + 2 = 4 := rfl

end bar

#check bar.exists

@[ext] structure subspace' (K : Type u) [field K] (V : Type u') [add_comm_group V]
  [vector_space K V] :=
(carrier : set V)
(zero_mem' : (0 : V) ∈ carrier)
(add_mem' {a b} : a ∈ carrier → b ∈ carrier → a + b ∈ carrier)
(smul_mem' : ∀ (c:K) {x}, x ∈ carrier → c • x ∈ carrier)

namespace subspace'

variables (W X : subspace' K V)

instance : has_mem V (subspace' K V) := ⟨λ v W, v ∈ W.carrier⟩

variables {K V}

lemma zero_mem : (0 : V) ∈ W := zero_mem' W
lemma add_mem {a b : V} : a ∈ W → b ∈ W → a + b ∈ W := add_mem' W
lemma smul_mem (c : K) {x : V} : x ∈ W → c • x ∈ W := smul_mem' W c

#check add_mem

instance : partial_order (subspace' K V) :=
partial_order.lift (carrier : subspace' K V → set V)
begin
    intros S T h,
    ext,
    rw h,
end

def inf (W X : subspace' K V) : subspace' K V :=
{ carrier := W.carrier ∩ X.carrier,
  zero_mem' := ⟨W.zero_mem, X.zero_mem⟩,
  add_mem' := λ a b ⟨haW, haX⟩ ⟨hbW, hbX⟩, ⟨W.add_mem haW hbW, X.add_mem haX hbX⟩,
  smul_mem' := λ c a h, ⟨W.smul_mem _ h.1, X.smul_mem _ h.2⟩ }

instance : semilattice_inf (subspace' K V) :=
{ inf := inf,
  inf_le_left := λ W X, set.inter_subset_left _ _,
  inf_le_right := λ W X, set.inter_subset_right _ _,
  le_inf := λ W X Y, set.subset_inter,
  ..subspace'.partial_order}

def sup (W X : subspace' K V) : subspace' K V :=
{ carrier := W.carrier + X.carrier,
  zero_mem' := begin use 0, use 0, use W.zero_mem, use X.zero_mem, simp, end,
  add_mem' := begin intros a b,
  rintro ⟨w₁, x₁, hw₁, hx₁, rfl⟩,
  rintro ⟨w₂, x₂, hw₂, hx₂, rfl⟩,
  use (w₁ + w₂),
  use (x₁ + x₂),
  use W.add_mem hw₁ hw₂,
  use X.add_mem hx₁ hx₂,
  abel,
  end,
  smul_mem' := begin
    rintros c v ⟨w, x, hw, hx, rfl⟩,
    use c • w, use c • x,
    use W.smul_mem c hw,
    use X.smul_mem c hx,
    rw smul_add
  end }

instance : semilattice_sup (subspace' K V) :=
{ sup := sup,
  le_sup_left := begin
    intros W X,
    intro w,
    intro hw,
    use w,
    use 0,
    use hw,
    use X.zero_mem,
    simp,
  end,
  le_sup_right := begin
    intros W X,
    intro x,
    intro hx,
    use 0,
    use x,
    use W.zero_mem,
    use hx,
    simp,
  end,
  sup_le := begin
    intros W X Y,
    intros hWY hXY,
    rintro v ⟨w, x, hw, hx, rfl⟩,
    apply Y.add_mem,
    apply hWY,
    apply hw,
    apply hXY,
    apply hx,
  end,
  ..subspace'.partial_order }

instance : lattice (subspace' K V) :=
{ ..subspace'.semilattice_sup, ..subspace'.semilattice_inf}

-- exercise : distrib_lattice

#check distrib_lattice
-- TODO
-- should library_search find this? Because I don't know how to look for it
-- def partial_order.lift' {α : Type u} {β : Type u'} [partial_order β] (f : α → β)
--     (hf : function.injective f) : partial_order α :=
-- by suggest

#check lattice

end subspace'

end lattice


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/
import topology.sheaves.sheaf
import category_theory.limits.shapes.types
import category_theory.types

/-!
# The sheaf condition for a type-valued presheaf

We provide an alternative formulation of the sheaf condition for type-valued presheaves.

A presheaf `F : presheaf (Type u) X` satisfies the sheaf condition if and only if, for every
compatible family of sections `sf : Π i : ι, F.obj (op (U i))`, there exists a unique gluing
`s : F.obj (op (supr U))`.

Here, the family `sf` is called compatible, if for all `i j : ι`, the restrictions of `sf i`
and `sf j` to `U i ⊓ U j` agree. A section `s : F.obj (op (supr U))` is a gluing for the
family `sf`, if `s` restricts to `sf i` on `U i` for all `i : ι`

We show that the sheaf condition in terms of unique gluings is equivalent to the definition
in terms of equalizers.

-/

noncomputable theory

universe u

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

namespace Top

namespace presheaf

variables {X : Top.{u}} (F : presheaf (Type u) X) {ι : Type u} (U : ι → opens X)

@[simp] lemma res_π_apply (i : ι) (s : F.obj (op (supr U))) :
  limit.π (discrete.functor (λ i : ι, F.obj (op (U i)))) i (res F U s) =
  F.map (opens.le_supr U i).op s :=
congr_fun (res_π F U i) s

/--
A family of sections `sf` is compatible, if the restrictions of `sf i` and `sf j` to `U i ⊓ U j`
agree, for all `i` and `j`
-/
def is_compatible (sf : Π i : ι, F.obj (op (U i))) : Prop :=
  ∀ i j : ι, F.map (inf_le_left (U i) (U j)).op (sf i) = F.map (inf_le_right (U i) (U j)).op (sf j)

/--
For presheaves of types, terms of `pi_opens F U` are just families of sections
-/
def pi_opens_iso_sections_family : pi_opens F U ≅ Π i : ι, F.obj (op (U i)) :=
  limits.is_limit.cone_point_unique_up_to_iso
    (limit.is_limit (discrete.functor (λ i : ι, F.obj (op (U i)))))
    ((types.product_limit_cone (λ i : ι, F.obj (op (U i)))).is_limit)

/--
Under the isomorphism `pi_opens_iso_sections_family`, compatibility of sections is the same
as being equalized by the arrows `left_res` and `right_res` of the equalizer diagram.
-/
lemma compatible_iff_left_res_eq_right_res (sf : pi_opens F U) :
  is_compatible F U ((pi_opens_iso_sections_family F U).hom sf)
    ↔ left_res F U sf = right_res F U sf :=
begin
  split ; intros h,
  { ext ⟨i,j⟩,
    rw [left_res, types.limit.lift_π_apply, fan.mk_π_app,
        right_res, types.limit.lift_π_apply, fan.mk_π_app],
    exact h i j, },
  { intros i j,
    convert congr_arg (limits.pi.π (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2))) (i,j)) h,
    {rw [left_res, types.pi_lift_π_apply], refl},
    {rw [right_res, types.pi_lift_π_apply], refl},
  }
end

/--
A section `s` is a gluing for a family of sections `sf` if it restricts to `sf i` on `U i`,
for all `i`
-/
def is_gluing (sf : Π i : ι, F.obj (op (U i))) (s : F.obj (op (supr U))) : Prop :=
  ∀ i : ι, F.map (opens.le_supr U i).op s = sf i

/--
Under the isomorphism `pi_opens_iso_sections_family`, being a gluing of a family of
sections `sf` is the same as lying in the preimage of `res` (the leftmost arrow of the
equalizer diagram).
-/
@[simp]
lemma is_gluing_iff_eq_res (sf : pi_opens F U) (s : F.obj (op (supr U))):
  is_gluing F U ((pi_opens_iso_sections_family F U).hom sf) s ↔ res F U s = sf :=
begin
  split ; intros h,
  { ext i,
    rw [res, types.limit.lift_π_apply, fan.mk_π_app],
    exact h i, },
  { intro i,
    convert congr_arg (limits.pi.π (λ i : ι, F.obj (op (U i))) i) h,
    rw [res, types.pi_lift_π_apply] },
end

/--
The subtype of all gluings for a given family of sections
-/
@[nolint has_inhabited_instance]
def gluing (sf : Π i : ι, F.obj (op (U i))) : Type u :=
  {s : F.obj (op (supr U)) // is_gluing F U sf s}

/--
The sheaf condition of type-valued presheaves in terms of unique gluings. A presheaf
`F : presheaf (Type u) X` satisfies this sheaf condition if and only if, for every
compatible family of sections `sf : Π i : ι, F.obj (op (U i))`, there exists a unique
gluing `s : F.obj (op (supr U))`.

We prove this to be equivalent to the usual one below in
`sheaf_condition_equiv_sheaf_condition_unique_gluing`
-/
@[derive subsingleton, nolint has_inhabited_instance]
def sheaf_condition_unique_gluing : Type (u+1) :=
  Π ⦃ι : Type u⦄ (U : ι → opens X) (sf : Π i : ι, F.obj (op (U i))),
    is_compatible F U sf → unique (gluing F U sf)

/--
The "equalizer" sheaf condition can be obtained from the sheaf condition
in terms of unique gluings
-/
def sheaf_condition_of_sheaf_condition_unique_gluing :
  F.sheaf_condition_unique_gluing → F.sheaf_condition := λ Fsh ι U,
begin
  refine fork.is_limit.mk' _ (λ s, ⟨_,_,_⟩) ; dsimp,
  { intro x,
    refine (Fsh U ((pi_opens_iso_sections_family F U).hom (s.ι x)) _).default.1,
    apply (compatible_iff_left_res_eq_right_res F U (s.ι x)).mpr,
    convert congr_fun s.condition x, },
  { ext i x,
    simp [res],
    let t : gluing F U _ := _,
    exact t.2 i },
  { intros m hm,
    ext x,
    refine congr_arg subtype.val
      ((Fsh U ((pi_opens_iso_sections_family F U).hom (s.ι x)) _).uniq ⟨m x, _⟩),
    apply (is_gluing_iff_eq_res F U _ _).mpr,
    exact congr_fun hm x },
end

/--
The sheaf condition in terms of unique gluings can be obtained from the usual
"equalizer" sheaf condition
-/
def sheaf_condition_unique_gluing_of_sheaf_condition :
  F.sheaf_condition → F.sheaf_condition_unique_gluing := λ Fsh ι U sf hsf,
{ default := begin
    let sf' := (pi_opens_iso_sections_family F U).inv sf,
    have hsf' : left_res F U sf' = right_res F U sf' := by
      rwa [← compatible_iff_left_res_eq_right_res F U sf', inv_hom_id_apply],
    choose s s_spec s_uniq using types.unique_of_type_equalizer _ _ (Fsh U) sf' hsf',
    use s,
    convert (is_gluing_iff_eq_res F U _ _).mpr s_spec,
    rw inv_hom_id_apply
  end,
  uniq := begin
    intro s,
    /- Unfortunately, type inference doesn't yet know about the `inhabited` instance of
    `gluing F U sf` We therefore introduce a metavariable and use unification to get our hands
    on the default value of `gluing F U sf`. -/
    let t : F.gluing U sf := _,
    change s = t,
    ext,
    let sf' := (pi_opens_iso_sections_family F U).inv sf,
    have hsf' : left_res F U sf' = right_res F U sf' := by
      rwa [← compatible_iff_left_res_eq_right_res F U sf', inv_hom_id_apply],
    choose gl gl_spec gl_uniq using types.unique_of_type_equalizer _ _ (Fsh U) sf' hsf',
    refine eq.trans (gl_uniq s.1 _) (gl_uniq t.1 _).symm ;
      rw [← is_gluing_iff_eq_res F U _ _, inv_hom_id_apply],
    exacts [s.2, t.2]
  end
}

/--
The sheaf condition in terms of unique gluings is equivalent to the usual sheaf condition
in terms of equalizer diagrams.
-/
def sheaf_condition_equiv_sheaf_condition_unique_gluing :
  F.sheaf_condition ≃ F.sheaf_condition_unique_gluing :=
equiv_of_subsingleton_of_subsingleton
  F.sheaf_condition_unique_gluing_of_sheaf_condition
  F.sheaf_condition_of_sheaf_condition_unique_gluing

/--
A slightly more convenient way of obtaining the sheaf condition for type-valued sheaves
-/
def sheaf_condition_of_exists_unique_gluing
  (h : ∀ ⦃ι : Type u⦄ (U : ι → opens X) (sf : Π i : ι, F.obj (op (U i))),
        is_compatible F U sf → ∃! s : F.obj (op (supr U)), is_gluing F U sf s) :
  F.sheaf_condition :=
sheaf_condition_of_sheaf_condition_unique_gluing F $ λ ι U sf hsf,
{ default := by {
    choose gl gl_spec gl_uniq using h U sf hsf,
    exact ⟨gl, gl_spec⟩,
  },
  uniq := by {
    intro s,
    let t : F.gluing U sf := _,
    change s = t,
    ext,
    choose gl gl_spec gl_uniq using h U sf hsf,
    refine eq.trans (gl_uniq s.1 _) (gl_uniq t.1 _).symm,
    exacts [s.2, t.2]
  },
}

end presheaf

namespace sheaf
open presheaf
open category_theory

variables {X : Top.{u}} (F : sheaf (Type u) X) {ι : Type u} (U : ι → opens X)

/--
A more convenient way of obtaining a unique gluing of sections for a sheaf
-/
lemma exists_unique_gluing (sf : Π i : ι, F.presheaf.obj (op (U i)))
  (h : is_compatible F.presheaf U sf ) :
  ∃! s : F.presheaf.obj (op (supr U)), is_gluing F.presheaf U sf s :=
begin
  have := (sheaf_condition_unique_gluing_of_sheaf_condition _ F.sheaf_condition U sf h),
  refine ⟨this.default.1,this.default.2,_⟩,
  intros s hs,
  exact congr_arg subtype.val (this.uniq ⟨s,hs⟩),
end

/--
In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
lemma exists_unique_gluing' (V : opens X) (iUV : Π i : ι, U i ⟶ V) (hcover : V ≤ supr U)
  (sf : Π i : ι, F.presheaf.obj (op (U i))) (h : is_compatible F.presheaf U sf) :
  ∃! s : F.presheaf.obj (op V), ∀ i : ι, F.presheaf.map (iUV i).op s = sf i :=
begin
  have V_eq_supr_U : V = supr U := le_antisymm hcover (supr_le (λ i, le_of_hom (iUV i))),
  obtain ⟨gl, gl_spec, gl_uniq⟩ := F.exists_unique_gluing U sf h,
  refine ⟨F.presheaf.map (eq_to_hom V_eq_supr_U).op gl, (λ i,_), (λ gl' gl'_spec,_)⟩,
  { rw ← functor_to_types.map_comp_apply,
    exact gl_spec i },
  { convert congr_arg _ (gl_uniq (F.presheaf.map (eq_to_hom V_eq_supr_U.symm).op gl') (λ i,_)) ;
      rw ← functor_to_types.map_comp_apply,
    { exact (functor_to_types.map_id_apply _ _).symm },
    { convert gl'_spec i }}
end

@[ext]
lemma eq_of_locally_eq (s t : F.presheaf.obj (op (supr U)))
  (h : ∀ i, F.presheaf.map (opens.le_supr U i).op s = F.presheaf.map (opens.le_supr U i).op t) :
  s = t :=
begin
  apply (mono_iff_injective _).mp (mono_of_is_limit_parallel_pair (F.sheaf_condition U)),
  ext,
  simp only [fork_ι, res_π_apply, h],
end

/--
In this version of the lemma, the inclusion homs `iUV` can be specified directly by the user,
which can be more convenient in practice.
-/
lemma eq_of_locally_eq' (V : opens X) (iUV : Π i : ι, U i ⟶ V) (hcover : V ≤ supr U)
  (s t : F.presheaf.obj (op V))
  (h : ∀ i, F.presheaf.map (iUV i).op s = F.presheaf.map (iUV i).op t) : s = t :=
begin
  have V_eq_supr_U : V = supr U := le_antisymm hcover (supr_le (λ i, le_of_hom (iUV i))),
  suffices : F.presheaf.map (eq_to_hom V_eq_supr_U.symm).op s =
             F.presheaf.map (eq_to_hom V_eq_supr_U.symm).op t,
  { convert congr_arg (F.presheaf.map (eq_to_hom V_eq_supr_U).op) this ;
    rw ← functor_to_types.map_comp_apply ;
    exact (functor_to_types.map_id_apply _ _).symm },
  apply eq_of_locally_eq,
  intro i,
  rw [← functor_to_types.map_comp_apply, ← functor_to_types.map_comp_apply],
  convert h i
end

end sheaf

end Top


import separation_world.level4 -- hide

/-
# Level 5: Every T₂ space is also T₁
-/

variables {X : Type} -- hide
variables [topological_space X] -- hide

namespace topological_space -- hide
open set -- hide

/- Lemma
Let τ be a topological space. τ is a frechet space if only if for all the points in the topology, their singletons are closed sets.
-/
lemma T2_space.T1_space [T2_space X]: T1_space X  :=
begin
  exact {t1 := λ x y hxy, let ⟨U, V, hU, hV, hUV, hh⟩  := T2_space.t2 x y hxy in
          ⟨U, hU, hh.1, not.imp (not_not.mpr hh.2) (λ c, (subset_compl_iff_disjoint.2 hUV) c)⟩ }

end

end topological_space -- hide