/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.closeds
import set_theory.cardinal
import topology.metric_space.gromov_hausdorff_realized
import topology.metric_space.completion
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 topological_space
universes u v w

open classical set function topological_space filter metric quotient
open bounded_continuous_function nat 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 definition isometry_rel :
  nonempty_compacts ℓ_infty_ℝ → nonempty_compacts ℓ_infty_ℝ → Prop :=
  λx y, nonempty (x.val ≃ᵢ y.val)

/-- This is indeed an equivalence relation -/
private lemma is_equivalence_isometry_rel : equivalence isometry_rel :=
⟨λx, ⟨isometric.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 (α : Type u) [metric_space α] [compact_space α] [nonempty α] : GH_space :=
  ⟦nonempty_compacts.Kuratowski_embedding α⟧

instance : inhabited GH_space := ⟨quot.mk _ ⟨{0}, by simp⟩⟩

/-- A metric space representative of any abstract point in `GH_space` -/
definition GH_space.rep (p : GH_space) : Type := (quot.out p).val

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

lemma eq_to_GH_space {p : nonempty_compacts ℓ_infty_ℝ} : ⟦p⟧ = to_GH_space p.val :=
begin
 refine eq_to_GH_space_iff.2 ⟨((λx, x) : p.val → ℓ_infty_ℝ), _, subtype.range_coe⟩,
 apply isometry_subtype_coe
end

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).val = 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. -/
lemma to_GH_space_eq_to_GH_space_iff_isometric {α : Type u} [metric_space α] [compact_space α]
  [nonempty α] {β : Type u} [metric_space β] [compact_space β] [nonempty β] :
  to_GH_space α = to_GH_space β ↔ nonempty (α ≃ᵢ β) :=
⟨begin
  simp only [to_GH_space, quotient.eq],
  assume h,
  rcases h with ⟨e⟩,
  have I : ((nonempty_compacts.Kuratowski_embedding α).val ≃ᵢ
             (nonempty_compacts.Kuratowski_embedding β).val)
          = ((range (Kuratowski_embedding α)) ≃ᵢ (range (Kuratowski_embedding β))),
    by { dunfold nonempty_compacts.Kuratowski_embedding, refl },
  have e' := cast I e,
  have f := (Kuratowski_embedding.isometry α).isometric_on_range,
  have g := (Kuratowski_embedding.isometry β).isometric_on_range.symm,
  have h := (f.trans e').trans g,
  exact ⟨h⟩
end,
begin
  rintros ⟨e⟩,
  simp only [to_GH_space, quotient.eq],
  have f := (Kuratowski_embedding.isometry α).isometric_on_range.symm,
  have g := (Kuratowski_embedding.isometry β).isometric_on_range,
  have h := (f.trans e).trans g,
  have I : ((range (Kuratowski_embedding α)) ≃ᵢ (range (Kuratowski_embedding β))) =
    ((nonempty_compacts.Kuratowski_embedding α).val ≃ᵢ
      (nonempty_compacts.Kuratowski_embedding β).val),
    by { dunfold nonempty_compacts.Kuratowski_embedding, refl },
  have h' := cast I h,
  exact ⟨h'⟩
end⟩

/-- 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.val p.2.val) '' (set.prod {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 (α : Type u) (β : Type v) [metric_space α] [nonempty α] [compact_space α]
  [metric_space β] [nonempty β] [compact_space β] : ℝ := dist (to_GH_space α) (to_GH_space β)

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 {α : Type u} [metric_space α] [compact_space α] [nonempty α]
  {β : Type v} [metric_space β] [compact_space β] [nonempty β]
  {γ : Type w} [metric_space γ] {Φ : α → γ} {Ψ : β → γ} (ha : isometry Φ) (hb : isometry Ψ) :
  GH_dist α β ≤ 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 `α` and `β` in `γ`, which is
  separable and therefore embeddable in `ℓ^∞(ℝ)`. -/
  rcases exists_mem_of_nonempty α with ⟨xα, _⟩,
  let s : set γ := (range Φ) ∪ (range Ψ),
  let Φ' : α → subtype s := λy, ⟨Φ y, mem_union_left _ (mem_range_self _)⟩,
  let Ψ' : β → 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 (compact_range ha.continuous).union (compact_range hb.continuous),
  letI : metric_space (subtype s) := by apply_instance,
  haveI : compact_space (subtype s) := ⟨compact_iff_compact_univ.1 ‹is_compact s›⟩,
  haveI : nonempty (subtype s) := ⟨Φ' xα⟩,
  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 `α` and `β` 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 Φ'), ⟨(range_nonempty _).image _,
      (compact_range IΦ'.continuous).image (Kuratowski_embedding.isometry _).continuous⟩⟩,
  let B : nonempty_compacts ℓ_infty_ℝ := ⟨F '' (range Ψ'), ⟨(range_nonempty _).image _,
      (compact_range IΨ'.continuous).image (Kuratowski_embedding.isometry _).continuous⟩⟩,
  have Aα : ⟦A⟧ = to_GH_space α,
  { rw eq_to_GH_space_iff,
    exact ⟨λx, F (Φ' x), ⟨(Kuratowski_embedding.isometry _).comp IΦ', by rw range_comp⟩⟩ },
  have Bβ : ⟦B⟧ = to_GH_space β,
  { rw eq_to_GH_space_iff,
    exact ⟨λx, F (Ψ' x), ⟨(Kuratowski_embedding.isometry _).comp IΨ', by rw range_comp⟩⟩ },
  refine cInf_le ⟨0,
    begin simp [lower_bounds], assume t _ _ _ _ ht, rw ← ht, exact Hausdorff_dist_nonneg end⟩ _,
  apply (mem_image _ _ _).2,
  existsi (⟨A, B⟩ : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ),
  simp [Aα, Bβ]
end

/-- The optimal coupling constructed above realizes exactly the Gromov-Hausdorff distance,
essentially by design. -/
lemma Hausdorff_dist_optimal {α : Type u} [metric_space α] [compact_space α] [nonempty α]
  {β : Type v} [metric_space β] [compact_space β] [nonempty β] :
  Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β)) = GH_dist α β :=
begin
  inhabit α, inhabit β,
  /- 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 `α ⊕ β` 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 α → ⟦q⟧ = to_GH_space β →
        Hausdorff_dist (p.val) (q.val) < diam (univ : set α) + 1 + diam (univ : set β) →
        Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β)) ≤
        Hausdorff_dist (p.val) (q.val),
  { 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 α) + 1 + 2 * diam (univ : set β),
    { rcases exists_mem_of_nonempty α with ⟨xα, _⟩,
      have : ∃y ∈ range Ψ, dist (Φ xα) y < diam (univ : set α) + 1 + diam (univ : set β),
      { rw Ψrange,
        have : Φ xα ∈ p.val := Φrange ▸ mem_range_self _,
        exact exists_dist_lt_of_Hausdorff_dist_lt this bound
          (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.2.1 q.2.1 p.2.2.bounded q.2.2.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 α) := Φisom.diam_range,
      have DΨ : diam (range Ψ) = diam (univ : set β) := Ψisom.diam_range,
      calc
        diam (range Φ ∪ range Ψ) ≤ diam (range Φ) + dist (Φ xα) (Ψ z) + diam (range Ψ) :
          diam_union (mem_range_self _) (mem_range_self _)
        ... ≤ diam (univ : set α) + (diam (univ : set α) + 1 + diam (univ : set β)) +
              diam (univ : set β) :
          by { rw [DΦ, DΨ], apply add_le_add (add_le_add (le_refl _) (le_of_lt dy)) (le_refl _) }
        ... = 2 * diam (univ : set α) + 1 + 2 * diam (univ : set β) : by ring },

    let f : α ⊕ β → ℓ_infty_ℝ := λx, match x with | inl y := Φ y | inr z := Ψ z end,
    let F : (α ⊕ β) × (α ⊕ β) → ℝ := λp, dist (f p.1) (f p.2),
    -- check that the induced "distance" is a candidate
    have Fgood : F ∈ candidates α β,
    { 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 : α ⊕ β, 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.2.2.union q.2.2).bounded,
        end
        ... ≤ 2 * diam (univ : set α) + 1 + 2 * diam (univ : set β) : I } },
    let Fb := candidates_b_of_candidates F Fgood,
    have : Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β)) ≤ 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 : α, (⨅ y, Fb (inl x, inr y)) ≤ r,
    { assume x,
      have : f (inl x) ∈ p.val, by { rw [← Φrange], apply mem_range_self },
      rcases exists_dist_lt_of_Hausdorff_dist_lt this hr
        (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.2.1 q.2.1 p.2.2.bounded q.2.2.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 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 : β, (⨅ x, Fb (inl x, inr y)) ≤ r,
    { assume y,
      have : f (inr y) ∈ q.val, by { rw [← Ψrange], apply mem_range_self },
      rcases exists_dist_lt_of_Hausdorff_dist_lt' this hr
        (Hausdorff_edist_ne_top_of_nonempty_of_bounded p.2.1 q.2.1 p.2.2.bounded q.2.2.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 using HD_below_aux2 0) x
        ... = dist (Φ x) (Ψ y) : rfl
        ... = dist z (f (inr y)) : by rw hx
        ... ≤ r : le_of_lt hz },
    simp [HD, csupr_le I1, csupr_le I2] },
  /- 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 α → ⟦q⟧ = to_GH_space β →
        Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β)) ≤
        Hausdorff_dist (p.val) (q.val),
  { assume p q hp hq,
    by_cases h : Hausdorff_dist (p.val) (q.val) < diam (univ : set α) + 1 + diam (univ : set β),
    { exact A p q hp hq h },
    { calc Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β))
               ≤ HD (candidates_b_dist α β) :
             Hausdorff_dist_optimal_le_HD _ _ (candidates_b_dist_mem_candidates_b)
           ... ≤ diam (univ : set α) + 1 + diam (univ : set β) : HD_candidates_b_dist_le
           ... ≤ Hausdorff_dist (p.val) (q.val) : 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 α β) (isometry_optimal_GH_injr α β) }
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 (α : Type u) [metric_space α] [compact_space α] [nonempty α]
  (β : Type v) [metric_space β] [compact_space β] [nonempty β] :
  ∃Φ : α → ℓ_infty_ℝ, ∃Ψ : β → ℓ_infty_ℝ, isometry Φ ∧ isometry Ψ ∧
  GH_dist α β = Hausdorff_dist (range Φ) (range Ψ) :=
