import Cat.Fam.Comp

/-! # Equivalence for category arrows in terms of the corresponding setoid -/

namespace Cat

/-- A proof that `f` is equivalent to `g` (`≋`, `\~~~`). -/
inductive Fam.Cat.Hom.Equiv
  {ℂ : Cat}
  {α β : ℂ.Obj}
  (f : α ↠ β)
: {γ δ : ℂ.Obj}
  → (γ ↠ δ)
  → Prop
where
| proof :
  (g : α ↠ β)
  → f ≈ g
  → Equiv f g

/-- Predicate for *"`f` and `g` are equivalent"* (`≋`, `\~~~`). -/
abbrev Fam.Cat.Hom.Equiv.equiv
  {ℂ : Cat}
  {α β γ δ : ℂ.Obj}
  (f : α ↠ β)
  (g : γ ↠ δ)
: Prop :=
  @Equiv ℂ α β f γ δ g

infix:30 " ≋ " =>
  Fam.Cat.Hom.Equiv.equiv

theorem Fam.Cat.Hom.Equiv.domEq
  {ℂ : Cat}
  {α β γ δ : ℂ.Obj}
  {f : α ↠ β}
  {g : γ ↠ δ}
  (h : f ≋ g)
: α = γ :=
  by
    cases h with
    | proof _ _ =>
      rfl

theorem Fam.Cat.Hom.Equiv.codEq
  {ℂ : Cat}
  {α β γ δ : ℂ.Obj}
  {f : α ↠ β}
  {g : γ ↠ δ}
  (h : f ≋ g)
: β = δ :=
  by
    cases h with
    | proof _ _ =>
      rfl

/-- Rewrites a `Equiv.proof` unifying (co)domains. -/
theorem Fam.Cat.Hom.Equiv.unify
  {ℂ : Cat}
  {α β γ δ : ℂ.Obj}
  {f : α ↠ β}
  {g : γ ↠ δ}
  (h : f ≋ g)
: (
  @Equiv ℂ α β f α β (
    let h_dom := domEq h
    let h_cod := codEq h
    by
      rw [h_dom, h_cod]
      exact g
  )
) :=
  by
    cases h with
    | proof g eq =>
      apply proof g eq

theorem Fam.Cat.Hom.Equiv.toEq
  {ℂ : Cat}
  {α β : ℂ.Obj}
  {f : α ↠ β}
  {g : α ↠ β}
  (h : f ≋ g)
: (f ≈ g) :=
  match h with
  | proof _ eq =>
    eq

/-! ## `Fam.Cat.Hom.Equiv` is an equivalence relation

We cannot build an `Equivalence` though, as it takes a `r : α → α → Prop`. `Equiv`'s arguments do
not have the same type in general `:/`.

We can still prove that `Equiv` is reflexive, symmetric and transitive so let's just do that.
-/
namespace Fam.Cat.Hom.Equiv

  theorem refl
    {ℂ : Cat}
    {α β : ℂ.Obj}
    (f : α ↠ β)
  : f ≋ f :=
    let eq_f :=
      ℂ.Hom α β |>.refl f
    proof f eq_f

  theorem symm
    {ℂ : Cat}
    {α₁ β₁ α₂ β₂ : ℂ.Obj}
    (f₁ : α₁ ↠ β₁)
    (f₂ : α₂ ↠ β₂)
  : f₁ ≋ f₂ → f₂ ≋ f₁ :=
    by
      intro h
      cases h
      apply proof
      apply ℂ.Hom α₁ β₁ |>.symm
      assumption

  theorem trans
    {ℂ : Cat}
    {α₁ β₁ α₂ β₂ α₃ β₃ : ℂ.Obj}
    {f₁ : α₁ ↠ β₁}
    {f₂ : α₂ ↠ β₂}
    {f₃ : α₃ ↠ β₃}
  : f₁ ≋ f₂ → f₂ ≋ f₃ → f₁ ≋ f₃ :=
    by
      intro h₁₂ h₂₃
      cases h₁₂ ; cases h₂₃
      apply proof
      apply ℂ.Hom α₁ β₁ |>.trans
      <;> assumption

end Fam.Cat.Hom.Equiv

instance instTransHomEq
  {ℂ : Fam.Cat}
  {α₁ β₁ α₂ β₂ α₃ β₃ : ℂ.Obj}
: Trans
  (@Fam.Cat.Hom.Equiv.equiv ℂ α₁ β₁ α₂ β₂)
  (@Fam.Cat.Hom.Equiv.equiv ℂ α₂ β₂ α₃ β₃)
  (@Fam.Cat.Hom.Equiv.equiv ℂ α₁ β₁ α₃ β₃)
where
  trans :=
    Fam.Cat.Hom.Equiv.trans


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

/-!
# Gromov-Hausdorff distance

This file defines the Gromov-Hausdorff distance on the space of nonempty compact metric spaces
up to isometry.

We introduce the space of all nonempty compact metric spaces, up to isometry,
called `GH_space`, and endow it with a metric space structure. The distance,
known as the Gromov-Hausdorff distance, is defined as follows: given two
nonempty compact spaces `X` and `Y`, their distance is the minimum Hausdorff distance
between all possible isometric embeddings of `X` and `Y` in all metric spaces.
To define properly the Gromov-Hausdorff space, we consider the non-empty
compact subsets of `ℓ^∞(ℝ)` up to isometry, which is a well-defined type,
and define the distance as the infimum of the Hausdorff distance over all
embeddings in `ℓ^∞(ℝ)`. We prove that this coincides with the previous description,
as all separable metric spaces embed isometrically into `ℓ^∞(ℝ)`, through an
embedding called the Kuratowski embedding.
To prove that we have a distance, we should show that if spaces can be coupled
to be arbitrarily close, then they are isometric. More generally, the Gromov-Hausdorff
distance is realized, i.e., there is a coupling for which the Hausdorff distance
is exactly the Gromov-Hausdorff distance. This follows from a compactness
argument, essentially following from Arzela-Ascoli.

## Main results

We prove the most important properties of the Gromov-Hausdorff space: it is a polish space,
i.e., it is complete and second countable. We also prove the Gromov compactness criterion.

-/

noncomputable theory
open_locale classical topology ennreal

local notation `ℓ_infty_ℝ`:= lp (λ n : ℕ, ℝ) ∞

universes u v w

open classical set function topological_space filter metric quotient
open bounded_continuous_function nat int Kuratowski_embedding
open sum (inl inr)

local attribute [instance] metric_space_sum

namespace Gromov_Hausdorff

section GH_space
/- In this section, we define the Gromov-Hausdorff space, denoted `GH_space` as the quotient
of nonempty compact subsets of `ℓ^∞(ℝ)` by identifying isometric sets.
Using the Kuratwoski embedding, we get a canonical map `to_GH_space` mapping any nonempty
compact type to `GH_space`. -/

/-- Equivalence relation identifying two nonempty compact sets which are isometric -/
private def isometry_rel : nonempty_compacts ℓ_infty_ℝ → nonempty_compacts ℓ_infty_ℝ → Prop :=
λ x y, nonempty (x ≃ᵢ y)

/-- This is indeed an equivalence relation -/
private lemma is_equivalence_isometry_rel : equivalence isometry_rel :=
⟨λ x, ⟨isometry_equiv.refl _⟩, λ x y ⟨e⟩, ⟨e.symm⟩, λ x y z ⟨e⟩ ⟨f⟩, ⟨e.trans f⟩⟩

/-- setoid instance identifying two isometric nonempty compact subspaces of ℓ^∞(ℝ) -/
instance isometry_rel.setoid : setoid (nonempty_compacts ℓ_infty_ℝ) :=
setoid.mk isometry_rel is_equivalence_isometry_rel

/-- The Gromov-Hausdorff space -/
definition GH_space : Type := quotient (isometry_rel.setoid)

/-- Map any nonempty compact type to `GH_space` -/
definition to_GH_space (X : Type u) [metric_space X] [compact_space X] [nonempty X] : GH_space :=
  ⟦nonempty_compacts.Kuratowski_embedding X⟧

instance : inhabited GH_space := ⟨quot.mk _ ⟨⟨{0}, is_compact_singleton⟩, singleton_nonempty _⟩⟩

/-- A metric space representative of any abstract point in `GH_space` -/
@[nolint has_nonempty_instance]
def GH_space.rep (p : GH_space) : Type := (quotient.out p : nonempty_compacts ℓ_infty_ℝ)

lemma eq_to_GH_space_iff {X : Type u} [metric_space X] [compact_space X] [nonempty X]
  {p : nonempty_compacts ℓ_infty_ℝ} :
  ⟦p⟧ = to_GH_space X ↔ ∃ Ψ : X → ℓ_infty_ℝ, isometry Ψ ∧ range Ψ = p :=
begin
  simp only [to_GH_space, quotient.eq],
  refine ⟨λ h, _, _⟩,
  { rcases setoid.symm h with ⟨e⟩,
    have f := (Kuratowski_embedding.isometry X).isometry_equiv_on_range.trans e,
    use [λ x, f x, isometry_subtype_coe.comp f.isometry],
    rw [range_comp, f.range_eq_univ, set.image_univ, subtype.range_coe],
    refl },
  { rintros ⟨Ψ, ⟨isomΨ, rangeΨ⟩⟩,
    have f := ((Kuratowski_embedding.isometry X).isometry_equiv_on_range.symm.trans
               isomΨ.isometry_equiv_on_range).symm,
    have E : (range Ψ ≃ᵢ nonempty_compacts.Kuratowski_embedding X) =
        (p ≃ᵢ range (Kuratowski_embedding X)),
      by { dunfold nonempty_compacts.Kuratowski_embedding, rw [rangeΨ]; refl },
    exact ⟨cast E f⟩ }
end

lemma eq_to_GH_space {p : nonempty_compacts ℓ_infty_ℝ} : ⟦p⟧ = to_GH_space p :=
eq_to_GH_space_iff.2 ⟨λ x, x, isometry_subtype_coe, subtype.range_coe⟩

section
local attribute [reducible] GH_space.rep

instance rep_GH_space_metric_space {p : GH_space} : metric_space p.rep := by apply_instance
instance rep_GH_space_compact_space {p : GH_space} : compact_space p.rep := by apply_instance
instance rep_GH_space_nonempty {p : GH_space} : nonempty p.rep := by apply_instance

end

lemma GH_space.to_GH_space_rep (p : GH_space) : to_GH_space p.rep = p :=
begin
  change to_GH_space (quot.out p : nonempty_compacts ℓ_infty_ℝ) = p,
  rw ← eq_to_GH_space,
  exact quot.out_eq p
end

/-- Two nonempty compact spaces have the same image in `GH_space` if and only if they are
isometric. -/

/-- Distance on `GH_space`: the distance between two nonempty compact spaces is the infimum
Hausdorff distance between isometric copies of the two spaces in a metric space. For the definition,
we only consider embeddings in `ℓ^∞(ℝ)`, but we will prove below that it works for all spaces. -/
instance : has_dist (GH_space) :=
{ dist := λ x y, Inf $
    (λ p : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ,
      Hausdorff_dist (p.1 : set ℓ_infty_ℝ) p.2) '' ({a | ⟦a⟧ = x} ×ˢ {b | ⟦b⟧ = y}) }

/-- The Gromov-Hausdorff distance between two nonempty compact metric spaces, equal by definition to
the distance of the equivalence classes of these spaces in the Gromov-Hausdorff space. -/
def GH_dist (X : Type u) (Y : Type v) [metric_space X] [nonempty X] [compact_space X]
  [metric_space Y] [nonempty Y] [compact_space Y] : ℝ := dist (to_GH_space X) (to_GH_space Y)

lemma dist_GH_dist (p q : GH_space) : dist p q = GH_dist p.rep (q.rep) :=
by rw [GH_dist, p.to_GH_space_rep, q.to_GH_space_rep]

/-- The Gromov-Hausdorff distance between two spaces is bounded by the Hausdorff distance
of isometric copies of the spaces, in any metric space. -/
theorem GH_dist_le_Hausdorff_dist {X : Type u} [metric_space X] [compact_space X] [nonempty X]
  {Y : Type v} [metric_space Y] [compact_space Y] [nonempty Y]
  {γ : Type w} [metric_space γ] {Φ : X → γ} {Ψ : Y → γ} (ha : isometry Φ) (hb : isometry Ψ) :
  GH_dist X Y ≤ Hausdorff_dist (range Φ) (range Ψ) :=
