/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Group.limits
import Mathlib.algebra.category.Group.preadditive
import Mathlib.category_theory.limits.shapes.biproducts
import Mathlib.category_theory.limits.shapes.types
import Mathlib.algebra.group.pi
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# The category of abelian groups has finite biproducts
-/

namespace AddCommGroup

/--
Construct limit data for a binary product in `AddCommGroup`, using `AddCommGroup.of (G × H)`.
-/
def binary_product_limit_cone (G : AddCommGroup) (H : AddCommGroup) : category_theory.limits.limit_cone (category_theory.limits.pair G H) :=
  category_theory.limits.limit_cone.mk
    (category_theory.limits.cone.mk (of (↥G × ↥H))
      (category_theory.nat_trans.mk
        fun (j : category_theory.discrete category_theory.limits.walking_pair) =>
          category_theory.limits.walking_pair.cases_on j (add_monoid_hom.fst ↥G ↥H) (add_monoid_hom.snd ↥G ↥H)))
    (category_theory.limits.is_limit.mk
      fun (s : category_theory.limits.cone (category_theory.limits.pair G H)) =>
        add_monoid_hom.prod
          (category_theory.nat_trans.app (category_theory.limits.cone.π s) category_theory.limits.walking_pair.left)
          (category_theory.nat_trans.app (category_theory.limits.cone.π s) category_theory.limits.walking_pair.right))

protected instance has_binary_product (G : AddCommGroup) (H : AddCommGroup) : category_theory.limits.has_binary_product G H :=
  category_theory.limits.has_limit.mk (binary_product_limit_cone G H)

protected instance category_theory.limits.has_binary_biproduct (G : AddCommGroup) (H : AddCommGroup) : category_theory.limits.has_binary_biproduct G H :=
  category_theory.limits.has_binary_biproduct.of_has_binary_product G H

/--
We verify that the biproduct in AddCommGroup is isomorphic to
the cartesian product of the underlying types:
-/
def biprod_iso_prod (G : AddCommGroup) (H : AddCommGroup) : G ⊞ H ≅ of (↥G × ↥H) :=
  category_theory.limits.is_limit.cone_point_unique_up_to_iso (category_theory.limits.binary_biproduct.is_limit G H)
    (category_theory.limits.limit_cone.is_limit (binary_product_limit_cone G H))

-- Furthermore, our biproduct will automatically function as a coproduct.

namespace has_limit

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
def lift {J : Type u} (F : category_theory.discrete J ⥤ AddCommGroup) (s : category_theory.limits.cone F) : category_theory.limits.cone.X s ⟶ of ((j : category_theory.discrete J) → ↥(category_theory.functor.obj F j)) :=
  add_monoid_hom.mk
    (fun (x : ↥(category_theory.limits.cone.X s)) (j : category_theory.discrete J) =>
      coe_fn (category_theory.nat_trans.app (category_theory.limits.cone.π s) j) x)
    sorry sorry

@[simp] theorem lift_apply {J : Type u} (F : category_theory.discrete J ⥤ AddCommGroup) (s : category_theory.limits.cone F) (x : ↥(category_theory.limits.cone.X s)) (j : J) : coe_fn (lift F s) x j = coe_fn (category_theory.nat_trans.app (category_theory.limits.cone.π s) j) x :=
  rfl

/--
Construct limit data for a product in `AddCommGroup`, using `AddCommGroup.of (Π j, F.obj j)`.
-/
def product_limit_cone {J : Type u} (F : category_theory.discrete J ⥤ AddCommGroup) : category_theory.limits.limit_cone F :=
  category_theory.limits.limit_cone.mk
    (category_theory.limits.cone.mk (of ((j : category_theory.discrete J) → ↥(category_theory.functor.obj F j)))
      (category_theory.discrete.nat_trans
        fun (j : category_theory.discrete J) =>
          add_monoid_hom.apply (fun (j : category_theory.discrete J) => ↥(category_theory.functor.obj F j)) j))
    (category_theory.limits.is_limit.mk (lift F))

end has_limit

protected instance category_theory.limits.has_biproduct {J : Type u} [DecidableEq J] [fintype J] (f : J → AddCommGroup) : category_theory.limits.has_biproduct f :=
  category_theory.limits.has_biproduct.of_has_product f

/--
We verify that the biproduct we've just defined is isomorphic to the AddCommGroup structure
on the dependent function type
-/
def biproduct_iso_pi {J : Type u} [DecidableEq J] [fintype J] (f : J → AddCommGroup) : ⨁ f ≅ of ((j : J) → ↥(f j)) :=
  category_theory.limits.is_limit.cone_point_unique_up_to_iso (category_theory.limits.biproduct.is_limit f)
    (category_theory.limits.limit_cone.is_limit (has_limit.product_limit_cone (category_theory.discrete.functor f)))

protected instance category_theory.limits.has_finite_biproducts : category_theory.limits.has_finite_biproducts AddCommGroup :=
  category_theory.limits.has_finite_biproducts.mk
    fun (J : Type u_1) (_x : DecidableEq J) (_x_1 : fintype J) =>
      category_theory.limits.has_biproducts_of_shape.mk
        fun (f : J → AddCommGroup) => category_theory.limits.has_biproduct f


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

prelude
import Init.Classical
import Init.Data.List

namespace Lean.Data.AC
inductive Expr
  | var (x : Nat)
  | op (lhs rhs : Expr)
  deriving Inhabited, Repr, BEq

structure Variable {α : Sort u} (op : α → α → α) : Type u where
  value : α
  neutral : Option $ IsNeutral op value

structure Context (α : Sort u) where
  op : α → α → α
  assoc : IsAssociative op
  comm : Option $ IsCommutative op
  idem : Option $ IsIdempotent op
  vars : List (Variable op)
  arbitrary : α

class ContextInformation (α : Sort u) where
  isNeutral : α → Nat → Bool
  isComm : α → Bool
  isIdem : α → Bool

class EvalInformation (α : Sort u) (β : Sort v) where
  arbitrary : α → β
  evalOp : α → β → β → β
  evalVar : α → Nat → β

def Context.var (ctx : Context α) (idx : Nat) : Variable ctx.op :=
  ctx.vars.getD idx ⟨ctx.arbitrary, none⟩

instance : ContextInformation (Context α) where
  isNeutral ctx x := ctx.var x |>.neutral.isSome
  isComm ctx := ctx.comm.isSome
  isIdem ctx := ctx.idem.isSome

instance : EvalInformation (Context α) α where
  arbitrary ctx := ctx.arbitrary
  evalOp ctx := ctx.op
  evalVar ctx idx := ctx.var idx |>.value

