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

! This file was ported from Lean 3 source module measure_theory.covering.besicovitch_vector_space
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Measure.HaarLebesgue
import Mathbin.MeasureTheory.Covering.Besicovitch

/-!
# Satellite configurations for Besicovitch covering lemma in vector spaces

The Besicovitch covering theorem ensures that, in a nice metric space, there exists a number `N`
such that, from any family of balls with bounded radii, one can extract `N` families, each made of
disjoint balls, covering together all the centers of the initial family.

A key tool in the proof of this theorem is the notion of a satellite configuration, i.e., a family
of `N + 1` balls, where the first `N` balls all intersect the last one, but none of them contains
the center of another one and their radii are controlled. This is a technical notion, but it shows
up naturally in the proof of the Besicovitch theorem (which goes through a greedy algorithm): to
ensure that in the end one needs at most `N` families of balls, the crucial property of the
underlying metric space is that there should be no satellite configuration of `N + 1` points.

This file is devoted to the study of this property in vector spaces: we prove the main result
of [Füredi and Loeb, On the best constant for the Besicovitch covering theorem][furedi-loeb1994],
which shows that the optimal such `N` in a vector space coincides with the maximal number
of points one can put inside the unit ball of radius `2` under the condition that their distances
are bounded below by `1`.
In particular, this number is bounded by `5 ^ dim` by a straightforward measure argument.

## Main definitions and results

* `multiplicity E` is the maximal number of points one can put inside the unit ball
  of radius `2` in the vector space `E`, under the condition that their distances
  are bounded below by `1`.
* `multiplicity_le E` shows that `multiplicity E ≤ 5 ^ (dim E)`.
* `good_τ E` is a constant `> 1`, but close enough to `1` that satellite configurations
  with this parameter `τ` are not worst than for `τ = 1`.
* `is_empty_satellite_config_multiplicity` is the main theorem, saying that there are
  no satellite configurations of `(multiplicity E) + 1` points, for the parameter `good_τ E`.
-/

universe u

open Metric Set FiniteDimensional MeasureTheory Filter Fin

open ENNReal Topology

noncomputable section

namespace Besicovitch

variable {E : Type _} [NormedAddCommGroup E]

namespace SatelliteConfig

variable [NormedSpace ℝ E] {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ)

/-- Rescaling a satellite configuration in a vector space, to put the basepoint at `0` and the base
radius at `1`. -/
def centerAndRescale : SatelliteConfig E N τ
    where
  c i := (a.R (last N))⁻¹ • (a.c i - a.c (last N))
  R i := (a.R (last N))⁻¹ * a.R i
  rpos i := mul_pos (inv_pos.2 (a.rpos _)) (a.rpos _)
  h i j hij := by
    rcases a.h i j hij with (H | H)
    · left
      constructor
      · rw [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs,
          abs_of_nonneg (inv_nonneg.2 (a.rpos _).le)]
        refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
        rw [dist_eq_norm] at H
        convert H.1 using 2
        abel
      · rw [← mul_assoc, mul_comm τ, mul_assoc]
        refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
        exact H.2
    · right
      constructor
      · rw [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs,
          abs_of_nonneg (inv_nonneg.2 (a.rpos _).le)]
        refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
        rw [dist_eq_norm] at H
        convert H.1 using 2
        abel
      · rw [← mul_assoc, mul_comm τ, mul_assoc]
        refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
        exact H.2
  hlast i hi := by
    have H := a.hlast i hi
    constructor
    · rw [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs,
        abs_of_nonneg (inv_nonneg.2 (a.rpos _).le)]
      refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
      rw [dist_eq_norm] at H
      convert H.1 using 2
      abel
    · rw [← mul_assoc, mul_comm τ, mul_assoc]
      refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
      exact H.2
  inter i hi := by
    have H := a.inter i hi
    rw [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs,
      abs_of_nonneg (inv_nonneg.2 (a.rpos _).le), ← mul_add]
    refine' mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (a.rpos _).le)
    rw [dist_eq_norm] at H
    convert H using 2
    abel
#align besicovitch.satellite_config.center_and_rescale Besicovitch.SatelliteConfig.centerAndRescale

theorem centerAndRescale_center : a.centerAndRescale.c (last N) = 0 := by
  simp [satellite_config.center_and_rescale]
#align besicovitch.satellite_config.center_and_rescale_center Besicovitch.SatelliteConfig.centerAndRescale_center