begin
  /- For the proof, we want to embed `γ` in `ℓ^∞(ℝ)`, to say that the Hausdorff distance is realized
  in `ℓ^∞(ℝ)` and therefore bounded below by the Gromov-Hausdorff-distance. However, `γ` is not
  separable in general. We restrict to the union of the images of `X` and `Y` in `γ`, which is
  separable and therefore embeddable in `ℓ^∞(ℝ)`. -/
  rcases exists_mem_of_nonempty X with ⟨xX, _⟩,
  let s : set γ := (range Φ) ∪ (range Ψ),
  let Φ' : X → subtype s := λ y, ⟨Φ y, mem_union_left _ (mem_range_self _)⟩,
  let Ψ' : Y → subtype s := λ y, ⟨Ψ y, mem_union_right _ (mem_range_self _)⟩,
  have IΦ' : isometry Φ' := λ x y, ha x y,
  have IΨ' : isometry Ψ' := λ x y, hb x y,
  have : is_compact s, from (is_compact_range ha.continuous).union (is_compact_range hb.continuous),
  letI : metric_space (subtype s) := by apply_instance,
  haveI : compact_space (subtype s) := ⟨is_compact_iff_is_compact_univ.1 ‹is_compact s›⟩,
  haveI : nonempty (subtype s) := ⟨Φ' xX⟩,
  have ΦΦ' : Φ = subtype.val ∘ Φ', by { funext, refl },
  have ΨΨ' : Ψ = subtype.val ∘ Ψ', by { funext, refl },
  have : Hausdorff_dist (range Φ) (range Ψ) = Hausdorff_dist (range Φ') (range Ψ'),
  { rw [ΦΦ', ΨΨ', range_comp, range_comp],
    exact Hausdorff_dist_image (isometry_subtype_coe) },
  rw this,
  -- Embed `s` in `ℓ^∞(ℝ)` through its Kuratowski embedding
  let F := Kuratowski_embedding (subtype s),
  have : Hausdorff_dist (F '' (range Φ')) (F '' (range Ψ')) =
    Hausdorff_dist (range Φ') (range Ψ') := Hausdorff_dist_image (Kuratowski_embedding.isometry _),
  rw ← this,
  -- Let `A` and `B` be the images of `X` and `Y` under this embedding. They are in `ℓ^∞(ℝ)`, and
  -- their Hausdorff distance is the same as in the original space.
  let A : nonempty_compacts ℓ_infty_ℝ := ⟨⟨F '' (range Φ'), (is_compact_range IΦ'.continuous).image
    (Kuratowski_embedding.isometry _).continuous⟩, (range_nonempty _).image _⟩,
  let B : nonempty_compacts ℓ_infty_ℝ := ⟨⟨F '' (range Ψ'), (is_compact_range IΨ'.continuous).image
    (Kuratowski_embedding.isometry _).continuous⟩, (range_nonempty _).image _⟩,
  have AX : ⟦A⟧ = to_GH_space X,
  { rw eq_to_GH_space_iff,
    exact ⟨λ x, F (Φ' x), (Kuratowski_embedding.isometry _).comp IΦ', range_comp _ _⟩ },
  have BY : ⟦B⟧ = to_GH_space Y,
  { rw eq_to_GH_space_iff,
    exact ⟨λ x, F (Ψ' x), (Kuratowski_embedding.isometry _).comp IΨ', range_comp _ _⟩ },
  refine cInf_le ⟨0, _⟩ _,
  { simp only [lower_bounds, mem_image, mem_prod, mem_set_of_eq, prod.exists, and_imp,
      forall_exists_index],
    assume t _ _ _ _ ht,
    rw ← ht,
    exact Hausdorff_dist_nonneg },
  apply (mem_image _ _ _).2,
  existsi (⟨A, B⟩ : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ),
  simp [AX, BY],
end

/-- The optimal coupling constructed above realizes exactly the Gromov-Hausdorff distance,
essentially by design. -/
lemma Hausdorff_dist_optimal {X : Type u} [metric_space X] [compact_space X] [nonempty X]
  {Y : Type v} [metric_space Y] [compact_space Y] [nonempty Y] :
  Hausdorff_dist (range (optimal_GH_injl X Y)) (range (optimal_GH_injr X Y)) = GH_dist X Y :=
begin
  inhabit X, inhabit Y,
  /- we only need to check the inequality `≤`, as the other one follows from the previous lemma.
     As the Gromov-Hausdorff distance is an infimum, we need to check that the Hausdorff distance
     in the optimal coupling is smaller than the Hausdorff distance of any coupling.
     First, we check this for couplings which already have small Hausdorff distance: in this
     case, the induced "distance" on `X ⊕ Y` belongs to the candidates family introduced in the
     definition of the optimal coupling, and the conclusion follows from the optimality
     of the optimal coupling within this family.
  -/
  have A : ∀ p q : nonempty_compacts ℓ_infty_ℝ, ⟦p⟧ = to_GH_space X → ⟦q⟧ = to_GH_space Y →
        Hausdorff_dist (p : set ℓ_infty_ℝ) q < diam (univ : set X) + 1 + diam (univ : set Y) →
        Hausdorff_dist (range (optimal_GH_injl X Y)) (range (optimal_GH_injr X Y)) ≤
        Hausdorff_dist (p : set ℓ_infty_ℝ) q,
  { assume p q hp hq bound,
    rcases eq_to_GH_space_iff.1 hp with ⟨Φ, ⟨Φisom, Φrange⟩⟩,
    rcases eq_to_GH_space_iff.1 hq with ⟨Ψ, ⟨Ψisom, Ψrange⟩⟩,
    have I : diam (range Φ ∪ range Ψ) ≤ 2 * diam (univ : set X) + 1 + 2 * diam (univ : set Y),
    { rcases exists_mem_of_nonempty X with ⟨xX, _⟩,
      have : ∃ y ∈ range Ψ, dist (Φ xX) y < diam (univ : set X) + 1 + diam (univ : set Y),
      { rw Ψrange,
        have : Φ xX ∈ ↑p := Φrange.subst (mem_range_self _),
        exact exists_dist_lt_of_Hausdorff_dist_lt this bound
          (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.nonempty q.nonempty
            p.is_compact.bounded q.is_compact.bounded) },
      rcases this with ⟨y, hy, dy⟩,
      rcases mem_range.1 hy with ⟨z, hzy⟩,
      rw ← hzy at dy,
      have DΦ : diam (range Φ) = diam (univ : set X) := Φisom.diam_range,
      have DΨ : diam (range Ψ) = diam (univ : set Y) := Ψisom.diam_range,
      calc
        diam (range Φ ∪ range Ψ) ≤ diam (range Φ) + dist (Φ xX) (Ψ z) + diam (range Ψ) :
          diam_union (mem_range_self _) (mem_range_self _)
        ... ≤ diam (univ : set X) + (diam (univ : set X) + 1 + diam (univ : set Y)) +
              diam (univ : set Y) :
          by { rw [DΦ, DΨ], apply add_le_add (add_le_add le_rfl (le_of_lt dy)) le_rfl }
        ... = 2 * diam (univ : set X) + 1 + 2 * diam (univ : set Y) : by ring },

    let f : X ⊕ Y → ℓ_infty_ℝ := λ x, match x with | inl y := Φ y | inr z := Ψ z end,
    let F : (X ⊕ Y) × (X ⊕ Y) → ℝ := λ p, dist (f p.1) (f p.2),
    -- check that the induced "distance" is a candidate
    have Fgood : F ∈ candidates X Y,
    { simp only [candidates, forall_const, and_true, add_comm, eq_self_iff_true, dist_eq_zero,
                 and_self, set.mem_set_of_eq],
      repeat {split},
      { exact λ x y, calc
        F (inl x, inl y) = dist (Φ x) (Φ y) : rfl
        ... = dist x y : Φisom.dist_eq x y },
      { exact λ x y, calc
        F (inr x, inr y) = dist (Ψ x) (Ψ y) : rfl
        ... = dist x y : Ψisom.dist_eq x y },
      { exact λ x y, dist_comm _ _ },
      { exact λ x y z, dist_triangle _ _ _ },
      { exact λ x y, calc
        F (x, y) ≤ diam (range Φ ∪ range Ψ) :
        begin
          have A : ∀ z : X ⊕ Y, f z ∈ range Φ ∪ range Ψ,
          { assume z,
            cases z,
            { apply mem_union_left, apply mem_range_self },
            { apply mem_union_right, apply mem_range_self } },
          refine dist_le_diam_of_mem _ (A _) (A _),
          rw [Φrange, Ψrange],
          exact (p ⊔ q).is_compact.bounded,
        end
        ... ≤ 2 * diam (univ : set X) + 1 + 2 * diam (univ : set Y) : I } },
    let Fb := candidates_b_of_candidates F Fgood,
    have : Hausdorff_dist (range (optimal_GH_injl X Y)) (range (optimal_GH_injr X Y)) ≤ HD Fb :=
      Hausdorff_dist_optimal_le_HD _ _ (candidates_b_of_candidates_mem F Fgood),
    refine le_trans this (le_of_forall_le_of_dense (λ r hr, _)),
    have I1 : ∀ x : X, (⨅ y, Fb (inl x, inr y)) ≤ r,
    { assume x,
      have : f (inl x) ∈ ↑p := Φrange.subst (mem_range_self _),
      rcases exists_dist_lt_of_Hausdorff_dist_lt this hr
        (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.nonempty q.nonempty
          p.is_compact.bounded q.is_compact.bounded)
        with ⟨z, zq, hz⟩,
      have : z ∈ range Ψ, by rwa [← Ψrange] at zq,
      rcases mem_range.1 this with ⟨y, hy⟩,
      calc (⨅ y, Fb (inl x, inr y)) ≤ Fb (inl x, inr y) :
          cinfi_le (by simpa only [add_zero] using HD_below_aux1 0) y
        ... = dist (Φ x) (Ψ y) : rfl
        ... = dist (f (inl x)) z : by rw hy
        ... ≤ r : le_of_lt hz },
    have I2 : ∀ y : Y, (⨅ x, Fb (inl x, inr y)) ≤ r,
    { assume y,
      have : f (inr y) ∈ ↑q := Ψrange.subst (mem_range_self _),
      rcases exists_dist_lt_of_Hausdorff_dist_lt' this hr
        (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.nonempty q.nonempty
          p.is_compact.bounded q.is_compact.bounded)
        with ⟨z, zq, hz⟩,
      have : z ∈ range Φ, by rwa [← Φrange] at zq,
      rcases mem_range.1 this with ⟨x, hx⟩,
      calc (⨅ x, Fb (inl x, inr y)) ≤ Fb (inl x, inr y) :
          cinfi_le (by simpa only [add_zero] using HD_below_aux2 0) x
        ... = dist (Φ x) (Ψ y) : rfl
        ... = dist z (f (inr y)) : by rw hx
        ... ≤ r : le_of_lt hz },
    simp only [HD, csupr_le I1, csupr_le I2, max_le_iff, and_self] },
  /- Get the same inequality for any coupling. If the coupling is quite good, the desired
  inequality has been proved above. If it is bad, then the inequality is obvious. -/
  have B : ∀ p q : nonempty_compacts ℓ_infty_ℝ, ⟦p⟧ = to_GH_space X → ⟦q⟧ = to_GH_space Y →
        Hausdorff_dist (range (optimal_GH_injl X Y)) (range (optimal_GH_injr X Y)) ≤
        Hausdorff_dist (p : set ℓ_infty_ℝ) q,
  { assume p q hp hq,
    by_cases h :
      Hausdorff_dist (p : set ℓ_infty_ℝ) q < diam (univ : set X) + 1 + diam (univ : set Y),
    { exact A p q hp hq h },
    { calc Hausdorff_dist (range (optimal_GH_injl X Y)) (range (optimal_GH_injr X Y))
               ≤ HD (candidates_b_dist X Y) :
             Hausdorff_dist_optimal_le_HD _ _ (candidates_b_dist_mem_candidates_b)
           ... ≤ diam (univ : set X) + 1 + diam (univ : set Y) : HD_candidates_b_dist_le
           ... ≤ Hausdorff_dist (p : set ℓ_infty_ℝ) q : not_lt.1 h } },
  refine le_antisymm _ _,
  { apply le_cInf,
    { refine (set.nonempty.prod _ _).image _; exact ⟨_, rfl⟩ },
    { rintro b ⟨⟨p, q⟩, ⟨hp, hq⟩, rfl⟩,
      exact B p q hp hq } },
  { exact GH_dist_le_Hausdorff_dist (isometry_optimal_GH_injl X Y) (isometry_optimal_GH_injr X Y) }
end

/-- The Gromov-Hausdorff distance can also be realized by a coupling in `ℓ^∞(ℝ)`, by embedding
the optimal coupling through its Kuratowski embedding. -/
theorem GH_dist_eq_Hausdorff_dist (X : Type u) [metric_space X] [compact_space X] [nonempty X]
  (Y : Type v) [metric_space Y] [compact_space Y] [nonempty Y] :
  ∃ Φ : X → ℓ_infty_ℝ, ∃ Ψ : Y → ℓ_infty_ℝ, isometry Φ ∧ isometry Ψ ∧
  GH_dist X Y = Hausdorff_dist (range Φ) (range Ψ) :=
begin
  let F := Kuratowski_embedding (optimal_GH_coupling X Y),
  let Φ := F ∘ optimal_GH_injl X Y,
  let Ψ := F ∘ optimal_GH_injr X Y,
  refine ⟨Φ, Ψ, _, _, _⟩,
  { exact (Kuratowski_embedding.isometry _).comp (isometry_optimal_GH_injl X Y) },
  { exact (Kuratowski_embedding.isometry _).comp (isometry_optimal_GH_injr X Y) },
  { rw [← image_univ, ← image_univ, image_comp F, image_univ, image_comp F (optimal_GH_injr X Y),
      image_univ, ← Hausdorff_dist_optimal],
    exact (Hausdorff_dist_image (Kuratowski_embedding.isometry _)).symm },
end

/-- The Gromov-Hausdorff distance defines a genuine distance on the Gromov-Hausdorff space. -/
instance : metric_space GH_space :=
{ dist := dist,
  dist_self := λ x, begin
    rcases exists_rep x with ⟨y, hy⟩,
    refine le_antisymm _ _,
    { apply cInf_le,
      { exact ⟨0, by { rintro b ⟨⟨u, v⟩, ⟨hu, hv⟩, rfl⟩, exact Hausdorff_dist_nonneg } ⟩},
      { simp only [mem_image, mem_prod, mem_set_of_eq, prod.exists],
        existsi [y, y],
        simpa only [and_self, Hausdorff_dist_self_zero, eq_self_iff_true, and_true]} },
    { apply le_cInf,
      { exact (nonempty.prod ⟨y, hy⟩ ⟨y, hy⟩).image _ },
      { rintro b ⟨⟨u, v⟩, ⟨hu, hv⟩, rfl⟩, exact Hausdorff_dist_nonneg } },
  end,
  dist_comm := λ x y, begin
    have A : (λ (p : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ),
                 Hausdorff_dist (p.1 : set ℓ_infty_ℝ) p.2) ''
             ({a | ⟦a⟧ = x} ×ˢ {b | ⟦b⟧ = y})
           = ((λ (p : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ),
                 Hausdorff_dist (p.1 : set ℓ_infty_ℝ) p.2) ∘ prod.swap) ''
                 ({a | ⟦a⟧ = x} ×ˢ {b | ⟦b⟧ = y}),
    { congr, funext, simp only [comp_app, prod.fst_swap, prod.snd_swap], rw Hausdorff_dist_comm },
    simp only [dist, A, image_comp, image_swap_prod],
  end,
  eq_of_dist_eq_zero := λ x y hxy, begin
    /- To show that two spaces at zero distance are isometric, we argue that the distance
    is realized by some coupling. In this coupling, the two spaces are at zero Hausdorff distance,
    i.e., they coincide. Therefore, the original spaces are isometric. -/
    rcases GH_dist_eq_Hausdorff_dist x.rep y.rep with ⟨Φ, Ψ, Φisom, Ψisom, DΦΨ⟩,
    rw [← dist_GH_dist, hxy] at DΦΨ,
    have : range Φ = range Ψ,
    { have hΦ : is_compact (range Φ) := is_compact_range Φisom.continuous,
      have hΨ : is_compact (range Ψ) := is_compact_range Ψisom.continuous,
      apply (is_closed.Hausdorff_dist_zero_iff_eq _ _ _).1 (DΦΨ.symm),
      { exact hΦ.is_closed },
      { exact hΨ.is_closed },
      { exact Hausdorff_edist_ne_top_of_nonempty_of_bounded (range_nonempty _)
          (range_nonempty _) hΦ.bounded hΨ.bounded } },
    have T : ((range Ψ) ≃ᵢ y.rep) = ((range Φ) ≃ᵢ y.rep), by rw this,
    have eΨ := cast T Ψisom.isometry_equiv_on_range.symm,
    have e := Φisom.isometry_equiv_on_range.trans eΨ,
    rw [← x.to_GH_space_rep, ← y.to_GH_space_rep, to_GH_space_eq_to_GH_space_iff_isometry_equiv],
    exact ⟨e⟩
  end,
  dist_triangle := λ x y z, begin
    /- To show the triangular inequality between `X`, `Y` and `Z`, realize an optimal coupling
    between `X` and `Y` in a space `γ1`, and an optimal coupling between `Y` and `Z` in a space
    `γ2`. Then, glue these metric spaces along `Y`. We get a new space `γ` in which `X` and `Y` are
    optimally coupled, as well as `Y` and `Z`. Apply the triangle inequality for the Hausdorff
    distance in `γ` to conclude. -/
    let X := x.rep,
    let Y := y.rep,
    let Z := z.rep,
    let γ1 := optimal_GH_coupling X Y,
    let γ2 := optimal_GH_coupling Y Z,
    let Φ : Y → γ1 := optimal_GH_injr X Y,
    have hΦ : isometry Φ := isometry_optimal_GH_injr X Y,
    let Ψ : Y → γ2 := optimal_GH_injl Y Z,
    have hΨ : isometry Ψ := isometry_optimal_GH_injl Y Z,
    let γ := glue_space hΦ hΨ,
    have Comm : (to_glue_l hΦ hΨ) ∘ (optimal_GH_injr X Y) =
      (to_glue_r hΦ hΨ) ∘ (optimal_GH_injl Y Z) := to_glue_commute hΦ hΨ,
    calc dist x z = dist (to_GH_space X) (to_GH_space Z) :
        by rw [x.to_GH_space_rep, z.to_GH_space_rep]
      ... ≤ Hausdorff_dist (range ((to_glue_l hΦ hΨ) ∘ (optimal_GH_injl X Y)))
                       (range ((to_glue_r hΦ hΨ) ∘ (optimal_GH_injr Y Z))) :
        GH_dist_le_Hausdorff_dist
          ((to_glue_l_isometry hΦ hΨ).comp (isometry_optimal_GH_injl X Y))
          ((to_glue_r_isometry hΦ hΨ).comp (isometry_optimal_GH_injr Y Z))
      ... ≤ Hausdorff_dist (range ((to_glue_l hΦ hΨ) ∘ (optimal_GH_injl X Y)))
                           (range ((to_glue_l hΦ hΨ) ∘ (optimal_GH_injr X Y)))
          + Hausdorff_dist (range ((to_glue_l hΦ hΨ) ∘ (optimal_GH_injr X Y)))
                           (range ((to_glue_r hΦ hΨ) ∘ (optimal_GH_injr Y Z))) :
        begin
          refine Hausdorff_dist_triangle (Hausdorff_edist_ne_top_of_nonempty_of_bounded
            (range_nonempty _) (range_nonempty _) _ _),
          { exact (is_compact_range (isometry.continuous ((to_glue_l_isometry hΦ hΨ).comp
              (isometry_optimal_GH_injl X Y)))).bounded },
          { exact (is_compact_range (isometry.continuous ((to_glue_l_isometry hΦ hΨ).comp
              (isometry_optimal_GH_injr X Y)))).bounded }
        end
      ... = Hausdorff_dist ((to_glue_l hΦ hΨ) '' (range (optimal_GH_injl X Y)))
                           ((to_glue_l hΦ hΨ) '' (range (optimal_GH_injr X Y)))
          + Hausdorff_dist ((to_glue_r hΦ hΨ) '' (range (optimal_GH_injl Y Z)))
                           ((to_glue_r hΦ hΨ) '' (range (optimal_GH_injr Y Z))) :
        by simp only [← range_comp, Comm, eq_self_iff_true, add_right_inj]
      ... = Hausdorff_dist (range (optimal_GH_injl X Y))
                           (range (optimal_GH_injr X Y))
          + Hausdorff_dist (range (optimal_GH_injl Y Z))
                           (range (optimal_GH_injr Y Z)) :
        by rw [Hausdorff_dist_image (to_glue_l_isometry hΦ hΨ),
               Hausdorff_dist_image (to_glue_r_isometry hΦ hΨ)]
      ... = dist (to_GH_space X) (to_GH_space Y) + dist (to_GH_space Y) (to_GH_space Z) :
        by rw [Hausdorff_dist_optimal, Hausdorff_dist_optimal, GH_dist, GH_dist]
      ... = dist x y + dist y z:
        by rw [x.to_GH_space_rep, y.to_GH_space_rep, z.to_GH_space_rep]
  end }

end GH_space --section
end Gromov_Hausdorff

/-- In particular, nonempty compacts of a metric space map to `GH_space`. We register this
in the topological_space namespace to take advantage of the notation `p.to_GH_space`. -/
definition topological_space.nonempty_compacts.to_GH_space {X : Type u} [metric_space X]
  (p : nonempty_compacts X) : Gromov_Hausdorff.GH_space := Gromov_Hausdorff.to_GH_space p

open topological_space

namespace Gromov_Hausdorff

section nonempty_compacts
variables {X : Type u} [metric_space X]

theorem GH_dist_le_nonempty_compacts_dist (p q : nonempty_compacts X) :
  dist p.to_GH_space q.to_GH_space ≤ dist p q :=
begin
  have ha : isometry (coe : p → X) := isometry_subtype_coe,
  have hb : isometry (coe : q → X) := isometry_subtype_coe,
  have A : dist p q = Hausdorff_dist (p : set X) q := rfl,
  have I : ↑p = range (coe : p → X) := subtype.range_coe_subtype.symm,
  have J : ↑q = range (coe : q → X) := subtype.range_coe_subtype.symm,
  rw [A, I, J],
  exact GH_dist_le_Hausdorff_dist ha hb
end

lemma to_GH_space_lipschitz :
  lipschitz_with 1 (nonempty_compacts.to_GH_space : nonempty_compacts X → GH_space) :=
lipschitz_with.mk_one GH_dist_le_nonempty_compacts_dist

lemma to_GH_space_continuous :
  continuous (nonempty_compacts.to_GH_space : nonempty_compacts X → GH_space) :=
to_GH_space_lipschitz.continuous

end nonempty_compacts

section
/- In this section, we show that if two metric spaces are isometric up to `ε₂`, then their
Gromov-Hausdorff distance is bounded by `ε₂ / 2`. More generally, if there are subsets which are
`ε₁`-dense and `ε₃`-dense in two spaces, and isometric up to `ε₂`, then the Gromov-Hausdorff
distance between the spaces is bounded by `ε₁ + ε₂/2 + ε₃`. For this, we construct a suitable
coupling between the two spaces, by gluing them (approximately) along the two matching subsets. -/

variables {X : Type u} [metric_space X] [compact_space X] [nonempty X]
          {Y : Type v} [metric_space Y] [compact_space Y] [nonempty Y]

-- we want to ignore these instances in the following theorem
local attribute [instance, priority 10] sum.topological_space sum.uniform_space
/-- If there are subsets which are `ε₁`-dense and `ε₃`-dense in two spaces, and
isometric up to `ε₂`, then the Gromov-Hausdorff distance between the spaces is bounded by
`ε₁ + ε₂/2 + ε₃`. -/
theorem GH_dist_le_of_approx_subsets {s : set X} (Φ : s → Y) {ε₁ ε₂ ε₃ : ℝ}
  (hs : ∀ x : X, ∃ y ∈ s, dist x y ≤ ε₁) (hs' : ∀ x : Y, ∃ y : s, dist x (Φ y) ≤ ε₃)
  (H : ∀ x y : s, |dist x y - dist (Φ x) (Φ y)| ≤ ε₂) :
  GH_dist X Y ≤ ε₁ + ε₂ / 2 + ε₃ :=
begin
  refine le_of_forall_pos_le_add (λ δ δ0, _),
  rcases exists_mem_of_nonempty X with ⟨xX, _⟩,
  rcases hs xX with ⟨xs, hxs, Dxs⟩,
  have sne : s.nonempty := ⟨xs, hxs⟩,
  letI : nonempty s := sne.to_subtype,
  have : 0 ≤ ε₂ := le_trans (abs_nonneg _) (H ⟨xs, hxs⟩ ⟨xs, hxs⟩),
  have : ∀ p q : s, |dist p q - dist (Φ p) (Φ q)| ≤ 2 * (ε₂/2 + δ) := λ p q, calc
    |dist p q - dist (Φ p) (Φ q)| ≤ ε₂ : H p q
    ... ≤ 2 * (ε₂/2 + δ) : by linarith,
  -- glue `X` and `Y` along the almost matching subsets
  letI : metric_space (X ⊕ Y) :=
    glue_metric_approx (λ x:s, (x:X)) (λ x, Φ x) (ε₂/2 + δ) (by linarith) this,
  let Fl := @sum.inl X Y,
  let Fr := @sum.inr X Y,
  have Il : isometry Fl := isometry.of_dist_eq (λ x y, rfl),
  have Ir : isometry Fr := isometry.of_dist_eq (λ x y, rfl),
  /- The proof goes as follows : the `GH_dist` is bounded by the Hausdorff distance of the images
  in the coupling, which is bounded (using the triangular inequality) by the sum of the Hausdorff
  distances of `X` and `s` (in the coupling or, equivalently in the original space), of `s` and
  `Φ s`, and of `Φ s` and `Y` (in the coupling or, equivalently, in the original space). The first
  term is bounded by `ε₁`, by `ε₁`-density. The third one is bounded by `ε₃`. And the middle one is
  bounded by `ε₂/2` as in the coupling the points `x` and `Φ x` are at distance `ε₂/2` by
  construction of the coupling (in fact `ε₂/2 + δ` where `δ` is an arbitrarily small positive
  constant where positivity is used to ensure that the coupling is really a metric space and not a
  premetric space on `X ⊕ Y`). -/
  have : GH_dist X Y ≤ Hausdorff_dist (range Fl) (range Fr) :=
    GH_dist_le_Hausdorff_dist Il Ir,
  have : Hausdorff_dist (range Fl) (range Fr) ≤ Hausdorff_dist (range Fl) (Fl '' s)
                                              + Hausdorff_dist (Fl '' s) (range Fr),
  { have B : bounded (range Fl) := (is_compact_range Il.continuous).bounded,
    exact Hausdorff_dist_triangle (Hausdorff_edist_ne_top_of_nonempty_of_bounded
      (range_nonempty _) (sne.image _) B (B.mono (image_subset_range _ _))) },
  have : Hausdorff_dist (Fl '' s) (range Fr) ≤ Hausdorff_dist (Fl '' s) (Fr '' (range Φ))
                                             + Hausdorff_dist (Fr '' (range Φ)) (range Fr),
  { have B : bounded (range Fr) := (is_compact_range Ir.continuous).bounded,
    exact Hausdorff_dist_triangle' (Hausdorff_edist_ne_top_of_nonempty_of_bounded
      ((range_nonempty _).image _) (range_nonempty _)
      (bounded.mono (image_subset_range _ _) B) B) },
  have : Hausdorff_dist (range Fl) (Fl '' s) ≤ ε₁,
  { rw [← image_univ, Hausdorff_dist_image Il],
    have : 0 ≤ ε₁ := le_trans dist_nonneg Dxs,
    refine Hausdorff_dist_le_of_mem_dist this (λ x hx, hs x)
      (λ x hx, ⟨x, mem_univ _, by simpa only [dist_self]⟩) },
  have : Hausdorff_dist (Fl '' s) (Fr '' (range Φ)) ≤ ε₂/2 + δ,
  { refine Hausdorff_dist_le_of_mem_dist (by linarith) _ _,
    { assume x' hx',
      rcases (set.mem_image _ _ _).1 hx' with ⟨x, ⟨x_in_s, xx'⟩⟩,
      rw ← xx',
      use [Fr (Φ ⟨x, x_in_s⟩), mem_image_of_mem Fr (mem_range_self _)],
      exact le_of_eq (glue_dist_glued_points (λ x:s, (x:X)) Φ (ε₂/2 + δ) ⟨x, x_in_s⟩) },
    { assume x' hx',
      rcases (set.mem_image _ _ _).1 hx' with ⟨y, ⟨y_in_s', yx'⟩⟩,
      rcases mem_range.1 y_in_s' with ⟨x, xy⟩,
      use [Fl x, mem_image_of_mem _ x.2],
      rw [← yx', ← xy, dist_comm],
      exact le_of_eq (glue_dist_glued_points (@subtype.val X s) Φ (ε₂/2 + δ) x) } },
  have : Hausdorff_dist (Fr '' (range Φ)) (range Fr) ≤ ε₃,
  { rw [← @image_univ _ _ Fr, Hausdorff_dist_image Ir],
    rcases exists_mem_of_nonempty Y with ⟨xY, _⟩,
    rcases hs' xY with ⟨xs', Dxs'⟩,
    have : 0 ≤ ε₃ := le_trans dist_nonneg Dxs',
    refine Hausdorff_dist_le_of_mem_dist this (λ x hx, ⟨x, mem_univ _, by simpa only [dist_self]⟩)
      (λ x _, _),
    rcases hs' x with ⟨y, Dy⟩,
    exact ⟨Φ y, mem_range_self _, Dy⟩ },
  linarith
end
end --section

/-- The Gromov-Hausdorff space is second countable. -/
instance : second_countable_topology GH_space :=
begin
  refine second_countable_of_countable_discretization (λ δ δpos, _),
  let ε := (2/5) * δ,
  have εpos : 0 < ε := mul_pos (by norm_num) δpos,
  have : ∀ p:GH_space, ∃ s : set p.rep, s.finite ∧ (univ ⊆ (⋃x∈s, ball x ε)) :=
    λ p, by simpa only [subset_univ, exists_true_left]
      using finite_cover_balls_of_compact is_compact_univ εpos,
  -- for each `p`, `s p` is a finite `ε`-dense subset of `p` (or rather the metric space
  -- `p.rep` representing `p`)
  choose s hs using this,
  have : ∀ p:GH_space, ∀ t:set p.rep, t.finite → ∃ n:ℕ, ∃ e:equiv t (fin n), true,
  { assume p t ht,
    letI : fintype t := finite.fintype ht,
    exact ⟨fintype.card t, fintype.equiv_fin t, trivial⟩ },
  choose N e hne using this,
  -- cardinality of the nice finite subset `s p` of `p.rep`, called `N p`
  let N := λ p:GH_space, N p (s p) (hs p).1,
  -- equiv from `s p`, a nice finite subset of `p.rep`, to `fin (N p)`, called `E p`
  let E := λ p:GH_space, e p (s p) (hs p).1,
  -- A function `F` associating to `p : GH_space` the data of all distances between points
  -- in the `ε`-dense set `s p`.
  let F : GH_space → Σn:ℕ, (fin n → fin n → ℤ) :=
    λp, ⟨N p, λa b, ⌊ε⁻¹ * dist ((E p).symm a) ((E p).symm b)⌋⟩,
  refine ⟨Σ n, fin n → fin n → ℤ, by apply_instance, F, λp q hpq, _⟩,
  /- As the target space of F is countable, it suffices to show that two points
  `p` and `q` with `F p = F q` are at distance `≤ δ`.
  For this, we construct a map `Φ` from `s p ⊆ p.rep` (representing `p`)
  to `q.rep` (representing `q`) which is almost an isometry on `s p`, and
  with image `s q`. For this, we compose the identification of `s p` with `fin (N p)`
  and the inverse of the identification of `s q` with `fin (N q)`. Together with
  the fact that `N p = N q`, this constructs `Ψ` between `s p` and `s q`, and then
  composing with the canonical inclusion we get `Φ`. -/
  have Npq : N p = N q := (sigma.mk.inj_iff.1 hpq).1,
  let Ψ : s p → s q := λ x, (E q).symm (fin.cast Npq ((E p) x)),
  let Φ : s p → q.rep := λ x, Ψ x,
  -- Use the almost isometry `Φ` to show that `p.rep` and `q.rep`
  -- are within controlled Gromov-Hausdorff distance.
  have main : GH_dist p.rep q.rep ≤ ε + ε/2 + ε,
  { refine GH_dist_le_of_approx_subsets Φ  _ _ _,
    show ∀ x : p.rep, ∃ (y : p.rep) (H : y ∈ s p), dist x y ≤ ε,
    { -- by construction, `s p` is `ε`-dense
      assume x,
      have : x ∈ ⋃y∈(s p), ball y ε := (hs p).2 (mem_univ _),
      rcases mem_Union₂.1 this with ⟨y, ys, hy⟩,
      exact ⟨y, ys, le_of_lt hy⟩ },
    show ∀ x : q.rep, ∃ (z : s p), dist x (Φ z) ≤ ε,
    { -- by construction, `s q` is `ε`-dense, and it is the range of `Φ`
      assume x,
      have : x ∈ ⋃y∈(s q), ball y ε := (hs q).2 (mem_univ _),
      rcases mem_Union₂.1 this with ⟨y, ys, hy⟩,
      let i : ℕ := E q ⟨y, ys⟩,
      let hi := ((E q) ⟨y, ys⟩).is_lt,
      have ihi_eq : (⟨i, hi⟩ : fin (N q)) = (E q) ⟨y, ys⟩, by rw [fin.ext_iff, fin.coe_mk],
      have hiq : i < N q := hi,
      have hip : i < N p, { rwa Npq.symm at hiq },
      let z := (E p).symm ⟨i, hip⟩,
      use z,
      have C1 : (E p) z = ⟨i, hip⟩ := (E p).apply_symm_apply ⟨i, hip⟩,
      have C2 : fin.cast Npq ⟨i, hip⟩ = ⟨i, hi⟩ := rfl,
      have C3 : (E q).symm ⟨i, hi⟩ = ⟨y, ys⟩,
      { rw ihi_eq, exact (E q).symm_apply_apply ⟨y, ys⟩ },
      have : Φ z = y,
      { simp only [Φ, Ψ], rw [C1, C2, C3], refl },
      rw this,
      exact le_of_lt hy },
    show ∀ x y : s p, |dist x y - dist (Φ x) (Φ y)| ≤ ε,
    { /- the distance between `x` and `y` is encoded in `F p`, and the distance between
      `Φ x` and `Φ y` (two points of `s q`) is encoded in `F q`, all this up to `ε`.
      As `F p = F q`, the distances are almost equal. -/
      assume x y,
      have : dist (Φ x) (Φ y) = dist (Ψ x) (Ψ y) := rfl,
      rw this,
      -- introduce `i`, that codes both `x` and `Φ x` in `fin (N p) = fin (N q)`
      let i : ℕ := E p x,
      have hip : i < N p := ((E p) x).2,
      have hiq : i < N q, by rwa Npq at hip,
      have i' : i = ((E q) (Ψ x)), by { simp only [equiv.apply_symm_apply, fin.coe_cast] },
      -- introduce `j`, that codes both `y` and `Φ y` in `fin (N p) = fin (N q)`
      let j : ℕ := E p y,
      have hjp : j < N p := ((E p) y).2,
      have hjq : j < N q, by rwa Npq at hjp,
      have j' : j = ((E q) (Ψ y)).1,
      { simp only [equiv.apply_symm_apply, fin.val_eq_coe, fin.coe_cast] },
      -- Express `dist x y` in terms of `F p`
      have : (F p).2 ((E p) x) ((E p) y) = floor (ε⁻¹ * dist x y),
        by simp only [F, (E p).symm_apply_apply],
      have Ap : (F p).2 ⟨i, hip⟩ ⟨j, hjp⟩ = floor (ε⁻¹ * dist x y),
        by { rw ← this, congr; apply fin.ext_iff.2; refl },
      -- Express `dist (Φ x) (Φ y)` in terms of `F q`
      have : (F q).2 ((E q) (Ψ x)) ((E q) (Ψ y)) = floor (ε⁻¹ * dist (Ψ x) (Ψ y)),
        by simp only [F, (E q).symm_apply_apply],
      have Aq : (F q).2 ⟨i, hiq⟩ ⟨j, hjq⟩ = floor (ε⁻¹ * dist (Ψ x) (Ψ y)),
        by { rw ← this, congr; apply fin.ext_iff.2; [exact i', exact j'] },
      -- use the equality between `F p` and `F q` to deduce that the distances have equal
      -- integer parts
      have : (F p).2 ⟨i, hip⟩ ⟨j, hjp⟩ = (F q).2 ⟨i, hiq⟩ ⟨j, hjq⟩,
      { -- we want to `subst hpq` where `hpq : F p = F q`, except that `subst` only works
        -- with a constant, so replace `F q` (and everything that depends on it) by a constant `f`
        -- then `subst`
        revert hiq hjq,
        change N q with (F q).1,
        generalize_hyp : F q = f at hpq ⊢,
        subst hpq,
        intros,
        refl },
      rw [Ap, Aq] at this,
      -- deduce that the distances coincide up to `ε`, by a straightforward computation
      -- that should be automated
      have I := calc
        |ε⁻¹| * |dist x y - dist (Ψ x) (Ψ y)| =
          |ε⁻¹ * (dist x y - dist (Ψ x) (Ψ y))| : (abs_mul _ _).symm
        ... = |(ε⁻¹ * dist x y) - (ε⁻¹ * dist (Ψ x) (Ψ y))| : by { congr, ring }
        ... ≤ 1 : le_of_lt (abs_sub_lt_one_of_floor_eq_floor this),
      calc
        |dist x y - dist (Ψ x) (Ψ y)| = (ε * ε⁻¹) * |dist x y - dist (Ψ x) (Ψ y)| :
          by rw [mul_inv_cancel (ne_of_gt εpos), one_mul]
        ... = ε * (|ε⁻¹| * |dist x y - dist (Ψ x) (Ψ y)|) :
          by rw [abs_of_nonneg (le_of_lt (inv_pos.2 εpos)), mul_assoc]
        ... ≤ ε * 1 : mul_le_mul_of_nonneg_left I (le_of_lt εpos)
        ... = ε : mul_one _ } },
  calc dist p q = GH_dist p.rep (q.rep) : dist_GH_dist p q
    ... ≤ ε + ε/2 + ε : main
    ... = δ : by { simp only [ε], ring }
end

/-- Compactness criterion: a closed set of compact metric spaces is compact if the spaces have
a uniformly bounded diameter, and for all `ε` the number of balls of radius `ε` required
to cover the spaces is uniformly bounded. This is an equivalence, but we only prove the
interesting direction that these conditions imply compactness. -/
lemma totally_bounded {t : set GH_space} {C : ℝ} {u : ℕ → ℝ} {K : ℕ → ℕ}
  (ulim : tendsto u at_top (𝓝 0))
  (hdiam : ∀ p ∈ t, diam (univ : set (GH_space.rep p)) ≤ C)
  (hcov : ∀ p ∈ t, ∀ n:ℕ, ∃ s : set (GH_space.rep p),
    cardinal.mk s ≤ K n ∧ univ ⊆ ⋃x∈s, ball x (u n)) :
  totally_bounded t :=
begin
  /- Let `δ>0`, and `ε = δ/5`. For each `p`, we construct a finite subset `s p` of `p`, which
  is `ε`-dense and has cardinality at most `K n`. Encoding the mutual distances of points in `s p`,
  up to `ε`, we will get a map `F` associating to `p` finitely many data, and making it possible to
  reconstruct `p` up to `ε`. This is enough to prove total boundedness. -/
  refine metric.totally_bounded_of_finite_discretization (λ δ δpos, _),
  let ε := (1/5) * δ,
  have εpos : 0 < ε := mul_pos (by norm_num) δpos,
  -- choose `n` for which `u n < ε`
  rcases metric.tendsto_at_top.1 ulim ε εpos with ⟨n, hn⟩,
  have u_le_ε : u n ≤ ε,
  { have := hn n le_rfl,
    simp only [real.dist_eq, add_zero, sub_eq_add_neg, neg_zero] at this,
    exact le_of_lt (lt_of_le_of_lt (le_abs_self _) this) },
  -- construct a finite subset `s p` of `p` which is `ε`-dense and has cardinal `≤ K n`
  have : ∀ p:GH_space, ∃ s : set p.rep, ∃ N ≤ K n, ∃ E : equiv s (fin N),
    p ∈ t → univ ⊆ ⋃x∈s, ball x (u n),
  { assume p,
    by_cases hp : p ∉ t,
    { have : nonempty (equiv (∅ : set p.rep) (fin 0)),
      { rw ← fintype.card_eq, simp only [empty_card', fintype.card_fin] },
      use [∅, 0, bot_le, choice (this)] },
    { rcases hcov _ (set.not_not_mem.1 hp) n with ⟨s, ⟨scard, scover⟩⟩,
      rcases cardinal.lt_aleph_0.1 (lt_of_le_of_lt scard (cardinal.nat_lt_aleph_0 _)) with ⟨N, hN⟩,
      rw [hN, cardinal.nat_cast_le] at scard,
      have : cardinal.mk s = cardinal.mk (fin N), by rw [hN, cardinal.mk_fin],
      cases quotient.exact this with E,
      use [s, N, scard, E],
      simp only [scover, implies_true_iff] } },
  choose s N hN E hs using this,
  -- Define a function `F` taking values in a finite type and associating to `p` enough data
  -- to reconstruct it up to `ε`, namely the (discretized) distances between elements of `s p`.
  let M := ⌊ε⁻¹ * max C 0⌋₊,
  let F : GH_space → (Σk:fin ((K n).succ), (fin k → fin k → fin (M.succ))) :=
    λ p, ⟨⟨N p, lt_of_le_of_lt (hN p) (nat.lt_succ_self _)⟩,
         λ a b, ⟨min M ⌊ε⁻¹ * dist ((E p).symm a) ((E p).symm b)⌋₊,
                ( min_le_left _ _).trans_lt (nat.lt_succ_self _) ⟩ ⟩,
  refine ⟨_, _, (λ p, F p), _⟩, apply_instance,
  -- It remains to show that if `F p = F q`, then `p` and `q` are `ε`-close
  rintros ⟨p, pt⟩ ⟨q, qt⟩ hpq,
  have Npq : N p = N q := fin.ext_iff.1 (sigma.mk.inj_iff.1 hpq).1,
  let Ψ : s p → s q := λ x, (E q).symm (fin.cast Npq ((E p) x)),
  let Φ : s p → q.rep := λ x, Ψ x,
  have main : GH_dist p.rep (q.rep) ≤ ε + ε/2 + ε,
  { -- to prove the main inequality, argue that `s p` is `ε`-dense in `p`, and `s q` is `ε`-dense
    -- in `q`, and `s p` and `s q` are almost isometric. Then closeness follows
    -- from `GH_dist_le_of_approx_subsets`
    refine GH_dist_le_of_approx_subsets Φ  _ _ _,
    show ∀ x : p.rep, ∃ (y : p.rep) (H : y ∈ s p), dist x y ≤ ε,
    { -- by construction, `s p` is `ε`-dense
      assume x,
      have : x ∈ ⋃y∈(s p), ball y (u n) := (hs p pt) (mem_univ _),
      rcases mem_Union₂.1 this with ⟨y, ys, hy⟩,
      exact ⟨y, ys, le_trans (le_of_lt hy) u_le_ε⟩ },
    show ∀ x : q.rep, ∃ (z : s p), dist x (Φ z) ≤ ε,
    { -- by construction, `s q` is `ε`-dense, and it is the range of `Φ`
      assume x,
      have : x ∈ ⋃y∈(s q), ball y (u n) := (hs q qt) (mem_univ _),
      rcases mem_Union₂.1 this with ⟨y, ys, hy⟩,
      let i : ℕ := E q ⟨y, ys⟩,
      let hi := ((E q) ⟨y, ys⟩).2,
      have ihi_eq : (⟨i, hi⟩ : fin (N q)) = (E q) ⟨y, ys⟩, by rw [fin.ext_iff, fin.coe_mk],
      have hiq : i < N q := hi,
      have hip : i < N p, { rwa Npq.symm at hiq },
      let z := (E p).symm ⟨i, hip⟩,
      use z,
      have C1 : (E p) z = ⟨i, hip⟩ := (E p).apply_symm_apply ⟨i, hip⟩,
      have C2 : fin.cast Npq ⟨i, hip⟩ = ⟨i, hi⟩ := rfl,
      have C3 : (E q).symm ⟨i, hi⟩ = ⟨y, ys⟩,
        by { rw ihi_eq, exact (E q).symm_apply_apply ⟨y, ys⟩ },
      have : Φ z = y :=
        by { simp only [Φ, Ψ], rw [C1, C2, C3], refl },
      rw this,
      exact le_trans (le_of_lt hy) u_le_ε },
    show ∀ x y : s p, |dist x y - dist (Φ x) (Φ y)| ≤ ε,
    { /- the distance between `x` and `y` is encoded in `F p`, and the distance between
      `Φ x` and `Φ y` (two points of `s q`) is encoded in `F q`, all this up to `ε`.
      As `F p = F q`, the distances are almost equal. -/
      assume x y,
      have : dist (Φ x) (Φ y) = dist (Ψ x) (Ψ y) := rfl,
      rw this,
      -- introduce `i`, that codes both `x` and `Φ x` in `fin (N p) = fin (N q)`
      let i : ℕ := E p x,
      have hip : i < N p := ((E p) x).2,
      have hiq : i < N q, by rwa Npq at hip,
      have i' : i = ((E q) (Ψ x)), by { simp only [equiv.apply_symm_apply, fin.coe_cast] },
      -- introduce `j`, that codes both `y` and `Φ y` in `fin (N p) = fin (N q)`
      let j : ℕ := E p y,
      have hjp : j < N p := ((E p) y).2,
      have hjq : j < N q, by rwa Npq at hjp,
      have j' : j = ((E q) (Ψ y)), by { simp only [equiv.apply_symm_apply, fin.coe_cast] },
      -- Express `dist x y` in terms of `F p`
      have Ap : ((F p).2 ⟨i, hip⟩ ⟨j, hjp⟩).1 = ⌊ε⁻¹ * dist x y⌋₊ := calc
        ((F p).2 ⟨i, hip⟩ ⟨j, hjp⟩).1 = ((F p).2 ((E p) x) ((E p) y)).1 :
          by { congr; apply fin.ext_iff.2; refl }
        ... = min M ⌊ε⁻¹ * dist x y⌋₊ :
          by simp only [F, (E p).symm_apply_apply]
        ... = ⌊ε⁻¹ * dist x y⌋₊ :
        begin
          refine min_eq_right (nat.floor_mono _),
          refine mul_le_mul_of_nonneg_left (le_trans _ (le_max_left _ _)) ((inv_pos.2 εpos).le),
          change dist (x : p.rep) y ≤ C,
          refine le_trans (dist_le_diam_of_mem is_compact_univ.bounded (mem_univ _) (mem_univ _)) _,
          exact hdiam p pt
        end,
      -- Express `dist (Φ x) (Φ y)` in terms of `F q`
      have Aq : ((F q).2 ⟨i, hiq⟩ ⟨j, hjq⟩).1 = ⌊ε⁻¹ * dist (Ψ x) (Ψ y)⌋₊ := calc
        ((F q).2 ⟨i, hiq⟩ ⟨j, hjq⟩).1 = ((F q).2 ((E q) (Ψ x)) ((E q) (Ψ y))).1 :
          by { congr; apply fin.ext_iff.2; [exact i', exact j'] }
        ... = min M ⌊ε⁻¹ * dist (Ψ x) (Ψ y)⌋₊ :
          by simp only [F, (E q).symm_apply_apply]
        ... = ⌊ε⁻¹ * dist (Ψ x) (Ψ y)⌋₊ :
        begin
          refine min_eq_right (nat.floor_mono _),
          refine mul_le_mul_of_nonneg_left (le_trans _ (le_max_left _ _)) ((inv_pos.2 εpos).le),
          change dist (Ψ x : q.rep) (Ψ y) ≤ C,
          refine le_trans (dist_le_diam_of_mem is_compact_univ.bounded (mem_univ _) (mem_univ _)) _,
          exact hdiam q qt
        end,
      -- use the equality between `F p` and `F q` to deduce that the distances have equal
      -- integer parts
      have : ((F p).2 ⟨i, hip⟩ ⟨j, hjp⟩).1 = ((F q).2 ⟨i, hiq⟩ ⟨j, hjq⟩).1,
      { -- we want to `subst hpq` where `hpq : F p = F q`, except that `subst` only works
        -- with a constant, so replace `F q` (and everything that depends on it) by a constant `f`
        -- then `subst`
        revert hiq hjq,
        change N q with (F q).1,
        generalize_hyp : F q = f at hpq ⊢,
        subst hpq,
        intros,
        refl },
      have : ⌊ε⁻¹ * dist x y⌋ = ⌊ε⁻¹ * dist (Ψ x) (Ψ y)⌋,
      { rw [Ap, Aq] at this,
        have D : 0 ≤ ⌊ε⁻¹ * dist x y⌋ :=
          floor_nonneg.2 (mul_nonneg (le_of_lt (inv_pos.2 εpos)) dist_nonneg),
        have D' : 0 ≤ ⌊ε⁻¹ * dist (Ψ x) (Ψ y)⌋ :=
          floor_nonneg.2 (mul_nonneg (le_of_lt (inv_pos.2 εpos)) dist_nonneg),
        rw [← int.to_nat_of_nonneg D, ← int.to_nat_of_nonneg D', int.floor_to_nat,int.floor_to_nat,
          this] },
      -- deduce that the distances coincide up to `ε`, by a straightforward computation
      -- that should be automated
      have I := calc
        |ε⁻¹| * |dist x y - dist (Ψ x) (Ψ y)| =
          |ε⁻¹ * (dist x y - dist (Ψ x) (Ψ y))| : (abs_mul _ _).symm
        ... = |(ε⁻¹ * dist x y) - (ε⁻¹ * dist (Ψ x) (Ψ y))| : by { congr, ring }
        ... ≤ 1 : le_of_lt (abs_sub_lt_one_of_floor_eq_floor this),
      calc
        |dist x y - dist (Ψ x) (Ψ y)| = (ε * ε⁻¹) * |dist x y - dist (Ψ x) (Ψ y)| :
          by rw [mul_inv_cancel (ne_of_gt εpos), one_mul]
        ... = ε * (|ε⁻¹| * |dist x y - dist (Ψ x) (Ψ y)|) :
          by rw [abs_of_nonneg (le_of_lt (inv_pos.2 εpos)), mul_assoc]
        ... ≤ ε * 1 : mul_le_mul_of_nonneg_left I (le_of_lt εpos)
        ... = ε : mul_one _ } },
  calc dist p q = GH_dist p.rep (q.rep) : dist_GH_dist p q
    ... ≤ ε + ε/2 + ε : main
    ... = δ/2 : by { simp only [ε, one_div], ring }
    ... < δ : half_lt_self δpos
end

section complete

/- We will show that a sequence `u n` of compact metric spaces satisfying
`dist (u n) (u (n+1)) < 1/2^n` converges, which implies completeness of the Gromov-Hausdorff space.
We need to exhibit the limiting compact metric space. For this, start from
a sequence `X n` of representatives of `u n`, and glue in an optimal way `X n` to `X (n+1)`
for all `n`, in a common metric space. Formally, this is done as follows.
Start from `Y 0 = X 0`. Then, glue `X 0` to `X 1` in an optimal way, yielding a space
`Y 1` (with an embedding of `X 1`). Then, consider an optimal gluing of `X 1` and `X 2`, and
glue it to `Y 1` along their common subspace `X 1`. This gives a new space `Y 2`, with an
embedding of `X 2`. Go on, to obtain a sequence of spaces `Y n`. Let `Z0` be the inductive
limit of the `Y n`, and finally let `Z` be the completion of `Z0`.
The images `X2 n` of `X n` in `Z` are at Hausdorff distance `< 1/2^n` by construction, hence they
form a Cauchy sequence for the Hausdorff distance. By completeness (of `Z`, and therefore of its
set of nonempty compact subsets), they converge to a limit `L`. This is the nonempty
compact metric space we are looking for.  -/

variables (X : ℕ → Type) [∀ n, metric_space (X n)] [∀ n, compact_space (X n)] [∀ n, nonempty (X n)]

/-- Auxiliary structure used to glue metric spaces below, recording an isometric embedding
of a type `A` in another metric space. -/
structure aux_gluing_struct (A : Type) [metric_space A] : Type 1 :=
(space  : Type)
(metric : metric_space space)
(embed  : A → space)
(isom   : isometry embed)

local attribute [instance] aux_gluing_struct.metric

instance (A : Type) [metric_space A] : inhabited (aux_gluing_struct A) :=
⟨{ space := A,
  metric := by apply_instance,
  embed := id,
  isom := λ x y, rfl }⟩

/-- Auxiliary sequence of metric spaces, containing copies of `X 0`, ..., `X n`, where each
`X i` is glued to `X (i+1)` in an optimal way. The space at step `n+1` is obtained from the space
at step `n` by adding `X (n+1)`, glued in an optimal way to the `X n` already sitting there. -/
def aux_gluing (n : ℕ) : aux_gluing_struct (X n) :=
nat.rec_on n default $ λ n Y,
  { space  := glue_space Y.isom (isometry_optimal_GH_injl (X n) (X (n+1))),
    metric := by apply_instance,
    embed  := (to_glue_r Y.isom (isometry_optimal_GH_injl (X n) (X (n+1))))
              ∘ (optimal_GH_injr (X n) (X (n+1))),
    isom   := (to_glue_r_isometry _ _).comp (isometry_optimal_GH_injr (X n) (X (n+1))) }

/-- The Gromov-Hausdorff space is complete. -/
instance : complete_space GH_space :=
begin
  have : ∀ (n : ℕ), 0 < ((1:ℝ) / 2) ^ n, by { apply pow_pos, norm_num },
  -- start from a sequence of nonempty compact metric spaces within distance `1/2^n` of each other
  refine metric.complete_of_convergent_controlled_sequences (λ n, (1/2)^n) this (λ u hu, _),
  -- `X n` is a representative of `u n`
  let X := λ n, (u n).rep,
  -- glue them together successively in an optimal way, getting a sequence of metric spaces `Y n`
  let Y := aux_gluing X,
  -- this equality is true by definition but Lean unfolds some defs in the wrong order
  have E : ∀ n : ℕ,
    glue_space (Y n).isom (isometry_optimal_GH_injl (X n) (X (n + 1))) = (Y (n + 1)).space :=
    λ n, by { dsimp only [Y, aux_gluing], refl },
  let c := λ n, cast (E n),
  have ic : ∀ n, isometry (c n) := λ n x y, by { dsimp only [Y, aux_gluing], exact rfl },
  -- there is a canonical embedding of `Y n` in `Y (n+1)`, by construction
  let f : Π n, (Y n).space → (Y (n + 1)).space :=
    λ n, c n ∘ to_glue_l (Y n).isom (isometry_optimal_GH_injl (X n) (X n.succ)),
  have I : ∀ n, isometry (f n) := λ n, (ic n).comp (to_glue_l_isometry _ _),
  -- consider the inductive limit `Z0` of the `Y n`, and then its completion `Z`
  let Z0 := metric.inductive_limit I,
  let Z := uniform_space.completion Z0,
  let Φ := to_inductive_limit I,
  let coeZ := (coe : Z0 → Z),
  -- let `X2 n` be the image of `X n` in the space `Z`
  let X2 := λ n, range (coeZ ∘ (Φ n) ∘ (Y n).embed),
  have isom : ∀ n, isometry (coeZ ∘ (Φ n) ∘ (Y n).embed),
  { assume n,
    refine uniform_space.completion.coe_isometry.comp _,
    exact (to_inductive_limit_isometry _ _).comp (Y n).isom },
  -- The Hausdorff distance of `X2 n` and `X2 (n+1)` is by construction the distance between
  -- `u n` and `u (n+1)`, therefore bounded by `1/2^n`
  have D2 : ∀ n, Hausdorff_dist (X2 n) (X2 n.succ) < (1/2)^n,
  { assume n,
    have X2n : X2 n = range ((coeZ ∘ (Φ n.succ) ∘ (c n)
      ∘ (to_glue_r (Y n).isom (isometry_optimal_GH_injl (X n) (X n.succ))))
      ∘ (optimal_GH_injl (X n) (X n.succ))),
    { change X2 n = range (coeZ ∘ (Φ n.succ) ∘ (c n)
        ∘ (to_glue_r (Y n).isom (isometry_optimal_GH_injl (X n) (X n.succ)))
        ∘ (optimal_GH_injl (X n) (X n.succ))),
      simp only [X2, Φ],
      rw [← to_inductive_limit_commute I],
      simp only [f],
      rw ← to_glue_commute },
    rw range_comp at X2n,
    have X2nsucc : X2 n.succ = range ((coeZ ∘ (Φ n.succ) ∘ (c n)
      ∘ (to_glue_r (Y n).isom (isometry_optimal_GH_injl (X n) (X n.succ))))
      ∘ (optimal_GH_injr (X n) (X n.succ))), by refl,
    rw range_comp at X2nsucc,
    rw [X2n, X2nsucc, Hausdorff_dist_image, Hausdorff_dist_optimal, ← dist_GH_dist],
    { exact hu n n n.succ (le_refl n) (le_succ n) },
    { apply uniform_space.completion.coe_isometry.comp _,
      exact (to_inductive_limit_isometry _ _).comp ((ic n).comp (to_glue_r_isometry _ _)) } },
  -- consider `X2 n` as a member `X3 n` of the type of nonempty compact subsets of `Z`, which
  -- is a metric space
  let X3 : ℕ → nonempty_compacts Z := λ n,
    ⟨⟨X2 n, is_compact_range (isom n).continuous⟩, range_nonempty _⟩,
  -- `X3 n` is a Cauchy sequence by construction, as the successive distances are
  -- bounded by `(1/2)^n`
  have : cauchy_seq X3,
  { refine cauchy_seq_of_le_geometric (1/2) 1 (by norm_num) (λ n, _),
    rw one_mul,
    exact le_of_lt (D2 n) },
  -- therefore, it converges to a limit `L`
  rcases cauchy_seq_tendsto_of_complete this with ⟨L, hL⟩,
  -- the images of `X3 n` in the Gromov-Hausdorff space converge to the image of `L`
  have M : tendsto (λ n, (X3 n).to_GH_space) at_top (𝓝 L.to_GH_space) :=
    tendsto.comp (to_GH_space_continuous.tendsto _) hL,
  -- By construction, the image of `X3 n` in the Gromov-Hausdorff space is `u n`.
  have : ∀ n, (X3 n).to_GH_space = u n,
  { assume n,
    rw [nonempty_compacts.to_GH_space, ← (u n).to_GH_space_rep,
        to_GH_space_eq_to_GH_space_iff_isometry_equiv],
    constructor,
    convert (isom n).isometry_equiv_on_range.symm, },
  -- Finally, we have proved the convergence of `u n`
  exact ⟨L.to_GH_space, by simpa only [this] using M⟩
end

end complete--section

end Gromov_Hausdorff --namespace


import category_theory.category.default
import category_theory.isomorphism

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

variables (C : Type u) [category.{v} C]

--rewrite this

/-
# Category world

## Level 1: Isomorphisms

An isomorphism `f : X ⟶ Y` is a morphism for which there exists a morphism `g : Y ⟶ X`, such that `f ≫ g = 𝟙 X` and `g ≫ f = 𝟙 Y`.
-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are morphisms such that $$f = g$$, then $$f ≫ h = g ≫ h$$.
-/
lemma cancel_right_iso' {X Y Z : C} (f : X ⟶ Y) [is_iso f] {g h : Y ⟶ Z} : (f ≫ g = f ≫ h) ↔ g = h :=
begin
    split,

    intro hyp,
    rw ← category.id_comp g,
    rw ← category.id_comp h,
    rw ← is_iso.inv_hom_id f,
    rw category.assoc,
    rw hyp,
    rw category.assoc,

    intro hyp,
    rw hyp,
end

end category_theory


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import linear_algebra.finite_dimensional
import geometry.manifold.smooth_manifold_with_corners
import analysis.inner_product_space.pi_L2

/-!
# Constructing examples of manifolds over ℝ

We introduce the necessary bits to be able to define manifolds modelled over `ℝ^n`, boundaryless
or with boundary or with corners. As a concrete example, we construct explicitly the manifold with
boundary structure on the real interval `[x, y]`.

More specifically, we introduce
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)` for the model space
  used to define `n`-dimensional real manifolds with boundary
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n)` for the model space used
  to define `n`-dimensional real manifolds with corners

## Notations

In the locale `manifold`, we introduce the notations
* `𝓡 n` for the identity model with corners on `euclidean_space ℝ (fin n)`
* `𝓡∂ n` for `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)`.

For instance, if a manifold `M` is boundaryless, smooth and modelled on `euclidean_space ℝ (fin m)`,
and `N` is smooth with boundary modelled on `euclidean_half_space n`, and `f : M → N` is a smooth
map, then the derivative of `f` can be written simply as `mfderiv (𝓡 m) (𝓡∂ n) f` (as to why the
model with corners can not be implicit, see the discussion in `smooth_manifold_with_corners.lean`).

## Implementation notes

The manifold structure on the interval `[x, y] = Icc x y` requires the assumption `x < y` as a
typeclass. We provide it as `[fact (x < y)]`.
-/

noncomputable theory
open set function
open_locale manifold
local attribute [instance] fact_one_le_two_real

/--
The half-space in `ℝ^n`, used to model manifolds with boundary. We only define it when
`1 ≤ n`, as the definition only makes sense in this case.
-/
def euclidean_half_space (n : ℕ) [has_zero (fin n)] : Type :=
{x : euclidean_space ℝ (fin n) // 0 ≤ x 0}

/--
The quadrant in `ℝ^n`, used to model manifolds with corners, made of all vectors with nonnegative
coordinates.
-/
def euclidean_quadrant (n : ℕ) : Type := {x : euclidean_space ℝ (fin n) // ∀i:fin n, 0 ≤ x i}

section
/- Register class instances for euclidean half-space and quadrant, that can not be noticed
without the following reducibility attribute (which is only set in this section). -/
local attribute [reducible] euclidean_half_space euclidean_quadrant
variable {n : ℕ}

instance [has_zero (fin n)] : topological_space (euclidean_half_space n) := by apply_instance
instance : topological_space (euclidean_quadrant n) := by apply_instance
instance [has_zero (fin n)] : inhabited (euclidean_half_space n) := ⟨⟨0, le_refl _⟩⟩
instance : inhabited (euclidean_quadrant n) := ⟨⟨0, λ i, le_refl _⟩⟩

lemma range_half_space (n : ℕ) [has_zero (fin n)] :
  range (λx : euclidean_half_space n, x.val) = {y | 0 ≤ y 0} :=
by simp

lemma range_quadrant (n : ℕ) :
  range (λx : euclidean_quadrant n, x.val) = {y | ∀i:fin n, 0 ≤ y i} :=
by simp

end

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_half_space n)`, used as
a model for manifolds with boundary. In the locale `manifold`, use the shortcut `𝓡∂ n`.
-/
def model_with_corners_euclidean_half_space (n : ℕ) [has_zero (fin n)] :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨update x 0 (max (x 0) 0), by simp [le_refl]⟩,
  source      := univ,
  target      := {x | 0 ≤ x 0},
  map_source' := λx hx, x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, begin
    rw [subtype.mk_eq_mk, update_eq_iff],
    exact ⟨max_eq_left xprop, λ i _, rfl⟩
  end,
  right_inv'  := λx hx, update_eq_iff.2 ⟨max_eq_left hx, λ i _, rfl⟩,
  source_eq    := rfl,
  unique_diff' :=
    have this : unique_diff_on ℝ _ :=
      unique_diff_on.pi (fin n) (λ _, ℝ) _ _ (λ i ∈ ({0} : set (fin n)), unique_diff_on_Ici 0),
    by simpa only [singleton_pi] using this,
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_id.update 0 $
    (continuous_apply 0).max continuous_const }

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_quadrant n)`, used as a
model for manifolds with corners -/
def model_with_corners_euclidean_quadrant (n : ℕ) :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨λi, max (x i) 0, λi, by simp only [le_refl, or_true, le_max_iff]⟩,
  source      := univ,
  target      := {x | ∀ i, 0 ≤ x i},
  map_source' := λx hx, by simpa only [subtype.range_val] using x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, by { ext i, simp only [subtype.coe_mk, xprop i, max_eq_left] },
  right_inv' := λ x hx, by { ext1 i, simp only [hx i, max_eq_left] },
  source_eq    := rfl,
  unique_diff' :=
    have this : unique_diff_on ℝ _ :=
      unique_diff_on.univ_pi (fin n) (λ _, ℝ) _ (λ i, unique_diff_on_Ici 0),
    by simpa only [pi_univ_Ici] using this,
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_pi $ λ i,
    (continuous_id.max continuous_const).comp (continuous_apply i) }

localized "notation `𝓡 `n := model_with_corners_self ℝ (euclidean_space ℝ (fin n))" in manifold
localized "notation `𝓡∂ `n := model_with_corners_euclidean_half_space n" in manifold

/--
The left chart for the topological space `[x, y]`, defined on `[x,y)` and sending `x` to `0` in
`euclidean_half_space 1`.
-/
def Icc_left_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | z.val < y},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, z.val - x, sub_nonneg.mpr z.property.1⟩,
  inv_fun     := λz, ⟨min (z.val 0 + x) y, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y))]⟩,
  map_source' := by simp only [imp_self, sub_lt_sub_iff_right, mem_set_of_eq, forall_true_iff],
  map_target' :=
    by { simp only [min_lt_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, min_eq_left, sub_add_cancel]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x + z 0 ≤ y, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, add_comm, add_sub_cancel', min_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | z < y} := is_open_Iio,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), z - x) :=
      continuous.sub (continuous_pi $ λi, continuous_id) continuous_const,
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, min (z + x) y) :=
      (continuous_id.add continuous_const).min continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