def eval (β : Sort u) [EvalInformation α β] (ctx : α) : (ex : Expr) → β
  | Expr.var idx => EvalInformation.evalVar ctx idx
  | Expr.op l r => EvalInformation.evalOp ctx (eval β ctx l) (eval β ctx r)

def Expr.toList : Expr → List Nat
  | Expr.var idx => [idx]
  | Expr.op l r => l.toList.append r.toList

def evalList (β : Sort u) [EvalInformation α β] (ctx : α) : List Nat → β
  | [] => EvalInformation.arbitrary ctx
  | [x] => EvalInformation.evalVar ctx x
  | x :: xs => EvalInformation.evalOp ctx (EvalInformation.evalVar ctx x) (evalList β ctx xs)

def insert (x : Nat) : List Nat → List Nat
  | [] => [x]
  | a :: as => if x < a then x :: a :: as else a :: insert x as

def sort (xs : List Nat) : List Nat :=
  let rec loop : List Nat → List Nat → List Nat
    | acc, [] => acc
    | acc, x :: xs => loop (insert x acc) xs
  loop [] xs

def mergeIdem (xs : List Nat) : List Nat :=
  let rec loop : Nat → List Nat → List Nat
    | curr, next :: rest =>
      if curr = next then
        loop curr rest
      else
        curr :: loop next rest
    | curr, [] => [curr]

  match xs with
  | [] => []
  | x :: xs => loop x xs

def removeNeutrals [info : ContextInformation α] (ctx : α) : List Nat → List Nat
  | x :: xs =>
    match loop (x :: xs) with
    | [] => [x]
    | ys => ys
  | [] => []
  where loop : List Nat → List Nat
    | x :: xs =>
      match info.isNeutral ctx x with
      | true => loop xs
      | false => x :: loop xs
    | [] => []

def norm [info : ContextInformation α] (ctx : α) (e : Expr) : List Nat :=
  let xs := e.toList
  let xs := removeNeutrals ctx xs
  let xs := if info.isComm ctx then sort xs else xs
  if info.isIdem ctx then mergeIdem xs else xs

theorem List.two_step_induction
  {motive : List Nat → Sort u}
  (l : List Nat)
  (empty : motive [])
  (single : ∀ a, motive [a])
  (step : ∀ a b l, motive (b :: l) → motive (a :: b :: l))
  : motive l := by
  induction l with
  | nil => assumption
  | cons a l => cases l; apply single; apply step; assumption

theorem Context.mergeIdem_nonEmpty (e : List Nat) (h : e ≠ []) : mergeIdem e ≠ [] := by
  induction e using List.two_step_induction with
  | empty => simp_all
  | single => simp [mergeIdem, mergeIdem.loop]
  | step => simp [mergeIdem, mergeIdem.loop] at *; split <;> simp_all

theorem Context.mergeIdem_head : mergeIdem (x :: x :: xs) = mergeIdem (x :: xs) := by
  simp [mergeIdem, mergeIdem.loop]

theorem Context.mergeIdem_head2 (h : x ≠ y) : mergeIdem (x :: y :: ys) = x :: mergeIdem (y :: ys) := by
  simp [mergeIdem, mergeIdem.loop, h]

theorem Context.evalList_mergeIdem (ctx : Context α) (h : ContextInformation.isIdem ctx) (e : List Nat) : evalList α ctx (mergeIdem e) = evalList α ctx e := by
  have h : IsIdempotent ctx.op := by simp [ContextInformation.isIdem, Option.isSome] at h; cases h₂ : ctx.idem <;> simp [h₂] at h; assumption
  induction e using List.two_step_induction with
  | empty => rfl
  | single => rfl
  | step x y ys ih =>
    cases ys with
    | nil =>
      simp [mergeIdem, mergeIdem.loop]
      split
      case inl h₂ => simp [evalList, h₂, h.1, EvalInformation.evalOp]
      rfl
    | cons z zs =>
      by_cases h₂ : x = y
      case inl =>
        rw [h₂, mergeIdem_head, ih]
        simp [evalList, ←ctx.assoc.1, h.1, EvalInformation.evalOp]
      case inr =>
        rw [mergeIdem_head2]
        by_cases h₃ : y = z
        case inl =>
          simp [mergeIdem_head, h₃, evalList]
          cases h₄ : mergeIdem (z :: zs) with
          | nil => apply absurd h₄; apply mergeIdem_nonEmpty; simp
          | cons u us => simp_all [mergeIdem, mergeIdem.loop, evalList]
        case inr =>
          simp [mergeIdem_head2, h₃, evalList] at *
          rw [ih]
        assumption

theorem insert_nonEmpty : insert x xs ≠ [] := by
  induction xs with
  | nil => simp [insert]
  | cons x xs _  => simp [insert]; split <;> simp

theorem Context.sort_loop_nonEmpty (xs : List Nat) (h : xs ≠ []) : sort.loop xs ys ≠ [] := by
  induction ys generalizing xs with
  | nil => simp [sort.loop]; assumption
  | cons y _  ih => simp [sort.loop]; apply ih; apply insert_nonEmpty

theorem Context.evalList_insert
  (ctx : Context α)
  (h : IsCommutative ctx.op)
  (x : Nat)
  (xs : List Nat)
  : evalList α ctx (insert x xs) = evalList α ctx (x::xs) := by
  induction xs using List.two_step_induction with
  | empty => rfl
  | single =>
    simp [insert]
    split
    . rfl
    . simp [evalList, h.1, EvalInformation.evalOp]
  | step y z zs ih =>
    simp [insert] at *; split
    case inl => rfl
    case inr =>
      split
      case inl => simp [evalList, EvalInformation.evalOp]; rw [h.1, ctx.assoc.1, h.1 (evalList _ _ _)]
      case inr => simp_all [evalList, EvalInformation.evalOp]; rw [h.1, ctx.assoc.1, h.1 (evalList _ _ _)]

theorem Context.evalList_sort_congr
  (ctx : Context α)
  (h : IsCommutative ctx.op)
  (h₂ : evalList α ctx a = evalList α ctx b)
  (h₃ : a ≠ [])
  (h₄ : b ≠ [])
  : evalList α ctx (sort.loop a c) = evalList α ctx (sort.loop b c) := by
  induction c generalizing a b with
  | nil => simp [sort.loop, h₂]
  | cons c _  ih =>
    simp [sort.loop]; apply ih; simp [evalList_insert ctx h, evalList]
    cases a with
    | nil => apply absurd h₃; simp
    | cons a as =>
      cases b with
      | nil => apply absurd h₄; simp
      | cons b bs => simp [evalList, h₂]
    all_goals apply insert_nonEmpty