theorem centerAndRescale_radius {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ) :
    a.centerAndRescale.R (last N) = 1 := by
  simp [satellite_config.center_and_rescale, inv_mul_cancel (a.rpos _).ne']
#align besicovitch.satellite_config.center_and_rescale_radius Besicovitch.SatelliteConfig.centerAndRescale_radius

end SatelliteConfig

/-! ### Disjoint balls of radius close to `1` in the radius `2` ball. -/

/-- The maximum cardinality of a `1`-separated set in the ball of radius `2`. This is also the
optimal number of families in the Besicovitch covering theorem. -/
def multiplicity (E : Type _) [NormedAddCommGroup E] :=
  supₛ
    { N | ∃ s : Finset E, s.card = N ∧ (∀ c ∈ s, ‖c‖ ≤ 2) ∧ ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 ≤ ‖c - d‖ }
#align besicovitch.multiplicity Besicovitch.multiplicity

section

variable [NormedSpace ℝ E] [FiniteDimensional ℝ E]

/-- Any `1`-separated set in the ball of radius `2` has cardinality at most `5 ^ dim`. This is
useful to show that the supremum in the definition of `besicovitch.multiplicity E` is
well behaved. -/
theorem card_le_of_separated (s : Finset E) (hs : ∀ c ∈ s, ‖c‖ ≤ 2)
    (h : ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 ≤ ‖c - d‖) : s.card ≤ 5 ^ finrank ℝ E :=
  by
  /- We consider balls of radius `1/2` around the points in `s`. They are disjoint, and all
    contained in the ball of radius `5/2`. A volume argument gives `s.card * (1/2)^dim ≤ (5/2)^dim`,
    i.e., `s.card ≤ 5^dim`. -/
  borelize E
  let μ : Measure E := measure.add_haar
  let δ : ℝ := (1 : ℝ) / 2
  let ρ : ℝ := (5 : ℝ) / 2
  have ρpos : 0 < ρ := by norm_num [ρ]
  set A := ⋃ c ∈ s, ball (c : E) δ with hA
  have D : Set.Pairwise (s : Set E) (Disjoint on fun c => ball (c : E) δ) :=
    by
    rintro c hc d hd hcd
    apply ball_disjoint_ball
    rw [dist_eq_norm]
    convert h c hc d hd hcd
    norm_num
  have A_subset : A ⊆ ball (0 : E) ρ :=
    by
    refine' Union₂_subset fun x hx => _
    apply ball_subset_ball'
    calc
      δ + dist x 0 ≤ δ + 2 := by
        rw [dist_zero_right]
        exact add_le_add le_rfl (hs x hx)
      _ = 5 / 2 := by norm_num [δ]

  have I :
    (s.card : ℝ≥0∞) * ENNReal.ofReal (δ ^ finrank ℝ E) * μ (ball 0 1) ≤
      ENNReal.ofReal (ρ ^ finrank ℝ E) * μ (ball 0 1) :=
    calc
      (s.card : ℝ≥0∞) * ENNReal.ofReal (δ ^ finrank ℝ E) * μ (ball 0 1) = μ A :=
        by
        rw [hA, measure_bUnion_finset D fun c hc => measurableSet_ball]
        have I : 0 < δ := by norm_num [δ]
        simp only [μ.add_haar_ball_of_pos _ I, one_div, one_pow, Finset.sum_const, nsmul_eq_mul,
          div_pow, mul_assoc]
      _ ≤ μ (ball (0 : E) ρ) := (measure_mono A_subset)
      _ = ENNReal.ofReal (ρ ^ finrank ℝ E) * μ (ball 0 1) := by
        simp only [μ.add_haar_ball_of_pos _ ρpos]

  have J : (s.card : ℝ≥0∞) * ENNReal.ofReal (δ ^ finrank ℝ E) ≤ ENNReal.ofReal (ρ ^ finrank ℝ E) :=
    (ENNReal.mul_le_mul_right (measure_ball_pos _ _ zero_lt_one).ne' measure_ball_lt_top.ne).1 I
  have K : (s.card : ℝ) ≤ (5 : ℝ) ^ finrank ℝ E := by
    simpa [ENNReal.toReal_mul, div_eq_mul_inv] using
      ENNReal.toReal_le_of_le_ofReal (pow_nonneg ρpos.le _) J
  exact_mod_cast K
#align besicovitch.card_le_of_separated Besicovitch.card_le_of_separated

theorem multiplicity_le : multiplicity E ≤ 5 ^ finrank ℝ E :=
  by
  apply csupₛ_le
  · refine' ⟨0, ⟨∅, by simp⟩⟩
  · rintro _ ⟨s, ⟨rfl, h⟩⟩
    exact Besicovitch.card_le_of_separated s h.1 h.2
#align besicovitch.multiplicity_le Besicovitch.multiplicity_le

theorem card_le_multiplicity {s : Finset E} (hs : ∀ c ∈ s, ‖c‖ ≤ 2)
    (h's : ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 ≤ ‖c - d‖) : s.card ≤ multiplicity E :=
  by
  apply le_csupₛ
  · refine' ⟨5 ^ finrank ℝ E, _⟩
    rintro _ ⟨s, ⟨rfl, h⟩⟩
    exact Besicovitch.card_le_of_separated s h.1 h.2
  · simp only [mem_set_of_eq, Ne.def]
    exact ⟨s, rfl, hs, h's⟩
#align besicovitch.card_le_multiplicity Besicovitch.card_le_multiplicity

variable (E)

/-- If `δ` is small enough, a `(1-δ)`-separated set in the ball of radius `2` also has cardinality
at most `multiplicity E`. -/
theorem exists_good_δ :
    ∃ δ : ℝ,
      0 < δ ∧
        δ < 1 ∧
          ∀ s : Finset E,
            (∀ c ∈ s, ‖c‖ ≤ 2) →
              (∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 - δ ≤ ‖c - d‖) → s.card ≤ multiplicity E :=
  by
  classical
    /- This follows from a compactness argument: otherwise, one could extract a converging
      subsequence, to obtain a `1`-separated set in the ball of radius `2` with cardinality
      `N = multiplicity E + 1`. To formalize this, we work with functions `fin N → E`.
       -/
    by_contra' h
    set N := multiplicity E + 1 with hN
    have :
      ∀ δ : ℝ,
        0 < δ → ∃ f : Fin N → E, (∀ i : Fin N, ‖f i‖ ≤ 2) ∧ ∀ i j, i ≠ j → 1 - δ ≤ ‖f i - f j‖ :=
      by
      intro δ hδ
      rcases lt_or_le δ 1 with (hδ' | hδ')
      · rcases h δ hδ hδ' with ⟨s, hs, h's, s_card⟩
        obtain ⟨f, f_inj, hfs⟩ : ∃ f : Fin N → E, Function.Injective f ∧ range f ⊆ ↑s :=
          by
          have : Fintype.card (Fin N) ≤ s.card :=
            by
            simp only [Fintype.card_fin]
            exact s_card
          rcases Function.Embedding.exists_of_card_le_finset this with ⟨f, hf⟩
          exact ⟨f, f.injective, hf⟩
        simp only [range_subset_iff, Finset.mem_coe] at hfs
        refine' ⟨f, fun i => hs _ (hfs i), fun i j hij => h's _ (hfs i) _ (hfs j) (f_inj.ne hij)⟩
      ·
        exact
          ⟨fun i => 0, fun i => by simp, fun i j hij => by
            simpa only [norm_zero, sub_nonpos, sub_self] ⟩
    -- For `δ > 0`, `F δ` is a function from `fin N` to the ball of radius `2` for which two points
    -- in the image are separated by `1 - δ`.
    choose! F hF using this
    -- Choose a converging subsequence when `δ → 0`.
    have : ∃ f : Fin N → E, (∀ i : Fin N, ‖f i‖ ≤ 2) ∧ ∀ i j, i ≠ j → 1 ≤ ‖f i - f j‖ :=
      by
      obtain ⟨u, u_mono, zero_lt_u, hu⟩ :
        ∃ u : ℕ → ℝ,
          (∀ m n : ℕ, m < n → u n < u m) ∧
            (∀ n : ℕ, 0 < u n) ∧ Filter.Tendsto u Filter.atTop (𝓝 0) :=
        exists_seq_strictAnti_tendsto (0 : ℝ)
      have A : ∀ n, F (u n) ∈ closed_ball (0 : Fin N → E) 2 :=
        by
        intro n
        simp only [pi_norm_le_iff_of_nonneg zero_le_two, mem_closed_ball, dist_zero_right,
          (hF (u n) (zero_lt_u n)).left, forall_const]
      obtain ⟨f, fmem, φ, φ_mono, hf⟩ :
        ∃ f ∈ closed_ball (0 : Fin N → E) 2,
          ∃ φ : ℕ → ℕ, StrictMono φ ∧ tendsto ((F ∘ u) ∘ φ) at_top (𝓝 f) :=
        IsCompact.tendsto_subseq (is_compact_closed_ball _ _) A
      refine' ⟨f, fun i => _, fun i j hij => _⟩
      · simp only [pi_norm_le_iff_of_nonneg zero_le_two, mem_closed_ball, dist_zero_right] at fmem
        exact fmem i
      · have A : tendsto (fun n => ‖F (u (φ n)) i - F (u (φ n)) j‖) at_top (𝓝 ‖f i - f j‖) :=
          ((hf.apply i).sub (hf.apply j)).norm
        have B : tendsto (fun n => 1 - u (φ n)) at_top (𝓝 (1 - 0)) :=
          tendsto_const_nhds.sub (hu.comp φ_mono.tendsto_at_top)
        rw [sub_zero] at B
        exact le_of_tendsto_of_tendsto' B A fun n => (hF (u (φ n)) (zero_lt_u _)).2 i j hij
    rcases this with ⟨f, hf, h'f⟩
    -- the range of `f` contradicts the definition of `multiplicity E`.
    have finj : Function.Injective f := by
      intro i j hij
      by_contra
      have : 1 ≤ ‖f i - f j‖ := h'f i j h
      simp only [hij, norm_zero, sub_self] at this
      exact lt_irrefl _ (this.trans_lt zero_lt_one)
    let s := Finset.image f Finset.univ
    have s_card : s.card = N :=
      by
      rw [Finset.card_image_of_injective _ finj]
      exact Finset.card_fin N
    have hs : ∀ c ∈ s, ‖c‖ ≤ 2 := by
      simp only [hf, forall_apply_eq_imp_iff', forall_const, forall_exists_index, Finset.mem_univ,
        Finset.mem_image]
    have h's : ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 ≤ ‖c - d‖ :=
      by
      simp only [s, forall_apply_eq_imp_iff', forall_exists_index, Finset.mem_univ,
        Finset.mem_image, Ne.def, exists_true_left, forall_apply_eq_imp_iff', forall_true_left]
      intro i j hij
      have : i ≠ j := fun h => by
        rw [h] at hij
        exact hij rfl
      exact h'f i j this
    have : s.card ≤ multiplicity E := card_le_multiplicity hs h's
    rw [s_card, hN] at this
    exact lt_irrefl _ ((Nat.lt_succ_self (multiplicity E)).trans_le this)
#align besicovitch.exists_good_δ Besicovitch.exists_good_δ

/-- A small positive number such that any `1 - δ`-separated set in the ball of radius `2` has
cardinality at most `besicovitch.multiplicity E`. -/
def goodδ : ℝ :=
  (exists_good_δ E).some
#align besicovitch.good_δ Besicovitch.goodδ

theorem goodδ_lt_one : goodδ E < 1 :=
  (exists_good_δ E).choose_spec.2.1
#align besicovitch.good_δ_lt_one Besicovitch.goodδ_lt_one

/-- A number `τ > 1`, but chosen close enough to `1` so that the construction in the Besicovitch
covering theorem using this parameter `τ` will give the smallest possible number of covering
families. -/
def goodτ : ℝ :=
  1 + goodδ E / 4
#align besicovitch.good_τ Besicovitch.goodτ

theorem one_lt_goodτ : 1 < goodτ E := by
  dsimp [good_τ, good_δ]
  linarith [(exists_good_δ E).choose_spec.1]
#align besicovitch.one_lt_good_τ Besicovitch.one_lt_goodτ

variable {E}

theorem card_le_multiplicity_of_δ {s : Finset E} (hs : ∀ c ∈ s, ‖c‖ ≤ 2)
    (h's : ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 - goodδ E ≤ ‖c - d‖) : s.card ≤ multiplicity E :=
  (Classical.choose_spec (exists_good_δ E)).2.2 s hs h's
#align besicovitch.card_le_multiplicity_of_δ Besicovitch.card_le_multiplicity_of_δ

theorem le_multiplicity_of_δ_of_fin {n : ℕ} (f : Fin n → E) (h : ∀ i, ‖f i‖ ≤ 2)
    (h' : ∀ i j, i ≠ j → 1 - goodδ E ≤ ‖f i - f j‖) : n ≤ multiplicity E := by
  classical
    have finj : Function.Injective f := by
      intro i j hij
      by_contra
      have : 1 - good_δ E ≤ ‖f i - f j‖ := h' i j h
      simp only [hij, norm_zero, sub_self] at this
      linarith [good_δ_lt_one E]
    let s := Finset.image f Finset.univ
    have s_card : s.card = n :=
      by
      rw [Finset.card_image_of_injective _ finj]
      exact Finset.card_fin n
    have hs : ∀ c ∈ s, ‖c‖ ≤ 2 := by
      simp only [h, forall_apply_eq_imp_iff', forall_const, forall_exists_index, Finset.mem_univ,
        Finset.mem_image, imp_true_iff]
    have h's : ∀ c ∈ s, ∀ d ∈ s, c ≠ d → 1 - good_δ E ≤ ‖c - d‖ :=
      by
      simp only [s, forall_apply_eq_imp_iff', forall_exists_index, Finset.mem_univ,
        Finset.mem_image, Ne.def, exists_true_left, forall_apply_eq_imp_iff', forall_true_left]
      intro i j hij
      have : i ≠ j := fun h => by
        rw [h] at hij
        exact hij rfl
      exact h' i j this
    have : s.card ≤ multiplicity E := card_le_multiplicity_of_δ hs h's
    rwa [s_card] at this
#align besicovitch.le_multiplicity_of_δ_of_fin Besicovitch.le_multiplicity_of_δ_of_fin

end

namespace SatelliteConfig

/-!
### Relating satellite configurations to separated points in the ball of radius `2`.

We prove that the number of points in a satellite configuration is bounded by the maximal number
of `1`-separated points in the ball of radius `2`. For this, start from a satellite congifuration
`c`. Without loss of generality, one can assume that the last ball is centered at `0` and of
radius `1`. Define `c' i = c i` if `‖c i‖ ≤ 2`, and `c' i = (2/‖c i‖) • c i` if `‖c i‖ > 2`.
It turns out that these points are `1 - δ`-separated, where `δ` is arbitrarily small if `τ` is
close enough to `1`. The number of such configurations is bounded by `multiplicity E` if `δ` is
suitably small.

To check that the points `c' i` are `1 - δ`-separated, one treats separately the cases where
both `‖c i‖` and `‖c j‖` are `≤ 2`, where one of them is `≤ 2` and the other one is `> 2`, and
where both of them are `> 2`.
-/

theorem exists_normalized_aux1 {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ)
    (lastr : a.R (last N) = 1) (hτ : 1 ≤ τ) (δ : ℝ) (hδ1 : τ ≤ 1 + δ / 4) (hδ2 : δ ≤ 1)
    (i j : Fin N.succ) (inej : i ≠ j) : 1 - δ ≤ ‖a.c i - a.c j‖ :=
  by
  have ah :
    ∀ i j,
      i ≠ j →
        a.r i ≤ ‖a.c i - a.c j‖ ∧ a.r j ≤ τ * a.r i ∨ a.r j ≤ ‖a.c j - a.c i‖ ∧ a.r i ≤ τ * a.r j :=
    by simpa only [dist_eq_norm] using a.h
  have δnonneg : 0 ≤ δ := by linarith only [hτ, hδ1]
  have D : 0 ≤ 1 - δ / 4 := by linarith only [hδ2]
  have τpos : 0 < τ := _root_.zero_lt_one.trans_le hτ
  have I : (1 - δ / 4) * τ ≤ 1 :=
    calc
      (1 - δ / 4) * τ ≤ (1 - δ / 4) * (1 + δ / 4) := mul_le_mul_of_nonneg_left hδ1 D
      _ = 1 - δ ^ 2 / 16 := by ring
      _ ≤ 1 := by linarith only [sq_nonneg δ]

  have J : 1 - δ ≤ 1 - δ / 4 := by linarith only [δnonneg]
  have K : 1 - δ / 4 ≤ τ⁻¹ := by
    rw [inv_eq_one_div, le_div_iff τpos]
    exact I
  suffices L : τ⁻¹ ≤ ‖a.c i - a.c j‖
  · linarith only [J, K, L]
  have hτ' : ∀ k, τ⁻¹ ≤ a.r k := by
    intro k
    rw [inv_eq_one_div, div_le_iff τpos, ← lastr, mul_comm]
    exact a.hlast' k hτ
  rcases ah i j inej with (H | H)
  · apply le_trans _ H.1
    exact hτ' i
  · rw [norm_sub_rev]
    apply le_trans _ H.1
    exact hτ' j
#align besicovitch.satellite_config.exists_normalized_aux1 Besicovitch.SatelliteConfig.exists_normalized_aux1

variable [NormedSpace ℝ E]

theorem exists_normalized_aux2 {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ)
    (lastc : a.c (last N) = 0) (lastr : a.R (last N) = 1) (hτ : 1 ≤ τ) (δ : ℝ) (hδ1 : τ ≤ 1 + δ / 4)
    (hδ2 : δ ≤ 1) (i j : Fin N.succ) (inej : i ≠ j) (hi : ‖a.c i‖ ≤ 2) (hj : 2 < ‖a.c j‖) :
    1 - δ ≤ ‖a.c i - (2 / ‖a.c j‖) • a.c j‖ :=
  by
  have ah :
    ∀ i j,
      i ≠ j →
        a.r i ≤ ‖a.c i - a.c j‖ ∧ a.r j ≤ τ * a.r i ∨ a.r j ≤ ‖a.c j - a.c i‖ ∧ a.r i ≤ τ * a.r j :=
    by simpa only [dist_eq_norm] using a.h
  have δnonneg : 0 ≤ δ := by linarith only [hτ, hδ1]
  have D : 0 ≤ 1 - δ / 4 := by linarith only [hδ2]
  have τpos : 0 < τ := _root_.zero_lt_one.trans_le hτ
  have hcrj : ‖a.c j‖ ≤ a.r j + 1 := by simpa only [lastc, lastr, dist_zero_right] using a.inter' j
  have I : a.r i ≤ 2 := by
    rcases lt_or_le i (last N) with (H | H)
    · apply (a.hlast i H).1.trans
      simpa only [dist_eq_norm, lastc, sub_zero] using hi
    · have : i = last N := top_le_iff.1 H
      rw [this, lastr]
      exact one_le_two
  have J : (1 - δ / 4) * τ ≤ 1 :=
    calc
      (1 - δ / 4) * τ ≤ (1 - δ / 4) * (1 + δ / 4) := mul_le_mul_of_nonneg_left hδ1 D
      _ = 1 - δ ^ 2 / 16 := by ring
      _ ≤ 1 := by linarith only [sq_nonneg δ]

  have A : a.r j - δ ≤ ‖a.c i - a.c j‖ :=
    by
    rcases ah j i inej.symm with (H | H)
    · rw [norm_sub_rev]
      linarith [H.1]
    have C : a.r j ≤ 4 :=
      calc
        a.r j ≤ τ * a.r i := H.2
        _ ≤ τ * 2 := (mul_le_mul_of_nonneg_left I τpos.le)
        _ ≤ 5 / 4 * 2 := (mul_le_mul_of_nonneg_right (by linarith only [hδ1, hδ2]) zero_le_two)
        _ ≤ 4 := by norm_num

    calc
      a.r j - δ ≤ a.r j - a.r j / 4 * δ :=
        by
        refine' sub_le_sub le_rfl _
        refine' mul_le_of_le_one_left δnonneg _
        linarith only [C]
      _ = (1 - δ / 4) * a.r j := by ring
      _ ≤ (1 - δ / 4) * (τ * a.r i) := (mul_le_mul_of_nonneg_left H.2 D)
      _ ≤ 1 * a.r i := by
        rw [← mul_assoc]
        apply mul_le_mul_of_nonneg_right J (a.rpos _).le
      _ ≤ ‖a.c i - a.c j‖ := by
        rw [one_mul]
        exact H.1

  set d := (2 / ‖a.c j‖) • a.c j with hd
  have : a.r j - δ ≤ ‖a.c i - d‖ + (a.r j - 1) :=
    calc
      a.r j - δ ≤ ‖a.c i - a.c j‖ := A
      _ ≤ ‖a.c i - d‖ + ‖d - a.c j‖ := by simp only [← dist_eq_norm, dist_triangle]
      _ ≤ ‖a.c i - d‖ + (a.r j - 1) := by
        apply add_le_add_left
        have A : 0 ≤ 1 - 2 / ‖a.c j‖ := by simpa [div_le_iff (zero_le_two.trans_lt hj)] using hj.le
        rw [← one_smul ℝ (a.c j), hd, ← sub_smul, norm_smul, norm_sub_rev, Real.norm_eq_abs,
          abs_of_nonneg A, sub_mul]
        field_simp [(zero_le_two.trans_lt hj).ne']
        linarith only [hcrj]

  linarith only [this]
#align besicovitch.satellite_config.exists_normalized_aux2 Besicovitch.SatelliteConfig.exists_normalized_aux2

theorem exists_normalized_aux3 {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ)
    (lastc : a.c (last N) = 0) (lastr : a.R (last N) = 1) (hτ : 1 ≤ τ) (δ : ℝ) (hδ1 : τ ≤ 1 + δ / 4)
    (i j : Fin N.succ) (inej : i ≠ j) (hi : 2 < ‖a.c i‖) (hij : ‖a.c i‖ ≤ ‖a.c j‖) :
    1 - δ ≤ ‖(2 / ‖a.c i‖) • a.c i - (2 / ‖a.c j‖) • a.c j‖ :=
  by
  have ah :
    ∀ i j,
      i ≠ j →
        a.r i ≤ ‖a.c i - a.c j‖ ∧ a.r j ≤ τ * a.r i ∨ a.r j ≤ ‖a.c j - a.c i‖ ∧ a.r i ≤ τ * a.r j :=
    by simpa only [dist_eq_norm] using a.h
  have δnonneg : 0 ≤ δ := by linarith only [hτ, hδ1]
  have τpos : 0 < τ := _root_.zero_lt_one.trans_le hτ
  have hcrj : ‖a.c j‖ ≤ a.r j + 1 := by simpa only [lastc, lastr, dist_zero_right] using a.inter' j
  have A : a.r i ≤ ‖a.c i‖ :=
    by
    have : i < last N := by
      apply lt_top_iff_ne_top.2
      intro iN
      change i = last N at iN
      rw [iN, lastc, norm_zero] at hi
      exact lt_irrefl _ (zero_le_two.trans_lt hi)
    convert(a.hlast i this).1
    rw [dist_eq_norm, lastc, sub_zero]
  have hj : 2 < ‖a.c j‖ := hi.trans_le hij
  set s := ‖a.c i‖ with hs
  have spos : 0 < s := zero_lt_two.trans hi
  set d := (s / ‖a.c j‖) • a.c j with hd
  have I : ‖a.c j - a.c i‖ ≤ ‖a.c j‖ - s + ‖d - a.c i‖ :=
    calc
      ‖a.c j - a.c i‖ ≤ ‖a.c j - d‖ + ‖d - a.c i‖ := by simp [← dist_eq_norm, dist_triangle]
      _ = ‖a.c j‖ - ‖a.c i‖ + ‖d - a.c i‖ :=
        by
        nth_rw 1 [← one_smul ℝ (a.c j)]
        rw [add_left_inj, hd, ← sub_smul, norm_smul, Real.norm_eq_abs, abs_of_nonneg, sub_mul,
          one_mul, div_mul_cancel _ (zero_le_two.trans_lt hj).ne']
        rwa [sub_nonneg, div_le_iff (zero_lt_two.trans hj), one_mul]

  have J : a.r j - ‖a.c j - a.c i‖ ≤ s / 2 * δ :=
    calc
      a.r j - ‖a.c j - a.c i‖ ≤ s * (τ - 1) :=
        by
        rcases ah j i inej.symm with (H | H)
        ·
          calc
            a.r j - ‖a.c j - a.c i‖ ≤ 0 := sub_nonpos.2 H.1
            _ ≤ s * (τ - 1) := mul_nonneg spos.le (sub_nonneg.2 hτ)

        · rw [norm_sub_rev] at H
          calc
            a.r j - ‖a.c j - a.c i‖ ≤ τ * a.r i - a.r i := sub_le_sub H.2 H.1
            _ = a.r i * (τ - 1) := by ring
            _ ≤ s * (τ - 1) := mul_le_mul_of_nonneg_right A (sub_nonneg.2 hτ)

      _ ≤ s * (δ / 2) := (mul_le_mul_of_nonneg_left (by linarith only [δnonneg, hδ1]) spos.le)
      _ = s / 2 * δ := by ring

  have invs_nonneg : 0 ≤ 2 / s := div_nonneg zero_le_two (zero_le_two.trans hi.le)
  calc
    1 - δ = 2 / s * (s / 2 - s / 2 * δ) :=
      by
      field_simp [spos.ne']
      ring
    _ ≤ 2 / s * ‖d - a.c i‖ :=
      (mul_le_mul_of_nonneg_left (by linarith only [hcrj, I, J, hi]) invs_nonneg)
    _ = ‖(2 / s) • a.c i - (2 / ‖a.c j‖) • a.c j‖ :=
      by
      conv_lhs => rw [norm_sub_rev, ← abs_of_nonneg invs_nonneg]
      rw [← Real.norm_eq_abs, ← norm_smul, smul_sub, hd, smul_smul]
      congr 3
      field_simp [spos.ne']

#align besicovitch.satellite_config.exists_normalized_aux3 Besicovitch.SatelliteConfig.exists_normalized_aux3

theorem exists_normalized {N : ℕ} {τ : ℝ} (a : SatelliteConfig E N τ) (lastc : a.c (last N) = 0)
    (lastr : a.R (last N) = 1) (hτ : 1 ≤ τ) (δ : ℝ) (hδ1 : τ ≤ 1 + δ / 4) (hδ2 : δ ≤ 1) :
    ∃ c' : Fin N.succ → E, (∀ n, ‖c' n‖ ≤ 2) ∧ ∀ i j, i ≠ j → 1 - δ ≤ ‖c' i - c' j‖ :=
  by
  let c' : Fin N.succ → E := fun i => if ‖a.c i‖ ≤ 2 then a.c i else (2 / ‖a.c i‖) • a.c i
  have norm_c'_le : ∀ i, ‖c' i‖ ≤ 2 := by
    intro i
    simp only [c']
    split_ifs
    · exact h
    by_cases hi : ‖a.c i‖ = 0 <;> field_simp [norm_smul, hi]
  refine' ⟨c', fun n => norm_c'_le n, fun i j inej => _⟩
  -- up to exchanging `i` and `j`, one can assume `∥c i∥ ≤ ∥c j∥`.
  wlog hij : ‖a.c i‖ ≤ ‖a.c j‖ generalizing i j
  · rw [norm_sub_rev]
    exact this j i inej.symm (le_of_not_le hij)
  rcases le_or_lt ‖a.c j‖ 2 with (Hj | Hj)
  -- case `∥c j∥ ≤ 2` (and therefore also `∥c i∥ ≤ 2`)
  · simp_rw [c', Hj, hij.trans Hj, if_true]
    exact exists_normalized_aux1 a lastr hτ δ hδ1 hδ2 i j inej
  -- case `2 < ‖c j‖`
  · have H'j : ‖a.c j‖ ≤ 2 ↔ False := by simpa only [not_le, iff_false_iff] using Hj
    rcases le_or_lt ‖a.c i‖ 2 with (Hi | Hi)
    · -- case `‖c i‖ ≤ 2`
      simp_rw [c', Hi, if_true, H'j, if_false]
      exact exists_normalized_aux2 a lastc lastr hτ δ hδ1 hδ2 i j inej Hi Hj
    · -- case `2 < ‖c i‖`
      have H'i : ‖a.c i‖ ≤ 2 ↔ False := by simpa only [not_le, iff_false_iff] using Hi
      simp_rw [c', H'i, if_false, H'j, if_false]
      exact exists_normalized_aux3 a lastc lastr hτ δ hδ1 i j inej Hi hij
#align besicovitch.satellite_config.exists_normalized Besicovitch.SatelliteConfig.exists_normalized

end SatelliteConfig

variable (E) [NormedSpace ℝ E] [FiniteDimensional ℝ E]

/-- In a normed vector space `E`, there can be no satellite configuration with `multiplicity E + 1`
points and the parameter `good_τ E`. This will ensure that in the inductive construction to get
the Besicovitch covering families, there will never be more than `multiplicity E` nonempty
families. -/
theorem isEmpty_satelliteConfig_multiplicity :
    IsEmpty (SatelliteConfig E (multiplicity E) (goodτ E)) :=
  ⟨by
    intro a
    let b := a.center_and_rescale
    rcases b.exists_normalized a.center_and_rescale_center a.center_and_rescale_radius
        (one_lt_good_τ E).le (good_δ E) le_rfl (good_δ_lt_one E).le with
      ⟨c', c'_le_two, hc'⟩
    exact
      lt_irrefl _ ((Nat.lt_succ_self _).trans_le (le_multiplicity_of_δ_of_fin c' c'_le_two hc'))⟩
#align besicovitch.is_empty_satellite_config_multiplicity Besicovitch.isEmpty_satelliteConfig_multiplicity

instance (priority := 100) : HasBesicovitchCovering E :=
  ⟨⟨multiplicity E, goodτ E, one_lt_goodτ E, isEmpty_satelliteConfig_multiplicity E⟩⟩

end Besicovitch


import Lake
import Init
import Mathlib.Data.Real.Basic

#eval 1

set_option autoImplicit false

-- All of Incidence Geometry
structure IncidenceGeometry where
  Point : Type
  Line : Type

  lies_on : Point → Line → Prop
  in_between : Point → Point → Point → Prop -- is this supposed to be here?
  -- properties of in_between
  between_refl_left (a b : Point) : in_between a a b
  between_refl_right (a b : Point) : in_between a b b

variable (geomi : IncidenceGeometry)

structure Segment where
  p1 : geomi.Point
  p2 : geomi.Point

structure Circle where
  centre : geomi.Point
  radius : ℝ

structure Angle where
  p1 : geomi.Point
  Pivot : geomi.Point
  p2 : geomi.Point

--def segme (geom : IncidenceGeometry) : Type := geom.Point × geom.Point

--#check segme

--def somseg (geom : IncidenceGeometry) (A B : geom.Point) : segme geom := (segme geom).mk A B

structure EuclidGeometry extends IncidenceGeometry where
  --Segment : Type := Point × Point
  --contain_end_points (seg : Segment) : --says the end points of the segment lies on the resulting line
    --lies_on (seg.1) (line_from_seg seg) ∧ lies_on (seg.2) (line_from_seg seg)

  --som (a b : Point) : Segment := (a,b)

  -- defining distance
  distance (Apt Bpt : Point) : ℝ
  --distance definition
  dist_is_not_neg (A B : Point): distance A B ≥ 0
  dist_same_point (A : Point) : distance A A = 0
  dist_geq_0 (A B : Point) : A ≠ B ↔ distance A B >  0
  dist_is_symm (A B : Point) : distance A B = distance B A
  dist_tri_ineq (A B C : Point) : distance A B + distance B C ≥ distance A C
  -- distance axioms when a point is in between other two
  dist_in_between (a b c : Point) (h : in_between a b c) :
    distance a b + distance b c = distance a c

  -- Postulate 1
  -- Between two points there is an unique line passing through them

  Line_of_two_points (A B : Point) (h : A ≠ B): Line -- from two points we get a line (it may not be unique)
  point_contain (A B : Point) (h : A ≠ B) : --says such a line contain both the points
    have l : Line := Line_of_two_points A B h
    lies_on A l ∧ lies_on B l

  line_unique (A B: Point) (h : A ≠ B) (l1 l2 : Line): --says such a line is unique
  (lies_on A l1 ∧ lies_on B l1) ∧ (lies_on A l2 ∧ lies_on B l2) → l1 = l2

  Collinear_point (A B C : Point) (h : A ≠ B):
    in_between A B C ∨ in_between A C B ∨ in_between C A B
    → lies_on C (Line_of_two_points A B h)

  lies_on_segment (p : geomi.Point) (seg : Segment geomi) : geomi.in_between seg.p1 p seg.p2

  -- end of Postulate 1

  -- Postulate 2
  -- A line segment can be extended to get a line

  --line_from_seg (seg : Segment) : Line --says a you get a line from a segment

instance : Coe EuclidGeometry IncidenceGeometry where
  coe geom := { Point := geom.Point, Line := geom.Line, lies_on := geom.lies_on, in_between := geom.in_between, between_refl_left := geom.between_refl_left, between_refl_right := geom.between_refl_right }

def EuclidGeometry.length (geom : EuclidGeometry) (s : Segment geom) : ℝ :=
  geom.distance s.p1 s.p2

-- def EuclidGeometry.point_on_segment (geom : EuclidGeometry) (s : Segment geom) (p : geom.Point) : Prop :=
--   geom.in_between s.p1 p s.p2

variable (geom : EuclidGeometry)

-- this says that there is

-- points in between the segment endpoints lie on the segment
def EuclidGeometry.lies_on_segment (p : geom.Point) (seg : Segment geom) : Prop :=
  geom.in_between seg.p1 p seg.p2

-- this defines when a segment lies on a line (use with CAUTION)
def EuclidGeometry.segment_in_line (geom: EuclidGeometry)
  (s: Segment geom)(l: geom.Line) : Prop :=
  ∀ p: geom.Point, geom.in_between s.p1 p s.p2 → geom.lies_on p l

-- this says that every segment lies on a line
def EuclidGeometry.Post2 (geom : EuclidGeometry) : Prop :=
  ∀ s : Segment geom, ∃ l: geom.Line, geom.segment_in_line s l

-- Line obtained from a segment
variable (Line_from_segment : Segment geom → geom.Line)

-- property of Line_from_segment
def EuclidGeometry.Line_from_segment_contains_segment (seg : Segment geom) : Prop :=
  geom.segment_in_line seg (Line_from_segment seg)

-- this theorem says that the line is unique when the length of the segment is non-zero
theorem EuclidGeometry.Unique_line_from_segment
  (seg : Segment geom) (h : ¬ seg.p1 = seg.p2) (l1 l2 : geom.Line) :
  geom.segment_in_line seg l1 ∧ geom.segment_in_line seg l2
  → l1 = l2
  := by
    intro h1
    let ⟨h2, h3⟩ := h1
    apply geom.line_unique seg.p1 seg.p2 h l1 l2
    apply And.intro
    case left =>
      apply And.intro
      case left =>
        have lem : geom.in_between seg.p1 seg.p1 seg.p2 :=
          geom.between_refl_left seg.p1 seg.p2
        simp [segment_in_line] at h2
        have lem' : geom.in_between seg.p1 seg.p1 seg.p2 →
          geom.lies_on seg.p1 l1 := by
            simp [h2, lem]
        apply lem'
        assumption
      case right =>
        have lem : geom.in_between seg.p1 seg.p2 seg.p2 :=
          geom.between_refl_right seg.p1 seg.p2
        simp [segment_in_line] at h2
        have lem' : geom.in_between seg.p1 seg.p2 seg.p2 →
          geom.lies_on seg.p2 l1 := by
            simp [h2, lem]
        apply lem'
        assumption
    case right =>
      apply And.intro
      case left =>
        have lem : geom.in_between seg.p1 seg.p1 seg.p2 :=
          geom.between_refl_left seg.p1 seg.p2
        simp [segment_in_line] at h3
        have lem' : geom.in_between seg.p1 seg.p1 seg.p2 →
          geom.lies_on seg.p1 l2 := by
            simp [h3, lem]
        apply lem'
        assumption
      case right =>
        have lem : geom.in_between seg.p1 seg.p2 seg.p2 :=
          geom.between_refl_right seg.p1 seg.p2
        simp [segment_in_line] at h3
        have lem' : geom.in_between seg.p1 seg.p2 seg.p2 →
          geom.lies_on seg.p2 l2 := by
            simp [h3, lem]
        apply lem'
        assumption

-- defining parallel lines
def EuclidGeometry.IsParallel (l1 l2 : geom.Line) : Prop :=
  (l1 = l2) ∨ (∀ a : geom.Point, geom.lies_on a l1 → ¬ geom.lies_on a l2)

-- IsParallel is an equivalence relation on Lines
theorem EuclidGeometry.Parallel_refl (l : geom.Line) :
  IsParallel geom l l
  := by
    simp [IsParallel]

theorem EuclidGeometry.Parallel_symm (l1 l2 : geom.Line) :
  IsParallel geom l1 l2 → IsParallel geom l2 l1
  := by
    intro h
    simp [IsParallel]
    simp [IsParallel] at h
    apply Or.elim h
    case left =>
      intro h1
      apply Or.inl
      rw [h1]
    case right =>
      intro h2
      apply Or.inr
      intro p hp
      have lem : geom.lies_on p l1 → ¬ geom.lies_on p l2 := by
        apply of_eq_true
        apply eq_true (h2 p)
      by_contra h3
      simp [h3] at lem
      contradiction

theorem EuclidGeometry.Parallel_trans (l1 l2 l3: geom.Line) :
  IsParallel geom l1 l2 → IsParallel geom l2 l3 → IsParallel geom l1 l3
  := by
    intro h1 h2
    have h1' : IsParallel geom l1 l2 := h1
    have h2' : IsParallel geom l2 l3 := h2

    simp [IsParallel]
    simp [IsParallel] at h1
    simp [IsParallel] at h2
    apply Or.elim h1
    case left =>
      intro h12eq
      apply Or.elim h2
      case left =>
        intro h23eq
        apply Or.inl
        rw [<- h23eq, h12eq]
      case right =>
        intro hk
        rw [<-h12eq] at h2'
        simp [IsParallel] at h2'
        assumption
    case right =>
      intro hk
      apply Or.elim h2
      case left =>
        intro h23eq
        rw [h23eq] at h1'
        simp [IsParallel] at h1'
        assumption
      case right =>
        intro hk1
        by_cases l1 = l3
        case pos =>
          apply Or.inl
          assumption
        case neg =>
          apply Or.inr
          intro p hp
          by_contra hk'
          sorry               -- need to use Playfair's axiom here for this case.

-- defining intersection of lines (not segments)
def EuclidGeometry.Lines_Intersect (l1 l2 : geom.Line) : Prop
  := ¬ IsParallel geom l1 l2

-- unique/existence(?) intersection point for two intersecting lines
theorem EuclidGeometry.Lines_Intersect_Point_Exist
  (l1 l2 : geom.Line) (h : Lines_Intersect geom l1 l2) :
  ∃ c : geom.Point, geom.lies_on c l1 ∧ geom.lies_on c l2
  := by
    simp [Lines_Intersect, IsParallel] at h
    rw [not_or] at h
    let ⟨_, h2⟩ := h
    simp at h2
    assumption

-- "extracting" point of intersection (use with CAUTION. point p can be any point whatsoever)
def EuclidGeometry.Lines_Intersect2
  (l1 l2 : geom.Line) (p : geom.Point) :
  Prop
  := geom.lies_on p l1 ∧ geom.lies_on p l2

-- lines, when they intersect, they do so at a unique point
theorem EuclidGeometry.Lines_Intersect_Point_Unique
  (l1 l2 : geom.Line) (h : Lines_Intersect geom l1 l2) (A B : geom.Point) :
  Lines_Intersect2 geom l1 l2 A →
  Lines_Intersect2 geom l1 l2 B →
  A = B
  := by
    intro h1 h2
    by_contra hab
    simp [Lines_Intersect2] at h1
    let ⟨h1l, h1r⟩ := h1
    simp [Lines_Intersect2] at h2
    let ⟨h2l, h2r⟩ := h2
    have lem1 : l1 = l2 := by
      apply geom.line_unique A B hab
      simp [h1l, h1r, h2l, h2r]
    simp [Lines_Intersect, IsParallel] at h
    rw [not_or] at h
    let ⟨hk, _⟩ := h
    contradiction

/-
variable (Point_from_lines_intersection :
  (l1 : geom.Line) →  (l2 : geom.Line) →  (geom.Lines_Intersect l1 l2) →  geom.Point)

#check Point_from_lines_intersection

-- property of Point_from_lines_intersection
def
-/

-- intersection of a line and a segment
def EuclidGeometry.Line_Intersect_Segment
  (seg : Segment geom) (l : geom.Line) : Prop :=
  ∃ p : geom.Point, geom.lies_on p l ∧ geom.lies_on_segment p seg

-- intersection of a line and a segment at point p
def EuclidGeometry.Line_Intersect_Segment2
  (seg : Segment geom) (l : geom.Line) (p : geom.Point): Prop :=
  geom.lies_on p l ∧ geom.lies_on_segment p seg

--variable (post2: Post2 geom)

-- postulate 3
-- just definition of circle

-- points on circle
def EuclidGeometry.On_Circle (P : geom.Point) (circ : Circle geom) : Prop
  := geom.distance P circ.centre = circ.radius

-- postulate 4

variable (reflexAngle : Angle geom → Angle geom)

-- measure of angle
variable (mAngle : Angle geom → ℝ)

-- statement that a point is inside an angle
def EuclidGeometry.IntPointAngle (a : geom.Point) (A : Angle geom) : Prop :=
  let A1 : Angle geom := Angle.mk a A.Pivot A.p1
  have A2 : Angle geom := Angle.mk a A.Pivot A.p2
  (mAngle (A1) < mAngle  A) ∧ (mAngle (A2) < mAngle A) -- strict inequality because of 120

-- we need to write that intpointangle for angles AOB and BOA are the same

-- properties of mAngle
def EuclidGeometry.mAngle_non_neg (a b c : geom.Point) : Prop :=
  mAngle (Angle.mk a b c) ≥ 0
def EuclidGeometry.ZeroAngle (a b c : geom.Point) (_ : geom.in_between a c b): Prop :=
  mAngle (Angle.mk a b c) = 0
def EuclidGeometry.mAngle_postive (a b c : geom.Point) : Prop :=
  ¬ geom.in_between a c b →
  ¬ geom.in_between c a b →
  mAngle (Angle.mk a b c) > 0

def EuclidGeometry.mReflexAngle (A : Angle geom) : Prop :=
  mAngle (reflexAngle A) = 360 - mAngle A

-- Angle A as Sum of its constituents
def EuclidGeometry.mAngleAdd (a : geom.Point) (A : Angle geom)
  (_ : EuclidGeometry.IntPointAngle geom mAngle a A) :
  have A1 : Angle geom := Angle.mk a A.Pivot A.p1
  have A2 : Angle geom := Angle.mk a A.Pivot A.p2
  mAngle A = mAngle A1 + mAngle A2
  := sorry

-- Postulate 4 says all right angles are equal.
-- We are assigning it a value of 90
def EuclidGeometry.isRightAngle (A : Angle geom): Prop := mAngle A = 90
-- straight line is two right angles

def EuclidGeometry.StraightAngle (a b c : geom.Point) (_ : geom.in_between a b c) :
  mAngle (Angle.mk a b c) = 180 := sorry

structure SA where
  StraightAngle (a b c : geom.Point) (h : geom.in_between a b c) :
    mAngle (Angle.mk a b c) = 180

--variable (StraightAngle) --(a b c : geom.Point) (_ : geom.in_between a b c) :
  --mAngle (Angle.mk a b c) = 180

-- Postulate 5

-- defining when two points are on opposite sides of a line
def EuclidGeometry.OppSidedPoints (p1 p2 : geom.Point) (l : geom.Line) : Prop :=
  geom.Line_Intersect_Segment (Segment.mk p1 p2) l

-- defining same sided points
def EuclidGeometry.SameSidedPoints (p1 p2 : geom.Point) (l : geom.Line) : Prop :=
  ¬ geom.OppSidedPoints p1 p2 l

-- Statement of Postulate 5:
-- Let line segment AB and CD be intersected by
-- line l at points p1 and p2 respectively.
-- Let A and C be same-sided wrt l.
-- Let mAngle(A p1 p2) + mAngle(C p2 p1) < 180.
-- Then there exists a point p such that
-- line from AB and CD intersect at p
-- and p is same-sided as A wrt to line l.

def EuclidGeometry.Post5 (A B C D p1 p2 : geom.Point) (l : geom.Line)
  (hab : ¬ A = B) (hcd : ¬ C = D) : Prop :=
  geom.Line_Intersect_Segment2 (Segment.mk A B) l p1
  →
  geom.Line_Intersect_Segment2 (Segment.mk C D) l p2
  →
  geom.SameSidedPoints A C l
  →
  mAngle (Angle.mk A p1 p2) + mAngle (Angle.mk C p2 p1) < 180
  →
  ∃ p : geom.Point,
  geom.Lines_Intersect2
  (geom.Line_of_two_points A B hab) (geom.Line_of_two_points C D hcd) p
  ∧
  geom.SameSidedPoints p A l

-- vertically opposite angles are equal

-- equality of measure of "symmetric" angles
def EuclidGeometry.SymmAngles (a o b : geom.Point):
  mAngle (Angle.mk a o b) = mAngle (Angle.mk b o a)
  := sorry

theorem VOAequal (a b c d o : geom.Point)
(h1 : ¬a = b)
(h2 : ¬c = d)
(h3 : geom.in_between a o b ∧ geom.in_between c o d)
(h4 : ¬geom.IsParallel
  (geom.Line_of_two_points a b h1)
  (geom.Line_of_two_points c d h2))
(h5: geom.IntPointAngle mAngle c (Angle.mk a o b))
(h6: geom.IntPointAngle mAngle a (Angle.mk c o d)):
let COB := Angle.mk c o b
let AOD := Angle.mk a o d
mAngle (COB) = mAngle (AOD)
:= by
  let COA := Angle.mk c o a
  let AOC := Angle.mk a o c
  let AOD := Angle.mk a o d
  let AOB := Angle.mk a o b
  let COD := Angle.mk c o d
  let COB := Angle.mk c o b
  have lem1 : mAngle (AOB) = 180 := SA.StraightAngle a o b (And.left h3)
  have lem2 : mAngle (COD) = 180 := geom.StraightAngle mAngle c o d (And.right h3)
  have lem3 : mAngle (AOB) = mAngle (COA) + mAngle (COB) :=
    geom.mAngleAdd mAngle c AOB h5
  have lem4 : mAngle (COD) = mAngle (AOC) + mAngle (AOD) :=
    geom.mAngleAdd mAngle a COD h6
  have lem5 : mAngle COA = mAngle AOC := by
    simp [geom.SymmAngles]
  have lem6 : mAngle (COA) + mAngle (COB) = mAngle (AOC) + mAngle (AOD) := by
    rw [<-lem3, <-lem4, lem1, lem2]
  rw [lem5] at lem6
  simp [add_left_cancel] at lem6
  assumption

--def reflexAngle (a : Angle geom) : Angle geom
  --:= (Angle geom).mk

structure Postulates (geom: EuclidGeometry) where
  post2 : ∀ s : Segment geom, ∃ l: geom.Line, geom.segment_in_line s l

--we would need to call these postulates to prove theorems within EuclidGeometry. Some other smaller definitions
-- and theorems require these postulates as "inputs".


import valuations
import analysis.topology.topological_space
import data.finsupp
import group_theory.quotient_group

universes u₁ u₂ u₃

local attribute [instance] classical.prop_decidable

variables {R : Type u₁} [comm_ring R] [decidable_eq R]

structure Valuation (R : Type u₁) [comm_ring R] :=
(Γ   : Type u₁)
(grp : linear_ordered_comm_group Γ)
(val : @valuation R _ Γ grp)

namespace Valuation
open valuation

instance : has_coe_to_fun (Valuation R) :=
{ F := λ v, R → with_zero v.Γ, coe := λ v, v.val.val }

instance linear_ordered_value_group {v : Valuation R} : linear_ordered_comm_group v.Γ := v.grp

def of_valuation {Γ : Type u₂} [linear_ordered_comm_group Γ] (v : valuation R Γ) : Valuation R :=
{ Γ   := (minimal_value_group v).Γ,
  grp := minimal_value_group.linear_ordered_comm_group v,
  val := v.minimal_valuation }

section
variables (R)

instance : setoid (Valuation R) :=
{ r := λ v₁ v₂, ∀ r s, v₁ r ≤ v₁ s ↔ v₂ r ≤ v₂ s,
  iseqv := begin
    split,
    { intros v r s, refl },
    split,
    { intros v₁ v₂ h r s, symmetry, exact h r s },
    { intros v₁ v₂ v₃ h₁ h₂ r s,
      exact iff.trans (h₁ r s) (h₂ r s) }
  end }

end

lemma ne_zero_of_equiv_ne_zero {Γ₁ : Type u₂} [linear_ordered_comm_group Γ₁] {Γ₂ : Type u₃} [linear_ordered_comm_group Γ₂]
{v₁ : valuation R Γ₁} {v₂ : valuation R Γ₂} {r : R} (heq : valuation.is_equiv v₁ v₂) (H : v₁ r ≠ 0) : v₂ r ≠ 0 :=
begin
  intro h,
  rw [eq_zero_iff_le_zero, ← heq r 0, ← eq_zero_iff_le_zero] at h,
  exact H h
end

end Valuation

section
variables (R)

definition Spv := {ineq : R → R → Prop // ∃ (v : Valuation R), ∀ r s : R, v r ≤ v s ↔ ineq r s}

end

namespace Spv
open valuation

definition mk (v : Valuation R) : Spv R := ⟨λ r s, v r ≤ v s, ⟨v, λ _ _, iff.rfl⟩⟩

definition mk' {Γ : Type u₂} [linear_ordered_comm_group Γ] (v : valuation R Γ) : Spv R := mk (Valuation.of_valuation v)

noncomputable definition out (v : Spv R) : Valuation R :=
subtype.cases_on v (λ ineq hv, classical.some hv)

noncomputable definition lift {β : Type u₃}
(f : Valuation R → β) (H : ∀ v₁ v₂ : Valuation R, v₁ ≈ v₂ → f v₁ = f v₂) : Spv R → β :=
f ∘ out

lemma out_mk {v : Valuation R} : out (mk v) ≈ v := classical.some_spec (mk v).property

@[simp] lemma mk_out {v : Spv R} : mk (out v) = v :=
begin
  cases v with ineq hv,
  rw subtype.ext,
  ext,
  exact classical.some_spec hv _ _
end

lemma lift_mk {β : Type u₃} {f : Valuation R → β} {H : ∀ v₁ v₂ : Valuation R, v₁ ≈ v₂ → f v₁ = f v₂} (v : Valuation R) :
lift f H (mk v) = f v := H _ _ out_mk

lemma exists_rep (v : Spv R) : ∃ v' : Valuation R, mk v' = v := ⟨out v, mk_out⟩

lemma ind {f : Spv R → Prop} (H : ∀ v, f (mk v)) : ∀ v, f v :=
λ v, by simpa using H (out v)

lemma sound {v₁ v₂ : Valuation R} (heq : v₁ ≈ v₂) : mk v₁ = mk v₂ :=
begin
  rw subtype.ext,
  funext,
  ext,
  exact heq _ _
end

noncomputable instance : has_coe (Spv R) (Valuation R) := ⟨out⟩

end Spv

-- TODO:
-- Also might need a variant of  Wedhorn 1.27 (ii) -/

/-
theorem equiv_value_group_map (R : Type) [comm_ring R] (v w : valuations R) (H : v ≈ w) :
∃ φ : value_group v.f → value_group w.f, is_group_hom φ ∧ function.bijective φ :=
begin
  existsi _,tactic.swap,
  { intro g,
    cases g with g Hg,
    unfold value_group at Hg,
    unfold group.closure at Hg,
    dsimp at Hg,
    induction Hg,
  },
  {sorry

  }
end
-/

namespace Spv

variables {A : Type u₁} [comm_ring A] [decidable_eq A]

definition basic_open (r s : A) : set (Spv A) :=
{v | v r ≤ v s ∧ v s ≠ 0}

lemma mk_mem_basic_open {r s : A} (v : Valuation A) : mk v ∈ basic_open r s ↔ v r ≤ v s ∧ v s ≠ 0 :=
begin
  split; intro h; split,
  { exact (out_mk r s).mp h.left },
  { exact Valuation.ne_zero_of_equiv_ne_zero out_mk h.right },
  { exact (out_mk r s).mpr h.left },
  { exact Valuation.ne_zero_of_equiv_ne_zero (setoid.symm out_mk) h.right }
end

instance : topological_space (Spv A) :=
topological_space.generate_from {U : set (Spv A) | ∃ r s : A, U = basic_open r s}

end Spv


import algebra.lattice.basic algebra.lattice.dcpo algebra.lattice.fixed_points

universes u v
open lattice

variables {α : Type u} {γ : Type v} [directed_complete_partial_order α][directed_complete_partial_order γ]

def specification α [order_bot α] := Σ' (f : α → α) (h : monotone f), h.ascending_chain.is_stationary

def specification.monotone (f : specification α) := f.snd.fst
def specification.lfp (f : specification α) := f.monotone.lfp
def specification.is_stationary (f : specification α) := f.snd.snd

lemma specification_Inf {α} [complete_lattice α] (f : specification α) : f.lfp = Inf { x | f.1 x ≤ x} :=
   have H₁  : ∀ x, f.1 x ≤ x → ∀ n, iter_n f.1 ⊥ n ≤ x,
   from take x, assume hx, take n,
        nat.rec_on n bot_le (take n, assume iH, le_trans (f.monotone iH) hx),
    le_antisymm (le_Inf (take x, assume hx, dSup_le (take y, assume ⟨n, hn⟩, eq.rec_on hn.symm (H₁ x hx n)) ))
                          (Inf_le (f.monotone.le_lfp f.is_stationary))

lemma fixpoint_approx {fc : specification γ} {fa : specification α} {abstr : scott_continuous γ α}
 : (∀ x, x ≤ fc.1 x → ∃ y, y ≤ x ∧ abstr.1 (fc.1 x) ≤ fa.1 (abstr.1 y)) → abstr.1 (fc.lfp) ≤ fa.lfp :=
 assume h,
 begin
 unfold specification.lfp,
 unfold monotone.lfp,
 rw abstr.2.preserve_dSup,
 apply dSup_le,
 intros a ha,
 cases ha with a₁ ha₁,
 rw -ha₁.right,
 cases ha₁.left with n hn,
 rw hn,
 change abstr.1 (iter_n fc.1 ⊥ n) ≤ fa.lfp,
 clear hn,
 assert H : ∀ n, abstr.1 (iter_n fc.1 ⊥ n) ≤ iter_n fa.1 ⊥ n,
   intro n,
   induction n with n iH,
     {
        simp [iter_n],
        apply bot_le
     },
    {
        cases (h (iter_n fc.1 ⊥ n) (@iter_n.single_step _ _ _ _ fc.monotone bot_le n)) with y hy,
        assert H₁ : abstr.1 y ≤ abstr.1 (iter_n fc.1 ⊥ n), apply abstr.monotone hy.left,
        apply le_trans hy.right,
        apply fa.monotone,
        apply le_trans H₁,
        assumption
    },
 apply le_dSup_of_le,
 exact ⟨n, rfl⟩,
 apply H
 end

lemma fixpoint_approx_complete {γ}{α}[complete_lattice γ][complete_lattice α ]
        {fc : specification γ}{fa : specification α}{abstr : γ → α}(hmono : monotone abstr ):
        (∀ y, fa.1 y ≤ y → ∃ x, abstr x ≤ y ∧  fc.1 x ≤ x) → abstr fc.lfp ≤ fa.lfp
:= assume h,
   have H : Inf {y | ∃ x, fc.1 x ≤ x ∧ y = abstr x} ≤ Inf { y | fa.1 y ≤ y},
     from le_Inf (take y, assume hy, match h _ hy with | ⟨x, hxy, hx⟩ := Inf_le_of_le ⟨_, hx,  rfl⟩ hxy end),
   begin
   rw specification_Inf fc,
   rw (specification_Inf fa),
   apply (function.swap le_trans H),
   apply le_Inf,
   intros y hy,
   cases hy with x hx,
   cases hx with hx eq,
   rw eq,
   apply hmono,
   apply Inf_le,
   assumption
   end

lemma fixpoint_transfer {fc : specification γ} {fa : specification α} {abstr : scott_continuous γ α} :
  fa.1 ∘ abstr.1 = abstr.1 ∘ fc.1 → abstr.1 fc.lfp = fa.lfp
:= assume h,
   have H : ∀ n, abstr.1 (iter_n fc.1 ⊥ n) = iter_n fa.1 ⊥ n,
     from begin
          intro n,
          induction n with n iH,
          simp [iter_n],
          simp [iter_n],
          rw -iH,
          change (abstr.1 ∘ fc.1) (iter_n fc.1 ⊥ n) = (fa.1 ∘ abstr.1) (iter_n fc.1 ⊥ n),
          rw h
          end,
   begin
   unfold specification.lfp,
   unfold monotone.lfp,
   rw abstr.2.preserve_dSup,
   apply congr_arg dSup,
   apply subtype.eq,
   apply set.ext,
   intro a,
   apply iff.intro,
     {
         intro ha,
         cases ha with a₁ ha₁,
         rw -ha₁.right,
         cases ha₁.left with n hn,
         rw hn,
         exact ⟨n , by apply H⟩
     },
     {
         intro ha,
         cases ha with n hn,
         rw hn,
         exact ⟨_, ⟨n, rfl⟩, H n⟩
     }
   end

structure abstraction α γ [weak_order α] [weak_order γ] :=
  (abstr : γ → α)
  (concr : α → γ)
  (abstr_monotone : monotone abstr)
  (concr_monotone : monotone concr)
  (gc : ∀ a c, abstr c ≤ a → c ≤ concr a)


/- 9/20/18
    Preliminary definitions and some functions for working with languages and first-order logic.
    Much of the structure and methods are taken from Russell O'Connor's proof of Goedel's incompleteness theorem, at http://r6.ca/Goedel/goedel1.html
    Andrew Tindall-/

structure Language :=
    language :: (relations : Π n : nat, Type) (functions : Π  n : nat, Type) (consts : Type)
variable L : Language

def term_param := unit ⊕ nat
def atm :term_param := sum.inl ()
def vec : nat → term_param := λ n, sum.inr n

inductive term : Π n, Type
    | var : ℕ → term atm
    | const: L.consts → term atm
    | apply : ∀ (n : nat) (f : L.functions n), term (vec n) → term atm
    | nil : term (vec 0)
    | conj : ∀ n, term atm → term (vec n) → term (vec (n + 1))

open term

local notation `⟦` l:(foldr `, ` (h t, ((prod.fst t) + 1, conj t.fst h (prod.snd t))) (0, nil L) `⟧`) := prod.snd l

def term_sizeof :Π n, term L n → ℕ
    | atm (var L n) := 0
    | atm (const c) := 0
    | atm (apply n f ts) :=  n + 2 + term_sizeof (vec n) ts
    | (sum.inr 0) (nil L) := 0
    | (sum.inr (n+1)) (conj m t ts) := 1 + term_sizeof atm t + term_sizeof (vec m) ts

instance term_has_sizeof { n: term_param}  : has_sizeof (term L n) := ⟨ term_sizeof L n ⟩

inductive formula : Type
    | equal : term L atm → term L atm → formula
    | atomic : ∀ (n : nat) (r : L.relations n), term L (vec n) → formula
    | imp : formula → formula → formula
    | not : formula → formula
    | all : ℕ → formula → formula
open formula

def andf := λ (f : formula L) g, not (imp f (not g))

reserve infix `⟾`:10
infix ⟾ := imp

reserve infix `⇔`:15
local infix ⇔ := λ (f : formula L) g, andf L (f ⟾ g) (g ⟾ f)

reserve infix `≍`:20
infix ≍ := equal

def free_vars_term : Π n, (term L n) → list ℕ
    | atm (var L n) := [n]
    | atm (const c) := []
    | atm (apply n f ts) := free_vars_term (vec n) ts
    | (sum.inr 0) _ := []
    | (sum.inr (n+1)) (conj m t ts) := list.union (free_vars_term atm t) (free_vars_term (vec n) ts)

def free_vars_formula : formula L → list ℕ
    | (equal t1 t2) := list.union (free_vars_term L atm t1) (free_vars_term L atm t2)
    | (atomic n r ts) := free_vars_term L (vec n) ts
    | (imp f1 f2) := list.union (free_vars_formula f1) (free_vars_formula f2)
    | (not f) := free_vars_formula f
    | (all n f) := list.filter (≠ n) (free_vars_formula f)

lemma lt_add : ∀ (n m k : ℕ), n < m → n < k + m:= begin {intros n m k n_lt_m, induction k, rw zero_add,exact n_lt_m, rw nat.succ_add, apply nat.lt_succ_of_lt,exact k_ih} end
lemma add_lt : ∀ (n m k : ℕ), n < m → n < m + k := begin {intros n m k n_lt_m, induction k, rw add_zero,exact n_lt_m, rw nat.add_comm, rw nat.succ_add, apply nat.lt_succ_of_lt, rw nat.add_comm, exact k_ih} end

def substitute_term : Π (n : term_param), term L n → list (nat × term L atm) → term L n
    | atm (var L n) [] := var L n
    | atm (var L n) ((m, t) :: pairs) := if n = m then t else substitute_term atm (var L n) pairs
    | atm (const c) _ := const c
    | atm (apply n f ts) pairs :=
            have term_sizeof L (vec n) ts < term_sizeof L atm (apply n f ts), from
                begin simp[term_sizeof],
                    apply lt_add,
                    exact nat.lt_add_of_pos_right (nat.zero_lt_succ 1)
                end,
        apply n f (substitute_term (sum.inr n) ts pairs)
    | (sum.inr 0) a b := nil L
    | (sum.inr n) (conj m t ts) pairs :=
            have term_sizeof L atm t < term_sizeof L (sum.inr (m + 1)) (conj m t ts), from
                begin
                    simp [term_sizeof, nat.add_assoc], simp [nat.one_add],
                    apply nat.lt_succ_of_le,
                    apply nat.le_add_right
                end,
            have term_sizeof L (vec m) ts < term_sizeof L (sum.inr (m + 1)) (conj m t ts), from
                begin
                    simp [term_sizeof, nat.one_add],
                    apply nat.lt_add_of_pos_left,
                    apply nat.zero_lt_succ
                end,
        conj m (substitute_term atm t pairs) (substitute_term (vec m) ts pairs)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf psigma.sizeof⟩]}

def var_in_term : ∀ n, ℕ → term L n → Prop
    | atm x (var L y) := x = y
    | atm _ (const c) := false
    | atm x (apply n f ts) := var_in_term (vec n) x ts
    | (sum.inr 0) _ _ := false
    | (sum.inr (n+1)) x (conj m t ts) := var_in_term atm x t ∨ var_in_term (vec n) x ts

def var_in_formula : ℕ → formula L → Prop
    | x (equal t t') := var_in_term L atm x t ∨ var_in_term L atm x t'
    | x (atomic n r ts) := var_in_term L (vec n) x ts
    | x (imp f f') := var_in_formula x f ∨ var_in_formula x f'
    | x (not f) := var_in_formula x f
    | x (all n f) := x = n ∨ var_in_formula x f

def var_in_pairs : ℕ → list (nat × term L atm) → Prop
    | x [] := false
    | x ((n, t) :: pairs) := (var_in_term L atm) x t ∨ var_in_pairs x pairs

def max_var_in_term : ∀ n, term L n → ℕ
    | atm (var L n) := n
    | atm (const c) := 0
    | atm (apply n f ts) := max_var_in_term (vec n) ts
    | (sum.inr 0) _ := 0
    | (sum.inr (n+1)) (conj L t ts) := max (max_var_in_term atm t) (max_var_in_term (vec n) ts)

def max_var_in_pairs : list (ℕ × term L atm) → ℕ
    | [] := 0
    | ((n, t) :: pairs) := max (max_var_in_term L atm t) (max_var_in_pairs pairs)

def max_var_in_formula : formula L → ℕ
    | (equal t t') := max (max_var_in_term L atm  t) (max_var_in_term L atm t')
    | (atomic n r ts) := max_var_in_term L (vec n) ts
    | (imp f f') := max (max_var_in_formula f) (max_var_in_formula f')
    | (not f) := max_var_in_formula f
    | (all n f) := max n (max_var_in_formula f)

def var_not_in : formula L → list (ℕ × term L atm) → ℕ
    | f pairs := 1 + (max (max_var_in_formula L f) (max_var_in_pairs L pairs))

def free_pairs : formula L → list (ℕ × term L atm) → list (ℕ × term L atm)
    | f pairs := let fv := free_vars_formula L f in list.filter (λ p : ℕ × term L atm, p.fst ∈ fv) pairs

instance var_in_decidable : ∀ n pairs f, decidable (var_in_formula L n f ∨ var_in_pairs L n pairs) :=
begin
    intros n pairs f,
    admit
end

def substitute_formula : formula L → list (nat × term L atm) → formula L
    | (equal t t') pairs := equal (substitute_term L atm t pairs) (substitute_term L atm t' pairs)
    | (atomic n r t) pairs := atomic n r (substitute_term L (vec n) t pairs)
    | (imp f f') pairs := imp (substitute_formula f pairs) (substitute_formula f' pairs)
    | (not f) pairs := not (substitute_formula f pairs)
    | (all n f) pairs := if var_in_formula L n f ∨ var_in_pairs L n pairs then let n' := var_not_in L f (free_pairs L f pairs) in all n' (substitute_formula f ((n, var L n') :: pairs)) else all n (substitute_formula f (free_pairs L f pairs))

def vec_length_n_diff_two : ∀ n, ℕ →  term L (vec n)
    | 0 hd := nil L
    | (n+1) hd := conj n (var L hd) (vec_length_n_diff_two n (hd+2))

def even_vec := λ n, vec_length_n_diff_two L n 0
def odd_vec := λ n, vec_length_n_diff_two L n 1

def axm_eq' : ∀ m, formula L → formula L
    | 0 f := (((var L 0) ≍ (var L 1)) ⟾ f)
    | (m+1) f := axm_eq' m (((var L (2 * (m + 1))) ≍ (var L (2 * (m + 1) + 1))) ⟾ f)

def axm_eq_4 : ∀ n, L.functions n → formula L
    | 0 f := ((apply 0 f (nil L)) ≍ (apply 0 f (nil L)))
    | (n+1) f := axm_eq' L n ((apply (n+1) f (even_vec L (n+1)) ≍ (apply (n+1) f (odd_vec L (n+1)))))

def axm_eq_5 : ∀ n, L.relations n → formula L
    | 0 r := ((atomic 0 r (nil L)) ⇔ (atomic 0 r (nil L)))
    | (n+1) r := axm_eq' L n ((atomic (n+1) r (even_vec L (n+1))) ⇔ (atomic (n+1) r (odd_vec L (n+1))))

inductive prf : list (formula L) → formula L → Type
    | axm : ∀ a, prf [a] a
    | mp : ∀ axm axm' f g, prf axm (imp f g) → prf axm' f → prf (axm ++ axm') g
    | gen : ∀ axm f v, ¬ (v ∈ (free_vars_formula L f)) → prf axm f → prf axm (all v f)
    | imp1 : ∀ f g, prf [] (f ⟾ (g ⟾ f))
    | imp2 : ∀ f g h, prf [] (f ⟾ (g ⟾ h) ⟾ ((f ⟾ g) ⟾ (f ⟾ h)))
    | cp : ∀ f g,  prf [] (((not f) ⟾ (not g)) ⟾ (g ⟾ f))
    | all1 : ∀ f v t, prf [] ((all v f) ⟾ (substitute_formula L f [(v,t)]))
    | all2 : ∀ f v, ¬ v ∈ (free_vars_formula L f) → prf [] (f ⟾ all v f)
    | all3 : ∀ f g v, prf [] ((all v (f ⟾ g) ⟾ ((all v f) ⟾ (all v g))))
    | eq1 : prf [] ((var L 0) ≍ (var L 0))
    | eq2 : prf [] (( (var L 0) ≍ (var L 1)) ⟾ ((var L 1) ≍ (var L 0)))
    | eq3 : prf [] (((var L 0) ≍ (var L 1)) ⟾ (((var L 1) ≍ (var L 2)) ⟾ ((var L 0) ≍ (var L 2))))
    /- the following two axioms are examples standing in for the more general equality axioms that need to be generated for n-ary relations and functions;

            x0 = x1 ⇒ … ⇒ x2n-2 = x2n-1 ⇒ (R(x0, x2, …, x2n-2) ⇔ R(x1, x3, …, x2n-1))  and
            x0 = x1 ⇒ … ⇒ x2n-2 = x2n-1 ⇒ f(x0, x2, …, x2n-2) = f(x1, x3, …, x2n-1)

            src http://r6.ca/Goedel/goedel1.html
            -/
    | eq4 : ∀ n, ∀  r : L.functions n, prf [] (axm_eq_4 L n r)
    | eq5 : ∀ n, ∀ f : L.relations n, prf [] (axm_eq_5 L n f)

 /-exact ⟨ λ t1 t2, prod.lex nat.lt nat.lt (sizeof t1.fst, sizeof t1.snd) (sizeof t2.fst, sizeof t2.snd)-/


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

! This file was ported from Lean 3 source module category_theory.sites.sheaf
! leanprover-community/mathlib commit a67ec23dd8dc08195d77b6df2cd21f9c64989131
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Equalizers
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Products
import Mathbin.CategoryTheory.Limits.Yoneda
import Mathbin.CategoryTheory.Preadditive.FunctorCategory
import Mathbin.CategoryTheory.Sites.SheafOfTypes

/-!
# Sheaves taking values in a category

If C is a category with a Grothendieck topology, we define the notion of a sheaf taking values in
an arbitrary category `A`. We follow the definition in https://stacks.math.columbia.edu/tag/00VR,
noting that the presheaf of sets "defined above" can be seen in the comments between tags 00VQ and
00VR on the page <https://stacks.math.columbia.edu/tag/00VL>. The advantage of this definition is
that we need no assumptions whatsoever on `A` other than the assumption that the morphisms in `C`
and `A` live in the same universe.

* An `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is defined to be a sheaf (for the topology `J`) iff for
  every `E : A`, the type-valued presheaves of sets given by sending `U : Cᵒᵖ` to `Hom_{A}(E, P U)`
  are all sheaves of sets, see `category_theory.presheaf.is_sheaf`.
* When `A = Type`, this recovers the basic definition of sheaves of sets, see
  `category_theory.is_sheaf_iff_is_sheaf_of_type`.
* An alternate definition when `C` is small, has pullbacks and `A` has products is given by an
  equalizer condition `category_theory.presheaf.is_sheaf'`. This is equivalent to the earlier
  definition, shown in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
* When `A = Type`, this is *definitionally* equal to the equalizer condition for presieves in
  `category_theory.sites.sheaf_of_types`.
* When `A` has limits and there is a functor `s : A ⥤ Type` which is faithful, reflects isomorphisms
  and preserves limits, then `P : Cᵒᵖ ⥤ A` is a sheaf iff the underlying presheaf of types
  `P ⋙ s : Cᵒᵖ ⥤ Type` is a sheaf (`category_theory.presheaf.is_sheaf_iff_is_sheaf_forget`).
  Cf https://stacks.math.columbia.edu/tag/0073, which is a weaker version of this statement (it's
  only over spaces, not sites) and https://stacks.math.columbia.edu/tag/00YR (a), which
  additionally assumes filtered colimits.
-/

universe w v₁ v₂ u₁ u₂

noncomputable section

namespace CategoryTheory

open Opposite CategoryTheory Category Limits Sieve

namespace Presheaf

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

variable {A : Type u₂} [Category.{v₂} A]

variable (J : GrothendieckTopology C)

-- We follow https://stacks.math.columbia.edu/tag/00VL definition 00VR
/-- A sheaf of A is a presheaf P : Cᵒᵖ => A such that for every E : A, the
presheaf of types given by sending U : C to Hom_{A}(E, P U) is a sheaf of types.

https://stacks.math.columbia.edu/tag/00VR
-/
def IsSheaf (P : Cᵒᵖ ⥤ A) : Prop :=
  ∀ E : A, Presieve.IsSheaf J (P ⋙ coyoneda.obj (op E))
#align category_theory.presheaf.is_sheaf CategoryTheory.Presheaf.IsSheaf

section LimitSheafCondition

open Presieve Presieve.FamilyOfElements Limits

variable (P : Cᵒᵖ ⥤ A) {X : C} (S : Sieve X) (R : Presieve X) (E : Aᵒᵖ)

/-- Given a sieve `S` on `X : C`, a presheaf `P : Cᵒᵖ ⥤ A`, and an object `E` of `A`,
    the cones over the natural diagram `S.arrows.diagram.op ⋙ P` associated to `S` and `P`
    with cone point `E` are in 1-1 correspondence with sieve_compatible family of elements
    for the sieve `S` and the presheaf of types `Hom (E, P -)`. -/
@[simps]
def conesEquivSieveCompatibleFamily :
    (S.arrows.diagram.op ⋙ P).cones.obj E ≃
      { x : FamilyOfElements (P ⋙ coyoneda.obj E) S // x.SieveCompatible }
    where
  toFun π :=
    ⟨fun Y f h => π.app (op ⟨Over.mk f, h⟩), fun _ =>
      by
      intros
      apply (id_comp _).symm.trans
      dsimp
      convert π.naturality (Quiver.Hom.op (over.hom_mk _ _)) <;> dsimp <;> rfl⟩
  invFun x :=
    { app := fun f => x.1 f.unop.1.Hom f.unop.2
      naturality' := fun f f' g =>
        by
        refine' Eq.trans _ (x.2 f.unop.1.Hom g.unop.left f.unop.2)
        erw [id_comp]
        congr
        rw [over.w g.unop] }
  left_inv π := by
    ext
    dsimp
    congr
    rw [op_eq_iff_eq_unop]
    ext
    symm
    apply costructured_arrow.eq_mk
  right_inv x := by
    ext
    rfl
#align category_theory.presheaf.cones_equiv_sieve_compatible_family CategoryTheory.Presheaf.conesEquivSieveCompatibleFamily

variable {P S E} {x : FamilyOfElements (P ⋙ coyoneda.obj E) S} (hx : x.SieveCompatible)

/-- The cone corresponding to a sieve_compatible family of elements, dot notation enabled. -/
@[simp]
def CategoryTheory.Presieve.FamilyOfElements.SieveCompatible.cone : Cone (S.arrows.diagram.op ⋙ P)
    where
  pt := E.unop
  π := (conesEquivSieveCompatibleFamily P S E).invFun ⟨x, hx⟩
#align category_theory.presieve.family_of_elements.sieve_compatible.cone CategoryTheory.Presieve.FamilyOfElements.SieveCompatible.cone

/-- Cone morphisms from the cone corresponding to a sieve_compatible family to the natural
    cone associated to a sieve `S` and a presheaf `P` are in 1-1 correspondence with amalgamations
    of the family. -/
def homEquivAmalgamation : (hx.Cone ⟶ P.mapCone S.arrows.Cocone.op) ≃ { t // x.IsAmalgamation t }
    where
  toFun l := ⟨l.Hom, fun Y f hf => l.w (op ⟨Over.mk f, hf⟩)⟩
  invFun t := ⟨t.1, fun f => t.2 f.unop.1.Hom f.unop.2⟩
  left_inv l := by
    ext
    rfl
  right_inv t := by
    ext
    rfl
#align category_theory.presheaf.hom_equiv_amalgamation CategoryTheory.Presheaf.homEquivAmalgamation

variable (P S)

/-- Given sieve `S` and presheaf `P : Cᵒᵖ ⥤ A`, their natural associated cone is a limit cone
    iff `Hom (E, P -)` is a sheaf of types for the sieve `S` and all `E : A`. -/
theorem isLimit_iff_isSheafFor :
    Nonempty (IsLimit (P.mapCone S.arrows.Cocone.op)) ↔
      ∀ E : Aᵒᵖ, IsSheafFor (P ⋙ coyoneda.obj E) S :=
  by
  dsimp [is_sheaf_for]; simp_rw [compatible_iff_sieve_compatible]
  rw [((cone.is_limit_equiv_is_terminal _).trans (is_terminal_equiv_unique _ _)).nonempty_congr]
  rw [Classical.nonempty_pi]; constructor
  · intro hu E x hx
    specialize hu hx.cone
    erw [(hom_equiv_amalgamation hx).uniqueCongr.nonempty_congr] at hu
    exact (unique_subtype_iff_exists_unique _).1 hu
  · rintro h ⟨E, π⟩
    let eqv := cones_equiv_sieve_compatible_family P S (op E)
    rw [← eqv.left_inv π]
    erw [(hom_equiv_amalgamation (eqv π).2).uniqueCongr.nonempty_congr]
    rw [unique_subtype_iff_exists_unique]
    exact h _ _ (eqv π).2
#align category_theory.presheaf.is_limit_iff_is_sheaf_for CategoryTheory.Presheaf.isLimit_iff_isSheafFor

/-- Given sieve `S` and presheaf `P : Cᵒᵖ ⥤ A`, their natural associated cone admits at most one
    morphism from every cone in the same category (i.e. over the same diagram),
    iff `Hom (E, P -)`is separated for the sieve `S` and all `E : A`. -/
theorem subsingleton_iff_isSeparatedFor :
    (∀ c, Subsingleton (c ⟶ P.mapCone S.arrows.Cocone.op)) ↔
      ∀ E : Aᵒᵖ, IsSeparatedFor (P ⋙ coyoneda.obj E) S :=
  by
  constructor
  · intro hs E x t₁ t₂ h₁ h₂
    have hx := is_compatible_of_exists_amalgamation x ⟨t₁, h₁⟩
    rw [compatible_iff_sieve_compatible] at hx
    specialize hs hx.cone
    cases hs
    have := (hom_equiv_amalgamation hx).symm.Injective
    exact Subtype.ext_iff.1 (@this ⟨t₁, h₁⟩ ⟨t₂, h₂⟩ (hs _ _))
  · rintro h ⟨E, π⟩
    let eqv := cones_equiv_sieve_compatible_family P S (op E)
    constructor
    rw [← eqv.left_inv π]
    intro f₁ f₂
    let eqv' := hom_equiv_amalgamation (eqv π).2
    apply eqv'.injective
    ext
    apply h _ (eqv π).1 <;> exact (eqv' _).2
#align category_theory.presheaf.subsingleton_iff_is_separated_for CategoryTheory.Presheaf.subsingleton_iff_isSeparatedFor

/-- A presheaf `P` is a sheaf for the Grothendieck topology `J` iff for every covering sieve
    `S` of `J`, the natural cone associated to `P` and `S` is a limit cone. -/
theorem isSheaf_iff_isLimit :
    IsSheaf J P ↔
      ∀ ⦃X : C⦄ (S : Sieve X), S ∈ J X → Nonempty (IsLimit (P.mapCone S.arrows.Cocone.op)) :=
  ⟨fun h X S hS => (isLimit_iff_isSheafFor P S).2 fun E => h E.unop S hS, fun h E X S hS =>
    (isLimit_iff_isSheafFor P S).1 (h S hS) (op E)⟩
#align category_theory.presheaf.is_sheaf_iff_is_limit CategoryTheory.Presheaf.isSheaf_iff_isLimit

/-- A presheaf `P` is separated for the Grothendieck topology `J` iff for every covering sieve
    `S` of `J`, the natural cone associated to `P` and `S` admits at most one morphism from every
    cone in the same category. -/
theorem isSeparated_iff_subsingleton :
    (∀ E : A, IsSeparated J (P ⋙ coyoneda.obj (op E))) ↔
      ∀ ⦃X : C⦄ (S : Sieve X), S ∈ J X → ∀ c, Subsingleton (c ⟶ P.mapCone S.arrows.Cocone.op) :=
  ⟨fun h X S hS => (subsingleton_iff_isSeparatedFor P S).2 fun E => h E.unop S hS, fun h E X S hS =>
    (subsingleton_iff_isSeparatedFor P S).1 (h S hS) (op E)⟩
#align category_theory.presheaf.is_separated_iff_subsingleton CategoryTheory.Presheaf.isSeparated_iff_subsingleton

/-- Given presieve `R` and presheaf `P : Cᵒᵖ ⥤ A`, the natural cone associated to `P` and
    the sieve `sieve.generate R` generated by `R` is a limit cone iff `Hom (E, P -)` is a
    sheaf of types for the presieve `R` and all `E : A`. -/
theorem isLimit_iff_isSheafFor_presieve :
    Nonempty (IsLimit (P.mapCone (generate R).arrows.Cocone.op)) ↔
      ∀ E : Aᵒᵖ, IsSheafFor (P ⋙ coyoneda.obj E) R :=
  (isLimit_iff_isSheafFor P _).trans (forall_congr' fun _ => (isSheafFor_iff_generate _).symm)
#align category_theory.presheaf.is_limit_iff_is_sheaf_for_presieve CategoryTheory.Presheaf.isLimit_iff_isSheafFor_presieve

/-- A presheaf `P` is a sheaf for the Grothendieck topology generated by a pretopology `K`
    iff for every covering presieve `R` of `K`, the natural cone associated to `P` and
    `sieve.generate R` is a limit cone. -/
theorem isSheaf_iff_isLimit_pretopology [HasPullbacks C] (K : Pretopology C) :
    IsSheaf (K.toGrothendieck C) P ↔
      ∀ ⦃X : C⦄ (R : Presieve X),
        R ∈ K X → Nonempty (IsLimit (P.mapCone (generate R).arrows.Cocone.op)) :=
  by
  dsimp [is_sheaf]
  simp_rw [is_sheaf_pretopology]
  exact
    ⟨fun h X R hR => (is_limit_iff_is_sheaf_for_presieve P R).2 fun E => h E.unop R hR,
      fun h E X R hR => (is_limit_iff_is_sheaf_for_presieve P R).1 (h R hR) (op E)⟩
#align category_theory.presheaf.is_sheaf_iff_is_limit_pretopology CategoryTheory.Presheaf.isSheaf_iff_isLimit_pretopology

end LimitSheafCondition

variable {J}

/-- This is a wrapper around `presieve.is_sheaf_for.amalgamate` to be used below.
  If `P`s a sheaf, `S` is a cover of `X`, and `x` is a collection of morphisms from `E`
  to `P` evaluated at terms in the cover which are compatible, then we can amalgamate
  the `x`s to obtain a single morphism `E ⟶ P.obj (op X)`. -/
def IsSheaf.amalgamate {A : Type u₂} [Category.{max v₁ u₁} A] {E : A} {X : C} {P : Cᵒᵖ ⥤ A}
    (hP : Presheaf.IsSheaf J P) (S : J.cover X) (x : ∀ I : S.arrow, E ⟶ P.obj (op I.y))
    (hx : ∀ I : S.Relation, x I.fst ≫ P.map I.g₁.op = x I.snd ≫ P.map I.g₂.op) : E ⟶ P.obj (op X) :=
  (hP _ _ S.condition).amalgamate (fun Y f hf => x ⟨Y, f, hf⟩) fun Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ w =>
    hx ⟨Y₁, Y₂, Z, g₁, g₂, f₁, f₂, h₁, h₂, w⟩
#align category_theory.presheaf.is_sheaf.amalgamate CategoryTheory.Presheaf.IsSheaf.amalgamate

@[simp, reassoc.1]
theorem IsSheaf.amalgamate_map {A : Type u₂} [Category.{max v₁ u₁} A] {E : A} {X : C} {P : Cᵒᵖ ⥤ A}
    (hP : Presheaf.IsSheaf J P) (S : J.cover X) (x : ∀ I : S.arrow, E ⟶ P.obj (op I.y))
    (hx : ∀ I : S.Relation, x I.fst ≫ P.map I.g₁.op = x I.snd ≫ P.map I.g₂.op) (I : S.arrow) :
    hP.amalgamate S x hx ≫ P.map I.f.op = x _ :=
  by
  rcases I with ⟨Y, f, hf⟩
  apply
    @presieve.is_sheaf_for.valid_glue _ _ _ _ _ _ (hP _ _ S.condition) (fun Y f hf => x ⟨Y, f, hf⟩)
      (fun Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ w => hx ⟨Y₁, Y₂, Z, g₁, g₂, f₁, f₂, h₁, h₂, w⟩) f hf
#align category_theory.presheaf.is_sheaf.amalgamate_map CategoryTheory.Presheaf.IsSheaf.amalgamate_map

theorem IsSheaf.hom_ext {A : Type u₂} [Category.{max v₁ u₁} A] {E : A} {X : C} {P : Cᵒᵖ ⥤ A}
    (hP : Presheaf.IsSheaf J P) (S : J.cover X) (e₁ e₂ : E ⟶ P.obj (op X))
    (h : ∀ I : S.arrow, e₁ ≫ P.map I.f.op = e₂ ≫ P.map I.f.op) : e₁ = e₂ :=
  (hP _ _ S.condition).IsSeparatedFor.ext fun Y f hf => h ⟨Y, f, hf⟩
#align category_theory.presheaf.is_sheaf.hom_ext CategoryTheory.Presheaf.IsSheaf.hom_ext

theorem isSheaf_of_iso_iff {P P' : Cᵒᵖ ⥤ A} (e : P ≅ P') : IsSheaf J P ↔ IsSheaf J P' :=
  forall_congr' fun a =>
    ⟨Presieve.isSheaf_iso J (isoWhiskerRight e _),
      Presieve.isSheaf_iso J (isoWhiskerRight e.symm _)⟩
#align category_theory.presheaf.is_sheaf_of_iso_iff CategoryTheory.Presheaf.isSheaf_of_iso_iff

variable (J)

theorem isSheaf_of_isTerminal {X : A} (hX : IsTerminal X) :
    Presheaf.IsSheaf J ((CategoryTheory.Functor.const _).obj X) := fun _ _ _ _ _ _ =>
  ⟨hX.from _, fun _ _ _ => hX.hom_ext _ _, fun _ _ => hX.hom_ext _ _⟩
#align category_theory.presheaf.is_sheaf_of_is_terminal CategoryTheory.Presheaf.isSheaf_of_isTerminal

end Presheaf

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

variable (J : GrothendieckTopology C)

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

/-- The category of sheaves taking values in `A` on a grothendieck topology. -/
structure Sheaf where
  val : Cᵒᵖ ⥤ A
  cond : Presheaf.IsSheaf J val
#align category_theory.Sheaf CategoryTheory.Sheaf

namespace Sheaf

variable {J A}

/-- Morphisms between sheaves are just morphisms of presheaves. -/
@[ext]
structure Hom (X Y : Sheaf J A) where
  val : X.val ⟶ Y.val
#align category_theory.Sheaf.hom CategoryTheory.Sheaf.Hom

@[simps]
instance : Category (Sheaf J A) where
  Hom := Hom
  id X := ⟨𝟙 _⟩
  comp X Y Z f g := ⟨f.val ≫ g.val⟩
  id_comp' X Y f := Hom.ext _ _ <| id_comp _
  comp_id' X Y f := Hom.ext _ _ <| comp_id _
  assoc' X Y Z W f g h := Hom.ext _ _ <| assoc _ _ _

-- Let's make the inhabited linter happy...
instance (X : Sheaf J A) : Inhabited (Hom X X) :=
  ⟨𝟙 X⟩

end Sheaf

/-- The inclusion functor from sheaves to presheaves. -/
@[simps]
def sheafToPresheaf : Sheaf J A ⥤ Cᵒᵖ ⥤ A
    where
  obj := Sheaf.val
  map _ _ f := f.val
  map_id' X := rfl
  map_comp' X Y Z f g := rfl
#align category_theory.Sheaf_to_presheaf CategoryTheory.sheafToPresheaf

instance : Full (sheafToPresheaf J A) where preimage X Y f := ⟨f⟩

instance : Faithful (sheafToPresheaf J A) where

/-- This is stated as a lemma to prevent class search from forming a loop since a sheaf morphism is
monic if and only if it is monic as a presheaf morphism (under suitable assumption).-/
theorem Sheaf.Hom.mono_of_presheaf_mono {F G : Sheaf J A} (f : F ⟶ G) [h : Mono f.1] : Mono f :=
  (sheafToPresheaf J A).mono_of_mono_map h
#align category_theory.Sheaf.hom.mono_of_presheaf_mono CategoryTheory.Sheaf.Hom.mono_of_presheaf_mono

instance Sheaf.Hom.epi_of_presheaf_epi {F G : Sheaf J A} (f : F ⟶ G) [h : Epi f.1] : Epi f :=
  (sheafToPresheaf J A).epi_of_epi_map h
#align category_theory.Sheaf.hom.epi_of_presheaf_epi CategoryTheory.Sheaf.Hom.epi_of_presheaf_epi

/-- The sheaf of sections guaranteed by the sheaf condition. -/
@[simps]
def sheafOver {A : Type u₂} [Category.{v₂} A] {J : GrothendieckTopology C} (ℱ : Sheaf J A) (E : A) :
    SheafOfTypes J :=
  ⟨ℱ.val ⋙ coyoneda.obj (op E), ℱ.cond E⟩
#align category_theory.sheaf_over CategoryTheory.sheafOver

theorem isSheaf_iff_isSheaf_of_type (P : Cᵒᵖ ⥤ Type w) :
    Presheaf.IsSheaf J P ↔ Presieve.IsSheaf J P :=
  by
  constructor
  · intro hP
    refine' presieve.is_sheaf_iso J _ (hP PUnit)
    exact iso_whisker_left _ coyoneda.punit_iso ≪≫ P.right_unitor
  · intro hP X Y S hS z hz
    refine' ⟨fun x => (hP S hS).amalgamate (fun Z f hf => z f hf x) _, _, _⟩
    · intro Y₁ Y₂ Z g₁ g₂ f₁ f₂ hf₁ hf₂ h
      exact congr_fun (hz g₁ g₂ hf₁ hf₂ h) x
    · intro Z f hf
      ext x
      apply presieve.is_sheaf_for.valid_glue
    · intro y hy
      ext x
      apply (hP S hS).IsSeparatedFor.ext
      intro Y' f hf
      rw [presieve.is_sheaf_for.valid_glue _ _ _ hf, ← hy _ hf]
      rfl
#align category_theory.is_sheaf_iff_is_sheaf_of_type CategoryTheory.isSheaf_iff_isSheaf_of_type

/-- The category of sheaves taking values in Type is the same as the category of set-valued sheaves.
-/
@[simps]
def sheafEquivSheafOfTypes : Sheaf J (Type w) ≌ SheafOfTypes J
    where
  Functor :=
    { obj := fun S => ⟨S.val, (isSheaf_iff_isSheaf_of_type _ _).1 S.2⟩
      map := fun S T f => ⟨f.val⟩ }
  inverse :=
    { obj := fun S => ⟨S.val, (isSheaf_iff_isSheaf_of_type _ _).2 S.2⟩
      map := fun S T f => ⟨f.val⟩ }
  unitIso := NatIso.ofComponents (fun X => ⟨⟨𝟙 _⟩, ⟨𝟙 _⟩, by tidy, by tidy⟩) (by tidy)
  counitIso := NatIso.ofComponents (fun X => ⟨⟨𝟙 _⟩, ⟨𝟙 _⟩, by tidy, by tidy⟩) (by tidy)
#align category_theory.Sheaf_equiv_SheafOfTypes CategoryTheory.sheafEquivSheafOfTypes

instance : Inhabited (Sheaf (⊥ : GrothendieckTopology C) (Type w)) :=
  ⟨(sheafEquivSheafOfTypes _).inverse.obj default⟩

variable {J} {A}

/-- If the empty sieve is a cover of `X`, then `F(X)` is terminal. -/
def Sheaf.isTerminalOfBotCover (F : Sheaf J A) (X : C) (H : ⊥ ∈ J X) :
    IsTerminal (F.1.obj (op X)) :=
  by
  apply (config := { instances := false }) is_terminal.of_unique
  intro Y
  choose t h using F.2 Y _ H (by tidy) (by tidy)
  exact ⟨⟨t⟩, fun a => h.2 a (by tidy)⟩
#align category_theory.Sheaf.is_terminal_of_bot_cover CategoryTheory.Sheaf.isTerminalOfBotCover

section Preadditive

open Preadditive

variable [Preadditive A] {P Q : Sheaf J A}

instance sheafHomHasZsmul : SMul ℤ (P ⟶ Q)
    where smul n f :=
    Sheaf.Hom.mk
      { app := fun U => n • f.1.app U
        naturality' := fun U V i =>
          by
          induction' n using Int.induction_on with n ih n ih
          · simp only [zero_smul, comp_zero, zero_comp]
          ·
            simpa only [add_zsmul, one_zsmul, comp_add, nat_trans.naturality, add_comp,
              add_left_inj]
          ·
            simpa only [sub_smul, one_zsmul, comp_sub, nat_trans.naturality, sub_comp,
              sub_left_inj] using ih }
#align category_theory.Sheaf_hom_has_zsmul CategoryTheory.sheafHomHasZsmul

instance : Sub (P ⟶ Q) where sub f g := Sheaf.Hom.mk <| f.1 - g.1

instance : Neg (P ⟶ Q) where neg f := Sheaf.Hom.mk <| -f.1

instance sheafHomHasNsmul : SMul ℕ (P ⟶ Q)
    where smul n f :=
    Sheaf.Hom.mk
      { app := fun U => n • f.1.app U
        naturality' := fun U V i => by
          induction' n with n ih
          · simp only [zero_smul, comp_zero, zero_comp]
          ·
            simp only [Nat.succ_eq_add_one, add_smul, ih, one_nsmul, comp_add, nat_trans.naturality,
              add_comp] }
#align category_theory.Sheaf_hom_has_nsmul CategoryTheory.sheafHomHasNsmul

instance : Zero (P ⟶ Q) where zero := Sheaf.Hom.mk 0

instance : Add (P ⟶ Q) where add f g := Sheaf.Hom.mk <| f.1 + g.1

@[simp]
theorem Sheaf.Hom.add_app (f g : P ⟶ Q) (U) : (f + g).1.app U = f.1.app U + g.1.app U :=
  rfl
#align category_theory.Sheaf.hom.add_app CategoryTheory.Sheaf.Hom.add_app

instance : AddCommGroup (P ⟶ Q) :=
  Function.Injective.addCommGroup (fun f : Sheaf.Hom P Q => f.1) (fun _ _ h => Sheaf.Hom.ext _ _ h)
    rfl (fun _ _ => rfl) (fun _ => rfl) (fun _ _ => rfl)
    (fun _ _ => by
      dsimp at *
      ext
      simpa [*] )
    fun _ _ => by
    dsimp at *
    ext
    simpa [*]

instance : Preadditive (Sheaf J A)
    where
  homGroup P Q := inferInstance
  add_comp P Q R f f' g := by
    ext
    simp
  comp_add P Q R f g g' := by
    ext
    simp

end Preadditive

end CategoryTheory

namespace CategoryTheory

open Opposite CategoryTheory Category Limits Sieve

namespace Presheaf

-- Under here is the equalizer story, which is equivalent if A has products (and doesn't
-- make sense otherwise). It's described in https://stacks.math.columbia.edu/tag/00VL,
-- between 00VQ and 00VR.
variable {C : Type u₁} [Category.{v₁} C]

variable {A : Type u₂} [Category.{max v₁ u₁} A]

variable (J : GrothendieckTopology C)

variable {U : C} (R : Presieve U)

variable (P : Cᵒᵖ ⥤ A)

section MultiequalizerConditions

/-- When `P` is a sheaf and `S` is a cover, the associated multifork is a limit. -/
def isLimitOfIsSheaf {X : C} (S : J.cover X) (hP : IsSheaf J P) : IsLimit (S.Multifork P)
    where
  lift := fun E : Multifork _ => hP.amalgamate S (fun I => E.ι _) fun I => E.condition _
  fac := by
    rintro (E : multifork _) (a | b)
    · apply hP.amalgamate_map
    · rw [← E.w (walking_multicospan.hom.fst b), ←
        (S.multifork P).w (walking_multicospan.hom.fst b), ← assoc]
      congr 1
      apply hP.amalgamate_map
  uniq := by
    rintro (E : multifork _) m hm
    apply hP.hom_ext S
    intro I
    erw [hm (walking_multicospan.left I)]
    symm
    apply hP.amalgamate_map
#align category_theory.presheaf.is_limit_of_is_sheaf CategoryTheory.Presheaf.isLimitOfIsSheaf

theorem isSheaf_iff_multifork :
    IsSheaf J P ↔ ∀ (X : C) (S : J.cover X), Nonempty (IsLimit (S.Multifork P)) :=
  by
  refine' ⟨fun hP X S => ⟨is_limit_of_is_sheaf _ _ _ hP⟩, _⟩
  intro h E X S hS x hx
  let T : J.cover X := ⟨S, hS⟩
  obtain ⟨hh⟩ := h _ T
  let K : multifork (T.index P) := multifork.of_ι _ E (fun I => x I.f I.hf) fun I => hx _ _ _ _ I.w
  use hh.lift K
  dsimp; constructor
  · intro Y f hf
    apply hh.fac K (walking_multicospan.left ⟨Y, f, hf⟩)
  · intro e he
    apply hh.uniq K
    rintro (a | b)
    · apply he
    · rw [← K.w (walking_multicospan.hom.fst b), ←
        (T.multifork P).w (walking_multicospan.hom.fst b), ← assoc]
      congr 1
      apply he
#align category_theory.presheaf.is_sheaf_iff_multifork CategoryTheory.Presheaf.isSheaf_iff_multifork

theorem isSheaf_iff_multiequalizer [∀ (X : C) (S : J.cover X), HasMultiequalizer (S.index P)] :
    IsSheaf J P ↔ ∀ (X : C) (S : J.cover X), IsIso (S.toMultiequalizer P) :=
  by
  rw [is_sheaf_iff_multifork]
  refine' forall₂_congr fun X S => ⟨_, _⟩
  · rintro ⟨h⟩
    let e : P.obj (op X) ≅ multiequalizer (S.index P) :=
      h.cone_point_unique_up_to_iso (limit.is_limit _)
    exact (inferInstance : is_iso e.hom)
  · intro h
    refine' ⟨is_limit.of_iso_limit (limit.is_limit _) (cones.ext _ _)⟩
    · apply (@as_iso _ _ _ _ _ h).symm
    · intro a
      symm
      erw [is_iso.inv_comp_eq]
      change _ = limit.lift _ _ ≫ _
      simp
#align category_theory.presheaf.is_sheaf_iff_multiequalizer CategoryTheory.Presheaf.isSheaf_iff_multiequalizer

end MultiequalizerConditions

section

variable [HasProducts.{max u₁ v₁} A]

/--
The middle object of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of <https://stacks.math.columbia.edu/tag/00VM>.
-/
def firstObj : A :=
  ∏ fun f : ΣV, { f : V ⟶ U // R f } => P.obj (op f.1)
#align category_theory.presheaf.first_obj CategoryTheory.Presheaf.firstObj

/--
The left morphism of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of <https://stacks.math.columbia.edu/tag/00VM>.
-/
def forkMap : P.obj (op U) ⟶ firstObj R P :=
  Pi.lift fun f => P.map f.2.1.op
#align category_theory.presheaf.fork_map CategoryTheory.Presheaf.forkMap

variable [HasPullbacks C]

/-- The rightmost object of the fork diagram of https://stacks.math.columbia.edu/tag/00VM, which
contains the data used to check a family of elements for a presieve is compatible.
-/
def secondObj : A :=
  ∏ fun fg : (ΣV, { f : V ⟶ U // R f }) × ΣW, { g : W ⟶ U // R g } =>
    P.obj (op (pullback fg.1.2.1 fg.2.2.1))
#align category_theory.presheaf.second_obj CategoryTheory.Presheaf.secondObj

/-- The map `pr₀*` of <https://stacks.math.columbia.edu/tag/00VM>. -/
def firstMap : firstObj R P ⟶ secondObj R P :=
  Pi.lift fun fg => Pi.π _ _ ≫ P.map pullback.fst.op
#align category_theory.presheaf.first_map CategoryTheory.Presheaf.firstMap

/-- The map `pr₁*` of <https://stacks.math.columbia.edu/tag/00VM>. -/
def secondMap : firstObj R P ⟶ secondObj R P :=
  Pi.lift fun fg => Pi.π _ _ ≫ P.map pullback.snd.op
#align category_theory.presheaf.second_map CategoryTheory.Presheaf.secondMap

theorem w : forkMap R P ≫ firstMap R P = forkMap R P ≫ secondMap R P :=
  by
  apply limit.hom_ext
  rintro ⟨⟨Y, f, hf⟩, ⟨Z, g, hg⟩⟩
  simp only [first_map, second_map, fork_map, limit.lift_π, limit.lift_π_assoc, assoc, fan.mk_π_app,
    Subtype.coe_mk, Subtype.val_eq_coe]
  rw [← P.map_comp, ← op_comp, pullback.condition]
  simp
#align category_theory.presheaf.w CategoryTheory.Presheaf.w

/-- An alternative definition of the sheaf condition in terms of equalizers. This is shown to be
equivalent in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
-/
def IsSheaf' (P : Cᵒᵖ ⥤ A) : Prop :=
  ∀ (U : C) (R : Presieve U) (hR : generate R ∈ J U), Nonempty (IsLimit (Fork.ofι _ (w R P)))
#align category_theory.presheaf.is_sheaf' CategoryTheory.Presheaf.IsSheaf'

/-- (Implementation). An auxiliary lemma to convert between sheaf conditions. -/
def isSheafForIsSheafFor' (P : Cᵒᵖ ⥤ A) (s : A ⥤ Type max v₁ u₁)
    [∀ J, PreservesLimitsOfShape (Discrete.{max v₁ u₁} J) s] (U : C) (R : Presieve U) :
    IsLimit (s.mapCone (Fork.ofι _ (w R P))) ≃
      IsLimit (Fork.ofι _ (Equalizer.Presieve.w (P ⋙ s) R)) :=
  by
  apply Equiv.trans (is_limit_map_cone_fork_equiv _ _) _
  apply (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _)
  · apply nat_iso.of_components _ _
    · rintro (_ | _)
      · apply preserves_product.iso s
      · apply preserves_product.iso s
    · rintro _ _ (_ | _)
      · ext : 1
        dsimp [equalizer.presieve.first_map, first_map]
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp]
        erw [pi_comparison_comp_π_assoc]
      · ext : 1
        dsimp [equalizer.presieve.second_map, second_map]
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp]
        erw [pi_comparison_comp_π_assoc]
      · dsimp
        simp
  · refine' fork.ext (iso.refl _) _
    dsimp [equalizer.fork_map, fork_map]
    simp [fork.ι]
#align category_theory.presheaf.is_sheaf_for_is_sheaf_for' CategoryTheory.Presheaf.isSheafForIsSheafFor'

/-- The equalizer definition of a sheaf given by `is_sheaf'` is equivalent to `is_sheaf`. -/
theorem isSheaf_iff_isSheaf' : IsSheaf J P ↔ IsSheaf' J P :=
  by
  constructor
  · intro h U R hR
    refine' ⟨_⟩
    apply coyoneda_jointly_reflects_limits
    intro X
    have q : presieve.is_sheaf_for (P ⋙ coyoneda.obj X) _ := h X.unop _ hR
    rw [← presieve.is_sheaf_for_iff_generate] at q
    rw [equalizer.presieve.sheaf_condition] at q
    replace q := Classical.choice q
    apply (is_sheaf_for_is_sheaf_for' _ _ _ _).symm q
  · intro h U X S hS
    rw [equalizer.presieve.sheaf_condition]
    refine' ⟨_⟩
    refine' is_sheaf_for_is_sheaf_for' _ _ _ _ _
    letI := preserves_smallest_limits_of_preserves_limits (coyoneda.obj (op U))
    apply is_limit_of_preserves
    apply Classical.choice (h _ S _)
    simpa
#align category_theory.presheaf.is_sheaf_iff_is_sheaf' CategoryTheory.Presheaf.isSheaf_iff_isSheaf'

end

section Concrete

variable [HasPullbacks C]

/--
For a concrete category `(A, s)` where the forgetful functor `s : A ⥤ Type v` preserves limits and
reflects isomorphisms, and `A` has limits, an `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is a sheaf iff its
underlying `Type`-valued presheaf `P ⋙ s : Cᵒᵖ ⥤ Type` is a sheaf.

Note this lemma applies for "algebraic" categories, eg groups, abelian groups and rings, but not
for the category of topological spaces, topological rings, etc since reflecting isomorphisms doesn't
hold.
-/
theorem isSheaf_iff_isSheaf_forget (s : A ⥤ Type max v₁ u₁) [HasLimits A] [PreservesLimits s]
    [ReflectsIsomorphisms s] : IsSheaf J P ↔ IsSheaf J (P ⋙ s) :=
  by
  rw [is_sheaf_iff_is_sheaf', is_sheaf_iff_is_sheaf']
  apply forall_congr' fun U => _
  apply ball_congr fun R hR => _
  letI : reflects_limits s := reflects_limits_of_reflects_isomorphisms
  have : is_limit (s.map_cone (fork.of_ι _ (w R P))) ≃ is_limit (fork.of_ι _ (w R (P ⋙ s))) :=
    is_sheaf_for_is_sheaf_for' P s U R
  rw [← Equiv.nonempty_congr this]
  constructor
  · haveI := preserves_smallest_limits_of_preserves_limits s
    exact Nonempty.map fun t => is_limit_of_preserves s t
  · haveI := reflects_smallest_limits_of_reflects_limits s
    exact Nonempty.map fun t => is_limit_of_reflects s t
#align category_theory.presheaf.is_sheaf_iff_is_sheaf_forget CategoryTheory.Presheaf.isSheaf_iff_isSheaf_forget

end Concrete

end Presheaf

end CategoryTheory


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.metric_space.hausdorff_distance
import Mathlib.analysis.specific_limits
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Closed subsets

This file defines the metric and emetric space structure on the types of closed subsets and nonempty compact
subsets of a metric or emetric space.

The Hausdorff distance induces an emetric space structure on the type of closed subsets
of an emetric space, called `closeds`. Its completeness, resp. compactness, resp.
second-countability, follow from the corresponding properties of the original space.

In a metric space, the type of nonempty compact subsets (called `nonempty_compacts`) also
inherits a metric space structure from the Hausdorff distance, as the Hausdorff edistance is
always finite in this context.
-/

namespace emetric

/-- In emetric spaces, the Hausdorff edistance defines an emetric space structure
on the type of closed subsets -/
protected instance closeds.emetric_space {α : Type u} [emetric_space α] : emetric_space (topological_space.closeds α) :=
  emetric_space.mk sorry sorry sorry sorry
    (uniform_space_of_edist (fun (s t : topological_space.closeds α) => Hausdorff_edist (subtype.val s) (subtype.val t))
      sorry sorry sorry)

/-- The edistance to a closed set depends continuously on the point and the set -/
theorem continuous_inf_edist_Hausdorff_edist {α : Type u} [emetric_space α] : continuous fun (p : α × topological_space.closeds α) => inf_edist (prod.fst p) (subtype.val (prod.snd p)) := sorry

/-- Subsets of a given closed subset form a closed set -/
theorem is_closed_subsets_of_is_closed {α : Type u} [emetric_space α] {s : set α} (hs : is_closed s) : is_closed (set_of fun (t : topological_space.closeds α) => subtype.val t ⊆ s) := sorry

/-- By definition, the edistance on `closeds α` is given by the Hausdorff edistance -/
theorem closeds.edist_eq {α : Type u} [emetric_space α] {s : topological_space.closeds α} {t : topological_space.closeds α} : edist s t = Hausdorff_edist (subtype.val s) (subtype.val t) :=
  rfl

/-- In a complete space, the type of closed subsets is complete for the
Hausdorff edistance. -/
protected instance closeds.complete_space {α : Type u} [emetric_space α] [complete_space α] : complete_space (topological_space.closeds α) := sorry

/-- In a compact space, the type of closed subsets is compact. -/
protected instance closeds.compact_space {α : Type u} [emetric_space α] [compact_space α] : compact_space (topological_space.closeds α) := sorry

/-- In an emetric space, the type of non-empty compact subsets is an emetric space,
where the edistance is the Hausdorff edistance -/
protected instance nonempty_compacts.emetric_space {α : Type u} [emetric_space α] : emetric_space (topological_space.nonempty_compacts α) :=
  emetric_space.mk sorry sorry sorry sorry
    (uniform_space_of_edist
      (fun (s t : topological_space.nonempty_compacts α) => Hausdorff_edist (subtype.val s) (subtype.val t)) sorry sorry
      sorry)

/-- `nonempty_compacts.to_closeds` is a uniform embedding (as it is an isometry) -/
theorem nonempty_compacts.to_closeds.uniform_embedding {α : Type u} [emetric_space α] : uniform_embedding topological_space.nonempty_compacts.to_closeds :=
  isometry.uniform_embedding fun (x y : topological_space.nonempty_compacts α) => rfl

/-- The range of `nonempty_compacts.to_closeds` is closed in a complete space -/
theorem nonempty_compacts.is_closed_in_closeds {α : Type u} [emetric_space α] [complete_space α] : is_closed (set.range topological_space.nonempty_compacts.to_closeds) := sorry

/-- In a complete space, the type of nonempty compact subsets is complete. This follows
from the same statement for closed subsets -/
protected instance nonempty_compacts.complete_space {α : Type u} [emetric_space α] [complete_space α] : complete_space (topological_space.nonempty_compacts α) :=
  iff.mpr (complete_space_iff_is_complete_range nonempty_compacts.to_closeds.uniform_embedding)
    (is_closed.is_complete nonempty_compacts.is_closed_in_closeds)

/-- In a compact space, the type of nonempty compact subsets is compact. This follows from
the same statement for closed subsets -/
protected instance nonempty_compacts.compact_space {α : Type u} [emetric_space α] [compact_space α] : compact_space (topological_space.nonempty_compacts α) :=
  compact_space.mk
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (is_compact set.univ))
          (propext
            (embedding.compact_iff_compact_image
              (uniform_embedding.embedding nonempty_compacts.to_closeds.uniform_embedding)))))
      (eq.mpr
        (id
          (Eq._oldrec (Eq.refl (is_compact (topological_space.nonempty_compacts.to_closeds '' set.univ))) set.image_univ))
        (is_closed.compact nonempty_compacts.is_closed_in_closeds)))

/-- In a second countable space, the type of nonempty compact subsets is second countable -/
protected instance nonempty_compacts.second_countable_topology {α : Type u} [emetric_space α] [topological_space.second_countable_topology α] : topological_space.second_countable_topology (topological_space.nonempty_compacts α) :=
  second_countable_of_separable (topological_space.nonempty_compacts α)

namespace metric

/-- `nonempty_compacts α` inherits a metric space structure, as the Hausdorff
edistance between two such sets is finite. -/
protected instance Mathlib.metric.nonempty_compacts.metric_space {α : Type u} [metric_space α] : metric_space (topological_space.nonempty_compacts α) :=
  emetric_space.to_metric_space sorry

/-- The distance on `nonempty_compacts α` is the Hausdorff distance, by construction -/
theorem Mathlib.metric.nonempty_compacts.dist_eq {α : Type u} [metric_space α] {x : topological_space.nonempty_compacts α} {y : topological_space.nonempty_compacts α} : dist x y = metric.Hausdorff_dist (subtype.val x) (subtype.val y) :=
  rfl

theorem Mathlib.metric.lipschitz_inf_dist_set {α : Type u} [metric_space α] (x : α) : lipschitz_with 1 fun (s : topological_space.nonempty_compacts α) => metric.inf_dist x (subtype.val s) := sorry

theorem Mathlib.metric.lipschitz_inf_dist {α : Type u} [metric_space α] : lipschitz_with (bit0 1)
  fun (p : α × topological_space.nonempty_compacts α) => metric.inf_dist (prod.fst p) (subtype.val (prod.snd p)) :=
  lipschitz_with.uncurry (fun (s : topological_space.nonempty_compacts α) => metric.lipschitz_inf_dist_pt (subtype.val s))
    metric.lipschitz_inf_dist_set

theorem Mathlib.metric.uniform_continuous_inf_dist_Hausdorff_dist {α : Type u} [metric_space α] : uniform_continuous
  fun (p : α × topological_space.nonempty_compacts α) => metric.inf_dist (prod.fst p) (subtype.val (prod.snd p)) :=
  lipschitz_with.uniform_continuous metric.lipschitz_inf_dist