The right chart for the topological space `[x, y]`, defined on `(x,y]` and sending `y` to `0` in
`euclidean_half_space 1`.
-/
def Icc_right_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | x < z.val},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, y - z.val, sub_nonneg.mpr z.property.2⟩,
  inv_fun     := λz,
    ⟨max (y - z.val 0) x, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y)), sub_eq_add_neg]⟩,
  map_source' := by simp only [imp_self, mem_set_of_eq, sub_lt_sub_iff_left, forall_true_iff],
  map_target' :=
    by { simp only [lt_max_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, sub_eq_add_neg, max_eq_left, add_add_neg_cancel'_right, neg_add_rev, neg_neg]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x ≤ y - z 0, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, sub_sub_cancel, max_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | x < z} := is_open_Ioi,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), y - z) :=
      continuous_const.sub (continuous_pi (λi, continuous_id)),
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, max (y - z) x) :=
      (continuous_const.sub continuous_id).max continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
Charted space structure on `[x, y]`, using only two charts taking values in
`euclidean_half_space 1`.
-/
instance Icc_manifold (x y : ℝ) [fact (x < y)] : charted_space (euclidean_half_space 1) (Icc x y) :=
{ atlas := {Icc_left_chart x y, Icc_right_chart x y},
  chart_at := λz, if z.val < y then Icc_left_chart x y else Icc_right_chart x y,
  mem_chart_source := λz, begin
    by_cases h' : z.val < y,
    { simp only [h', if_true],
      exact h' },
    { simp only [h', if_false],
      apply lt_of_lt_of_le (fact.out (x < y)),
      simpa only [not_lt] using h'}
  end,
  chart_mem_atlas := λz, by { by_cases h' : z.val < y; simp [h'] } }

/--
The manifold structure on `[x, y]` is smooth.
-/
instance Icc_smooth_manifold (x y : ℝ) [fact (x < y)] :
  smooth_manifold_with_corners (𝓡∂ 1) (Icc x y) :=
begin
  have M : times_cont_diff_on ℝ ∞ (λz : euclidean_space ℝ (fin 1), - z + (λi, y - x)) univ,
  { rw times_cont_diff_on_univ,
    exact times_cont_diff_id.neg.add times_cont_diff_const },
  apply smooth_manifold_with_corners_of_times_cont_diff_on,
  assume e e' he he',
  simp only [atlas, mem_singleton_iff, mem_insert_iff] at he he',
  /- We need to check that any composition of two charts gives a `C^∞` function. Each chart can be
  either the left chart or the right chart, leaving 4 possibilities that we handle successively.
  -/
  rcases he with rfl | rfl; rcases he' with rfl | rfl,
  { -- `e = left chart`, `e' = left chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 },
  { -- `e = left chart`, `e' = right chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨⟨z, hz₀⟩, rfl⟩⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      update_same, max_eq_left, hz₀, lt_sub_iff_add_lt] with mfld_simps at hz₁ hz₂,
    rw [min_eq_left hz₁.le, lt_add_iff_pos_left] at hz₂,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, *,
      pi_Lp.add_apply, pi_Lp.neg_apply, max_eq_left, min_eq_left hz₁.le, update_same]
      with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = left chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨z, hz₀⟩, rfl⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, max_lt_iff,
      update_same, max_eq_left hz₀] with mfld_simps at hz₁ hz₂,
    rw lt_sub at hz₁,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      pi_Lp.add_apply, pi_Lp.neg_apply, update_same, max_eq_left, hz₀, hz₁.le] with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = right chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 }
end

/-! Register the manifold structure on `Icc 0 1`, and also its zero and one. -/
section

lemma fact_zero_lt_one : fact ((0 : ℝ) < 1) := ⟨zero_lt_one⟩

local attribute [instance] fact_zero_lt_one

instance : charted_space (euclidean_half_space 1) (Icc (0 : ℝ) 1) := by apply_instance
instance : smooth_manifold_with_corners (𝓡∂ 1) (Icc (0 : ℝ) 1) := by apply_instance

end


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Anne Baanen
-/
import algebra.big_operators.finsupp
import algebra.floor
import algebraic_number_theory.class_number.admissible_absolute_value
import algebraic_number_theory.function_field
import algebraic_number_theory.number_field
import data.polynomial.field_division
import group_theory.quotient_group
import linear_algebra.determinant
import linear_algebra.free_module
import linear_algebra.matrix
import ring_theory.class_group
import ring_theory.dedekind_domain
import ring_theory.fractional_ideal
import algebraic_number_theory.class_number.det
import algebraic_number_theory.class_number.integral_closure

/-!
# Class numbers of global fields

In this file, we use the notion of "admissible absolute value" to prove
finiteness of the class group for number fields and function fields,
and define `class_number` as the order of this group.

## Main definitions

 - `class_group.fintype_of_admissible`: if `R` has an admissible absolute value,
   its integral closure has a finite class group
 - `number_field.class_number`: the class number of a number field is the (finite)
   cardinality of the class group of its ring of integers
 - `function_field.class_number`: the class number of a number field is the (finite)
   cardinality of the class group of its ring of integers
-/

namespace class_group

open ring

open_locale big_operators

section euclidean_domain

variables {R K L : Type*} [euclidean_domain R] [field K] [field L]
variables (f : fraction_map R K)
variables [algebra f.codomain L] [finite_dimensional f.codomain L] [is_separable f.codomain L]
variables [algebra R L] [is_scalar_tower R f.codomain L]

variables (L)

lemma integral_closure.dim_pos : 0 < integral_closure.dim L f :=
by { rw [← fintype.card_fin (integral_closure.dim L f), fintype.card_pos_iff],
     exact is_basis.nonempty_of_nontrivial (integral_closure.is_basis L f) }

/-- If `a : integral_closure R L` has coordinates `≤ y`, `norm a ≤ norm_bound L f abs * y ^ n`. -/
noncomputable def norm_bound (abs : absolute_value R ℤ) : ℤ :=
let n := integral_closure.dim L f,
    h : 0 < integral_closure.dim L f := integral_closure.dim_pos L f,
    m : ℤ := finset.max' (finset.univ.image (λ (ijk : fin _ × fin _ × fin _),
        abs (matrix.lmul
               (integral_closure.is_basis L f)
               (integral_closure.basis L f ijk.1)
               ijk.2.1
               ijk.2.2)))
        ⟨_, finset.mem_image.mpr ⟨⟨⟨0, h⟩, ⟨0, h⟩, ⟨0, h⟩⟩, finset.mem_univ _, rfl⟩⟩