theorem Context.evalList_sort_loop_swap
  (ctx : Context α)
  (h : IsCommutative ctx.op)
  (xs ys : List Nat)
  : evalList α ctx (sort.loop xs (y::ys)) = evalList α ctx (sort.loop (y::xs) ys) := by
  induction ys generalizing y xs with
  | nil => simp [sort.loop, evalList_insert ctx h]
  | cons z zs _  =>
    simp [sort.loop]; apply evalList_sort_congr ctx h
    simp [evalList_insert ctx h]
    cases h₂ : insert y xs
    . apply absurd h₂; simp [insert_nonEmpty]
    . simp [evalList, ←h₂, evalList_insert ctx h]
    all_goals simp [insert_nonEmpty]

theorem Context.evalList_sort_cons
  (ctx : Context α)
  (h : IsCommutative ctx.op)
  (x : Nat)
  (xs : List Nat)
  : evalList α ctx (sort (x :: xs)) = evalList α ctx (x :: sort xs) := by
  simp [sort, sort.loop]
  generalize [] = ys
  induction xs generalizing x ys with
  | nil => simp [sort.loop, evalList_insert ctx h]
  | cons z zs ih =>
    rw [evalList_sort_loop_swap ctx h]; simp [sort.loop, ←ih]; apply evalList_sort_congr ctx h; rw [evalList_insert ctx h]
    cases h₂ : insert x ys with
    | nil => apply absurd h₂; simp [insert_nonEmpty]
    | cons u us =>
      cases h₃ : insert z ys with
      | nil => apply absurd h₃; simp [insert_nonEmpty]
      | cons v vs =>
        simp [evalList, ←h₂, ←h₃, evalList_insert ctx h]
        cases ys
        . simp [evalList, h.1, EvalInformation.evalOp]
        . simp [evalList, EvalInformation.evalOp]; rw [h.1, ctx.assoc.1, h.1 (evalList _ _ _)]
    all_goals simp [insert_nonEmpty]

theorem Context.evalList_sort (ctx : Context α) (h : ContextInformation.isComm ctx) (e : List Nat) : evalList α ctx (sort e) = evalList α ctx e := by
  have h : IsCommutative ctx.op := by simp [ContextInformation.isComm, Option.isSome] at h; cases h₂ : ctx.comm <;> simp [h₂] at h; assumption
  induction e using List.two_step_induction with
  | empty => rfl
  | single => rfl
  | step x y ys ih =>
    simp [evalList_sort_cons ctx h]
    cases h₂ : sort (y :: ys) with
    | nil => simp [sort, sort.loop] at *; apply absurd h₂; apply sort_loop_nonEmpty; apply insert_nonEmpty
    | cons z zs => simp [evalList, ←h₂, ih]

theorem Context.toList_nonEmpty (e : Expr) : e.toList ≠ [] := by
  induction e with
  | var => simp [Expr.toList]
  | op l r ih₁ _   =>
    simp [Expr.toList]
    cases h : l.toList with
    | nil => contradiction
    | cons => simp [List.append]

theorem Context.unwrap_isNeutral
  {ctx : Context α}
  {x : Nat}
  : ContextInformation.isNeutral ctx x = true → IsNeutral (EvalInformation.evalOp ctx) (EvalInformation.evalVar (β := α) ctx x) := by
  simp [ContextInformation.isNeutral, Option.isSome, EvalInformation.evalOp, EvalInformation.evalVar]
  match (var ctx x).neutral with
  | some hn => intro; assumption
  | none => intro; contradiction

theorem Context.evalList_removeNeutrals (ctx : Context α) (e : List Nat) : evalList α ctx (removeNeutrals ctx e) = evalList α ctx e := by
  induction e using List.two_step_induction with
  | empty => rfl
  | single =>
    simp [removeNeutrals, removeNeutrals.loop]; split
    case h_1 => rfl
    case h_2 h => split at h <;> simp_all
  | step x y ys ih =>
    cases h₁ : ContextInformation.isNeutral ctx x <;> cases h₂ : ContextInformation.isNeutral ctx y <;> cases h₃ : removeNeutrals.loop ctx ys
    <;> simp [removeNeutrals, removeNeutrals.loop, h₁, h₂, h₃, evalList, ←ih]
    <;> (try simp [unwrap_isNeutral h₂ |>.2])
    <;> (try simp [unwrap_isNeutral h₁ |>.1])

theorem Context.evalList_append
  (ctx : Context α)
  (l r : List Nat)
  (h₁ : l ≠ [])
  (h₂ : r ≠ [])
  : evalList α ctx (l.append r) = ctx.op (evalList α ctx l) (evalList α ctx r) := by
  induction l using List.two_step_induction with
  | empty => simp_all
  | single x =>
    cases r
    . simp at h₂
    . simp [List.append, evalList, EvalInformation.evalOp]
  | step x y ys ih => simp [List.append, evalList, EvalInformation.evalOp] at *; rw [ih]; simp [ctx.assoc.1]

theorem Context.eval_toList (ctx : Context α) (e : Expr) : evalList α ctx e.toList = eval α ctx e := by
  induction e with
  | var x => rfl
  | op l r ih₁ ih₂ =>
    simp [evalList, Expr.toList, eval, ←ih₁, ←ih₂]
    apply evalList_append <;> apply toList_nonEmpty

theorem Context.eval_norm (ctx : Context α) (e : Expr) : evalList α ctx (norm ctx e) = eval α ctx e := by
  simp [norm]
  cases h₁ : ContextInformation.isIdem ctx <;> cases h₂ : ContextInformation.isComm ctx <;>
  simp_all [evalList_removeNeutrals, eval_toList, toList_nonEmpty, evalList_mergeIdem, evalList_sort]

theorem Context.eq_of_norm (ctx : Context α) (a b : Expr) (h : norm ctx a == norm ctx b) : eval α ctx a = eval α ctx b := by
  have h := congrArg (evalList α ctx) (eq_of_beq h)
  rw [eval_norm, eval_norm] at h
  assumption

end Lean.Data.AC


/-
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 topological_space 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, ⟨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 (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_inhabited_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).isometric_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).isometric_on_range.symm.trans
               isomΨ.isometric_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. -/
lemma to_GH_space_eq_to_GH_space_iff_isometric {X : Type u} [metric_space X] [compact_space X]
  [nonempty X] {Y : Type v} [metric_space Y] [compact_space Y] [nonempty Y] :
  to_GH_space X = to_GH_space Y ↔ nonempty (X ≃ᵢ Y) :=