begin
  let F := Kuratowski_embedding (optimal_GH_coupling α β),
  let Φ := F ∘ optimal_GH_injl α β,
  let Ψ := F ∘ optimal_GH_injr α β,
  refine ⟨Φ, Ψ, _, _, _⟩,
  { exact (Kuratowski_embedding.isometry _).comp (isometry_optimal_GH_injl α β) },
  { exact (Kuratowski_embedding.isometry _).comp (isometry_optimal_GH_injr α β) },
  { rw [← image_univ, ← image_univ, image_comp F, image_univ, image_comp F (optimal_GH_injr α β),
      image_univ, ← Hausdorff_dist_optimal],
    exact (Hausdorff_dist_image (Kuratowski_embedding.isometry _)).symm },
end

-- without the next two lines, `{ exact hΦ.is_closed }` in the next
-- proof is very slow, as the `t2_space` instance is very hard to find
local attribute [instance, priority 10] order_topology.t2_space
local attribute [instance, priority 10] order_closed_topology.to_t2_space

/-- The Gromov-Hausdorff distance defines a genuine distance on the Gromov-Hausdorff space. -/
instance GH_space_metric_space : metric_space GH_space :=
{ 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, existsi [y, y], simpa } },
    { 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.fst).val) ((p.snd).val)) ''
             (set.prod {a | ⟦a⟧ = x} {b | ⟦b⟧ = y})
           = ((λ (p : nonempty_compacts ℓ_infty_ℝ × nonempty_compacts ℓ_infty_ℝ),
                 Hausdorff_dist ((p.fst).val) ((p.snd).val)) ∘ prod.swap) ''
                 (set.prod {a | ⟦a⟧ = x} {b | ⟦b⟧ = y}) :=
      by { congr, funext, simp, 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 Φ) := compact_range Φisom.continuous,
      have hΨ : is_compact (range Ψ) := compact_range Ψisom.continuous,
      apply (Hausdorff_dist_zero_iff_eq_of_closed _ _ _).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.isometric_on_range.symm,
    have e := Φisom.isometric_on_range.trans eΨ,
    rw [← x.to_GH_space_rep, ← y.to_GH_space_rep, to_GH_space_eq_to_GH_space_iff_isometric],
    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Ψ,
    letI : metric_space γ := metric.metric_space_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 (compact_range (isometry.continuous ((to_glue_l_isometry hΦ hΨ).comp
              (isometry_optimal_GH_injl X Y)))).bounded },
          { exact (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 {α : Type u} [metric_space α]
  (p : nonempty_compacts α) : Gromov_Hausdorff.GH_space := Gromov_Hausdorff.to_GH_space p.val

open topological_space

namespace Gromov_Hausdorff

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

theorem GH_dist_le_nonempty_compacts_dist (p q : nonempty_compacts α) :
  dist p.to_GH_space q.to_GH_space ≤ dist p q :=
begin
  have ha : isometry (coe : p.val → α) := isometry_subtype_coe,
  have hb : isometry (coe : q.val → α) := isometry_subtype_coe,
  have A : dist p q = Hausdorff_dist p.val q.val := rfl,
  have I : p.val = range (coe : p.val → α), by simp,
  have J : q.val = range (coe : q.val → α), by simp,
  rw [I, J] at A,
  rw A,
  exact GH_dist_le_Hausdorff_dist ha hb
end

lemma to_GH_space_lipschitz :
  lipschitz_with 1 (nonempty_compacts.to_GH_space : nonempty_compacts α → 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 α → 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 {α : Type u} [metric_space α] [compact_space α] [nonempty α]
          {β : Type v} [metric_space β] [compact_space β] [nonempty β]

-- 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 α} (Φ : s → β) {ε₁ ε₂ ε₃ : ℝ}
  (hs : ∀x : α, ∃y ∈ s, dist x y ≤ ε₁) (hs' : ∀x : β, ∃y : s, dist x (Φ y) ≤ ε₃)
  (H : ∀x y : s, abs (dist x y - dist (Φ x) (Φ y)) ≤ ε₂) :
  GH_dist α β ≤ ε₁ + ε₂ / 2 + ε₃ :=
begin
  refine le_of_forall_pos_le_add (λδ δ0, _),
  rcases exists_mem_of_nonempty α with ⟨xα, _⟩,
  rcases hs xα 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, abs (dist p q - dist (Φ p) (Φ q)) ≤ 2 * (ε₂/2 + δ) := λp q, calc
    abs (dist p q - dist (Φ p) (Φ q)) ≤ ε₂ : H p q
    ... ≤ 2 * (ε₂/2 + δ) : by linarith,
  -- glue `α` and `β` along the almost matching subsets
  letI : metric_space (α ⊕ β) :=
    glue_metric_approx (λ x:s, (x:α)) (λx, Φ x) (ε₂/2 + δ) (by linarith) this,
  let Fl := @sum.inl α β,
  let Fr := @sum.inr α β,
  have Il : isometry Fl := isometry_emetric_iff_metric.2 (λx y, rfl),
  have Ir : isometry Fr := isometry_emetric_iff_metric.2 (λ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 `α` and `s` (in the coupling or, equivalently in the original space), of `s` and
  `Φ s`, and of `Φ s` and `β` (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 `α ⊕ β`). -/
  have : GH_dist α β ≤ 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) := (compact_range Il.continuous).bounded,
    exact Hausdorff_dist_triangle (Hausdorff_edist_ne_top_of_nonempty_of_bounded
      (range_nonempty _) (sne.image _) B (B.subset (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) := (compact_range Ir.continuous).bounded,
    exact Hausdorff_dist_triangle' (Hausdorff_edist_ne_top_of_nonempty_of_bounded
      ((range_nonempty _).image _) (range_nonempty _)
      (bounded.subset (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⟩) },
  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:α)) Φ (ε₂/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 α s) Φ (ε₂/2 + δ) x) } },
  have : Hausdorff_dist (Fr '' (range Φ)) (range Fr) ≤ ε₃,
  { rw [← @image_univ _ _ Fr, Hausdorff_dist_image Ir],
    rcases exists_mem_of_nonempty β with ⟨xβ, _⟩,
    rcases hs' xβ 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⟩) (λ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 : 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), finite s ∧ (univ ⊆ (⋃x∈s, ball x ε)) :=
    λp, by simpa using finite_cover_balls_of_compact (@compact_univ p.rep _ _) ε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), finite t → ∃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, floor (ε⁻¹ * dist ((E p).symm a) ((E p).symm b))⟩,
  refine ⟨_, 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_bUnion_iff.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_bUnion_iff.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⟩,
        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_of_lt hy },
    show ∀x y : s p, abs (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 [Ψ] },
      -- 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, by { simp [Ψ] },
      -- 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
        abs (ε⁻¹) * abs (dist x y - dist (Ψ x) (Ψ y)) =
          abs (ε⁻¹ * (dist x y - dist (Ψ x) (Ψ y))) : (abs_mul _ _).symm
        ... = abs ((ε⁻¹ * dist x y) - (ε⁻¹ * dist (Ψ x) (Ψ y))) : by { congr, ring }
        ... ≤ 1 : le_of_lt (abs_sub_lt_one_of_floor_eq_floor this),
      calc
        abs (dist x y - dist (Ψ x) (Ψ y)) = (ε * ε⁻¹) * abs (dist x y - dist (Ψ x) (Ψ y)) :
          by rw [mul_inv_cancel (ne_of_gt εpos), one_mul]
        ... = ε * (abs (ε⁻¹) * abs (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 [ε], 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_refl _),
    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 },
      use [∅, 0, bot_le, choice (this)] },
    { rcases hcov _ (set.not_not_mem.1 hp) n with ⟨s, ⟨scard, scover⟩⟩,
      rcases cardinal.lt_omega.1 (lt_of_le_of_lt scard (cardinal.nat_lt_omega _)) 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 [hp, scover] } },
  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 := (floor (ε⁻¹ * max C 0)).to_nat,
  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 (floor (ε⁻¹ * dist ((E p).symm a) ((E p).symm b))).to_nat,
                lt_of_le_of_lt ( min_le_left _ _) (nat.lt_succ_self _) ⟩ ⟩,
  refine ⟨_, by apply_instance, (λp, F p), _⟩,
  -- 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_bUnion_iff.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_bUnion_iff.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, abs (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 [Ψ] },
      -- 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 [Ψ] },
      -- Express `dist x y` in terms of `F p`
      have Ap : ((F p).2 ⟨i, hip⟩ ⟨j, hjp⟩).1 = (floor (ε⁻¹ * dist x y)).to_nat := 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 (floor (ε⁻¹ * dist x y)).to_nat :
          by simp only [F, (E p).symm_apply_apply]
        ... = (floor (ε⁻¹ * dist x y)).to_nat :
        begin
          refine min_eq_right (int.to_nat_le_to_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 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 = (floor (ε⁻¹ * dist (Ψ x) (Ψ y))).to_nat := 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 (floor (ε⁻¹ * dist (Ψ x) (Ψ y))).to_nat :
          by simp only [F, (E q).symm_apply_apply]
        ... = (floor (ε⁻¹ * dist (Ψ x) (Ψ y))).to_nat :
        begin
          refine min_eq_right (int.to_nat_le_to_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 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 : floor (ε⁻¹ * dist x y) = floor (ε⁻¹ * dist (Ψ x) (Ψ y)),
      { rw [Ap, Aq] at this,
        have D : 0 ≤ floor (ε⁻¹ * dist x y) :=
          floor_nonneg.2 (mul_nonneg (le_of_lt (inv_pos.2 εpos)) dist_nonneg),
        have D' : floor (ε⁻¹ * dist (Ψ x) (Ψ y)) ≥ 0 :=
          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', this] },
      -- deduce that the distances coincide up to `ε`, by a straightforward computation
      -- that should be automated
      have I := calc
        abs (ε⁻¹) * abs (dist x y - dist (Ψ x) (Ψ y)) =
          abs (ε⁻¹ * (dist x y - dist (Ψ x) (Ψ y))) : (abs_mul _ _).symm
        ... = abs ((ε⁻¹ * dist x y) - (ε⁻¹ * dist (Ψ x) (Ψ y))) : by { congr, ring }
        ... ≤ 1 : le_of_lt (abs_sub_lt_one_of_floor_eq_floor this),
      calc
        abs (dist x y - dist (Ψ x) (Ψ y)) = (ε * ε⁻¹) * abs (dist x y - dist (Ψ x) (Ψ y)) :
          by rw [mul_inv_cancel (ne_of_gt εpos), one_mul]
        ... = ε * (abs (ε⁻¹) * abs (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 [ε], 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)

/-- 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
  { space  := X 0,
    metric := by apply_instance,
    embed  := id,
    isom   := λx y, rfl }
(λn a, by letI : metric_space a.space := a.metric; exact
  { space  := glue_space a.isom (isometry_optimal_GH_injl (X n) (X n.succ)),
    metric := metric.metric_space_glue_space a.isom (isometry_optimal_GH_injl (X n) (X n.succ)),
    embed  := (to_glue_r a.isom (isometry_optimal_GH_injl (X n) (X n.succ)))
              ∘ (optimal_GH_injr (X n) (X n.succ)),
    isom   := (to_glue_r_isometry _ _).comp (isometry_optimal_GH_injr (X n) (X n.succ)) })

/-- 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,
  letI : ∀n, metric_space (Y n).space := λn, (Y n).metric,
  have E : ∀ n : ℕ,
    glue_space (Y n).isom (isometry_optimal_GH_injl (X n) (X n.succ)) = (Y n.succ).space :=
    λ n, by { simp [Y, aux_gluing], refl },
  let c := λn, cast (E n),
  have ic : ∀n, isometry (c n) := λn x y, rfl,
  -- there is a canonical embedding of `Y n` in `Y (n+1)`, by construction
  let f : Πn, (Y n).space → (Y n.succ).space :=
    λn, (c n) ∘ (to_glue_l (aux_gluing X n).isom (isometry_optimal_GH_injl (X n) (X n.succ))),
  have I : ∀n, isometry (f n),
  { assume n,
    apply isometry.comp,
    { assume x y, refl },
    { apply 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,
    apply isometry.comp completion.coe_isometry _,
    apply isometry.comp _ (Y n).isom,
    apply to_inductive_limit_isometry },
  -- 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 isometry.comp completion.coe_isometry _,
      apply isometry.comp _ ((ic n).comp (to_glue_r_isometry _ _)),
      apply to_inductive_limit_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,
    ⟨range_nonempty _, compact_range (isom n).continuous ⟩⟩,
  -- `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_isometric],
    constructor,
    convert (isom n).isometric_on_range.symm,
  },
  -- Finally, we have proved the convergence of `u n`
  exact ⟨L.to_GH_space, by simpa [this] using M⟩
end

end complete--section

end Gromov_Hausdorff --namespace


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

/-!
# The cartesian product of multisets
-/

namespace multiset

section pi
variables {α : Type*}
open function

/-- Given `δ : α → Type*`, `pi.empty δ` is the trivial dependent function out of the empty
multiset. -/
def pi.empty (δ : α → Type*) : (Πa∈(0:multiset α), δ a) .

variables [decidable_eq α] {δ : α → Type*}

/-- Given `δ : α → Type*`, a multiset `m` and a term `a`, as well as a term `b : δ a` and a
function `f` such that `f a' : δ a'` for all `a'` in `m`, `pi.cons m a b f` is a function `g` such
that `g a'' : δ a''` for all `a''` in `a ::ₘ m`. -/
def pi.cons (m : multiset α) (a : α) (b : δ a) (f : Πa∈m, δ a) : Πa'∈a ::ₘ m, δ a' :=
λa' ha', if h : a' = a then eq.rec b h.symm else f a' $ (mem_cons.1 ha').resolve_left h

lemma pi.cons_same {m : multiset α} {a : α} {b : δ a} {f : Πa∈m, δ a} (h : a ∈ a ::ₘ m) :
  pi.cons m a b f a h = b :=
dif_pos rfl

lemma pi.cons_ne {m : multiset α} {a a' : α} {b : δ a} {f : Πa∈m, δ a}
  (h' : a' ∈ a ::ₘ m) (h : a' ≠ a) :
  pi.cons m a b f a' h' = f a' ((mem_cons.1 h').resolve_left h) :=
dif_neg h

lemma pi.cons_swap {a a' : α} {b : δ a} {b' : δ a'} {m : multiset α} {f : Πa∈m, δ a} (h : a ≠ a') :
  pi.cons (a' ::ₘ m) a b (pi.cons m a' b' f) == pi.cons (a ::ₘ m) a' b' (pi.cons m a b f) :=
begin
  apply hfunext, { refl }, intros a'' _ h, subst h,
  apply hfunext, { rw [cons_swap] }, intros ha₁ ha₂ h,
  by_cases h₁ : a'' = a,
  simp [*, pi.cons_same, pi.cons_ne] at *,
  { subst h₁, rw [pi.cons_same, pi.cons_same] },
  by_cases h₂ : a'' = a';
    simp [*, pi.cons_same, pi.cons_ne] at *;
    subst h₂; rw [pi.cons_same, pi.cons_same]
end

/-- `pi m t` constructs the Cartesian product over `t` indexed by `m`. -/
def pi (m : multiset α) (t : Πa, multiset (δ a)) : multiset (Πa∈m, δ a) :=
m.rec_on {pi.empty δ} (λa m (p : multiset (Πa∈m, δ a)), (t a).bind $ λb, p.map $ pi.cons m a b)
begin
  intros a a' m n,
  by_cases eq : a = a',
  { subst eq },
  { simp [map_bind, bind_bind (t a') (t a)],
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b hb,
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b' hb',
    apply map_hcongr, { rw [cons_swap a a'] },
    intros f hf,
    exact pi.cons_swap eq }
end

@[simp] lemma pi_zero (t : Πa, multiset (δ a)) : pi 0 t = {pi.empty δ} := rfl

@[simp] lemma pi_cons (m : multiset α) (t : Πa, multiset (δ a)) (a : α) :
  pi (a ::ₘ m) t = ((t a).bind $ λb, (pi m t).map $ pi.cons m a b) :=
rec_on_cons a m

lemma pi_cons_injective {a : α} {b : δ a} {s : multiset α} (hs : a ∉ s) :
  function.injective (pi.cons s a b) :=
assume f₁ f₂ eq, funext $ assume a', funext $ assume h',
have ne : a ≠ a', from assume h, hs $ h.symm ▸ h',
have a' ∈ a ::ₘ s, from mem_cons_of_mem h',
calc f₁ a' h' = pi.cons s a b f₁ a' this : by rw [pi.cons_ne this ne.symm]
  ... = pi.cons s a b f₂ a' this : by rw [eq]
  ... = f₂ a' h' : by rw [pi.cons_ne this ne.symm]

lemma card_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  card (pi m t) = prod (m.map $ λa, card (t a)) :=
multiset.induction_on m (by simp) (by simp [mul_comm] {contextual := tt})

lemma nodup_pi {s : multiset α} {t : Πa, multiset (δ a)} :
  nodup s → (∀a∈s, nodup (t a)) → nodup (pi s t) :=
multiset.induction_on s (assume _ _, nodup_singleton _)
begin
  assume a s ih hs ht,
  have has : a ∉ s, by simp at hs; exact hs.1,
  have hs : nodup s, by simp at hs; exact hs.2,
  simp,
  split,
  { assume b hb,
    from nodup_map (pi_cons_injective has) (ih hs $ assume a' h', ht a' $ mem_cons_of_mem h') },
  { apply pairwise_of_nodup _ (ht a $ mem_cons_self _ _),
    from assume b₁ hb₁ b₂ hb₂ neb, disjoint_map_map.2 (assume f hf g hg eq,
      have pi.cons s a b₁ f a (mem_cons_self _ _) = pi.cons s a b₂ g a (mem_cons_self _ _),
        by rw [eq],
      neb $ show b₁ = b₂, by rwa [pi.cons_same, pi.cons_same] at this) }
end

lemma mem_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  ∀f:Πa∈m, δ a, (f ∈ pi m t) ↔ (∀a (h : a ∈ m), f a h ∈ t a) :=
begin
  refine multiset.induction_on m (λ f, _) (λ a m ih f, _),
  { simpa using show f = pi.empty δ, by funext a ha; exact ha.elim },
  simp only [mem_bind, exists_prop, mem_cons, pi_cons, mem_map], split,
  { rintro ⟨b, hb, f', hf', rfl⟩ a' ha',
    rw [ih] at hf',
    by_cases a' = a,
    { subst h, rwa [pi.cons_same] },
    { rw [pi.cons_ne _ h], apply hf' } },
  { intro hf,
    refine ⟨_, hf a (mem_cons_self a _), λa ha, f a (mem_cons_of_mem ha),
      (ih _).2 (λ a' h', hf _ _), _⟩,
    funext a' h',
    by_cases a' = a,
    { subst h, rw [pi.cons_same] },
    { rw [pi.cons_ne _ h] } }
end

end pi

end multiset


/-
Copyright (c) 2017 Simon Hudon All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Mario Carneiro

Evaluating arithmetic expressions including *, +, -, ^, ≤
-/

import algebra.group_power data.rat data.nat.prime
import tactic.interactive tactic.converter.interactive

universes u v w

namespace expr

protected meta def to_pos_rat : expr → option ℚ
| `(%%e₁ / %%e₂) := do m ← e₁.to_nat, n ← e₂.to_nat, some (rat.mk m n)
| e              := do n ← e.to_nat, return (rat.of_int n)

protected meta def to_rat : expr → option ℚ
| `(has_neg.neg %%e) := do q ← e.to_pos_rat, some (-q)
| e                  := e.to_pos_rat

protected meta def of_rat (α : expr) : ℚ → tactic expr
| ⟨(n:ℕ), d, h, c⟩   := do
  e₁ ← expr.of_nat α n,
  if d = 1 then return e₁ else
  do e₂ ← expr.of_nat α d,
  tactic.mk_app ``has_div.div [e₁, e₂]
| ⟨-[1+n], d, h, c⟩ := do
  e₁ ← expr.of_nat α (n+1),
  e ← (if d = 1 then return e₁ else do
    e₂ ← expr.of_nat α d,
    tactic.mk_app ``has_div.div [e₁, e₂]),
  tactic.mk_app ``has_neg.neg [e]

end expr

namespace tactic

meta def refl_conv (e : expr) : tactic (expr × expr) :=
do p ← mk_eq_refl e, return (e, p)

meta def trans_conv (t₁ t₂ : expr → tactic (expr × expr)) (e : expr) :
  tactic (expr × expr) :=
(do (e₁, p₁) ← t₁ e,
  (do (e₂, p₂) ← t₂ e₁,
    p ← mk_eq_trans p₁ p₂, return (e₂, p)) <|>
  return (e₁, p₁)) <|> t₂ e

end tactic

open tactic

namespace norm_num
variable {α : Type u}

lemma subst_into_neg {α} [has_neg α] (a ta t : α) (pra : a = ta) (prt : -ta = t) : -a = t :=
by simp [pra, prt]

theorem bit0_zero [add_group α] : bit0 (0 : α) = 0 := add_zero _

theorem bit1_zero [add_group α] [has_one α] : bit1 (0 : α) = 1 :=
by rw [bit1, bit0_zero, zero_add]

lemma pow_bit0_helper [monoid α] (a t : α) (b : ℕ) (h : a ^ b = t) :
  a ^ bit0 b = t * t :=
by simp [pow_bit0, h]

lemma pow_bit1_helper [monoid α] (a t : α) (b : ℕ) (h : a ^ b = t) :
  a ^ bit1 b = t * t * a :=
by simp [pow_bit1, h]

lemma lt_add_of_pos_helper [ordered_cancel_comm_monoid α]
  (a b c : α) (h : a + b = c) (h₂ : 0 < b) : a < c :=
h ▸ (lt_add_iff_pos_right _).2 h₂

lemma nat_div_helper (a b q r : ℕ) (h : r + q * b = a) (h₂ : r < b) : a / b = q :=
by rw [← h, nat.add_mul_div_right _ _ (lt_of_le_of_lt (nat.zero_le _) h₂),
       nat.div_eq_of_lt h₂, zero_add]

lemma int_div_helper (a b q r : ℤ) (h : r + q * b = a) (h₁ : 0 ≤ r) (h₂ : r < b) : a / b = q :=
by rw [← h, int.add_mul_div_right _ _ (ne_of_gt (lt_of_le_of_lt h₁ h₂)),
       int.div_eq_zero_of_lt h₁ h₂, zero_add]

lemma nat_mod_helper (a b q r : ℕ) (h : r + q * b = a) (h₂ : r < b) : a % b = r :=
by rw [← h, nat.add_mul_mod_self_right, nat.mod_eq_of_lt h₂]

lemma int_mod_helper (a b q r : ℤ) (h : r + q * b = a) (h₁ : 0 ≤ r) (h₂ : r < b) : a % b = r :=
by rw [← h, int.add_mul_mod_self, int.mod_eq_of_lt h₁ h₂]

meta def eval_pow (simp : expr → tactic (expr × expr)) : expr → tactic (expr × expr)
| `(@has_pow.pow %%α _ %%m %%e₁ %%e₂) :=
  match m with
  | `(nat.has_pow) :=
    mk_app ``nat.pow [e₁, e₂] >>= eval_pow
  | `(@monoid.has_pow %%α %%m) :=
    mk_app ``monoid.pow [e₁, e₂] >>= eval_pow
  | _ := failed
  end
| `(monoid.pow %%e₁ 0) := do
  p ← mk_app ``pow_zero [e₁],
  a ← infer_type e₁,
  o ← mk_app ``has_one.one [a],
  return (o, p)
| `(monoid.pow %%e₁ 1) := do
  p ← mk_app ``pow_one [e₁],
  return (e₁, p)
| `(monoid.pow %%e₁ (bit0 %%e₂)) := do
  e ← mk_app ``monoid.pow [e₁, e₂],
  (e', p) ← simp e,
  p' ← mk_app ``norm_num.pow_bit0_helper [e₁, e', e₂, p],
  e'' ← to_expr ``(%%e' * %%e'),
  return (e'', p')
| `(monoid.pow %%e₁ (bit1 %%e₂)) := do
  e ← mk_app ``monoid.pow [e₁, e₂],
  (e', p) ← simp e,
  p' ← mk_app ``norm_num.pow_bit1_helper [e₁, e', e₂, p],
  e'' ← to_expr ``(%%e' * %%e' * %%e₁),
  return (e'', p')
| `(nat.pow %%e₁ %%e₂) := do
  p₁ ← mk_app ``nat.pow_eq_pow [e₁, e₂],
  e ← mk_app ``monoid.pow [e₁, e₂],
  (e', p₂) ← simp e,
  p ← mk_eq_trans p₁ p₂,
  return (e', p)
| _ := failed

meta def prove_pos : instance_cache → expr → tactic (instance_cache × expr)
| c `(has_one.one _) := do (c, p) ← c.mk_app ``zero_lt_one [], return (c, p)
| c `(bit0 %%e)      := do (c, p) ← prove_pos c e, (c, p) ← c.mk_app ``bit0_pos [e, p], return (c, p)
| c `(bit1 %%e)      := do (c, p) ← prove_pos c e, (c, p) ← c.mk_app ``bit1_pos' [e, p], return (c, p)
| c `(%%e₁ / %%e₂)   := do
  (c, p₁) ← prove_pos c e₁, (c, p₂) ← prove_pos c e₂,
  (c, p) ← c.mk_app ``div_pos_of_pos_of_pos [e₁, e₂, p₁, p₂],
  return (c, p)
| c e                       := failed

meta def prove_lt (simp : expr → tactic (expr × expr)) : instance_cache → expr → expr → tactic (instance_cache × expr)
| c `(- %%e₁) `(- %%e₂) := do
  (c, p) ← prove_lt c e₁ e₂,
  (c, p) ← c.mk_app ``neg_lt_neg [e₁, e₂, p],
  return (c, p)
| c `(- %%e₁) `(has_zero.zero _) := do
  (c, p) ← prove_pos c e₁,
  (c, p) ← c.mk_app ``neg_neg_of_pos [e₁, p],
  return (c, p)
| c `(- %%e₁) e₂ := do
  (c, p₁) ← prove_pos c e₁,
  (c, me₁) ← c.mk_app ``has_neg.neg [e₁],
  (c, p₁) ← c.mk_app ``neg_neg_of_pos [e₁, p₁],
  (c, p₂) ← prove_pos c e₂,
  (c, z) ← c.mk_app ``has_zero.zero [],
  (c, p) ← c.mk_app ``lt_trans [me₁, z, e₂, p₁, p₂],
  return (c, p)
| c `(has_zero.zero _) e₂ := prove_pos c e₂
| c e₁ e₂ := do
  n₁ ← e₁.to_rat, n₂ ← e₂.to_rat,
  d ← expr.of_rat c.α (n₂ - n₁),
  (c, e₃) ← c.mk_app ``has_add.add [e₁, d],
  (e₂', p) ← norm_num e₃,
  guard (e₂'.is_num_eq e₂),
  (c, p') ← prove_pos c d,
  (c, p) ← c.mk_app ``norm_num.lt_add_of_pos_helper [e₁, d, e₂, p, p'],
  return (c, p)

private meta def true_intro (p : expr) : tactic (expr × expr) :=
prod.mk <$> mk_const `true <*> mk_app ``eq_true_intro [p]

private meta def false_intro (p : expr) : tactic (expr × expr) :=
prod.mk <$> mk_const `false <*> mk_app ``eq_false_intro [p]

meta def eval_ineq (simp : expr → tactic (expr × expr)) : expr → tactic (expr × expr)
| `(%%e₁ < %%e₂) := do
  n₁ ← e₁.to_rat, n₂ ← e₂.to_rat,
  c ← infer_type e₁ >>= mk_instance_cache,
  if n₁ < n₂ then
    do (_, p) ← prove_lt simp c e₁ e₂, true_intro p
  else do
    (c, p) ← if n₁ = n₂ then c.mk_app ``lt_irrefl [e₁] else
      (do (c, p') ← prove_lt simp c e₂ e₁,
          c.mk_app ``not_lt_of_gt [e₁, e₂, p']),
    false_intro p
| `(%%e₁ ≤ %%e₂) := do
  n₁ ← e₁.to_rat, n₂ ← e₂.to_rat,
  c ← infer_type e₁ >>= mk_instance_cache,
  if n₁ ≤ n₂ then do
    (c, p) ← if n₁ = n₂ then c.mk_app ``le_refl [e₁] else
      (do (c, p') ← prove_lt simp c e₁ e₂,
          c.mk_app ``le_of_lt [e₁, e₂, p']),
    true_intro p
  else do
    (c, p) ← prove_lt simp c e₂ e₁,
    (c, p) ← c.mk_app ``not_le_of_gt [e₁, e₂, p],
    false_intro p
| `(%%e₁ = %%e₂) := do
  n₁ ← e₁.to_rat, n₂ ← e₂.to_rat,
  c ← infer_type e₁ >>= mk_instance_cache,
  if n₁ < n₂ then do
    (c, p) ← prove_lt simp c e₁ e₂,
    (c, p) ← c.mk_app ``ne_of_lt [e₁, e₂, p],
    false_intro p
  else if n₂ < n₁ then do
    (c, p) ← prove_lt simp c e₂ e₁,
    (c, p) ← c.mk_app ``ne_of_gt [e₁, e₂, p],
    false_intro p
  else mk_eq_refl e₁ >>= true_intro
| `(%%e₁ > %%e₂) := mk_app ``has_lt.lt [e₂, e₁] >>= simp
| `(%%e₁ ≥ %%e₂) := mk_app ``has_le.le [e₂, e₁] >>= simp
| `(%%e₁ ≠ %%e₂) := do e ← mk_app ``eq [e₁, e₂], mk_app ``not [e] >>= simp
| _ := failed

meta def eval_div_ext (simp : expr → tactic (expr × expr)) : expr → tactic (expr × expr)
| `(has_inv.inv %%e) := do
  c ← infer_type e >>= mk_instance_cache,
  (c, p₁) ← c.mk_app ``inv_eq_one_div [e],
  (c, o) ← c.mk_app ``has_one.one [],
  (c, e') ← c.mk_app ``has_div.div [o, e],
  (do (e'', p₂) ← simp e',
    p ← mk_eq_trans p₁ p₂,
    return (e'', p)) <|> return (e', p₁)
| `(%%e₁ / %%e₂) := do
  α ← infer_type e₁,
  c ← mk_instance_cache α,
  match α with
  | `(nat) := do
    n₁ ← e₁.to_nat, n₂ ← e₂.to_nat,
    q ← expr.of_nat α (n₁ / n₂),
    r ← expr.of_nat α (n₁ % n₂),
    (c, e₃) ← c.mk_app ``has_mul.mul [q, e₂],
    (c, e₃) ← c.mk_app ``has_add.add [r, e₃],
    (e₁', p) ← norm_num e₃,
    guard (e₁' =ₐ e₁),
    (c, p') ← prove_lt simp c r e₂,
    p ← mk_app ``norm_num.nat_div_helper [e₁, e₂, q, r, p, p'],
    return (q, p)
  | `(int) := match e₂ with
    | `(- %%e₂') := do
      (c, p₁) ← c.mk_app ``int.div_neg [e₁, e₂'],
      (c, e) ← c.mk_app ``has_div.div [e₁, e₂'],
      (c, e) ← c.mk_app ``has_neg.neg [e],
      (e', p₂) ← simp e,
      p ← mk_eq_trans p₁ p₂,
      return (e', p)
    | _ := do
      n₁ ← e₁.to_int,
      n₂ ← e₂.to_int,
      q ← expr.of_rat α $ rat.of_int (n₁ / n₂),
      r ← expr.of_rat α $ rat.of_int (n₁ % n₂),
      (c, e₃) ← c.mk_app ``has_mul.mul [q, e₂],
      (c, e₃) ← c.mk_app ``has_add.add [r, e₃],
      (e₁', p) ← norm_num e₃,
      guard (e₁' =ₐ e₁),
      (c, r0) ← c.mk_app ``has_zero.zero [],
      (c, r0) ← c.mk_app ``has_le.le [r0, r],
      (_, p₁) ← simp r0,
      p₁ ← mk_app ``of_eq_true [p₁],
      (c, p₂) ← prove_lt simp c r e₂,
      p ← mk_app ``norm_num.int_div_helper [e₁, e₂, q, r, p, p₁, p₂],
      return (q, p)
    end
  | _ := failed
  end
| `(%%e₁ % %%e₂) := do
  α ← infer_type e₁,
  c ← mk_instance_cache α,
  match α with
  | `(nat) := do
    n₁ ← e₁.to_nat, n₂ ← e₂.to_nat,
    q ← expr.of_nat α (n₁ / n₂),
    r ← expr.of_nat α (n₁ % n₂),
    (c, e₃) ← c.mk_app ``has_mul.mul [q, e₂],
    (c, e₃) ← c.mk_app ``has_add.add [r, e₃],
    (e₁', p) ← norm_num e₃,
    guard (e₁' =ₐ e₁),
    (c, p') ← prove_lt simp c r e₂,
    p ← mk_app ``norm_num.nat_mod_helper [e₁, e₂, q, r, p, p'],
    return (r, p)
  | `(int) := match e₂ with
    | `(- %%e₂') := do
      let p₁ := (expr.const ``int.mod_neg []).mk_app [e₁, e₂'],
      (c, e) ← c.mk_app ``has_mod.mod [e₁, e₂'],
      (e', p₂) ← simp e,
      p ← mk_eq_trans p₁ p₂,
      return (e', p)
    | _ := do
      n₁ ← e₁.to_int,
      n₂ ← e₂.to_int,
      q ← expr.of_rat α $ rat.of_int (n₁ / n₂),
      r ← expr.of_rat α $ rat.of_int (n₁ % n₂),
      (c, e₃) ← c.mk_app ``has_mul.mul [q, e₂],
      (c, e₃) ← c.mk_app ``has_add.add [r, e₃],
      (e₁', p) ← norm_num e₃,
      guard (e₁' =ₐ e₁),
      (c, r0) ← c.mk_app ``has_zero.zero [],
      (c, r0) ← c.mk_app ``has_le.le [r0, r],
      (_, p₁) ← simp r0,
      p₁ ← mk_app ``of_eq_true [p₁],
      (c, p₂) ← prove_lt simp c r e₂,
      p ← mk_app ``norm_num.int_mod_helper [e₁, e₂, q, r, p, p₁, p₂],
      return (r, p)
    end
  | _ := failed
  end
| `(%%e₁ ∣ %%e₂) := do
  α ← infer_type e₁,
  c ← mk_instance_cache α,
  n ← match α with
  | `(nat) := return ``nat.dvd_iff_mod_eq_zero
  | `(int) := return ``int.dvd_iff_mod_eq_zero
  | _ := failed
  end,
  p₁ ← mk_app ``propext [@expr.const tt n [] e₁ e₂],
  (e', p₂) ← simp `(%%e₂ % %%e₁ = 0),
  p' ← mk_eq_trans p₁ p₂,
  return (e', p')
| _ := failed

lemma not_prime_helper (a b n : ℕ)
  (h : a * b = n) (h₁ : 1 < a) (h₂ : 1 < b) : ¬ nat.prime n :=
by rw ← h; exact nat.not_prime_mul h₁ h₂

lemma is_prime_helper (n : ℕ)
  (h₁ : 1 < n) (h₂ : nat.min_fac n = n) : nat.prime n :=
nat.prime_def_min_fac.2 ⟨h₁, h₂⟩

lemma min_fac_bit0 (n : ℕ) : nat.min_fac (bit0 n) = 2 :=
by simp [nat.min_fac_eq, show 2 ∣ bit0 n, by simp [bit0_eq_two_mul n]]

def min_fac_helper (n k : ℕ) : Prop :=
0 < k ∧ bit1 k ≤ nat.min_fac (bit1 n)

theorem min_fac_helper.n_pos {n k : ℕ} (h : min_fac_helper n k) : 0 < n :=
nat.pos_iff_ne_zero.2 $ λ e,
by rw e at h; exact not_le_of_lt (nat.bit1_lt h.1) h.2

lemma min_fac_ne_bit0 {n k : ℕ} : nat.min_fac (bit1 n) ≠ bit0 k :=
by rw bit0_eq_two_mul; exact λ e, absurd
  ((nat.dvd_add_iff_right (by simp [bit0_eq_two_mul n])).2
    (dvd_trans ⟨_, e⟩ (nat.min_fac_dvd _)))
  dec_trivial

lemma min_fac_helper_0 (n : ℕ) (h : 0 < n) : min_fac_helper n 1 :=
begin
  refine ⟨zero_lt_one, lt_of_le_of_ne _ min_fac_ne_bit0.symm⟩,
  refine @lt_of_le_of_ne ℕ _ _ _ (nat.min_fac_pos _) _,
  intro e,
  have := nat.min_fac_prime _,
  { rw ← e at this, exact nat.not_prime_one this },
  { exact ne_of_gt (nat.bit1_lt h) }
end

lemma min_fac_helper_1 {n k k' : ℕ} (e : k + 1 = k')
  (np : nat.min_fac (bit1 n) ≠ bit1 k)
  (h : min_fac_helper n k) : min_fac_helper n k' :=
begin
  rw ← e,
  refine ⟨nat.succ_pos _,
    (lt_of_le_of_ne (lt_of_le_of_ne _ _ : k+1+k < _)
      min_fac_ne_bit0.symm : bit0 (k+1) < _)⟩,
  { rw add_right_comm, exact h.2 },
  { rw add_right_comm, exact np.symm }
end

lemma min_fac_helper_2 (n k k' : ℕ) (e : k + 1 = k')
  (np : ¬ nat.prime (bit1 k)) (h : min_fac_helper n k) : min_fac_helper n k' :=
begin
  refine min_fac_helper_1 e _ h,
  intro e₁, rw ← e₁ at np,
  exact np (nat.min_fac_prime $ ne_of_gt $ nat.bit1_lt h.n_pos)
end

lemma min_fac_helper_3 (n k k' : ℕ) (e : k + 1 = k')
  (nd : bit1 k ∣ bit1 n = false)
  (h : min_fac_helper n k) : min_fac_helper n k' :=
begin
  refine min_fac_helper_1 e _ h,
  intro e₁, rw [eq_false, ← e₁] at nd,
  exact nd (nat.min_fac_dvd _)
end

lemma min_fac_helper_4 (n k : ℕ) (hd : bit1 k ∣ bit1 n = true)
  (h : min_fac_helper n k) : nat.min_fac (bit1 n) = bit1 k :=
by rw eq_true at hd; exact
le_antisymm (nat.min_fac_le_of_dvd (nat.bit1_lt h.1) hd) h.2

lemma min_fac_helper_5 (n k k' : ℕ) (e : bit1 k * bit1 k = k')
  (hd : bit1 n < k') (h : min_fac_helper n k) : nat.min_fac (bit1 n) = bit1 n :=
begin
  refine (nat.prime_def_min_fac.1 (nat.prime_def_le_sqrt.2
    ⟨nat.bit1_lt h.n_pos, _⟩)).2,
  rw ← e at hd,
  intros m m2 hm md,
  have := le_trans h.2 (le_trans (nat.min_fac_le_of_dvd m2 md) hm),
  rw nat.le_sqrt at this,
  exact not_le_of_lt hd this
end

meta def prove_non_prime (simp : expr → tactic (expr × expr)) (e : expr) (n d₁ : ℕ) : tactic expr :=
do let e₁ := reflect d₁,
  c ← mk_instance_cache `(nat),
  (c, p₁) ← prove_lt simp c `(1) e₁,
  let d₂ := n / d₁, let e₂ := reflect d₂,
  (e', p) ← mk_app ``has_mul.mul [e₁, e₂] >>= norm_num,
  guard (e' =ₐ e),
  (c, p₂) ← prove_lt simp c `(1) e₂,
  return $ (expr.const ``not_prime_helper []).mk_app [e₁, e₂, e, p, p₁, p₂]

meta def prove_min_fac (simp : expr → tactic (expr × expr))
  (e₁ : expr) (n1 : ℕ) : expr → expr → tactic (expr × expr)
| e₂ p := do
  k ← e₂.to_nat,
  let k1 := bit1 k,
  e₁1 ← mk_app ``bit1 [e₁],
  e₂1 ← mk_app ``bit1 [e₂],
  if n1 < k1*k1 then do
    c ← mk_instance_cache `(nat),
    (c, e') ← c.mk_app ``has_mul.mul [e₂1, e₂1],
    (e', p₁) ← norm_num e',
    (c, p₂) ← prove_lt simp c e₁1 e',
    p' ← mk_app ``min_fac_helper_5 [e₁, e₂, e', p₁, p₂, p],
    return (e₁1, p')
  else let d := k1.min_fac in
  if to_bool (d < k1) then do
    (e', p₁) ← norm_num `(%%e₂ + 1),
    p₂ ← prove_non_prime simp e₂1 k1 d,
    mk_app ``min_fac_helper_2 [e₁, e₂, e', p₁, p₂, p] >>= prove_min_fac e'
  else do
    (_, p₂) ← simp `((%%e₂1 : ℕ) ∣ %%e₁1),
    if k1 ∣ n1 then do
      p' ← mk_app ``min_fac_helper_4 [e₁, e₂, p₂, p],
      return (e₂1, p')
    else do
      (e', p₁) ← norm_num `(%%e₂ + 1),
      mk_app ``min_fac_helper_3 [e₁, e₂, e', p₁, p₂, p] >>= prove_min_fac e'

meta def eval_prime (simp : expr → tactic (expr × expr)) : expr → tactic (expr × expr)
| `(nat.prime %%e) := do
  n ← e.to_nat,
  match n with
  | 0 := false_intro `(nat.not_prime_zero)
  | 1 := false_intro `(nat.not_prime_one)
  | _ := let d₁ := n.min_fac in
    if d₁ < n then prove_non_prime simp e n d₁ >>= false_intro
    else do
      let e₁ := reflect d₁,
      c ← mk_instance_cache `(nat),
      (c, p₁) ← prove_lt simp c `(1) e₁,
      (e₁, p) ← simp `(nat.min_fac %%e),
      true_intro $ (expr.const ``is_prime_helper []).mk_app [e, p₁, p]
  end
| `(nat.min_fac 0) := refl_conv (reflect (0:ℕ))
| `(nat.min_fac 1) := refl_conv (reflect (1:ℕ))
| `(nat.min_fac (bit0 %%e)) := prod.mk `(2) <$> mk_app ``min_fac_bit0 [e]
| `(nat.min_fac (bit1 %%e)) := do
  n ← e.to_nat,
  c ← mk_instance_cache `(nat),
  (c, p) ← prove_pos c e,
  mk_app ``min_fac_helper_0 [e, p] >>= prove_min_fac simp e (bit1 n) `(1)
| _ := failed

meta def derive1 (simp : expr → tactic (expr × expr)) (e : expr) :
  tactic (expr × expr) :=
norm_num e <|> eval_div_ext simp e <|>
eval_pow simp e <|> eval_ineq simp e <|> eval_prime simp e

meta def derive : expr → tactic (expr × expr) | e :=
do e ← instantiate_mvars e,
   (_, e', pr) ←
    ext_simplify_core () {} simp_lemmas.mk (λ _, failed) (λ _ _ _ _ _, failed)
      (λ _ _ _ _ e,
        do (new_e, pr) ← derive1 derive e,
           guard (¬ new_e =ₐ e),
           return ((), new_e, some pr, tt))
      `eq e,
    return (e', pr)

end norm_num

namespace tactic.interactive
open norm_num interactive interactive.types

/-- Basic version of `norm_num` that does not call `simp`. -/
meta def norm_num1 (loc : parse location) : tactic unit :=
do ns ← loc.get_locals,
   tt ← tactic.replace_at derive ns loc.include_goal
      | fail "norm_num failed to simplify",
   when loc.include_goal $ try tactic.triv,
   when (¬ ns.empty) $ try tactic.contradiction

/-- Normalize numerical expressions. Supports the operations
  `+` `-` `*` `/` `^` `<` `≤` over ordered fields (or other
  appropriate classes), as well as `-` `/` `%` over `ℤ` and `ℕ`. -/
meta def norm_num (hs : parse simp_arg_list) (l : parse location) : tactic unit :=
repeat1 $ orelse' (norm_num1 l) $
simp_core {} (norm_num1 (loc.ns [none])) ff hs [] l

meta def apply_normed (x : parse texpr) : tactic unit :=
do x₁ ← to_expr x,
  (x₂,_) ← derive x₁,
  tactic.exact x₂

end tactic.interactive

namespace conv.interactive
open conv interactive tactic.interactive
open norm_num (derive)

meta def norm_num1 : conv unit := replace_lhs derive

meta def norm_num (hs : parse simp_arg_list) : conv unit :=
repeat1 $ orelse' norm_num1 $
simp_core {} norm_num1 ff hs [] (loc.ns [none])

end conv.interactive


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.basic
import Mathlib.PostPort

universes v u l u'

namespace Mathlib

/-!
# Categories

Defines a category, as a type class parametrised by the type of objects.

## Notations

Introduces notations
* `X ⟶ Y` for the morphism spaces,
* `f ≫ g` for composition in the 'arrows' convention.

Users may like to add `f ⊚ g` for composition in the standard convention, using
```lean
local notation f ` ⊚ `:80 g:80 := category.comp g f    -- type as \oo
```
-/

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

-- can be omitted

namespace category_theory

/-- A 'notation typeclass' on the way to defining a category. -/
class has_hom (obj : Type u)
where
  hom : obj → obj → Type v

infixr:10 " ⟶ " => Mathlib.category_theory.has_hom.hom

/-- A preliminary structure on the way to defining a category,
containing the data, but none of the axioms. -/
class category_struct (obj : Type u)
extends has_hom obj
where
  id : (X : obj) → X ⟶ X
  comp : {X Y Z : obj} → (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z)

notation:1024 "𝟙" => Mathlib.category_theory.category_struct.id

infixr:80 " ≫ " => Mathlib.category_theory.category_struct.comp

/--
The typeclass `category C` describes morphisms associated to objects of type `C`.
The universe levels of the objects and morphisms are unconstrained, and will often need to be
specified explicitly, as `category.{v} C`. (See also `large_category` and `small_category`.)

See https://stacks.math.columbia.edu/tag/0014.
-/
class category (obj : Type u)
extends category_struct obj
where
  id_comp' : autoParam (∀ {X Y : obj} (f : X ⟶ Y), 𝟙 ≫ f = f)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_id' : autoParam (∀ {X Y : obj} (f : X ⟶ Y), f ≫ 𝟙 = f)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  assoc' : autoParam (∀ {W X Y Z : obj} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z), (f ≫ g) ≫ h = f ≫ g ≫ h)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- `restate_axiom` is a command that creates a lemma from a structure field,

-- discarding any auto_param wrappers from the type.

-- (It removes a backtick from the name, if it finds one, and otherwise adds "_lemma".)

@[simp] theorem category.id_comp {obj : Type u} [c : category obj] {X : obj} {Y : obj} (f : X ⟶ Y) : 𝟙 ≫ f = f := sorry

@[simp] theorem category.comp_id {obj : Type u} [c : category obj] {X : obj} {Y : obj} (f : X ⟶ Y) : f ≫ 𝟙 = f := sorry

@[simp] theorem category.assoc {obj : Type u} [c : category obj] {W : obj} {X : obj} {Y : obj} {Z : obj} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z) : (f ≫ g) ≫ h = f ≫ g ≫ h := sorry

/--
A `large_category` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category of types, or the category
of groups, etc.
-/
/--
def large_category (C : Type (u + 1)) :=
  category C

A `small_category` has objects and morphisms in the same universe level.
-/
def small_category (C : Type u) :=
  category C

/-- postcompose an equation between morphisms by another morphism -/
theorem eq_whisker {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : X ⟶ Y} (w : f = g) (h : Y ⟶ Z) : f ≫ h = g ≫ h :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f ≫ h = g ≫ h)) w)) (Eq.refl (g ≫ h))

/-- precompose an equation between morphisms by another morphism -/
theorem whisker_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) {g : Y ⟶ Z} {h : Y ⟶ Z} (w : g = h) : f ≫ g = f ≫ h :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f ≫ g = f ≫ h)) w)) (Eq.refl (f ≫ h))

infixr:80 " =≫ " => Mathlib.category_theory.eq_whisker

infixr:80 " ≫= " => Mathlib.category_theory.whisker_eq

theorem eq_of_comp_left_eq {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {g : X ⟶ Y} (w : ∀ {Z : C} (h : Y ⟶ Z), f ≫ h = g ≫ h) : f = g := sorry

theorem eq_of_comp_right_eq {C : Type u} [category C] {Y : C} {Z : C} {f : Y ⟶ Z} {g : Y ⟶ Z} (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) : f = g := sorry

theorem eq_of_comp_left_eq' {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) (w : (fun {Z : C} (h : Y ⟶ Z) => f ≫ h) = fun {Z : C} (h : Y ⟶ Z) => g ≫ h) : f = g := sorry

theorem eq_of_comp_right_eq' {C : Type u} [category C] {Y : C} {Z : C} (f : Y ⟶ Z) (g : Y ⟶ Z) (w : (fun {X : C} (h : X ⟶ Y) => h ≫ f) = fun {X : C} (h : X ⟶ Y) => h ≫ g) : f = g := sorry

theorem id_of_comp_left_id {C : Type u} [category C] {X : C} (f : X ⟶ X) (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 := sorry

theorem id_of_comp_right_id {C : Type u} [category C] {X : C} (f : X ⟶ X) (w : ∀ {Y : C} (g : Y ⟶ X), g ≫ f = g) : f = 𝟙 := sorry

theorem comp_dite {C : Type u} [category C] {P : Prop} [Decidable P] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) : (f ≫ dite P (fun (h : P) => g h) fun (h : ¬P) => g' h) = dite P (fun (h : P) => f ≫ g h) fun (h : ¬P) => f ≫ g' h := sorry

theorem dite_comp {C : Type u} [category C] {P : Prop} [Decidable P] {X : C} {Y : C} {Z : C} (f : P → (X ⟶ Y)) (f' : ¬P → (X ⟶ Y)) (g : Y ⟶ Z) : (dite P (fun (h : P) => f h) fun (h : ¬P) => f' h) ≫ g = dite P (fun (h : P) => f h ≫ g) fun (h : ¬P) => f' h ≫ g := sorry

/--
A morphism `f` is an epimorphism if it can be "cancelled" when precomposed:
`f ≫ g = f ≫ h` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class epi {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  left_cancellation : ∀ {Z : C} (g h : Y ⟶ Z), f ≫ g = f ≫ h → g = h

/--
A morphism `f` is a monomorphism if it can be "cancelled" when postcomposed:
`g ≫ f = h ≫ f` implies `g = h`.

See https://stacks.math.columbia.edu/tag/003B.
-/
class mono {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  right_cancellation : ∀ {Z : C} (g h : Z ⟶ X), g ≫ f = h ≫ f → g = h

protected instance category_struct.id.epi {C : Type u} [category C] (X : C) : epi 𝟙 :=
  epi.mk
    fun (Z : C) (g h : X ⟶ Z) (w : 𝟙 ≫ g = 𝟙 ≫ h) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : X ⟶ Z) (e_1 : a = a_1) (ᾰ ᾰ_1 : X ⟶ Z) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2) (𝟙 ≫ g) g
            (category.id_comp g) (𝟙 ≫ h) h (category.id_comp h))
          w)

protected instance category_struct.id.mono {C : Type u} [category C] (X : C) : mono 𝟙 :=
  mono.mk
    fun (Z : C) (g h : Z ⟶ X) (w : g ≫ 𝟙 = h ≫ 𝟙) =>
      eq.mpr (id (Eq.refl (g = h)))
        (eq.mp
          ((fun (a a_1 : Z ⟶ X) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ X) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2) (g ≫ 𝟙) g
            (category.comp_id g) (h ≫ 𝟙) h (category.comp_id h))
          w)

theorem cancel_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [epi f] {g : Y ⟶ Z} {h : Y ⟶ Z} : f ≫ g = f ≫ h ↔ g = h :=
  { mp := fun (p : f ≫ g = f ≫ h) => epi.left_cancellation g h p,
    mpr := fun (a : g = h) => Eq._oldrec (Eq.refl (f ≫ g)) a }

theorem cancel_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [mono f] {g : Z ⟶ X} {h : Z ⟶ X} : g ≫ f = h ≫ f ↔ g = h :=
  { mp := fun (p : g ≫ f = h ≫ f) => mono.right_cancellation g h p,
    mpr := fun (a : g = h) => Eq._oldrec (Eq.refl (g ≫ f)) a }

theorem cancel_epi_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [epi f] {h : Y ⟶ Y} : f ≫ h = f ↔ h = 𝟙 := sorry

theorem cancel_mono_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] {g : X ⟶ X} : g ≫ f = f ↔ g = 𝟙 := sorry

theorem epi_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [epi f] (g : Y ⟶ Z) [epi g] : epi (f ≫ g) := sorry

theorem mono_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) [mono f] (g : Y ⟶ Z) [mono g] : mono (f ≫ g) := sorry

theorem mono_of_mono {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono (f ≫ g)] : mono f := sorry

theorem mono_of_mono_fac {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [mono h] (w : f ≫ g = h) : mono f :=
  Eq._oldrec (mono_of_mono f g) w _inst_2

theorem epi_of_epi {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi (f ≫ g)] : epi g := sorry

theorem epi_of_epi_fac {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [epi h] (w : f ≫ g = h) : epi g :=
  Eq._oldrec (epi_of_epi f g) w _inst_2

protected instance ulift_category (C : Type u) [category C] : category (ulift C) :=
  category.mk

-- We verify that this previous instance can lift small categories to large categories.

end category_theory

/-!
We now put a category instance on any preorder.

Because we do not allow the morphisms of a category to live in `Prop`,
unfortunately we need to use `plift` and `ulift` when defining the morphisms.

As convenience functions, we provide `hom_of_le` and `le_of_hom` to wrap and unwrap inequalities.
-/

namespace preorder

/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ulift (plift (X ≤ Y))`.
See `category_theory.hom_of_le` and `category_theory.le_of_hom`.

See https://stacks.math.columbia.edu/tag/00D3.
-/
protected instance small_category (α : Type u) [preorder α] : category_theory.small_category α :=
  category_theory.category.mk

end preorder

namespace category_theory

/--
Express an inequality as a morphism in the corresponding preorder category.
-/
def hom_of_le {α : Type u} [preorder α] {U : α} {V : α} (h : U ≤ V) : U ⟶ V :=
  ulift.up (plift.up h)

/--
Extract the underlying inequality from a morphism in a preorder category.
-/
theorem le_of_hom {α : Type u} [preorder α] {U : α} {V : α} (h : U ⟶ V) : U ≤ V :=
  plift.down (ulift.down h)

end category_theory

/--
Many proofs in the category theory library use the `dsimp, simp` pattern,


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.separation
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Compact separated uniform spaces

## Main statements

* `compact_space_uniformity`: On a separated compact uniform space, the topology determines the
  uniform structure, entourages are exactly the neighborhoods of the diagonal.
* `uniform_space_of_compact_t2`: every compact T2 topological structure is induced by a uniform
  structure. This uniform structure is described in the previous item.
* Heine-Cantor theorem: continuous functions on compact separated uniform spaces with values in
  uniform spaces are automatically uniformly continuous. There are several variations, the main one
  is `compact_space.uniform_continuous_of_continuous`.

## Implementation notes

The construction `uniform_space_of_compact_t2` is not declared as an instance, as it would badly
loop.

## tags

uniform space, uniform continuity, compact space
-/

/-!
### Uniformity on compact separated spaces
-/

/-- On a separated compact uniform space, the topology determines the uniform structure, entourages
are exactly the neighborhoods of the diagonal. -/
theorem compact_space_uniformity {α : Type u_1} [uniform_space α] [compact_space α] [separated_space α] : uniformity α = supr fun (x : α) => nhds (x, x) := sorry

theorem unique_uniformity_of_compact_t2 {α : Type u_1} [t : topological_space α] [compact_space α] [t2_space α] {u : uniform_space α} {u' : uniform_space α} (h : uniform_space.to_topological_space = t) (h' : uniform_space.to_topological_space = t) : u = u' := sorry

/-- The unique uniform structure inducing a given compact Hausdorff topological structure. -/
def uniform_space_of_compact_t2 {α : Type (max (max u_1 u_2 u_3) u_2)} [topological_space α] [compact_space α] [t2_space α] : uniform_space α :=
  uniform_space.mk (uniform_space.core.mk (supr fun (x : α) => nhds (x, x)) sorry sorry sorry) sorry

/-!
### Heine-Cantor theorem
-/

/-- Heine-Cantor: a continuous function on a compact separated uniform space is uniformly
continuous. -/
theorem compact_space.uniform_continuous_of_continuous {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] [compact_space α] [separated_space α] {f : α → β} (h : continuous f) : uniform_continuous f := sorry

/-- Heine-Cantor: a continuous function on a compact separated set of a uniform space is
uniformly continuous. -/
theorem is_compact.uniform_continuous_on_of_continuous' {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] {s : set α} {f : α → β} (hs : is_compact s) (hs' : is_separated s) (hf : continuous_on f s) : uniform_continuous_on f s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (uniform_continuous_on f s)) (propext uniform_continuous_on_iff_restrict)))
    (compact_space.uniform_continuous_of_continuous
      (eq.mp (Eq._oldrec (Eq.refl (continuous_on f s)) (propext continuous_on_iff_continuous_restrict)) hf))

/-- Heine-Cantor: a continuous function on a compact set of a separated uniform space
is uniformly continuous. -/
theorem is_compact.uniform_continuous_on_of_continuous {α : Type u_1} {β : Type u_2} [uniform_space α] [uniform_space β] [separated_space α] {s : set α} {f : α → β} (hs : is_compact s) (hf : continuous_on f s) : uniform_continuous_on f s :=
  is_compact.uniform_continuous_on_of_continuous' hs (is_separated_of_separated_space s) hf