in nat.factorial n • (n • m) ^ n

lemma norm_bound_pos (abs : absolute_value R ℤ) : 0 < norm_bound L f abs :=
begin
  obtain ⟨i, j, k, hijk⟩ : ∃ i j k,
    matrix.lmul (integral_closure.is_basis L f) (integral_closure.basis L f i) j k ≠ 0,
  { by_contra h,
    push_neg at h,
    apply (integral_closure.is_basis L f).ne_zero ⟨0, integral_closure.dim_pos L f⟩,
    apply (matrix.lmul _).injective_iff.mp (matrix.lmul_injective (integral_closure.is_basis L f)),
    ext j k,
    rw [h, matrix.zero_apply] },
  simp only [norm_bound, algebra.smul_def, ring_hom.eq_nat_cast, int.nat_cast_eq_coe_nat],
  apply mul_pos (int.coe_nat_pos.mpr (nat.factorial_pos _)),
  apply pow_pos (mul_pos (int.coe_nat_pos.mpr (integral_closure.dim_pos L f)) _),
  apply lt_of_lt_of_le (abs.pos hijk) (finset.le_max' _ _ _),
  exact finset.mem_image.mpr ⟨⟨i, j, k⟩, finset.mem_univ _, rfl⟩
end

lemma norm_bound_ne_zero (abs : absolute_value R ℤ) : norm_bound L f abs ≠ 0 :=
ne_of_gt (norm_bound_pos L f abs)

lemma norm_le (a : integral_closure R L) {abs : absolute_value R ℤ}
  {y : ℤ} (hy : ∀ k, abs ((integral_closure.is_basis L f).repr a k) ≤ y) :
  abs_norm f abs a ≤ norm_bound L f abs * y ^ (integral_closure.dim L f) :=
begin
  conv_lhs { rw ← sum_repr (integral_closure.is_basis L f) a },
  unfold abs_norm algebra.norm norm_bound,
  rw [monoid_hom.coe_mk, matrix.to_matrix_lmul_eq],
  simp only [alg_hom.map_sum, alg_hom.map_smul],
  convert det_sum_le finset.univ _ hy;
    try { simp only [finset.card_univ, fintype.card_fin] },
  { rw [algebra.smul_mul_assoc, ← mul_pow _ _ (integral_closure.dim L f)],
    conv_lhs { rw algebra.smul_mul_assoc } },
  { intros i j k,
    apply finset.le_max',
    exact finset.mem_image.mpr ⟨⟨i, j, k⟩, finset.mem_univ _, rfl⟩ },
end

lemma norm_lt {S : Type*} [linear_ordered_comm_ring S]
  (a : integral_closure R L) {abs : absolute_value R ℤ}
  {y : S} (hy : ∀ k, (abs ((integral_closure.is_basis L f).repr a k) : S) < y) :
  (abs_norm f abs a : S) < norm_bound L f abs * y ^ (integral_closure.dim L f) :=
begin
  have h : 0 < integral_closure.dim L f := integral_closure.dim_pos L f,
  have him : (finset.univ.image (λ k, abs ((integral_closure.is_basis L f).repr a k))).nonempty :=
    ⟨_, finset.mem_image.mpr ⟨⟨0, h⟩, finset.mem_univ _, rfl⟩⟩,
  set y' : ℤ := finset.max' _ him with y'_def,
  have hy' : ∀ k, abs ((integral_closure.is_basis L f).repr a k) ≤ y',
  { intro k,
    exact finset.le_max' _ _ (finset.mem_image.mpr ⟨k, finset.mem_univ _, rfl⟩) },
  have : (y' : S) < y,
  { rw [y'_def, finset.map_max' (show monotone (coe : ℤ → S), from λ x y h, int.cast_le.mpr h)],
    apply finset.max'_lt _ (him.image _),
    simp only [finset.mem_image, exists_prop],
    rintros _ ⟨x, ⟨k, -, rfl⟩, rfl⟩,
    exact hy k },
  have y'_nonneg : 0 ≤ y' := le_trans (abs.nonneg _) (hy' ⟨0, h⟩),
  apply lt_of_le_of_lt (int.cast_le.mpr (norm_le L f a hy')),
  simp only [int.cast_mul, int.cast_pow],
  apply mul_lt_mul' (le_refl _),
  { exact pow_lt_pow_of_lt_left this (int.cast_nonneg.mpr y'_nonneg) h },
  { exact pow_nonneg (int.cast_nonneg.mpr y'_nonneg) _ },
  { exact int.cast_pos.mpr (norm_bound_pos L f abs) },
  { apply_instance }
end

section

variables (L)
variables (abs : admissible_absolute_value R)

open admissible_absolute_value

include L f abs

/-- The `M` from the proof of thm 5.4.

Should really be `abs.card (nat.ceil_nth_root _ _)`, but nth_root _ x ≤ x so this works too.
-/
noncomputable def cardM : ℕ :=
(abs.card (norm_bound L f abs ^ (-1 / (integral_closure.dim L f) : ℝ)))^(integral_closure.dim L f)

variables [infinite R]

/-- In the following results, we need a large set of distinct elements of `R`. -/
noncomputable def distinct_elems : fin (cardM L f abs).succ ↪ R :=
function.embedding.trans (fin.coe_embedding _).to_embedding (infinite.nat_embedding R)

/-- `finset_approx` is a finite set such that each fractional ideal in the integral closure
contains an element close to `finset_approx`. -/
noncomputable def finset_approx [decidable_eq R] : finset R :=
((finset.univ.product finset.univ)
  .image (λ (xy : fin _ × fin _), distinct_elems L f abs xy.1 - distinct_elems L f abs xy.2))
  .erase 0

lemma finset_approx.zero_not_mem [decidable_eq R] : (0 : R) ∉ finset_approx L f abs :=
finset.not_mem_erase _ _

@[simp] lemma mem_finset_approx [decidable_eq R] {x : R} :
  x ∈ finset_approx L f abs ↔
  ∃ i j, i ≠ j ∧ distinct_elems L f abs i - distinct_elems L f abs j = x :=
begin
  simp only [finset_approx, finset.mem_erase, finset.mem_image],
  split,
  { rintros ⟨hx, ⟨i, j⟩, _, rfl⟩,
    refine ⟨i, j, _, rfl⟩,
    rintro rfl,
    simpa using hx },
  { rintros ⟨i, j, hij, rfl⟩,
    refine ⟨_, ⟨i, j⟩, finset.mem_product.mpr ⟨finset.mem_univ _, finset.mem_univ _⟩, rfl⟩,
    rw [ne.def, sub_eq_zero],
    exact λ h, hij ((distinct_elems L f abs).injective h) }
end

section

open real

local attribute [-instance] real.decidable_eq

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finset_approx [decidable_eq R]
  (a : integral_closure R L) {b} (hb : b ≠ (0 : R)) :
  ∃ (q : integral_closure R L) (r ∈ finset_approx L f abs),
    abs_norm f abs (r • a - b • q) < abs_norm f abs (algebra_map R (integral_closure R L) b) :=
begin
  set ε : ℝ := norm_bound L f abs ^ (-1 / (integral_closure.dim L f) : ℝ) with ε_eq,
  have hε : 0 < ε := real.rpow_pos_of_pos (int.cast_pos.mpr (norm_bound_pos L f abs)) _,
  have ε_le : (norm_bound L f abs : ℝ) * (abs b • ε) ^ integral_closure.dim L f ≤
                (abs b ^ integral_closure.dim L f),
  { have := integral_closure.dim_pos L f,
    have := norm_bound_pos L f abs,
    have := abs.nonneg b,
    rw [ε_eq, algebra.smul_def, ring_hom.eq_int_cast, ← rpow_nat_cast, mul_rpow, ← rpow_mul,
        div_mul_cancel, rpow_neg_one, mul_left_comm, mul_inv_cancel, mul_one, rpow_nat_cast];
      try { norm_cast, linarith },
    { apply rpow_nonneg_of_nonneg,
      norm_cast,
      linarith } },
  let μ : fin (cardM L f abs).succ ↪ R := distinct_elems L f abs,
  set s := (integral_closure.is_basis L f).repr a,
  have s_eq : ∀ i, s i = (integral_closure.is_basis L f).repr a i := λ i, rfl,
  set qs := λ j i, (μ j * s i) / b,
  have q_eq : ∀ j i, qs j i = (μ j * s i) / b := λ i j, rfl,
  set rs := λ j i, (μ j * s i) % b with r_eq,
  have r_eq : ∀ j i, rs j i = (μ j * s i) % b := λ i j, rfl,
  set c := integral_closure.basis L f,
  have c_eq : ∀ i, c i = integral_closure.basis L f i := λ i, rfl,
  have μ_eq : ∀ i j, μ j * s i = b * qs j i + rs j i,
  { intros i j,
    rw [q_eq, r_eq, euclidean_domain.div_add_mod], },
  have μ_mul_a_eq : ∀ j, μ j • a = b • ∑ i, qs j i • c i + ∑ i, rs j i • c i,
  { intro j,
    rw ← sum_repr (integral_closure.is_basis L f) a,
    simp only [finset.smul_sum, ← finset.sum_add_distrib],
    refine finset.sum_congr rfl (λ i _, _),
    rw [← c_eq, ← s_eq, ← mul_smul, μ_eq, add_smul, mul_smul] },

  obtain ⟨j, k, j_ne_k, hjk⟩ :=
    abs.exists_approx (integral_closure.dim L f) hε hb (λ j i, μ j * s i),
  have hjk' : ∀ i, (abs (rs k i - rs j i) : ℝ) < abs b • ε,
  { simpa only [r_eq] using hjk },
  set q := ∑ i, (qs k i - qs j i) • c i with q_eq,
  set r := μ k - μ j with r_eq,
  refine ⟨q, r, (mem_finset_approx L f abs).mpr _, _⟩,
  { exact ⟨k, j, j_ne_k.symm, rfl⟩ },
  have : r • a - b • q = (∑ (x : fin (integral_closure.dim L f)), (rs k x • c x - rs j x • c x)),
  { simp only [r_eq, sub_smul, μ_mul_a_eq, q_eq, finset.smul_sum, ← finset.sum_add_distrib,
               ← finset.sum_sub_distrib, smul_sub],
    refine finset.sum_congr rfl (λ x _, _),
    ring },
  rw [this, abs_norm_algebra_map],

  refine int.cast_lt.mp (lt_of_lt_of_le (norm_lt L f _ (λ i, lt_of_le_of_lt _ (hjk' i))) _),
  { apply le_of_eq,
    congr,
    simp_rw [linear_map.map_sum, linear_map.map_sub, linear_map.map_smul,
             finset.sum_apply', finsupp.sub_apply, finsupp.smul_apply',
             finset.sum_sub_distrib, is_basis.repr_self_apply, smul_eq_mul, mul_boole,
             finset.sum_ite_eq', finset.mem_univ, if_true] },
  { exact_mod_cast ε_le },
end

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finset_approx' [decidable_eq R]
  (a : integral_closure R L) {b} (hb : b ≠ (0 : integral_closure R L)) :
  ∃ (q : integral_closure R L) (r ∈ finset_approx L f abs),
  abs_norm f abs (r • a - q * b) < abs_norm f abs b :=
begin
  obtain ⟨a', b', hb', h⟩ := exists_eq_mul f a b hb,
  obtain ⟨q, r, hr, hqr⟩ := exists_mem_finset_approx L f abs a' hb',
  refine ⟨q, r, hr, _⟩,
  apply lt_of_mul_lt_mul_left _
    (show 0 ≤ abs_norm f abs (algebra_map R (integral_closure R L) b'), from abs.nonneg _),
  refine lt_of_le_of_lt (le_of_eq _) (mul_lt_mul hqr (le_refl (abs_norm f abs b))
    (abs.pos ((algebra.norm_ne_zero _).mpr hb)) (abs.nonneg _)),
  rw [← abs_norm_mul, ← abs_norm_mul, ← algebra.smul_def, smul_sub b', sub_mul, smul_comm, h,
      mul_comm b a', algebra.smul_mul_assoc r a' b, algebra.smul_mul_assoc b' q b]
end

end

end

end euclidean_domain

lemma monoid_hom.range_eq_top {G H : Type*} [group G] [group H] (f : G →* H) :
  f.range = ⊤ ↔ function.surjective f :=
⟨ λ h y, show y ∈ f.range, from h.symm ▸ subgroup.mem_top y,
  λ h, subgroup.ext (λ x, by simp [h x]) ⟩

section euclidean_domain

variables {R K L : Type*} [euclidean_domain R]
variables [field K] [field L]
variables (f : fraction_map R K)
variables [algebra f.codomain L]
variables [algebra R L] [is_scalar_tower R f.codomain L]
variables (abs : admissible_absolute_value R)

/-- A nonzero ideal has an element of minimal norm. -/
lemma exists_min [finite_dimensional f.codomain L] [is_separable f.codomain L]
  (I : nonzero_ideal (integral_closure R L)) :
  ∃ b ∈ I.1, b ≠ 0 ∧ ∀ c ∈ I.1, abs_norm f abs c < abs_norm f abs b → c = 0 :=
begin
  haveI := classical.dec_eq L,
  obtain ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩, min⟩ :=
    @int.exists_least_of_bdd (λ a, ∃ b ∈ I.1, b ≠ 0 ∧ abs_norm f abs b = a) _ _,
  { use [b, b_mem, b_ne_zero],
    intros c hc lt,
    by_contra c_ne_zero,
    exact not_le_of_gt lt (min _ ⟨c, hc, c_ne_zero, rfl⟩) },
  { use 0,
    rintros _ ⟨b, b_mem, b_ne_zero, rfl⟩,
    apply abs.nonneg },
  { obtain ⟨b, b_mem, b_ne_zero⟩ := I.1.ne_bot_iff.mp I.2,
    exact ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩⟩ }
end

lemma is_scalar_tower.algebra_map_injective {R S T : Type*}
  [comm_semiring R] [comm_semiring S] [comm_semiring T]
  [algebra R S] [algebra S T] [algebra R T]
  [is_scalar_tower R S T]
  (hRS : function.injective (algebra_map R S)) (hST : function.injective (algebra_map S T)) :
  function.injective (algebra_map R T) :=
by { rw is_scalar_tower.algebra_map_eq R S T, exact hST.comp hRS }

lemma subalgebra.algebra_map_injective {R S : Type*} [comm_semiring R] [comm_semiring S]
  [algebra R S] (A : subalgebra R S) (h : function.injective (algebra_map R S)) :
  function.injective (algebra_map R A) :=
begin
  intros x y hxy,
  apply h,
  simp only [is_scalar_tower.algebra_map_apply R A S],
  exact congr_arg (coe : A → S) hxy
end

lemma integral_closure.algebra_map_injective :
  function.injective (algebra_map R (integral_closure R L)) :=
(subalgebra.algebra_map_injective _
  (is_scalar_tower.algebra_map_injective
    (show function.injective (algebra_map R f.codomain), from f.injective)
    (algebra_map f.codomain L).injective))

lemma cancel_monoid_with_zero.dvd_of_mul_dvd_mul_left {G₀ : Type*} [cancel_monoid_with_zero G₀]
  {a b c : G₀} (ha : a ≠ 0) (h : a * b ∣ a * c) :
  b ∣ c :=
begin
  obtain ⟨d, hd⟩ := h,
  refine ⟨d, mul_left_cancel' ha _⟩,
  rwa mul_assoc at hd
end

lemma ideal.dvd_of_mul_dvd_mul_left {R : Type*} [integral_domain R] [is_dedekind_domain R]
  {I J K : ideal R} (hI : I ≠ ⊥)
  (h : I * J ∣ I * K) :
  J ∣ K :=
cancel_monoid_with_zero.dvd_of_mul_dvd_mul_left hI h

lemma ideal.span_singleton_ne_bot {R : Type*} [comm_ring R] {a : R} (ha : a ≠ 0) :
  ideal.span ({a} : set R) ≠ ⊥ :=
begin
  rw [ne.def, ideal.span_eq_bot],
  push_neg,
  exact ⟨a, set.mem_singleton a, ha⟩
end

lemma finset.dvd_prod {ι M : Type*} [comm_monoid M] {x : ι} {s : finset ι}
  (hx : x ∈ s) (f : ι → M) :
  f x ∣ ∏ i in s, f i :=
multiset.dvd_prod (multiset.mem_map.mpr ⟨x, hx, rfl⟩)

lemma prod_finset_approx_ne_zero
  [finite_dimensional f.codomain L] [is_separable f.codomain L] [infinite R] [decidable_eq R] :
  algebra_map R (integral_closure R L) (∏ m in finset_approx L f abs, m) ≠ 0 :=
begin
  refine mt ((algebra_map R _).injective_iff.mp (integral_closure.algebra_map_injective f) _) _,
  simp only [finset.prod_eq_zero_iff, not_exists],
  rintros x hx rfl,
  exact finset_approx.zero_not_mem L f abs hx
end

lemma ne_zero_of_dvd_prod_finset_approx
  [finite_dimensional f.codomain L] [is_separable f.codomain L] [infinite R] [decidable_eq R]
  (J : ideal (integral_closure R L))
  (h : J ∣ ideal.span {algebra_map _ _ (∏ m in finset_approx L f abs, m)}) :
  J ≠ 0 :=
begin
  simp only [ne.def, ideal.zero_eq_bot, submodule.eq_bot_iff, not_forall, not_imp],
  refine ⟨(algebra_map _ _) (∏ (m : R) in finset_approx L f abs, m), _, _⟩,
  { exact ideal.le_of_dvd h (ideal.subset_span (set.mem_singleton _)) },
  apply prod_finset_approx_ne_zero
end

/-- Each class in the class group contains an ideal `J`
such that the product of `finset_approx.prod` is in `J`. -/
theorem exists_mk0_eq_mk0 [finite_dimensional f.codomain L] [is_separable f.codomain L]
  [infinite R] [decidable_eq R] (I : nonzero_ideal (integral_closure R L))
  [is_dedekind_domain (integral_closure R L)] :
  ∃ (J : nonzero_ideal (integral_closure R L)),
  class_group.mk0 (integral_closure.fraction_map_of_finite_extension L f) I =
  class_group.mk0 (integral_closure.fraction_map_of_finite_extension L f) J ∧
    J.1 ∣ ideal.span {algebra_map _ _ (∏ m in finset_approx L f abs, m)} :=
begin
  set m := ∏ m in finset_approx L f abs, m with m_eq,
  have hm : algebra_map R (integral_closure R L) m ≠ 0 := prod_finset_approx_ne_zero f abs,
  obtain ⟨b, b_mem, b_ne_zero, b_min⟩ := exists_min f abs I,
  suffices : ideal.span {b} ∣ ideal.span {algebra_map _ _ m} * I.1,
  { obtain ⟨J, hJ⟩ := this,
    refine ⟨⟨J, _⟩, _, _⟩,
    { rintro rfl,
      rw [ideal.mul_bot, ideal.mul_eq_bot] at hJ,
      exact I.2 (hJ.resolve_left (mt ideal.span_singleton_eq_bot.mp hm)) },
    { rw class_group.mk0_eq_mk0_iff,
      exact ⟨algebra_map _ _ m, b, hm, b_ne_zero, hJ⟩ },
    apply ideal.dvd_of_mul_dvd_mul_left (ideal.span_singleton_ne_bot b_ne_zero),
    rw [ideal.dvd_iff_le, ← hJ, mul_comm, m_eq],
    apply ideal.mul_mono le_rfl,
    rw [ideal.span_le, set.singleton_subset_iff],
    exact b_mem },
  rw [ideal.dvd_iff_le, ideal.mul_le],
  intros r' hr' a ha,
  rw ideal.mem_span_singleton at ⊢ hr',
  obtain ⟨q, r, r_mem, lt⟩ := exists_mem_finset_approx' L f abs a b_ne_zero,
  apply @dvd_of_mul_left_dvd _ _ q,
  simp only [algebra.smul_def] at lt,
  rw ← sub_eq_zero.mp (b_min _ (I.1.sub_mem (I.1.mul_mem_left _ ha) (I.1.mul_mem_left _ b_mem)) lt),
  refine mul_dvd_mul_right (dvd_trans (ring_hom.map_dvd _ _) hr') _,
  exact finset.dvd_prod r_mem (λ x, x)
end

variables (L)

/-- `class_group.mk_dvd` is a specialization of `class_group.mk0` to (the finite set of)
ideals that contain `∏ m in finset_approx L f abs, m` -/
noncomputable def mk_dvd [finite_dimensional f.codomain L] [is_separable f.codomain L]
  [infinite R] [decidable_eq R] [is_dedekind_domain (integral_closure R L)]
  (J : {J : ideal (integral_closure R L) // J ∣
    ideal.span {algebra_map _ _ (∏ m in finset_approx L f abs, m)}}) :
  class_group (integral_closure.fraction_map_of_finite_extension L f) :=
class_group.mk0 _ ⟨J.1, ne_zero_of_dvd_prod_finset_approx f abs J.1 J.2⟩

lemma mk_dvd_surjective
  [finite_dimensional f.codomain L] [is_separable f.codomain L]
  [infinite R] [decidable_eq R] [is_dedekind_domain (integral_closure R L)] :
  function.surjective (class_group.mk_dvd L f abs) :=
begin
  intro I',
  obtain ⟨⟨I, hI⟩, rfl⟩ := class_group.mk0_surjective _ I',
  obtain ⟨J, mk0_eq_mk0, J_dvd⟩ := exists_mk0_eq_mk0 f abs ⟨I, hI⟩,
  exact ⟨⟨J, J_dvd⟩, mk0_eq_mk0.symm⟩
end

include abs

/-- The main theorem: the class group of an integral closure is finite.

Requires you to provide an "admissible absolute value", see `admissible_absolute_value.lean`
for a few constructions of those.
-/
noncomputable def finite_of_admissible [infinite R]
  [finite_dimensional f.codomain L] [is_separable f.codomain L]
  [is_dedekind_domain (integral_closure R L)] :
  fintype (class_group (integral_closure.fraction_map_of_finite_extension L f)) :=
begin
  haveI := classical.dec_eq (class_group (integral_closure.fraction_map_of_finite_extension L f)),
  haveI := classical.dec_eq R,
  refine @fintype.of_surjective _ _ _
       (ideal.finite_divisors _ _)
       (class_group.mk_dvd L f abs)
       (class_group.mk_dvd_surjective L f abs),
  rw [ne.def, ideal.span_singleton_eq_bot],
  exact prod_finset_approx_ne_zero f abs
end

end euclidean_domain

section integral_domain

variables {R K : Type*} [integral_domain R] [field K] (f : fraction_map R K)

end integral_domain

end class_group

namespace number_field

variables (K : Type*) [field K] [is_number_field K]

namespace ring_of_integers

open fraction_map
local attribute [class] algebra.is_algebraic

noncomputable instance : fintype (class_group (ring_of_integers.fraction_map K)) :=
class_group.finite_of_admissible K int.fraction_map int.admissible_abs

end ring_of_integers

/-- The class number of a number field is the (finite) cardinality of the class group. -/
noncomputable def class_number : ℕ := fintype.card (class_group (ring_of_integers.fraction_map K))

variables {K}

/-- The class number of a number field is `1` iff the ring of integers is a PID. -/
theorem class_number_eq_one_iff :
  class_number K = 1 ↔ is_principal_ideal_ring (ring_of_integers K) :=
card_class_group_eq_one_iff _

end number_field

namespace rat

open number_field

theorem class_number : number_field.class_number ℚ = 1 :=
class_number_eq_one_iff.mpr $ is_principal_ideal_ring.of_surjective _
  (rat.ring_of_integers_equiv.symm : ℤ ≃+* ring_of_integers ℚ).surjective

end rat

namespace function_field_over

variables {K L : Type*} [field K] [fintype K] [field L] (f : fraction_map (polynomial K) L)
variables (F : Type*) [field F] [algebra f.codomain F] [function_field_over f F]
variables [decidable_eq K] [is_separable f.codomain F]

namespace ring_of_integers

open function_field_over

noncomputable instance : fintype (class_group (ring_of_integers.fraction_map f F)) :=
class_group.finite_of_admissible F f polynomial.admissible_card_pow_degree

end ring_of_integers

/-- The class number in a function field is the (finite) cardinality of the class group. -/
noncomputable def class_number : ℕ := fintype.card (class_group (ring_of_integers.fraction_map f F))

/-- The class number of a function field is `1` iff the ring of integers is a PID. -/
theorem class_number_eq_one_iff :
  class_number f F = 1 ↔ is_principal_ideal_ring (ring_of_integers f F) :=
card_class_group_eq_one_iff _

end function_field_over