⟨begin
  simp only [to_GH_space, quotient.eq],
  rintro ⟨e⟩,
  have I : ((nonempty_compacts.Kuratowski_embedding X) ≃ᵢ
             (nonempty_compacts.Kuratowski_embedding Y))
          = ((range (Kuratowski_embedding X)) ≃ᵢ (range (Kuratowski_embedding Y))),
    by { dunfold nonempty_compacts.Kuratowski_embedding, refl },
  have f := (Kuratowski_embedding.isometry X).isometric_on_range,
  have g := (Kuratowski_embedding.isometry Y).isometric_on_range.symm,
  exact ⟨f.trans $ (cast I e).trans g⟩
end,
begin
  rintro ⟨e⟩,
  simp only [to_GH_space, quotient.eq],
  have f := (Kuratowski_embedding.isometry X).isometric_on_range.symm,
  have g := (Kuratowski_embedding.isometry Y).isometric_on_range,
  have I : ((range (Kuratowski_embedding X)) ≃ᵢ (range (Kuratowski_embedding Y))) =
    ((nonempty_compacts.Kuratowski_embedding X) ≃ᵢ
      (nonempty_compacts.Kuratowski_embedding Y)),
    by { dunfold nonempty_compacts.Kuratowski_embedding, refl },
  exact ⟨cast I ((f.trans e).trans g)⟩
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 : 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,
    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 [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.compact.bounded q.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).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.compact.bounded q.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 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.compact.bounded q.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 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 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, 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.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}) :=
      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 Φ) := 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.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 (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_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 `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⟩) },
  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⟩) (λ 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 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, 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⟩,
        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, |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
        |ε⁻¹| * |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 [ε], 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 },
      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 [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 := ⌊ε⁻¹ * 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 [Ψ] },
      -- 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 = ⌊ε⁻¹ * 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 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 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 [ε], 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)

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
  { space  := X 0,
    metric := by apply_instance,
    embed  := id,
    isom   := λ x y, rfl }
(λ n Y, by letI : metric_space Y.space := Y.metric; exact
  { 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,
  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,
    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_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) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.preadditive
import category_theory.limits.shapes.biproducts

/-!
# Additive Functors

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.

# Implementation details

`functor.additive` is a `Prop`-valued class, defined by saying that
for every two objects `X` and `Y`, the map
`F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian
groups.

# Project:

- Prove that a functor is additive if it preserves finite biproducts
  (See https://stacks.math.columbia.edu/tag/010M.)
-/

namespace category_theory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class functor.additive {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] (F : C ⥤ D) : Prop :=
(map_zero' : Π {X Y : C}, F.map (0 : X ⟶ Y) = 0 . obviously)
(map_add' : Π {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g . obviously)

section preadditive

namespace functor

section
variables {C D : Type*} [category C] [category D] [preadditive C]
  [preadditive D] (F : C ⥤ D) [functor.additive F]

@[simp]
lemma map_zero {X Y : C} : F.map (0 : X ⟶ Y) = 0 :=
functor.additive.map_zero'

@[simp]

instance : additive (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] (G : D ⥤ E) [functor.additive G] :
  additive (F ⋙ G) :=
{}

/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps]
def map_add_hom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
{ to_fun := λ f, F.map f,
  map_zero' := F.map_zero,
  map_add' := λ _ _, F.map_add }

lemma coe_map_add_hom {X Y : C} : ⇑(F.map_add_hom : (X ⟶ Y) →+ _) = @map C _ D _ F X Y := rfl

@[simp]
lemma map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = - F.map f :=
F.map_add_hom.map_neg _

@[simp]
lemma map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
F.map_add_hom.map_sub _ _

open_locale big_operators

@[simp]
lemma map_sum {X Y : C} {α : Type*} (f : α → (X ⟶ Y)) (s : finset α) :
  F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
(F.map_add_hom : (X ⟶ Y) →+ _).map_sum f s

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] (F : C → D)

instance induced_functor_additive : functor.additive (induced_functor F) := {}

end induced_category

section
-- To talk about preservation of biproducts we need to specify universes explicitly.

noncomputable theory
universes v u₁ u₂

variables {C : Type u₁} {D : Type u₂} [category.{v} C] [category.{v} D]
  [preadditive C] [preadditive D] (F : C ⥤ D) [functor.additive F]

open category_theory.limits

/--
An additive functor between preadditive categories creates finite biproducts.
-/
instance map_has_biproduct {J : Type v} [fintype J] [decidable_eq J] (f : J → C) [has_biproduct f] :
  has_biproduct (λ j, F.obj (f j)) :=
has_biproduct_of_total
{ X := F.obj (⨁ f),
  π := λ j, F.map (biproduct.π f j),
  ι := λ j, F.map (biproduct.ι f j),
  ι_π := λ j j', by { simp only [←F.map_comp], split_ifs, { subst h, simp, }, { simp [h], }, }, }
(by simp_rw [←F.map_comp, ←F.map_sum, biproduct.total, functor.map_id])

/--
An additive functor between preadditive categories preserves finite biproducts.
-/
-- This essentially repeats the work of the previous instance,
-- but gives good definitional reduction to `biproduct.lift` and `biproduct.desc`.
@[simps]
def map_biproduct {J : Type v} [fintype J] [decidable_eq J] (f : J → C) [has_biproduct f] :
  F.obj (⨁ f) ≅ ⨁ (λ j, F.obj (f j)) :=
{ hom := biproduct.lift (λ j, F.map (biproduct.π f j)),
  inv := biproduct.desc (λ j, F.map (biproduct.ι f j)),
  hom_inv_id' :=
  by simp only [biproduct.lift_desc, ←F.map_comp, ←F.map_sum, biproduct.total, F.map_id],
  inv_hom_id' :=
  begin
    ext j j',
    simp only [category.comp_id,  category.assoc, biproduct.lift_π, biproduct.ι_desc_assoc,
      ←F.map_comp, biproduct.ι_π, F.map_dite, dif_ctx_congr, eq_to_hom_map, F.map_zero],
  end }

end

end functor

namespace equivalence

variables {C D : Type*} [category C] [category D] [preadditive C] [preadditive D]

instance inverse_additive (e : C ≌ D) [e.functor.additive] : e.inverse.additive :=
{ map_zero' := λ X Y, by { apply e.functor.map_injective, simp, },
  map_add' := λ X Y f g, by { apply e.functor.map_injective, simp, }, }

end equivalence

end preadditive

end category_theory


import GMLInit.Meta.Stable
import GMLInit.Meta.Decidable

namespace Relation

section Reflexive

class Reflexive {α} (r : α → α → Prop) : Prop where
  protected refl (x) : r x x

protected abbrev Reflexive.rfl {α} {r : α → α → Prop} [Reflexive r] {x : α} := Reflexive.refl (r:=r) x

theorem Reflexive.of_eq {α} (r : α → α → Prop) [Reflexive r] : {x y : α} → x = y → r x y
| _, _, rfl => Reflexive.rfl

instance (α) [Setoid α] : Reflexive (α:=α) (.≈.) := ⟨Setoid.refl⟩
instance (α) [Setoid α] : Reflexive (α:=α) Setoid.r := ⟨Setoid.refl⟩
instance (α) : Reflexive (α:=α) (.≅.) := ⟨HEq.refl⟩
instance (α) : Reflexive (α:=α) (.=.) := ⟨Eq.refl⟩
instance : Reflexive (.→.) := ⟨@id⟩
instance : Reflexive (.↔.) := ⟨Iff.refl⟩

instance {α} (r : α → α → Prop) [Reflexive r] : Reflexive (TC r) where
  refl x := TC.base _ _ (Reflexive.refl x)

end Reflexive

section Irreflexive

abbrev Irreflexive {α} (r : α → α → Prop) : Prop := Reflexive (¬ r . .)

protected abbrev Irreflexive.irrefl {α} {r : α → α → Prop} [Irreflexive r] (x : α) := Reflexive.refl (r:=(¬ r . .)) x

protected abbrev Irreflexive.irrfl {α} {r : α → α → Prop} [Irreflexive r] {x : α} := Irreflexive.irrefl (r:=r) x

theorem Irreflexive.ne_of {α} {r : α → α → Prop} [Irreflexive r] : {x y : α} → r x y → x ≠ y
| _, _, h, rfl => Irreflexive.irrfl h

instance (α) : Irreflexive (α:=α) (.≠.) := ⟨λ x h => h (Eq.refl x)⟩

end Irreflexive

section Symmetric

class HSymmetric (r : α → β → Prop) (s : β → α → Prop) : Prop where
  protected symm {x y} : r x y → s y x

class Symmetric (r : α → α → Prop) : Prop where
  protected symm {x y} : r y x → r x y

@[default_instance]
instance {α} (r : α → α → Prop) [Symmetric r] : HSymmetric r r := ⟨Symmetric.symm⟩

abbrev Asymmetric (r : α → α → Prop) := HSymmetric r (¬ r . .)

protected def Asymmetric.asymm {α} {r : α → α → Prop} [Asymmetric r] {x y : α} : r x y → ¬ r y x := HSymmetric.symm (r:=r) (s:=(¬ r . .))

instance (α) : Symmetric (α:=α) (.=.) := ⟨Eq.symm⟩
instance (α) : Symmetric (α:=α) (.≠.) := ⟨Ne.symm⟩
instance (α) [Setoid α] : Symmetric (α:=α) (.≈.) := ⟨Setoid.symm⟩
instance (α) [Setoid α] : Symmetric (α:=α) Setoid.r := ⟨Setoid.symm⟩
instance (α β) : HSymmetric (α:=α) (β:=β) (.≅.) (.≅.) := ⟨HEq.symm⟩
instance (α) [LE α] : HSymmetric (α:=α) (.≤.) (.≥.) := ⟨id⟩
instance (α) [LE α] : HSymmetric (α:=α) (.≥.) (.≤.) := ⟨id⟩
instance (α) [LT α] : HSymmetric (α:=α) (.<.) (.>.) := ⟨id⟩
instance (α) [LT α] : HSymmetric (α:=α) (.>.) (.<.) := ⟨id⟩
instance : Symmetric (.↔.) := ⟨Iff.symm⟩

instance {α} (r : α → α → Prop) [Symmetric r] : Symmetric (TC r) where
  symm := by
    intros x y hxy
    induction hxy with
    | base x y h =>
      apply TC.base
      exact Symmetric.symm h
    | trans x y z _ _ hyx hzy =>
      apply TC.trans
      exact hzy
      exact hyx

end Symmetric

section Antisymmetric

class HAntisymmetric {α} (r : α → α → Prop) (s : outParam (α → α → Prop)) : Prop where
  protected antisymm {x y} : r x y → r y x → s x y

class Antisymmetric {α} (r : α → α → Prop) : Prop where
  protected antisymm {x y} : r x y → r y x → x = y

@[default_instance]
instance {α} (r : α → α → Prop) [Antisymmetric r] : HAntisymmetric r Eq where
  antisymm := Antisymmetric.antisymm

instance : HAntisymmetric (.→.) (.↔.) := ⟨Iff.intro⟩

abbrev WeaklyConnex {α} (r : α → α → Prop) := Antisymmetric (λ x y => ¬ r y x)

abbrev WeaklyConnex.connex {α} {r : α → α → Prop} [WeaklyConnex r] {x y} : ¬ r y x → ¬ r x y → x = y :=
  Antisymmetric.antisymm (r := λ x y => ¬ r y x)

end Antisymmetric

section Transitive

class HTransitive {α β γ} (r : α → β → Prop) (s : β → γ → Prop) (t : outParam (α → γ → Prop)) : Prop where
  protected trans {x y z} : (left : r x y) → (right : s y z) → t x z

instance {α β γ} (r : α → β → Prop) (s : β → γ → Prop) (t : α → γ → Prop) [HTransitive r s t] : Trans r s t where
  trans := HTransitive.trans

class Transitive {α} (r : α → α → Prop) : Prop where
  protected trans {x y z} : (left : r x y) → (right : r y z) → r x z

@[default_instance]
instance {α} (r : α → α → Prop) [Transitive r] : HTransitive r r r := ⟨Transitive.trans⟩

instance (α) : Transitive (α:=α) (.=.) := ⟨Eq.trans⟩
instance (α β γ) : HTransitive (α:=α) (β:=β) (γ:=γ) (.≅.) (.≅.) (.≅.) := ⟨HEq.trans⟩
instance {α β} (r : α → β → Prop) : HTransitive (.=.) r r := ⟨λ he hr => he ▸ hr⟩
instance {α β} (r : α → β → Prop) : HTransitive r (.=.) r := ⟨λ hr he => he ▸ hr⟩
instance (α) [Setoid α] : Transitive (α:=α) (.≈.) := ⟨Setoid.trans⟩
instance (α) [Setoid α] : Transitive (α:=α) Setoid.r := ⟨Setoid.trans⟩
instance : Transitive (.→.) := ⟨λ h₁ h₂ h => h₂ (h₁ h)⟩
instance : Transitive (.↔.) := ⟨Iff.trans⟩
instance {α} (r : α → α → Prop) : Transitive (TC r) := ⟨TC.trans _ _ _⟩

instance {α} (r : α → α → Prop) [Irreflexive r] [Transitive r] : Asymmetric r := ⟨fun hxy hyx => Irreflexive.irrfl (Transitive.trans hxy hyx)⟩

end Transitive

section Euclidean

class HEuclidean {α β γ} (r : α → β → Prop) (s : α → γ → Prop) (t : outParam (β → γ → Prop)) : Prop where
  protected eucl {x y z} : (left : r x y) → (right : s x z) → t y z

class Euclidean {α} (r : α → α → Prop) : Prop where
  protected eucl {x y z} : (left : r x y) → (right : r x z) → r y z

@[default_instance]
instance {α} (r : α → α → Prop) [Euclidean r] : HEuclidean r r r := ⟨Euclidean.eucl⟩

instance [Reflexive r] [Euclidean r] : Symmetric r where
  symm hxy := Euclidean.eucl hxy (Reflexive.refl _)

instance [Symmetric r] [Transitive r] : Euclidean r where
  eucl hxy hxz := Transitive.trans (Symmetric.symm hxy) hxz

def Euclidean.toSymmetric {α} (r : α → α → Prop) [Reflexive r] [Euclidean r] : Symmetric r where
  symm hxy := Euclidean.eucl hxy Reflexive.rfl

def Euclidean.toTransitive {α} (r : α → α → Prop) [Symmetric r] [Euclidean r] : Transitive r where
  trans hxy hyz := Euclidean.eucl (Symmetric.symm hxy) hyz

end Euclidean

section Total

class HTotal {α β} (r : α → β → Prop) (s : β → α → Prop) : Prop where
  protected total (x y) : (r x y) ∨ (s y x)

class Total {α} (r : α → α → Prop) : Prop where
  protected total (x y) : (r x y) ∨ (r y x)

@[default_instance]
instance {α} (r : α → α → Prop) [Total r] : HTotal r r := ⟨Total.total⟩

end Total

section Comparison

class HComparison {α} (r : α → α → Prop) (s : α → α → Prop) : Prop where
  protected compare {x y} : s x y → (z : α) → r x z ∨ r z y

class Comparison {α} (r : α → α → Prop) : Prop where
  protected compare {x y} : r x y → (z : α) → r x z ∨ r z y

@[default_instance]
instance {α} (r : α → α → Prop) [Comparison r] : HComparison r r := ⟨Comparison.compare⟩

def Transitive.toComparison {α} (r : α → α → Prop) [ComplementedRel r] [Transitive r] : Comparison (λ x y => ¬ r y x) where
  compare := by
    intro x y nxy z
    by_cases r z x using Complemented with
    | .isFalse nxz =>
      left
      exact nxz
    | .isTrue hxz =>
      right
      intro hzy
      apply nxy
      exact Transitive.trans hzy hxz

instance Comparison.toTransitive {α} (r : α → α → Prop) [Comparison r] : Transitive (λ x y => ¬ r y x) where
  trans := by
    intros x y z nxy nyz hxz
    cases Comparison.compare hxz y with
    | inl hyz => exact nyz hyz
    | inr hxy => exact nxy hxy

end Comparison

section Connex

class HConnex {α} (r : α → α → Prop) (s : α → α → Prop) : Prop where
  protected connex {x y} : s x y → r x y ∨ r y x

class Connex {α} (r : α → α → Prop) : Prop where
  protected connex {x y} : x ≠ y → r x y ∨ r y x

@[default_instance]
instance {α} (r : α → α → Prop) [Connex r] : HConnex r (.≠.) := ⟨Connex.connex⟩

def Connex.toAntisymmetric {α} (r : α → α → Prop) [StableEq α] [Connex r] : Antisymmetric (λ x y => ¬ r y x) where
  antisymm := by
    intro x y nxy nyx
    by_contradiction
    | assuming hne =>
      cases Connex.connex (r:=r) hne with
      | inl hyx => exact nyx hyx
      | inr hxy => exact nxy hxy

def Antisymmetric.toConnex {α} (r : α → α → Prop) [WeaklyComplementedRel r] [Antisymmetric r] : Connex fun x y => ¬ r y x where
  connex := by
    intro x y hne
    rw [←And.deMorgan]
    intro ⟨hyx, hxy⟩
    absurd hne
    exact Antisymmetric.antisymm hxy hyx

def Connex.toComparison {α} (r : α → α → Prop) [ComplementedEq α] [Connex r] [Transitive r] : Comparison r where
  compare := by
    intro x y hxy z
    by_cases x = z using Complemented with
    | .isTrue rfl => right; exact hxy
    | .isFalse hne =>
      match Connex.connex (r:=r) hne with
      | .inl hxz => left; exact hxz
      | .inr hzx => right; exact Transitive.trans hzx hxy

end Connex

end Relation


-- From @joehendrix
-- The imul doesn't type check as Lean won't try to coerce from a reg (bv 64) to a expr (bv ?u)

inductive MCType
| bv : Nat → MCType

open MCType

inductive Reg : MCType → Type
| rax (n : Nat) : Reg (bv n)

inductive Expr : MCType → Type
| r : ∀{tp:MCType}, Reg tp → Expr tp
| sextC {s:Nat} (x : Expr (bv s)) (t:Nat) : Expr (bv t)

instance reg_is_expr {tp:MCType} : Coe (Reg tp) (Expr tp) := ⟨Expr.r⟩

def bvmul {w:Nat} (x y : Expr (bv w)) : Expr (bv w) := x

/-
Remark: Joe's original example used the following definition.
```
def sext {s:Nat} (x : Expr (bv s)) (t:Nat) : Expr (bv t) := Expr.sextC x t
```
This definition is bad because the parameter `s` is unconstrained.
Type class resolution gets stuck at
```
CoeT (Reg (bv 64)) (Reg.rax 64) (Expr (bv ?m_1))
```
It would have to set `?m_1 := 64` which is not allowed since TC should
not change external TC metavariables.
I fixed the problem by changing the definition. Now,
type inference will enforce that `?m_1` must be 64, and TC will be able
to synthesize the instance.
-/
def sext {s:Nat} (x : Expr (bv s)) (n:Nat) : Expr (bv (s+n)) := Expr.sextC x (s+n)

open MCType

variable {u:Nat} (e : Expr (bv 64))
#check (bvmul (sext (Reg.rax 64) 64) (sext e 64) : Expr (bv 128))


/-
Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning and Patrick Lutz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.normal
import Mathlib.field_theory.primitive_element
import Mathlib.field_theory.fixed
import Mathlib.ring_theory.power_basis
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Galois Extensions

In this file we define Galois extensions as extensions which are both separable and normal.

## Main definitions

- `is_galois F E` where `E` is an extension of `F`
- `fixed_field H` where `H : subgroup (E ≃ₐ[F] E)`
- `fixing_subgroup K` where `K : intermediate_field F E`
- `galois_correspondence` where `E/F` is finite dimensional and Galois

## Main results

- `fixing_subgroup_of_fixed_field` : If `E/F` is finite dimensional (but not necessarily Galois)
  then `fixing_subgroup (fixed_field H) = H`
- `fixed_field_of_fixing_subgroup`: If `E/F` is finite dimensional and Galois
  then `fixed_field (fixing_subgroup K) = K`
Together, these two result prove the Galois correspondence

- `is_galois.tfae` : Equivalent characterizations of a Galois extension of finite degree
-/

/-- A field extension E/F is galois if it is both separable and normal -/
def is_galois (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E] :=
  is_separable F E ∧ normal F E

namespace is_galois

protected instance self (F : Type u_1) [field F] : is_galois F F :=
  { left := Mathlib.is_separable_self F, right := Mathlib.normal_self F }

protected instance to_is_separable (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [h : is_galois F E] : is_separable F E :=
  and.left h

protected instance to_normal (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [h : is_galois F E] : normal F E :=
  and.right h

theorem integral (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] [is_galois F E]
    (x : E) : is_integral F x :=
  normal.is_integral F x

theorem separable (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E]
    [h : is_galois F E] (x : E) : polynomial.separable (minpoly F x) :=
  and.right (and.left h x)

-- TODO(Commelin, Browning): rename this to `splits`

theorem normal (F : Type u_1) [field F] {E : Type u_2} [field E] [algebra F E] [is_galois F E]
    (x : E) : polynomial.splits (algebra_map F E) (minpoly F x) :=
  normal.splits F x

protected instance of_fixed_field (E : Type u_2) [field E] (G : Type u_1) [group G] [fintype G]
    [mul_semiring_action G E] : is_galois (↥(mul_action.fixed_points G E)) E :=
  { left := fixed_points.separable G E, right := fixed_points.normal G E }

theorem intermediate_field.adjoin_simple.card_aut_eq_findim (F : Type u_1) [field F] (E : Type u_2)
    [field E] [algebra F E] [finite_dimensional F E] {α : E} (hα : is_integral F α)
    (h_sep : polynomial.separable (minpoly F α))
    (h_splits :
      polynomial.splits
        (algebra_map F ↥(intermediate_field.adjoin F (intermediate_field.insert.insert ∅ α)))
        (minpoly F α)) :
    fintype.card
          (alg_equiv F ↥(intermediate_field.adjoin F (intermediate_field.insert.insert ∅ α))
            ↥(intermediate_field.adjoin F (intermediate_field.insert.insert ∅ α))) =
        finite_dimensional.findim F
          ↥(intermediate_field.adjoin F (intermediate_field.insert.insert ∅ α)) :=
  sorry

theorem card_aut_eq_findim (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [finite_dimensional F E] [h : is_galois F E] :
    fintype.card (alg_equiv F E E) = finite_dimensional.findim F E :=
  sorry

end is_galois

theorem is_galois.tower_top_of_is_galois (F : Type u_1) (K : Type u_2) (E : Type u_3) [field F]
    [field K] [field E] [algebra F K] [algebra F E] [algebra K E] [is_scalar_tower F K E]
    [is_galois F E] : is_galois K E :=
  { left := is_separable_tower_top_of_is_separable F K E,
    right := normal.tower_top_of_normal F K E }

protected instance is_galois.tower_top_intermediate_field {F : Type u_1} {E : Type u_3} [field F]
    [field E] [algebra F E] (K : intermediate_field F E) [h : is_galois F E] : is_galois (↥K) E :=
  is_galois.tower_top_of_is_galois F (↥K) E

theorem is_galois_iff_is_galois_bot {F : Type u_1} {E : Type u_3} [field F] [field E]
    [algebra F E] : is_galois (↥⊥) E ↔ is_galois F E :=
  { mp := fun (h : is_galois (↥⊥) E) => is_galois.tower_top_of_is_galois (↥⊥) F E,
    mpr := fun (h : is_galois F E) => is_galois.tower_top_intermediate_field ⊥ }

theorem is_galois.of_alg_equiv {F : Type u_1} {E : Type u_3} [field F] [field E] {E' : Type u_4}
    [field E'] [algebra F E'] [algebra F E] [h : is_galois F E] (f : alg_equiv F E E') :
    is_galois F E' :=
  { left := is_separable.of_alg_hom F E ↑(alg_equiv.symm f), right := normal.of_alg_equiv f }

theorem alg_equiv.transfer_galois {F : Type u_1} {E : Type u_3} [field F] [field E] {E' : Type u_4}
    [field E'] [algebra F E'] [algebra F E] (f : alg_equiv F E E') :
    is_galois F E ↔ is_galois F E' :=
  { mp := fun (h : is_galois F E) => is_galois.of_alg_equiv f,
    mpr := fun (h : is_galois F E') => is_galois.of_alg_equiv (alg_equiv.symm f) }

theorem is_galois_iff_is_galois_top {F : Type u_1} {E : Type u_3} [field F] [field E]
    [algebra F E] : is_galois F ↥⊤ ↔ is_galois F E :=
  alg_equiv.transfer_galois intermediate_field.top_equiv

protected instance is_galois_bot {F : Type u_1} {E : Type u_3} [field F] [field E] [algebra F E] :
    is_galois F ↥⊥ :=
  iff.mpr (alg_equiv.transfer_galois intermediate_field.bot_equiv) (is_galois.self F)

namespace intermediate_field

protected instance subgroup_action {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (H : subgroup (alg_equiv F E E)) : faithful_mul_semiring_action (↥H) E :=
  faithful_mul_semiring_action.mk sorry

/-- The intermediate_field fixed by a subgroup -/
def fixed_field {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (H : subgroup (alg_equiv F E E)) : intermediate_field F E :=
  mk (mul_action.fixed_points (↥H) E) sorry sorry sorry sorry sorry sorry sorry

theorem findim_fixed_field_eq_card {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (H : subgroup (alg_equiv F E E)) [finite_dimensional F E] :
    finite_dimensional.findim (↥(fixed_field H)) E = fintype.card ↥H :=
  fixed_points.findim_eq_card (↥H) E

/-- The subgroup fixing an intermediate_field -/
def fixing_subgroup {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (K : intermediate_field F E) : subgroup (alg_equiv F E E) :=
  subgroup.mk (fun (ϕ : alg_equiv F E E) => ∀ (x : ↥K), coe_fn ϕ ↑x = ↑x) sorry sorry sorry

theorem le_iff_le {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (H : subgroup (alg_equiv F E E)) (K : intermediate_field F E) :
    K ≤ fixed_field H ↔ H ≤ fixing_subgroup K :=
  sorry

/-- The fixing_subgroup of `K : intermediate_field F E` is isomorphic to `E ≃ₐ[K] E` -/
def fixing_subgroup_equiv {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (K : intermediate_field F E) : ↥(fixing_subgroup K) ≃* alg_equiv (↥K) E E :=
  mul_equiv.mk
    (fun (ϕ : ↥(fixing_subgroup K)) =>
      alg_equiv.of_bijective (alg_hom.mk ⇑ϕ sorry sorry sorry sorry sorry) sorry)
    (fun (ϕ : alg_equiv (↥K) E E) =>
      { val := alg_equiv.of_bijective (alg_hom.mk ⇑ϕ sorry sorry sorry sorry sorry) sorry,
        property := sorry })
    sorry sorry sorry

theorem fixing_subgroup_fixed_field {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (H : subgroup (alg_equiv F E E)) [finite_dimensional F E] :
    fixing_subgroup (fixed_field H) = H :=
  sorry

protected instance fixed_field.algebra {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (K : intermediate_field F E) : algebra ↥K ↥(fixed_field (fixing_subgroup K)) :=
  algebra.mk
    (ring_hom.mk (fun (x : ↥K) => { val := ↑x, property := sorry }) sorry sorry sorry sorry) sorry
    sorry

protected instance fixed_field.is_scalar_tower {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (K : intermediate_field F E) :
    is_scalar_tower (↥K) (↥(fixed_field (fixing_subgroup K))) E :=
  is_scalar_tower.mk
    fun (_x : ↥K) (_x_1 : ↥(fixed_field (fixing_subgroup K))) (_x_2 : E) =>
      mul_assoc (↑_x) (↑_x_1) _x_2

end intermediate_field

namespace is_galois

theorem fixed_field_fixing_subgroup {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    (K : intermediate_field F E) [finite_dimensional F E] [h : is_galois F E] :
    intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) = K :=
  sorry

theorem card_fixing_subgroup_eq_findim {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] (K : intermediate_field F E) [finite_dimensional F E] [is_galois F E] :
    fintype.card ↥(intermediate_field.fixing_subgroup K) = finite_dimensional.findim (↥K) E :=
  sorry

/-- The Galois correspondence from intermediate fields to subgroups -/
def intermediate_field_equiv_subgroup {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] [finite_dimensional F E] [is_galois F E] :
    intermediate_field F E ≃o order_dual (subgroup (alg_equiv F E E)) :=
  rel_iso.mk
    (equiv.mk intermediate_field.fixing_subgroup intermediate_field.fixed_field sorry sorry) sorry

/-- The Galois correspondence as a galois_insertion -/
def galois_insertion_intermediate_field_subgroup {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] [finite_dimensional F E] :
    galois_insertion (⇑order_dual.to_dual ∘ intermediate_field.fixing_subgroup)
        (intermediate_field.fixed_field ∘ ⇑order_dual.to_dual) :=
  galois_insertion.mk
    (fun (K : intermediate_field F E)
      (_x :
      function.comp intermediate_field.fixed_field (⇑order_dual.to_dual)
          (function.comp (⇑order_dual.to_dual) intermediate_field.fixing_subgroup K) ≤
        K) =>
      intermediate_field.fixing_subgroup K)
    sorry sorry sorry

/-- The Galois correspondence as a galois_coinsertion -/
def galois_coinsertion_intermediate_field_subgroup {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] [finite_dimensional F E] [is_galois F E] :
    galois_coinsertion (⇑order_dual.to_dual ∘ intermediate_field.fixing_subgroup)
        (intermediate_field.fixed_field ∘ ⇑order_dual.to_dual) :=
  galois_coinsertion.mk
    (fun (H : order_dual (subgroup (alg_equiv F E E)))
      (_x :
      H ≤
        function.comp (⇑order_dual.to_dual) intermediate_field.fixing_subgroup
          (function.comp intermediate_field.fixed_field (⇑order_dual.to_dual) H)) =>
      intermediate_field.fixed_field H)
    sorry sorry sorry

end is_galois

namespace is_galois

theorem is_separable_splitting_field (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [finite_dimensional F E] [h : is_galois F E] :
    ∃ (p : polynomial F), polynomial.separable p ∧ polynomial.is_splitting_field F E p :=
  sorry

theorem of_fixed_field_eq_bot (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [finite_dimensional F E] (h : intermediate_field.fixed_field ⊤ = ⊥) : is_galois F E :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_galois F E)) (Eq.symm (propext is_galois_iff_is_galois_bot))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (is_galois (↥⊥) E)) (Eq.symm h)))
      (is_galois.of_fixed_field E ↥⊤))

theorem of_card_aut_eq_findim (F : Type u_1) [field F] (E : Type u_2) [field E] [algebra F E]
    [finite_dimensional F E] (h : fintype.card (alg_equiv F E E) = finite_dimensional.findim F E) :
    is_galois F E :=
  sorry

theorem of_separable_splitting_field_aux {F : Type u_1} [field F] {E : Type u_2} [field E]
    [algebra F E] {p : polynomial F} [hFE : finite_dimensional F E]
    [sp : polynomial.is_splitting_field F E p] (hp : polynomial.separable p)
    (K : intermediate_field F E) {x : E}
    (hx : x ∈ polynomial.roots (polynomial.map (algebra_map F E) p)) :
    fintype.card
          (alg_hom F (↥↑(intermediate_field.adjoin (↥K) (intermediate_field.insert.insert ∅ x)))
            E) =
        fintype.card (alg_hom F (↥K) E) *
          finite_dimensional.findim ↥K
            ↥(intermediate_field.adjoin (↥K) (intermediate_field.insert.insert ∅ x)) :=
  sorry

theorem of_separable_splitting_field {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    {p : polynomial F} [sp : polynomial.is_splitting_field F E p] (hp : polynomial.separable p) :
    is_galois F E :=
  sorry

/--Equivalent characterizations of a Galois extension of finite degree-/
theorem tfae {F : Type u_1} [field F] {E : Type u_2} [field E] [algebra F E]
    [finite_dimensional F E] :
    tfae
        [is_galois F E, intermediate_field.fixed_field ⊤ = ⊥,
          fintype.card (alg_equiv F E E) = finite_dimensional.findim F E,
          ∃ (p : polynomial F), polynomial.separable p ∧ polynomial.is_splitting_field F E p] :=
  sorry

end Mathlib