/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot
-/

import order.filter.pointwise
import group_theory.quotient_group
import topology.algebra.monoid
import topology.homeomorph
import topology.compacts

/-!
# Theory of topological groups

This file defines the following typeclasses:

* `topological_group`, `topological_add_group`: multiplicative and additive topological groups,
  i.e., groups with continuous `(*)` and `(⁻¹)` / `(+)` and `(-)`;

* `has_continuous_sub G` means that `G` has a continuous subtraction operation.

There is an instance deducing `has_continuous_sub` from `topological_group` but we use a separate
typeclass because, e.g., `ℕ` and `ℝ≥0` have continuous subtraction but are not additive groups.

We also define `homeomorph` versions of several `equiv`s: `homeomorph.mul_left`,
`homeomorph.mul_right`, `homeomorph.inv`, and prove a few facts about neighbourhood filters in
groups.

## Tags

topological space, group, topological group
-/

open classical set filter topological_space function
open_locale classical topological_space filter pointwise

universes u v w x
variables {α : Type u} {β : Type v} {G : Type w} {H : Type x}

section continuous_mul_group

/-!
### Groups with continuous multiplication

In this section we prove a few statements about groups with continuous `(*)`.
-/

variables [topological_space G] [group G] [has_continuous_mul G]

/-- Multiplication from the left in a topological group as a homeomorphism. -/
@[to_additive "Addition from the left in a topological additive group as a homeomorphism."]
protected def homeomorph.mul_left (a : G) : G ≃ₜ G :=
{ continuous_to_fun  := continuous_const.mul continuous_id,
  continuous_inv_fun := continuous_const.mul continuous_id,
  .. equiv.mul_left a }

@[simp, to_additive]
lemma homeomorph.coe_mul_left (a : G) : ⇑(homeomorph.mul_left a) = (*) a := rfl

@[to_additive]
lemma homeomorph.mul_left_symm (a : G) : (homeomorph.mul_left a).symm = homeomorph.mul_left a⁻¹ :=
by { ext, refl }

@[to_additive]
lemma is_open_map_mul_left (a : G) : is_open_map (λ x, a * x) :=
(homeomorph.mul_left a).is_open_map

@[to_additive]
lemma is_closed_map_mul_left (a : G) : is_closed_map (λ x, a * x) :=
(homeomorph.mul_left a).is_closed_map

/-- Multiplication from the right in a topological group as a homeomorphism. -/
@[to_additive "Addition from the right in a topological additive group as a homeomorphism."]
protected def homeomorph.mul_right (a : G) :
  G ≃ₜ G :=
{ continuous_to_fun  := continuous_id.mul continuous_const,
  continuous_inv_fun := continuous_id.mul continuous_const,
  .. equiv.mul_right a }

@[simp, to_additive]
lemma homeomorph.coe_mul_right (a : G) : ⇑(homeomorph.mul_right a) = λ g, g * a := rfl

@[to_additive]
lemma homeomorph.mul_right_symm (a : G) :
  (homeomorph.mul_right a).symm = homeomorph.mul_right a⁻¹ :=
by { ext, refl }

@[to_additive]
lemma is_open_map_mul_right (a : G) : is_open_map (λ x, x * a) :=
(homeomorph.mul_right a).is_open_map

@[to_additive]
lemma is_closed_map_mul_right (a : G) : is_closed_map (λ x, x * a) :=
(homeomorph.mul_right a).is_closed_map

@[to_additive]
lemma is_open_map_div_right (a : G) : is_open_map (λ x, x / a) :=
by simpa only [div_eq_mul_inv] using is_open_map_mul_right (a⁻¹)

@[to_additive]
lemma is_closed_map_div_right (a : G) : is_closed_map (λ x, x / a) :=
by simpa only [div_eq_mul_inv] using is_closed_map_mul_right (a⁻¹)

@[to_additive]
lemma discrete_topology_of_open_singleton_one (h : is_open ({1} : set G)) : discrete_topology G :=
begin
  rw ← singletons_open_iff_discrete,
  intro g,
  suffices : {g} = (λ (x : G), g⁻¹ * x) ⁻¹' {1},
  { rw this, exact (continuous_mul_left (g⁻¹)).is_open_preimage _ h, },
  simp only [mul_one, set.preimage_mul_left_singleton, eq_self_iff_true,
    inv_inv, set.singleton_eq_singleton_iff],
end

@[to_additive]
lemma discrete_topology_iff_open_singleton_one : discrete_topology G ↔ is_open ({1} : set G) :=
⟨λ h, forall_open_iff_discrete.mpr h {1}, discrete_topology_of_open_singleton_one⟩

end continuous_mul_group

section topological_group

/-!
### Topological groups

A topological group is a group in which the multiplication and inversion operations are
continuous. Topological additive groups are defined in the same way. Equivalently, we can require
that the division operation `λ x y, x * y⁻¹` (resp., subtraction) is continuous.
-/

/-- A topological (additive) group is a group in which the addition and negation operations are
continuous. -/
class topological_add_group (G : Type u) [topological_space G] [add_group G]
  extends has_continuous_add G : Prop :=
(continuous_neg : continuous (λa:G, -a))

/-- A topological group is a group in which the multiplication and inversion operations are
continuous. -/
@[to_additive]
class topological_group (G : Type*) [topological_space G] [group G]
  extends has_continuous_mul G : Prop :=
(continuous_inv : continuous (has_inv.inv : G → G))

variables [topological_space G] [group G] [topological_group G]

export topological_group (continuous_inv)
export topological_add_group (continuous_neg)

@[to_additive]
lemma continuous_on_inv {s : set G} : continuous_on has_inv.inv s :=
continuous_inv.continuous_on

@[to_additive]
lemma continuous_within_at_inv {s : set G} {x : G} : continuous_within_at has_inv.inv s x :=
continuous_inv.continuous_within_at

@[to_additive]
lemma continuous_at_inv {x : G} : continuous_at has_inv.inv x :=
continuous_inv.continuous_at

@[to_additive]
lemma tendsto_inv (a : G) : tendsto has_inv.inv (𝓝 a) (𝓝 (a⁻¹)) :=
continuous_at_inv

/-- If a function converges to a value in a multiplicative topological group, then its inverse
converges to the inverse of this value. For the version in normed fields assuming additionally
that the limit is nonzero, use `tendsto.inv'`. -/
@[to_additive]
lemma filter.tendsto.inv {f : α → G} {l : filter α} {y : G} (h : tendsto f l (𝓝 y)) :
  tendsto (λ x, (f x)⁻¹) l (𝓝 y⁻¹) :=
(continuous_inv.tendsto y).comp h

variables [topological_space α] {f : α → G} {s : set α} {x : α}

@[continuity, to_additive]
lemma continuous.inv (hf : continuous f) : continuous (λx, (f x)⁻¹) :=
continuous_inv.comp hf

@[to_additive]
lemma continuous_at.inv (hf : continuous_at f x) : continuous_at (λ x, (f x)⁻¹) x :=
continuous_at_inv.comp hf

@[to_additive]
lemma continuous_on.inv (hf : continuous_on f s) : continuous_on (λx, (f x)⁻¹) s :=
continuous_inv.comp_continuous_on hf

@[to_additive]
lemma continuous_within_at.inv (hf : continuous_within_at f s x) :
  continuous_within_at (λ x, (f x)⁻¹) s x :=
hf.inv

section ordered_comm_group

variables [topological_space H] [ordered_comm_group H] [topological_group H]

@[to_additive] lemma tendsto_inv_nhds_within_Ioi {a : H} :
  tendsto has_inv.inv (𝓝[Ioi a] a) (𝓝[Iio (a⁻¹)] (a⁻¹)) :=
(continuous_inv.tendsto a).inf $ by simp [tendsto_principal_principal]

@[to_additive] lemma tendsto_inv_nhds_within_Iio {a : H} :
  tendsto has_inv.inv (𝓝[Iio a] a) (𝓝[Ioi (a⁻¹)] (a⁻¹)) :=
(continuous_inv.tendsto a).inf $ by simp [tendsto_principal_principal]

@[to_additive] lemma tendsto_inv_nhds_within_Ioi_inv {a : H} :
  tendsto has_inv.inv (𝓝[Ioi (a⁻¹)] (a⁻¹)) (𝓝[Iio a] a) :=
by simpa only [inv_inv] using @tendsto_inv_nhds_within_Ioi _ _ _ _ (a⁻¹)

@[to_additive] lemma tendsto_inv_nhds_within_Iio_inv {a : H} :
  tendsto has_inv.inv (𝓝[Iio (a⁻¹)] (a⁻¹)) (𝓝[Ioi a] a) :=
by simpa only [inv_inv] using @tendsto_inv_nhds_within_Iio _ _ _ _ (a⁻¹)

@[to_additive] lemma tendsto_inv_nhds_within_Ici {a : H} :
  tendsto has_inv.inv (𝓝[Ici a] a) (𝓝[Iic (a⁻¹)] (a⁻¹)) :=
(continuous_inv.tendsto a).inf $ by simp [tendsto_principal_principal]

@[to_additive] lemma tendsto_inv_nhds_within_Iic {a : H} :
  tendsto has_inv.inv (𝓝[Iic a] a) (𝓝[Ici (a⁻¹)] (a⁻¹)) :=
(continuous_inv.tendsto a).inf $ by simp [tendsto_principal_principal]

@[to_additive] lemma tendsto_inv_nhds_within_Ici_inv {a : H} :
  tendsto has_inv.inv (𝓝[Ici (a⁻¹)] (a⁻¹)) (𝓝[Iic a] a) :=
by simpa only [inv_inv] using @tendsto_inv_nhds_within_Ici _ _ _ _ (a⁻¹)

@[to_additive] lemma tendsto_inv_nhds_within_Iic_inv {a : H} :
  tendsto has_inv.inv (𝓝[Iic (a⁻¹)] (a⁻¹)) (𝓝[Ici a] a) :=
by simpa only [inv_inv] using @tendsto_inv_nhds_within_Iic _ _ _ _ (a⁻¹)

end ordered_comm_group

@[instance, to_additive]
instance [topological_space H] [group H] [topological_group H] :
  topological_group (G × H) :=
{ continuous_inv := continuous_inv.prod_map continuous_inv }

@[to_additive]
instance pi.topological_group {C : β → Type*} [∀ b, topological_space (C b)]
  [∀ b, group (C b)] [∀ b, topological_group (C b)] : topological_group (Π b, C b) :=
{ continuous_inv := continuous_pi (λ i, (continuous_apply i).inv) }

variable (G)

/-- Inversion in a topological group as a homeomorphism. -/
@[to_additive "Negation in a topological group as a homeomorphism."]
protected def homeomorph.inv : G ≃ₜ G :=
{ continuous_to_fun  := continuous_inv,
  continuous_inv_fun := continuous_inv,
  .. equiv.inv G }

@[to_additive]
lemma nhds_one_symm : comap has_inv.inv (𝓝 (1 : G)) = 𝓝 (1 : G) :=
((homeomorph.inv G).comap_nhds_eq _).trans (congr_arg nhds one_inv)

/-- The map `(x, y) ↦ (x, xy)` as a homeomorphism. This is a shear mapping. -/
@[to_additive "The map `(x, y) ↦ (x, x + y)` as a homeomorphism.
This is a shear mapping."]
protected def homeomorph.shear_mul_right : G × G ≃ₜ G × G :=
{ continuous_to_fun  := continuous_fst.prod_mk continuous_mul,
  continuous_inv_fun := continuous_fst.prod_mk $ continuous_fst.inv.mul continuous_snd,
  .. equiv.prod_shear (equiv.refl _) equiv.mul_left }

@[simp, to_additive]
lemma homeomorph.shear_mul_right_coe :
  ⇑(homeomorph.shear_mul_right G) = λ z : G × G, (z.1, z.1 * z.2) :=
rfl

@[simp, to_additive]
lemma homeomorph.shear_mul_right_symm_coe :
  ⇑(homeomorph.shear_mul_right G).symm = λ z : G × G, (z.1, z.1⁻¹ * z.2) :=
rfl

variable {G}

namespace subgroup

@[to_additive] instance (S : subgroup G) :
  topological_group S :=
{ continuous_inv :=
  begin
    rw embedding_subtype_coe.to_inducing.continuous_iff,
    exact continuous_subtype_coe.inv
  end,
  ..S.to_submonoid.has_continuous_mul }

end subgroup

@[to_additive]
lemma inv_closure (s : set G) : (closure s)⁻¹ = closure s⁻¹ :=
(homeomorph.inv G).preimage_closure s

/-- The (topological-space) closure of a subgroup of a space `M` with `has_continuous_mul` is
itself a subgroup. -/
@[to_additive "The (topological-space) closure of an additive subgroup of a space `M` with
`has_continuous_add` is itself an additive subgroup."]
def subgroup.topological_closure (s : subgroup G) : subgroup G :=
{ carrier := closure (s : set G),
  inv_mem' := λ g m, by simpa [←mem_inv, inv_closure] using m,
  ..s.to_submonoid.topological_closure }

@[simp, to_additive] lemma subgroup.topological_closure_coe {s : subgroup G} :
  (s.topological_closure : set G) = closure s :=
rfl

@[to_additive]
instance subgroup.topological_closure_topological_group (s : subgroup G) :
  topological_group (s.topological_closure) :=
{ continuous_inv :=
  begin
    apply continuous_induced_rng,
    change continuous (λ p : s.topological_closure, (p : G)⁻¹),
    continuity,
  end
  ..s.to_submonoid.topological_closure_has_continuous_mul}

@[to_additive] lemma subgroup.subgroup_topological_closure (s : subgroup G) :
  s ≤ s.topological_closure :=
subset_closure

@[to_additive] lemma subgroup.is_closed_topological_closure (s : subgroup G) :
  is_closed (s.topological_closure : set G) :=
by convert is_closed_closure

@[to_additive] lemma subgroup.topological_closure_minimal
  (s : subgroup G) {t : subgroup G} (h : s ≤ t) (ht : is_closed (t : set G)) :
  s.topological_closure ≤ t :=
closure_minimal h ht

@[to_additive] lemma dense_range.topological_closure_map_subgroup [group H] [topological_space H]
  [topological_group H] {f : G →* H} (hf : continuous f) (hf' : dense_range f) {s : subgroup G}
  (hs : s.topological_closure = ⊤) :
  (s.map f).topological_closure = ⊤ :=
begin
  rw set_like.ext'_iff at hs ⊢,
  simp only [subgroup.topological_closure_coe, subgroup.coe_top, ← dense_iff_closure_eq] at hs ⊢,
  exact hf'.dense_image hf hs
end

@[to_additive exists_nhds_half_neg]
lemma exists_nhds_split_inv {s : set G} (hs : s ∈ 𝓝 (1 : G)) :
  ∃ V ∈ 𝓝 (1 : G), ∀ (v ∈ V) (w ∈ V), v / w ∈ s :=
have ((λp : G × G, p.1 * p.2⁻¹) ⁻¹' s) ∈ 𝓝 ((1, 1) : G × G),
  from continuous_at_fst.mul continuous_at_snd.inv (by simpa),
by simpa only [div_eq_mul_inv, nhds_prod_eq, mem_prod_self_iff, prod_subset_iff, mem_preimage]
  using this

@[to_additive]
lemma nhds_translation_mul_inv (x : G) : comap (λ y : G, y * x⁻¹) (𝓝 1) = 𝓝 x :=
((homeomorph.mul_right x⁻¹).comap_nhds_eq 1).trans $ show 𝓝 (1 * x⁻¹⁻¹) = 𝓝 x, by simp

@[simp, to_additive] lemma map_mul_left_nhds (x y : G) : map ((*) x) (𝓝 y) = 𝓝 (x * y) :=
(homeomorph.mul_left x).map_nhds_eq y

@[to_additive] lemma map_mul_left_nhds_one (x : G) : map ((*) x) (𝓝 1) = 𝓝 x := by simp

@[to_additive]
lemma topological_group.ext {G : Type*} [group G] {t t' : topological_space G}
  (tg : @topological_group G t _) (tg' : @topological_group G t' _)
  (h : @nhds G t 1 = @nhds G t' 1) : t = t' :=
eq_of_nhds_eq_nhds $ λ x, by
  rw [← @nhds_translation_mul_inv G t _ _ x , ← @nhds_translation_mul_inv G t' _ _ x , ← h]

@[to_additive]
lemma topological_group.of_nhds_aux {G : Type*} [group G] [topological_space G]
  (hinv : tendsto (λ (x : G), x⁻¹) (𝓝 1) (𝓝 1))
  (hleft : ∀ (x₀ : G), 𝓝 x₀ = map (λ (x : G), x₀ * x) (𝓝 1))
  (hconj : ∀ (x₀ : G), map (λ (x : G), x₀ * x * x₀⁻¹) (𝓝 1) ≤ 𝓝 1) : continuous (λ x : G, x⁻¹) :=
begin
  rw continuous_iff_continuous_at,
  rintros x₀,
  have key : (λ x, (x₀*x)⁻¹) = (λ x, x₀⁻¹*x) ∘ (λ x, x₀*x*x₀⁻¹) ∘ (λ x, x⁻¹),
    by {ext ; simp[mul_assoc] },
  calc map (λ x, x⁻¹) (𝓝 x₀)
      = map (λ x, x⁻¹) (map (λ x, x₀*x) $ 𝓝 1) : by rw hleft
  ... = map (λ x, (x₀*x)⁻¹) (𝓝 1) : by rw filter.map_map
  ... = map (((λ x, x₀⁻¹*x) ∘ (λ x, x₀*x*x₀⁻¹)) ∘ (λ x, x⁻¹)) (𝓝 1) : by rw key
  ... = map ((λ x, x₀⁻¹*x) ∘ (λ x, x₀*x*x₀⁻¹)) _ : by rw ← filter.map_map
  ... ≤ map ((λ x, x₀⁻¹ * x) ∘ λ x, x₀ * x * x₀⁻¹) (𝓝 1) : map_mono hinv
  ... = map (λ x, x₀⁻¹ * x) (map (λ x, x₀ * x * x₀⁻¹) (𝓝 1)) : filter.map_map
  ... ≤ map (λ x, x₀⁻¹ * x) (𝓝 1) : map_mono (hconj x₀)
  ... = 𝓝 x₀⁻¹ : (hleft _).symm
end

@[to_additive]
lemma topological_group.of_nhds_one' {G : Type u} [group G] [topological_space G]
  (hmul : tendsto (uncurry ((*) : G → G → G)) ((𝓝 1) ×ᶠ 𝓝 1) (𝓝 1))
  (hinv : tendsto (λ x : G, x⁻¹) (𝓝 1) (𝓝 1))
  (hleft : ∀ x₀ : G, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1))
  (hright : ∀ x₀ : G, 𝓝 x₀ = map (λ x, x*x₀) (𝓝 1)) : topological_group G :=
begin
  refine { continuous_mul := (has_continuous_mul.of_nhds_one hmul hleft hright).continuous_mul,
           continuous_inv := topological_group.of_nhds_aux hinv hleft _ },
  intros x₀,
  suffices : map (λ (x : G), x₀ * x * x₀⁻¹) (𝓝 1) = 𝓝 1, by simp [this, le_refl],
  rw [show (λ x, x₀ * x * x₀⁻¹) = (λ x, x₀ * x) ∘ λ x, x*x₀⁻¹, by {ext, simp [mul_assoc] },
      ← filter.map_map, ← hright, hleft x₀⁻¹, filter.map_map],
  convert map_id,
  ext,
  simp
end

@[to_additive]
lemma topological_group.of_nhds_one {G : Type u} [group G] [topological_space G]
  (hmul : tendsto (uncurry ((*) : G → G → G)) ((𝓝 1) ×ᶠ 𝓝 1) (𝓝 1))
  (hinv : tendsto (λ x : G, x⁻¹) (𝓝 1) (𝓝 1))
  (hleft : ∀ x₀ : G, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1))
  (hconj : ∀ x₀ : G, tendsto (λ x, x₀*x*x₀⁻¹) (𝓝 1) (𝓝 1)) : topological_group G :=
 { continuous_mul := begin
    rw continuous_iff_continuous_at,
    rintros ⟨x₀, y₀⟩,
    have key : (λ (p : G × G), x₀ * p.1 * (y₀ * p.2)) =
      ((λ x, x₀*y₀*x) ∘ (uncurry (*)) ∘ (prod.map (λ x, y₀⁻¹*x*y₀) id)),
      by { ext, simp [uncurry, prod.map, mul_assoc] },
    specialize hconj y₀⁻¹, rw inv_inv at hconj,
    calc map (λ (p : G × G), p.1 * p.2) (𝓝 (x₀, y₀))
        = map (λ (p : G × G), p.1 * p.2) ((𝓝 x₀) ×ᶠ 𝓝 y₀)
            : by rw nhds_prod_eq
    ... = map (λ (p : G × G), x₀ * p.1 * (y₀ * p.2)) ((𝓝 1) ×ᶠ (𝓝 1))
            : by rw [hleft x₀, hleft y₀, prod_map_map_eq, filter.map_map]
    ... = map (((λ x, x₀*y₀*x) ∘ (uncurry (*))) ∘ (prod.map (λ x, y₀⁻¹*x*y₀) id))((𝓝 1) ×ᶠ (𝓝 1))
            : by rw key
    ... = map ((λ x, x₀*y₀*x) ∘ (uncurry (*))) ((map  (λ x, y₀⁻¹*x*y₀) $ 𝓝 1) ×ᶠ (𝓝 1))
            : by rw [← filter.map_map, ← prod_map_map_eq', map_id]
    ... ≤ map ((λ x, x₀*y₀*x) ∘ (uncurry (*))) ((𝓝 1) ×ᶠ (𝓝 1))
            : map_mono (filter.prod_mono hconj $ le_refl _)
    ... = map (λ x, x₀*y₀*x) (map (uncurry (*)) ((𝓝 1) ×ᶠ (𝓝 1)))   : by rw filter.map_map
    ... ≤ map (λ x, x₀*y₀*x) (𝓝 1)   : map_mono hmul
    ... = 𝓝 (x₀*y₀)   : (hleft _).symm
  end,
  continuous_inv := topological_group.of_nhds_aux hinv hleft hconj}

@[to_additive]
lemma topological_group.of_comm_of_nhds_one {G : Type u} [comm_group G] [topological_space G]
  (hmul : tendsto (uncurry ((*) : G → G → G)) ((𝓝 1) ×ᶠ 𝓝 1) (𝓝 1))
  (hinv : tendsto (λ x : G, x⁻¹) (𝓝 1) (𝓝 1))
  (hleft : ∀ x₀ : G, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1)) : topological_group G :=
topological_group.of_nhds_one hmul hinv hleft (by simpa using tendsto_id)

end topological_group

section quotient_topological_group
variables [topological_space G] [group G] [topological_group G] (N : subgroup G) (n : N.normal)

@[to_additive]
instance quotient_group.quotient.topological_space {G : Type*} [group G] [topological_space G]
  (N : subgroup G) : topological_space (G ⧸ N) :=
quotient.topological_space

open quotient_group

@[to_additive]
lemma quotient_group.is_open_map_coe : is_open_map (coe : G → G ⧸ N) :=
begin
  intros s s_op,
  change is_open ((coe : G → G ⧸ N) ⁻¹' (coe '' s)),
  rw quotient_group.preimage_image_coe N s,
  exact is_open_Union (λ n, (continuous_mul_right _).is_open_preimage s s_op)
end

@[to_additive]
instance topological_group_quotient [N.normal] : topological_group (G ⧸ N) :=
{ continuous_mul := begin
    have cont : continuous ((coe : G → G ⧸ N) ∘ (λ (p : G × G), p.fst * p.snd)) :=
      continuous_quot_mk.comp continuous_mul,
    have quot : quotient_map (λ p : G × G, ((p.1 : G ⧸ N), (p.2 : G ⧸ N))),
    { apply is_open_map.to_quotient_map,
      { exact (quotient_group.is_open_map_coe N).prod (quotient_group.is_open_map_coe N) },
      { exact continuous_quot_mk.prod_map continuous_quot_mk },
      { exact (surjective_quot_mk _).prod_map (surjective_quot_mk _) } },
    exact (quotient_map.continuous_iff quot).2 cont,
  end,
  continuous_inv := begin
    have : continuous ((coe : G → G ⧸ N) ∘ (λ (a : G), a⁻¹)) :=
      continuous_quot_mk.comp continuous_inv,
    convert continuous_quotient_lift _ this,
  end }

end quotient_topological_group

/-- A typeclass saying that `λ p : G × G, p.1 - p.2` is a continuous function. This property
automatically holds for topological additive groups but it also holds, e.g., for `ℝ≥0`. -/
class has_continuous_sub (G : Type*) [topological_space G] [has_sub G] : Prop :=
(continuous_sub : continuous (λ p : G × G, p.1 - p.2))

/-- A typeclass saying that `λ p : G × G, p.1 / p.2` is a continuous function. This property
automatically holds for topological groups. Lemmas using this class have primes.
The unprimed version is for `group_with_zero`. -/
@[to_additive]
class has_continuous_div (G : Type*) [topological_space G] [has_div G] : Prop :=
(continuous_div' : continuous (λ p : G × G, p.1 / p.2))

@[priority 100, to_additive] -- see Note [lower instance priority]
instance topological_group.to_has_continuous_div [topological_space G] [group G]
  [topological_group G] : has_continuous_div G :=
⟨by { simp only [div_eq_mul_inv], exact continuous_fst.mul continuous_snd.inv }⟩

export has_continuous_sub (continuous_sub)
export has_continuous_div (continuous_div')

section has_continuous_div

variables [topological_space G] [has_div G] [has_continuous_div G]

@[to_additive sub]
lemma filter.tendsto.div' {f g : α → G} {l : filter α} {a b : G} (hf : tendsto f l (𝓝 a))
  (hg : tendsto g l (𝓝 b)) : tendsto (λ x, f x / g x) l (𝓝 (a / b)) :=
(continuous_div'.tendsto (a, b)).comp (hf.prod_mk_nhds hg)

@[to_additive const_sub]
lemma filter.tendsto.const_div' (b : G) {c : G} {f : α → G} {l : filter α}
  (h : tendsto f l (𝓝 c)) : tendsto (λ k : α, b / f k) l (𝓝 (b / c)) :=
tendsto_const_nhds.div' h

@[to_additive sub_const]
lemma filter.tendsto.div_const' (b : G) {c : G} {f : α → G} {l : filter α}
  (h : tendsto f l (𝓝 c)) : tendsto (λ k : α, f k / b) l (𝓝 (c / b)) :=
h.div' tendsto_const_nhds

variables [topological_space α] {f g : α → G} {s : set α} {x : α}

@[continuity, to_additive sub] lemma continuous.div' (hf : continuous f) (hg : continuous g) :
  continuous (λ x, f x / g x) :=
continuous_div'.comp (hf.prod_mk hg : _)

@[to_additive continuous_sub_left]
lemma continuous_div_left' (a : G) : continuous (λ b : G, a / b) :=
continuous_const.div' continuous_id

@[to_additive continuous_sub_right]
lemma continuous_div_right' (a : G) : continuous (λ b : G, b / a) :=
continuous_id.div' continuous_const

@[to_additive sub]
lemma continuous_at.div' {f g : α → G} {x : α} (hf : continuous_at f x) (hg : continuous_at g x) :
  continuous_at (λx, f x / g x) x :=
hf.div' hg

@[to_additive sub]
lemma continuous_within_at.div' (hf : continuous_within_at f s x)
  (hg : continuous_within_at g s x) :
  continuous_within_at (λ x, f x / g x) s x :=
hf.div' hg

@[to_additive sub]
lemma continuous_on.div' (hf : continuous_on f s) (hg : continuous_on g s) :
  continuous_on (λx, f x / g x) s :=
λ x hx, (hf x hx).div' (hg x hx)

end has_continuous_div

@[to_additive]
lemma nhds_translation_div [topological_space G] [group G] [topological_group G] (x : G) :
  comap (λy:G, y / x) (𝓝 1) = 𝓝 x :=
by simpa only [div_eq_mul_inv] using nhds_translation_mul_inv x

/-- additive group with a neighbourhood around 0.
Only used to construct a topology and uniform space.

This is currently only available for commutative groups, but it can be extended to
non-commutative groups too.
-/
class add_group_with_zero_nhd (G : Type u) extends add_comm_group G :=
(Z [] : filter G)
(zero_Z : pure 0 ≤ Z)
(sub_Z : tendsto (λp:G×G, p.1 - p.2) (Z ×ᶠ Z) Z)

section filter_mul

section
variables [topological_space G] [group G] [topological_group G]

@[to_additive]
lemma is_open.mul_left {s t : set G} : is_open t → is_open (s * t) := λ ht,
begin
  have : ∀a, is_open ((λ (x : G), a * x) '' t) :=
    assume a, is_open_map_mul_left a t ht,
  rw ← Union_mul_left_image,
  exact is_open_Union (λa, is_open_Union $ λha, this _),
end

@[to_additive]
lemma is_open.mul_right {s t : set G} : is_open s → is_open (s * t) := λ hs,
begin
  have : ∀a, is_open ((λ (x : G), x * a) '' s),
    assume a, apply is_open_map_mul_right, exact hs,
  rw ← Union_mul_right_image,
  exact is_open_Union (λa, is_open_Union $ λha, this _),
end

variables (G)

@[to_additive]
lemma topological_group.t1_space (h : @is_closed G _ {1}) : t1_space G :=
⟨assume x, by { convert is_closed_map_mul_right x _ h, simp }⟩

@[to_additive]
lemma topological_group.regular_space [t1_space G] : regular_space G :=
⟨assume s a hs ha,
 let f := λ p : G × G, p.1 * (p.2)⁻¹ in
 have hf : continuous f := continuous_fst.mul continuous_snd.inv,
 -- a ∈ -s implies f (a, 1) ∈ -s, and so (a, 1) ∈ f⁻¹' (-s);
 -- and so can find t₁ t₂ open such that a ∈ t₁ × t₂ ⊆ f⁻¹' (-s)
 let ⟨t₁, t₂, ht₁, ht₂, a_mem_t₁, one_mem_t₂, t_subset⟩ :=
   is_open_prod_iff.1 ((is_open_compl_iff.2 hs).preimage hf) a (1:G) (by simpa [f]) in
 begin
   use [s * t₂, ht₂.mul_left, λ x hx, ⟨x, 1, hx, one_mem_t₂, mul_one _⟩],
   rw [nhds_within, inf_principal_eq_bot, mem_nhds_iff],
   refine ⟨t₁, _, ht₁, a_mem_t₁⟩,
   rintros x hx ⟨y, z, hy, hz, yz⟩,
   have : x * z⁻¹ ∈ sᶜ := (prod_subset_iff.1 t_subset) x hx z hz,
   have : x * z⁻¹ ∈ s, rw ← yz, simpa,
   contradiction
 end⟩

local attribute [instance] topological_group.regular_space

@[to_additive]
lemma topological_group.t2_space [t1_space G] : t2_space G := regular_space.t2_space G

end

section

/-! Some results about an open set containing the product of two sets in a topological group. -/

variables [topological_space G] [group G] [topological_group G]

/-- Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of `1`
  such that `KV ⊆ U`. -/
@[to_additive "Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of
`0` such that `K + V ⊆ U`."]
lemma compact_open_separated_mul {K U : set G} (hK : is_compact K) (hU : is_open U) (hKU : K ⊆ U) :
  ∃ V : set G, is_open V ∧ (1 : G) ∈ V ∧ K * V ⊆ U :=
begin
  let W : G → set G := λ x, (λ y, x * y) ⁻¹' U,
  have h1W : ∀ x, is_open (W x) := λ x, hU.preimage (continuous_mul_left x),
  have h2W : ∀ x ∈ K, (1 : G) ∈ W x := λ x hx, by simp only [mem_preimage, mul_one, hKU hx],
  choose V hV using λ x : K, exists_open_nhds_one_mul_subset ((h1W x).mem_nhds (h2W x.1 x.2)),
  let X : K → set G := λ x, (λ y, (x : G)⁻¹ * y) ⁻¹' (V x),
  obtain ⟨t, ht⟩ : ∃ t : finset ↥K, K ⊆ ⋃ i ∈ t, X i,
  { refine hK.elim_finite_subcover X (λ x, (hV x).1.preimage (continuous_mul_left x⁻¹)) _,
    intros x hx, rw [mem_Union], use ⟨x, hx⟩, rw [mem_preimage], convert (hV _).2.1,
    simp only [mul_left_inv, subtype.coe_mk] },
  refine ⟨⋂ x ∈ t, V x, is_open_bInter (finite_mem_finset _) (λ x hx, (hV x).1), _, _⟩,
  { simp only [mem_Inter], intros x hx, exact (hV x).2.1 },
  rintro _ ⟨x, y, hx, hy, rfl⟩, simp only [mem_Inter] at hy,
  have := ht hx, simp only [mem_Union, mem_preimage] at this, rcases this with ⟨z, h1z, h2z⟩,
  have : (z : G)⁻¹ * x * y ∈ W z := (hV z).2.2 (mul_mem_mul h2z (hy z h1z)),
  rw [mem_preimage] at this, convert this using 1, simp only [mul_assoc, mul_inv_cancel_left]
end

/-- A compact set is covered by finitely many left multiplicative translates of a set
  with non-empty interior. -/
@[to_additive "A compact set is covered by finitely many left additive translates of a set
  with non-empty interior."]
lemma compact_covered_by_mul_left_translates {K V : set G} (hK : is_compact K)
  (hV : (interior V).nonempty) : ∃ t : finset G, K ⊆ ⋃ g ∈ t, (λ h, g * h) ⁻¹' V :=
begin
  obtain ⟨t, ht⟩ : ∃ t : finset G, K ⊆ ⋃ x ∈ t, interior (((*) x) ⁻¹' V),
  { refine hK.elim_finite_subcover (λ x, interior $ ((*) x) ⁻¹' V) (λ x, is_open_interior) _,
    cases hV with g₀ hg₀,
    refine λ g hg, mem_Union.2 ⟨g₀ * g⁻¹, _⟩,
    refine preimage_interior_subset_interior_preimage (continuous_const.mul continuous_id) _,
    rwa [mem_preimage, inv_mul_cancel_right] },
  exact ⟨t, subset.trans ht $ bUnion_mono $ λ g hg, interior_subset⟩
end

/-- Every locally compact separable topological group is σ-compact.
  Note: this is not true if we drop the topological group hypothesis. -/
@[priority 100, to_additive separable_locally_compact_add_group.sigma_compact_space]
instance separable_locally_compact_group.sigma_compact_space
  [separable_space G] [locally_compact_space G] : sigma_compact_space G :=
begin
  obtain ⟨L, hLc, hL1⟩ := exists_compact_mem_nhds (1 : G),
  refine ⟨⟨λ n, (λ x, x * dense_seq G n) ⁻¹' L, _, _⟩⟩,
  { intro n, exact (homeomorph.mul_right _).compact_preimage.mpr hLc },
  { refine Union_eq_univ_iff.2 (λ x, _),
    obtain ⟨_, ⟨n, rfl⟩, hn⟩ : (range (dense_seq G) ∩ (λ y, x * y) ⁻¹' L).nonempty,
    { rw [← (homeomorph.mul_left x).apply_symm_apply 1] at hL1,
      exact (dense_range_dense_seq G).inter_nhds_nonempty
        ((homeomorph.mul_left x).continuous.continuous_at $ hL1) },
    exact ⟨n, hn⟩ }
end

/-- Every separated topological group in which there exists a compact set with nonempty interior
is locally compact. -/
@[to_additive] lemma topological_space.positive_compacts.locally_compact_space_of_group
  [t2_space G] (K : positive_compacts G) :
  locally_compact_space G :=
begin
  refine locally_compact_of_compact_nhds (λ x, _),
  obtain ⟨y, hy⟩ : ∃ y, y ∈ interior K.1 := K.2.2,
  let F := homeomorph.mul_left (x * y⁻¹),
  refine ⟨F '' K.1, _, is_compact.image K.2.1 F.continuous⟩,
  suffices : F.symm ⁻¹' K.1 ∈ 𝓝 x, by { convert this, apply equiv.image_eq_preimage },
  apply continuous_at.preimage_mem_nhds F.symm.continuous.continuous_at,
  have : F.symm x = y, by simp [F, homeomorph.mul_left_symm],
  rw this,
  exact mem_interior_iff_mem_nhds.1 hy
end

end

section
variables [topological_space G] [comm_group G] [topological_group G]

@[to_additive]
lemma nhds_mul (x y : G) : 𝓝 (x * y) = 𝓝 x * 𝓝 y :=
filter_eq $ set.ext $ assume s,
begin
  rw [← nhds_translation_mul_inv x, ← nhds_translation_mul_inv y, ← nhds_translation_mul_inv (x*y)],
  split,
  { rintros ⟨t, ht, ts⟩,
    rcases exists_nhds_one_split ht with ⟨V, V1, h⟩,
    refine ⟨(λa, a * x⁻¹) ⁻¹' V, (λa, a * y⁻¹) ⁻¹' V,
            ⟨V, V1, subset.refl _⟩, ⟨V, V1, subset.refl _⟩, _⟩,
    rintros a ⟨v, w, v_mem, w_mem, rfl⟩,
    apply ts,
    simpa [mul_comm, mul_assoc, mul_left_comm] using h (v * x⁻¹) v_mem (w * y⁻¹) w_mem },
  { rintros ⟨a, c, ⟨b, hb, ba⟩, ⟨d, hd, dc⟩, ac⟩,
    refine ⟨b ∩ d, inter_mem hb hd, assume v, _⟩,
    simp only [preimage_subset_iff, mul_inv_rev, mem_preimage] at *,
    rintros ⟨vb, vd⟩,
    refine ac ⟨v * y⁻¹, y, _, _, _⟩,
    { rw ← mul_assoc _ _ _ at vb, exact ba _ vb },
    { apply dc y, rw mul_right_inv, exact mem_of_mem_nhds hd },
    { simp only [inv_mul_cancel_right] } }
end

/-- On a topological group, `𝓝 : G → filter G` can be promoted to a `mul_hom`. -/
@[to_additive "On an additive topological group, `𝓝 : G → filter G` can be promoted to an
`add_hom`.", simps]
def nhds_mul_hom : mul_hom G (filter G) :=
{ to_fun := 𝓝,
  map_mul' := λ_ _, nhds_mul _ _ }

end

end filter_mul

instance additive.topological_add_group {G} [h : topological_space G]
  [group G] [topological_group G] : @topological_add_group (additive G) h _ :=
{ continuous_neg := @continuous_inv G _ _ _ }

instance multiplicative.topological_group {G} [h : topological_space G]
  [add_group G] [topological_add_group G] : @topological_group (multiplicative G) h _ :=
{ continuous_inv := @continuous_neg G _ _ _ }

namespace units

variables [monoid α] [topological_space α] [has_continuous_mul α]

instance : topological_group (units α) :=
{ continuous_inv := continuous_induced_rng ((continuous_unop.comp (continuous_snd.comp
    (@continuous_embed_product α _ _))).prod_mk (continuous_op.comp continuous_coe)) }

end units

/-!
### Lattice of group topologies
We define a type class `group_topology α` which endows a group `α` with a topology such that all
group operations are continuous.

Group topologies on a fixed group `α` are ordered, by reverse inclusion. They form a complete
lattice, with `⊥` the discrete topology and `⊤` the indiscrete topology.

Any function `f : α → β` induces `coinduced f : topological_space α → group_topology β`.

The additive version `add_group_topology α` and corresponding results are provided as well.
-/

/-- A group topology on a group `α` is a topology for which multiplication and inversion
are continuous. -/
@[ext]
structure group_topology (α : Type u) [group α]
  extends topological_space α, topological_group α : Type u

/-- An additive group topology on an additive group `α` is a topology for which addition and
  negation are continuous. -/
@[ext]
structure add_group_topology (α : Type u) [add_group α]
  extends topological_space α, topological_add_group α : Type u

attribute [to_additive] group_topology

namespace group_topology

@[to_additive]
instance inhabited {α : Type u} [group α] : inhabited (group_topology α) :=
⟨{to_topological_space := ⊤,
  continuous_mul       := continuous_top,
  continuous_inv       := continuous_top}⟩

variables {γ : Type*}

@[ext, to_additive add_group_topology.ext]
lemma ext' [group γ] {f g : group_topology γ} (h : f.is_open = g.is_open) : f = g :=
by { ext, rw h }

/-- The ordering on group topologies on the group `γ`.
  `t ≤ s` if every set open in `s` is also open in `t` (`t` is finer than `s`). -/
@[to_additive]
instance [group γ] : partial_order (group_topology γ) :=
partial_order.lift to_topological_space $ ext

local notation `cont` := @continuous _ _
@[to_additive add_group_topology.def_Inf "Infimum of a collection of additive group topologies"]
private def def_Inf [group γ] (S : set (group_topology γ)) : group_topology γ :=
let Inf_S' := Inf (to_topological_space '' S) in
{ to_topological_space := Inf_S',
  continuous_mul       :=
  begin
    apply continuous_Inf_rng,
    rintros _ ⟨⟨t, tr⟩, haS, rfl⟩, resetI,
    have h := continuous_Inf_dom (set.mem_image_of_mem to_topological_space haS) continuous_id,
    have h_continuous_id := @continuous.prod_map _ _ _ _ t t Inf_S' Inf_S' _ _ h h,
    have h_continuous_mul : cont (id _) t (λ (p : γ × γ), p.fst * p.snd) := continuous_mul,
    exact @continuous.comp _ _ _ (id _) (id _) t _ _ h_continuous_mul h_continuous_id,
  end,
  continuous_inv       :=
  begin
    apply continuous_Inf_rng,
    rintros _ ⟨⟨t, tr⟩, haS, rfl⟩, resetI,
    exact @continuous.comp _ _ _ (id _) (id _) t _ _ continuous_inv
      (continuous_Inf_dom (set.mem_image_of_mem to_topological_space haS) continuous_id),
  end, }

/-- Group topologies on `γ` form a complete lattice, with `⊥` the discrete topology and `⊤` the
indiscrete topology.

The infimum of a collection of group topologies is the topology generated by all their open sets
(which is a group topology).

The supremum of two group topologies `s` and `t` is the infimum of the family of all group
topologies contained in the intersection of `s` and `t`. -/
@[to_additive]
instance [group γ] : complete_semilattice_Inf (group_topology γ) :=
{ Inf    := def_Inf,
  Inf_le := λ S a haS, by { apply topological_space.complete_lattice.Inf_le, use [a, ⟨ haS, rfl⟩] },
  le_Inf :=
  begin
    intros S a hab,
    apply topological_space.complete_lattice.le_Inf,
    rintros _ ⟨b, hbS, rfl⟩,
    exact hab b hbS,
  end,
  ..group_topology.partial_order }

@[to_additive]
instance [group γ] : complete_lattice (group_topology γ) :=
complete_lattice_of_complete_semilattice_Inf _

/--  Given `f : α → β` and a topology on `α`, the coinduced group topology on `β` is the finest
topology such that `f` is continuous and `β` is a topological group. -/
@[to_additive "Given `f : α → β` and a topology on `α`, the coinduced additive group topology on `β`
is the finest topology such that `f` is continuous and `β` is a topological additive group."]
def coinduced {α β : Type*} [t : topological_space α] [group β] (f : α → β) :
  group_topology β :=
Inf {b : group_topology β | (topological_space.coinduced f t) ≤ b.to_topological_space}

@[to_additive]
lemma coinduced_continuous {α β : Type*} [t : topological_space α] [group β]
  (f : α → β) : cont t (coinduced f).to_topological_space f :=
begin
  rw continuous_iff_coinduced_le,
  refine le_Inf _,
  rintros _ ⟨t', ht', rfl⟩,
  exact ht',
end

end group_topology


open classical

variables (α : Type) (p q : α → Prop)
variable a : α
variable r : Prop

theorem dne {p : Prop} (hp : ¬¬p) : p :=
  by_contradiction (assume hnp : ¬p, absurd hnp hp)
--
example : (∃ x : α, r) → r :=
  assume h : (∃ x : α, r),
  exists.elim h
    (assume w,
      assume hr : r,
      hr)

example : r → (∃ x : α, r) :=
  assume hr : r,
  show ∃ x : α, r, from ⟨a, hr⟩

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
  iff.intro
    (assume h : (∃ x, p x ∧ r),
      match h with ⟨w, hpw, hr⟩ :=
        ⟨⟨w, hpw⟩, hr⟩
      end)
    (assume h : (∃ x, p x) ∧ r,
      match h with ⟨⟨w, hpw⟩, hr⟩ :=
        ⟨w, ⟨hpw, hr⟩⟩
      end)
example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
  iff.intro
    (assume h : (∃ x, p x ∨ q x),
      match h with ⟨w, hpqw⟩ :=
        hpqw.elim
          (assume hpw : p w,
            show (∃ x, p x) ∨ (∃ x, q x), from or.inl ⟨w, hpw⟩)
          (assume hqw : q w,
            show (∃ x, p x) ∨ (∃ x, q x), from or.inr ⟨w, hqw⟩)
      end)
    (assume h : (∃ x, p x) ∨ (∃ x, q x),
      h.elim
        (assume h : (∃ x, p x),
          match h with ⟨w, hpw⟩ := ⟨w, or.inl hpw⟩
          end)
        (assume h : (∃ x, q x),
          match h with ⟨w, hqw⟩ := ⟨w, or.inr hqw⟩
          end))
--
example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) :=
  iff.intro
    (assume h : ∀ x, p x,
      assume hn : ∃ y, ¬ p y,
      match hn with ⟨w, hnpw⟩ :=
        have hpw : p w, from h w,
        absurd hpw hnpw
      end)
    (assume h : ¬ (∃ x, ¬ p x),
      assume x,
      have dnp : ¬¬ p x, from (
        assume hnpx : ¬ p x,
        have hen : ∃ x, ¬ p x, from ⟨x, hnpx⟩,
        absurd hen h
      ),
      dne dnp)
example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) :=
  iff.intro
    (assume h : ∃ x, p x,
      show ¬(∀ x, ¬ p x), from (
        assume hfnp : ∀ x, ¬p x,
        match h with ⟨w, hpw⟩ :=
          have hnpw : ¬p w, from hfnp w,
          absurd hpw hnpw
        end
      ))
    (assume h : ¬(∀ x, ¬p x),
      by_contradiction
        (assume hnex : ¬(∃ x, p x),
          have ha : ∀ x, ¬p x, from (
            assume x,
              assume hp : p x,
              have hex: ∃ x, p x, from ⟨x, hp⟩,
              absurd hex hnex
          ),
          h ha))
example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) :=
  iff.intro
    (assume h : ¬ ∃ x, p x,
      assume x,
      show ¬ p x, from (
        assume hp : p x,
        absurd (exists.intro x hp) h
      ))
    (assume h : ∀ x, ¬ p x,
      assume hex : ∃ x, p x,
      exists.elim hex (
        assume w,
        assume hp : p w,
        absurd hp (h w)
      ))
example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
  iff.intro
    (assume h : ¬ ∀ x, p x,
      by_contradiction
        (assume h' : ¬ ∃ x, ¬ p x,
          have hfp : ∀ x, p x, from (
            assume x,
            show p x, from by_contradiction (
              assume hnp : ¬ p x,
              absurd (exists.intro x hnp) h'
            )
          ),
          absurd hfp h))
    (assume ⟨w, (hnpw : ¬ p w)⟩,
      assume hfp : ∀ x, p x,
      absurd (hfp w) hnpw)
--
example : (∀ x, p x → r) ↔ (∃ x, p x) → r :=
  iff.intro
    (assume h : ∀ x, p x → r,
      assume ⟨w, (hpw : p w)⟩,
        (h w) hpw)
    (assume h : (∃ x, p x) → r,
      assume x,
      assume hpx : p x,
      h ⟨x, hpx⟩)
example : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
  iff.intro
    (assume ⟨w, (hw : p w → r)⟩,
      assume h : ∀ x, p x,
      hw (h w))
    (assume h : (∀ x, p x) → r,
      show ∃ x, p x → r, from
        by_cases
          (assume hap : ∀ x, p x,
            ⟨a, (λ h', h hap)⟩)
          (assume hnap : ¬(∀ x, p x),
            by_contradiction
              (assume hnex : ¬ ∃ x, p x → r,
                have hap : ∀ x, p x,
                from
                  (assume x,
                    by_contradiction
                      (assume hnp : ¬ p x,
                        have hex : ∃ x, p x → r, from (
                          have hpair : p x → r, from (assume hpx : p x, absurd hpx hnp),
                          ⟨x, hpair⟩
                        ),
                        absurd hex hnex)),
                absurd hap hnap)
            )
      )
example : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
  iff.intro
    (assume ⟨w, ripw⟩,
      assume hr : r,
      ⟨w, ripw hr⟩)
    (assume h : r → ∃ x, p x,
      by_cases
        (assume hr : r,
          match h hr with ⟨w, hpw⟩ :=
            have hi : r → p w, from (assume r, hpw),
            ⟨w, hi⟩
          end)
        (assume hnr : ¬r,
          have hpa : r → p a, from (
            assume hr : r,
            absurd hr hnr),
          ⟨a, hpa⟩))


import dimension_theory.order_height
import ring_theory.ideal.minimal_prime
import dimension_theory.min_generator_card
import dimension_theory.noetherian
import algebra.order.pointwise

variables {R : Type*} [comm_ring R] (I : ideal R)

noncomputable
def ideal.prime_height [I.is_prime] : with_top ℕ :=
set.chain_height (set_of ideal.is_prime ∩ set.Iio I)

noncomputable
def ideal.height : with_top ℕ :=
⨅ (J ∈ I.minimal_primes), @@ideal.prime_height _ J (and.left H).1

lemma ideal.height_eq_prime_height [I.is_prime] : I.height = I.prime_height :=
begin
  delta ideal.height ideal.prime_height,
  rw [ideal.minimal_primes_eq_subsingleton_self],
  simp,
end

@[mk_iff]
class ideal.finite_height : Prop :=
(eq_top_or_height_ne_top : I = ⊤ ∨ I.height ≠ ⊤)

lemma ideal.finite_height_iff_lt {I : ideal R} : I.finite_height ↔ I = ⊤ ∨ I.height < ⊤ :=
by { rw ideal.finite_height_iff, congr', simp }

lemma ideal.height_ne_top {I : ideal R} (hI : I ≠ ⊤) [h : I.finite_height] : I.height ≠ ⊤ :=
(h.1 : _).resolve_left hI

lemma ideal.height_lt_top {I : ideal R} (hI : I ≠ ⊤) [h : I.finite_height] : I.height < ⊤ :=
lt_of_le_of_ne le_top (ideal.height_ne_top hI)

lemma ideal.prime_height_ne_top (I : ideal R) [I.finite_height] [h : I.is_prime] :
  I.prime_height ≠ ⊤ :=
I.height_eq_prime_height ▸ (ideal.height_ne_top h.1)

lemma ideal.prime_height_lt_top (I : ideal R) [I.finite_height] [h : I.is_prime] :
  I.prime_height < ⊤ :=
I.height_eq_prime_height ▸ (ideal.height_lt_top h.1)

lemma ideal.prime_height_succ [h : I.is_prime] :
  I.prime_height + 1 = set.chain_height (set_of ideal.is_prime ∩ set.Iic I) :=
begin
  convert (set.chain_height_insert_of_forall_lt _ I _).symm,
  { rw [set.insert_inter_distrib, set.insert_eq_of_mem], { simp }, { exact h } },
  { intros a ha, exact ha.2 }
end

lemma ideal.prime_height_mono {I J : ideal R} [I.is_prime] [J.is_prime] (e : I ≤ J) :
  I.prime_height ≤ J.prime_height :=
set.chain_height_le_of_subset (set.inter_subset_inter set.subset.rfl $ set.Iio_subset_Iio e)

lemma ideal.prime_height_add_one_le_of_lt {I J : ideal R} [I.is_prime] [J.is_prime] (e : I < J) :
  I.prime_height + 1 ≤ J.prime_height :=
I.prime_height_succ.trans_le
  (set.chain_height_le_of_subset (set.inter_subset_inter set.subset.rfl $ set.Iic_subset_Iio.mpr e))

lemma ideal.prime_height_strict_mono {I J : ideal R} [I.is_prime] [J.is_prime]
  (e : I < J) [J.finite_height] :
  I.prime_height < J.prime_height :=
begin
  have H := ideal.prime_height_add_one_le_of_lt e,
  cases hJ : J.prime_height with n,
  { exact (J.prime_height_ne_top hJ).elim },
  cases hI : I.prime_height with m; rw [hI, hJ] at H,
  { rw [with_top.none_eq_top, top_add, ← eq_top_iff] at H, cases H },
  { have : (m : with_top ℕ) + (1 : ℕ) ≤ n := H,
    rw [← with_top.coe_add, with_top.coe_le_coe, nat.add_one_le_iff] at this,
    exact with_top.coe_lt_coe.mpr this },
end

lemma with_top.coe_lt_iff_add_one_le {n : ℕ} {m : ℕ∞} :
  ↑n < m ↔ ↑n + 1 ≤ m :=
begin
  cases m; simp only [with_top.none_eq_top, with_top.some_eq_coe, ← with_top.coe_one,
    with_top.top_add, ← with_top.coe_add, with_top.coe_le_coe, with_top.coe_lt_coe,
    with_top.nat_ne_top, not_top_lt, top_le_iff, nat.lt_iff_add_one_le, le_top,
    with_top.coe_lt_top],
end

lemma ideal.height_strict_mono_of_is_prime {I J : ideal R} [I.is_prime]
  (e : I < J) [I.finite_height] :
  I.height < J.height :=
begin
  rw [ideal.height_eq_prime_height I, ideal.height,
    ← enat.coe_to_nat_eq_self.mpr (ideal.prime_height_ne_top I),
    with_top.coe_lt_iff_add_one_le, le_infi₂_iff],
  simp_rw [← with_top.coe_lt_iff_add_one_le, enat.coe_to_nat_eq_self.mpr
    (ideal.prime_height_ne_top I)],
  intros K hK,
  haveI := hK.1.1,
  cases hn : K.prime_height with n,
  { rw with_top.none_eq_top, exact ideal.prime_height_lt_top _ },
  haveI : K.finite_height := ⟨or.inr _⟩,
  { exact hn ▸ ideal.prime_height_strict_mono (e.trans_le hK.1.2) },
  { rw [ideal.height_eq_prime_height, hn], exact with_top.coe_ne_top }
end

lemma ideal.minimal_primes_eq_empty_iff : I.minimal_primes = ∅ ↔ I = ⊤ :=
begin
  split,
  { intros e,
    by_contra h,
    obtain ⟨M, hM, hM'⟩ := ideal.exists_le_maximal I h,
    resetI,
    obtain ⟨p, hp, _⟩ := ideal.exists_minimal_primes_le hM',
    show p ∈ (∅ : set (ideal R)), by rwa ← e },
  { contrapose,
    intros h e,
    rw [← ne.def, set.ne_empty_iff_nonempty] at h,
    obtain ⟨p, hp⟩ := h,
    exact (hp.1.1.1 : _) (eq_top_iff.mpr (e.symm.trans_le hp.1.2)) }
end

lemma ideal.minimal_primes_top : (⊤ : ideal R).minimal_primes = ∅ :=
(ideal.minimal_primes_eq_empty_iff _).mpr rfl

lemma ideal.height_top : ideal.height (⊤ : ideal R) = ⊤ :=
begin
  simp_rw [ideal.height, ideal.prime_height, ideal.minimal_primes_top],
  simp
end

lemma ideal.height_mono {I J : ideal R} (h : I ≤ J) : I.height ≤ J.height :=
begin
  apply le_infi₂ _,
  intros p hp,
  haveI := hp.1.1,
  obtain ⟨q, hq, e⟩ := ideal.exists_minimal_primes_le (h.trans hp.1.2),
  haveI := hq.1.1,
  exact (infi₂_le q hq).trans (ideal.prime_height_mono e)
end

lemma with_top.supr_add {ι : Sort*} [nonempty ι]
  (f : ι → with_top ℕ) (x : with_top ℕ) :
  supr f + x = ⨆ i, f i + x :=
begin
  cases x, { simp_rw [with_top.none_eq_top, add_top, supr_const] },
  have : ↑x ≤ ⨆ i, f i + ↑x,
  { refine le_trans _ (le_supr _ $ classical.arbitrary _), exact le_add_left rfl.le },
  rw with_top.some_eq_coe,
  apply le_antisymm,
  { rw [← tsub_add_cancel_of_le this],
    refine add_le_add (supr_le $ λ i, _) rfl.le,
    apply (with_top.add_le_add_iff_right (with_top.coe_ne_top : (x : with_top ℕ) ≠ ⊤)).mp,
    rw [tsub_add_cancel_of_le this],
    exact le_supr _ i },
  { exact supr_le (λ i, add_le_add (le_supr f i) rfl.le) }
end

lemma with_top.supr₂_add {ι : Sort*} {p : ι → Sort*} (hs : Exists p)
  (f : ∀ (i : ι), p i → with_top ℕ) (x : with_top ℕ) :
  (⨆ (i : ι) (h : p i), f i h) + x = ⨆ (i : ι) (h : p i), f i h + x :=
begin
  haveI : nonempty { i // p i } := ⟨⟨_, hs.some_spec⟩⟩,
  rw [supr_subtype', supr_subtype', with_top.supr_add]
end

noncomputable
def krull_dimension (R : Type*) [comm_ring R] : with_top ℕ :=
⨆ (I : ideal R) [I.is_prime], by exactI I.prime_height

@[mk_iff]
class finite_krull_dimensional (R : Type*) [comm_ring R] : Prop :=
(krull_dimension_ne_top : krull_dimension R ≠ ⊤)

lemma krull_dimension_ne_top (R : Type*) [comm_ring R] [h : finite_krull_dimensional R] :
  krull_dimension R ≠ ⊤ :=
h.1

lemma krull_dimension_lt_top (R : Type*) [comm_ring R] [finite_krull_dimensional R] :
  krull_dimension R < ⊤ :=
lt_of_le_of_ne le_top (krull_dimension_ne_top R)

lemma finite_krull_dimensional_iff_lt :
  finite_krull_dimensional R ↔ krull_dimension R < ⊤ :=
by simp [finite_krull_dimensional_iff]

lemma krull_dimension_of_subsingleton (R : Type*) [comm_ring R] [subsingleton R] :
  krull_dimension R = 0 :=
begin
  apply supr₂_eq_bot.mpr,
  intros i hI,
  exact ((hI.1 : _) (subsingleton.elim _ _)).elim
end

@[priority 100]
instance finite_krull_dimensional_of_subsingleton [subsingleton R] : finite_krull_dimensional R :=
by { rw [finite_krull_dimensional_iff, krull_dimension_of_subsingleton], rintro ⟨⟩ }

lemma ideal.prime_height_le_krull_dimension [I.is_prime] : I.prime_height ≤ krull_dimension R :=
le_supr₂ _ _

@[priority 900]
instance ideal.finite_height_of_finite_dimensional [finite_krull_dimensional R] :
  I.finite_height :=
begin
  rw [ideal.finite_height_iff_lt, or_iff_not_imp_left],
  intro e,
  obtain ⟨M, hM, hM'⟩ := ideal.exists_le_maximal I e,
  refine (ideal.height_mono hM').trans_lt (has_le.le.trans_lt _ (krull_dimension_lt_top R)),
  resetI,
  rw ideal.height_eq_prime_height,
  exact M.prime_height_le_krull_dimension
end

lemma krull_dimension_succ (R : Type*) [comm_ring R] [nontrivial R] :
  krull_dimension R + 1 = set.chain_height (set_of ideal.is_prime : set (ideal R)) :=
begin
  have : ∃ I : ideal R, I.is_prime := ⟨_, (ideal.exists_maximal R).some_spec.is_prime⟩,
  rw [krull_dimension, with_top.supr₂_add this, set.chain_height_eq_supr_Iic],
  simpa only [ideal.prime_height_succ]
end

variables {I}

lemma ideal.finite_height_of_le {I J : ideal R} (e : I ≤ J) (hJ : J ≠ ⊤) [J.finite_height] :
  I.finite_height :=
⟨or.inr $ by { rw ← lt_top_iff_ne_top,
  exact (ideal.height_mono e).trans_lt (ideal.height_lt_top hJ) }⟩

lemma ideal.mem_minimal_primes_of_height_eq {I J : ideal R} (e : I ≤ J) [J.is_prime]
  [hJ : J.finite_height]
  (e' : J.height ≤ I.height) : J ∈ I.minimal_primes :=
begin
  obtain ⟨p, h₁, h₂⟩ := ideal.exists_minimal_primes_le e,
  convert h₁,
  refine (eq_of_le_of_not_lt h₂ _).symm,
  intro h₃,
  haveI := h₁.1.1,
  haveI := ideal.finite_height_of_le h₂ ‹J.is_prime›.ne_top,
  exact lt_irrefl _
    ((ideal.height_strict_mono_of_is_prime h₃).trans_le (e'.trans $ ideal.height_mono h₁.1.2))
end

lemma ideal.prime_height_eq_zero_iff [I.is_prime] : I.prime_height = 0 ↔ I ∈ minimal_primes R :=
begin
  rw [ideal.prime_height, set.chain_height_eq_zero_iff],
  split,
  { intro e,
    refine ⟨⟨infer_instance, bot_le⟩, λ J hJ e', (eq_of_le_of_not_lt e' _).symm.le⟩,
    intro e'',
    show J ∈ (∅ : set (ideal R)),
    rw ← e,
    exact ⟨hJ.1, e''⟩ },
  { intro hI,
    ext J,
    suffices : J.is_prime → ¬J < I, { simpa },
    intros hJ e,
    exact not_le_of_lt e (hI.2 ⟨hJ, bot_le⟩ e.le) }
end

lemma ideal.is_maximal_of_prime_height_eq_krull_dimesion
  [h : I.is_prime] [finite_krull_dimensional R]
  (e : I.prime_height = krull_dimension R) : I.is_maximal :=
begin
  casesI subsingleton_or_nontrivial R,
  { exact ((h.1 : _) $ subsingleton.elim _ _).elim },
  have := congr_arg (λ x : with_top ℕ, x + 1) e,
  dsimp at this,
  rw [ideal.prime_height_succ] at this,
  refine ⟨⟨h.1, _⟩⟩,
  intros J hJ,
  by_contra e',
  obtain ⟨M, hM, hM'⟩ := ideal.exists_le_maximal J e',
  have H : (insert M (set_of ideal.is_prime ∩ set.Iic I)).chain_height =
    krull_dimension R + 1 + 1,
  { rw [← this, set.chain_height_insert_of_forall_lt],
    intros I' hI',
    calc I' ≤ I : hI'.2
        ... < J : hJ
        ... ≤ M : hM' },
  have : krull_dimension R + 1 + 1 ≤ set.chain_height (set_of ideal.is_prime),
  { rw ← H, apply set.chain_height_le_of_subset, rintros K (rfl|⟨h, _⟩), exacts [hM.is_prime, h] },
  cases h : krull_dimension R with x,
  { exact krull_dimension_ne_top R h },
  { rw [← krull_dimension_succ, h] at this, linarith [with_top.coe_le_coe.mp this] }
end

lemma local_ring.maximal_ideal_prime_height [local_ring R] :
  (local_ring.maximal_ideal R).prime_height = krull_dimension R :=
begin
  apply le_antisymm,
  { apply ideal.prime_height_le_krull_dimension },
  { apply supr₂_le _,
    introsI I hI,
    apply ideal.prime_height_mono,
    exact local_ring.le_maximal_ideal hI.1 }
end

lemma local_ring.maximal_ideal_height [local_ring R] :
  (local_ring.maximal_ideal R).height = krull_dimension R :=
by rw [ideal.height_eq_prime_height, local_ring.maximal_ideal_prime_height]

lemma ideal.prime_height_eq_krull_dimesion_iff [local_ring R] [I.is_prime]
  [finite_krull_dimensional R] :
  I.prime_height = krull_dimension R ↔ I = local_ring.maximal_ideal R :=
begin
  split,
  { exact λ e, local_ring.eq_maximal_ideal (ideal.is_maximal_of_prime_height_eq_krull_dimesion e) },
  { unfreezingI { rintro rfl }, rw local_ring.maximal_ideal_prime_height }
end

lemma set.chain_height_univ {α : Type*} [preorder α] (s : set α) :
  (set.univ : set s).chain_height = s.chain_height :=
begin
  conv_rhs { rw [← @subtype.range_coe _ s, ← set.image_univ] },
  rw set.chain_height_image,
  intros x y, refl,
end

lemma order_iso.chain_height_eq {α β : Type*} [preorder α] [preorder β]
  (e : α ≃o β) : (set.univ : set α).chain_height = (set.univ : set β).chain_height :=
begin
  rw [← set.range_iff_surjective.mpr e.surjective, ← set.image_univ, set.chain_height_image],
  exact λ _ _, e.lt_iff_lt.symm
end

lemma with_top.add_injective {n : ℕ∞} (hn : n ≠ ⊤) : function.injective (λ a, a + n) :=
λ a b e, ((with_top.add_le_add_iff_right hn).mp e.le).antisymm
    ((with_top.add_le_add_iff_right hn).mp e.ge)

lemma is_localization.prime_height (S : submonoid R)
  (A : Type*) [comm_ring A] [algebra R A] [is_localization S A]
  (J : ideal A) (hJ : J.is_prime) :
  J.prime_height = (J.comap (algebra_map R A)).prime_height :=
begin
  apply with_top.add_injective with_top.one_ne_top,
  dsimp only,
  rw [ideal.prime_height_succ, ideal.prime_height_succ, ← set.chain_height_univ,
    ← set.chain_height_univ (_ ∩ _)],
  let e := is_localization.order_iso_of_prime S A,
  have H : ∀ p : ideal R, p ≤ J.comap (algebra_map R A) → disjoint (S : set R) p,
  { exact λ p hp, set.disjoint_of_subset_right hp (e ⟨_, ‹J.is_prime›⟩).2.2 },
  refine order_iso.chain_height_eq
  { to_fun := λ I, ⟨I.1.comap (algebra_map R A), (e ⟨_, I.2.1⟩).2.1, ideal.comap_mono I.2.2⟩,
    inv_fun := λ I, ⟨_, (e.symm ⟨_, I.2.1, H _ I.2.2⟩).2, ideal.map_le_iff_le_comap.mpr I.2.2⟩,
    left_inv := λ I, subtype.ext (by injection (e.left_inv ⟨_, I.2.1⟩)),
    right_inv := λ I, subtype.ext (by injection (e.right_inv ⟨_, I.2.1, H _ I.2.2⟩)),
    map_rel_iff' := λ I₁ I₂, @rel_iso.map_rel_iff _ _ _ _ e ⟨_, I₁.2.1⟩ ⟨_, I₂.2.1⟩ }
end

lemma ideal.minimal_primes_comap_subset {A : Type*} [comm_ring A] (f : R →+* A) (J : ideal A) :
  (J.comap f).minimal_primes ⊆ ideal.comap f '' J.minimal_primes :=
λ p hp, let h := ideal.exists_minimal_primes_comap_eq f p hp in
  ⟨h.some, h.some_spec.some, h.some_spec.some_spec⟩

lemma is_localization.minimal_primes_comap (S : submonoid R) (A : Type*) [comm_ring A]
  [algebra R A] [is_localization S A] (J : ideal A) :
  (J.comap (algebra_map R A)).minimal_primes = ideal.comap (algebra_map R A) '' J.minimal_primes :=
begin
  rcases eq_or_ne J ⊤ with (rfl|hJ),
  { simp_rw [ideal.comap_top, ideal.minimal_primes_top, set.image_empty] },
  refine (ideal.minimal_primes_comap_subset _ _).antisymm _,
  rintro _ ⟨p, hp, rfl⟩,
  let i := is_localization.order_iso_of_prime S A,
  refine ⟨⟨@@ideal.is_prime.comap _ _ _ _ hp.1.1, ideal.comap_mono hp.1.2⟩, λ q hq e, _⟩,
  obtain ⟨⟨q', h₁⟩, h₂⟩ := i.surjective ⟨q, hq.1, set.disjoint_of_subset_right e (i ⟨_, hp.1.1⟩).2.2⟩,
  replace h₂ : q'.comap (algebra_map R A) = q := by injection h₂, subst h₂,
  replace e := @ideal.map_mono _ _ _ _ _ _ (algebra_map R A) _ _ e,
  replace hq := @ideal.map_mono _ _ _ _ _ _ (algebra_map R A) _ _ hq.2,
  simp_rw [is_localization.map_comap S A] at e hq,
  exact ideal.comap_mono (hp.2 ⟨h₁, hq⟩ e)
end

lemma is_localization.disjoint_comap_iff (S : submonoid R) (A : Type*) [comm_ring A]
  [algebra R A] [is_localization S A] (J : ideal A) :
  disjoint (S : set R) (J.comap $ algebra_map R A) ↔ J ≠ ⊤ :=
begin
  rw ← iff_not_comm, split,
  { rintro rfl, rw ideal.comap_top, apply set.disjoint_univ.not.mpr _,
    rw [← ne.def, set.ne_empty_iff_nonempty], exact ⟨_, S.one_mem⟩ },
  { rw [disjoint_iff, set.bot_eq_empty, ← ne.def, set.ne_empty_iff_nonempty],
    rintro ⟨x, hx, hx' : algebra_map R A x ∈ J⟩,
    exact J.eq_top_of_is_unit_mem hx' (is_localization.map_units A ⟨x, hx⟩) }
end

lemma is_localization.minimal_primes_map (S : submonoid R) (A : Type*) [comm_ring A]
  [algebra R A] [is_localization S A] (J : ideal R) :
  (J.map (algebra_map R A)).minimal_primes =
    ideal.comap (algebra_map R A) ⁻¹' J.minimal_primes :=
begin
  ext p, split,
  { intro hp,
    refine ⟨⟨@@ideal.is_prime.comap _ _ _ _ hp.1.1, ideal.map_le_iff_le_comap.mp hp.1.2⟩, _⟩,
    rintros I hI e,
    have hI' : disjoint (S : set R) I := (set.disjoint_of_subset_right e $
      ((is_localization.is_prime_iff_is_prime_disjoint S A _).mp hp.1.1).2),
    refine (ideal.comap_mono $
      hp.2 ⟨_, ideal.map_mono hI.2⟩ (ideal.map_le_iff_le_comap.mpr e)).trans_eq _,
    { exact is_localization.is_prime_of_is_prime_disjoint S A I hI.1 hI' },
    { exact is_localization.comap_map_of_is_prime_disjoint S A _ hI.1 hI' } },
  { intro hp,
    refine ⟨⟨_, ideal.map_le_iff_le_comap.mpr hp.1.2⟩, _⟩,
    { rw [is_localization.is_prime_iff_is_prime_disjoint S A,
        is_localization.disjoint_comap_iff S A],
      refine ⟨hp.1.1, _⟩, rintro rfl, exact hp.1.1.ne_top rfl },
    { intros I hI e,
      rw [← is_localization.map_comap S A I, ← is_localization.map_comap S A p],
      exact ideal.map_mono (hp.2 ⟨@@ideal.is_prime.comap _ _ _ _ hI.1,
        ideal.map_le_iff_le_comap.mp hI.2⟩ (ideal.comap_mono e)) } }
end

lemma is_localization.height (S : submonoid R)
  (A : Type*) [comm_ring A] [nontrivial A] [algebra R A] [is_localization S A]
  (J : ideal A) :
  J.height = (J.comap (algebra_map R A)).height :=
begin
  delta ideal.height,
  simp_rw [is_localization.prime_height S A, is_localization.minimal_primes_comap S A,
    ← ideal.height_eq_prime_height, infi_image]
end

lemma is_localization.at_prime.comap_maximal_ideal {R : Type*} (S : Type*) [comm_ring R] [comm_ring S]
  (I : ideal R) [I.is_prime] [algebra R S] [is_localization.at_prime S I] [local_ring S] :
  (local_ring.maximal_ideal S).comap (algebra_map R S) = I :=
ideal.ext $ λ x, by
simpa only [ideal.mem_comap] using is_localization.at_prime.to_map_mem_maximal_iff _ I x

lemma is_localization.at_prime.krull_dimension_eq_height (I : ideal R) [I.is_prime]
  (A : Type*) [comm_ring A] [nontrivial A] [algebra R A] [is_localization.at_prime A I] :
  krull_dimension A = I.height :=
begin
  haveI := is_localization.at_prime.local_ring A I,
  rw [← local_ring.maximal_ideal_prime_height,
    is_localization.prime_height I.prime_compl A,
    ← is_localization.at_prime.comap_maximal_ideal A I,
    ideal.height_eq_prime_height],
end

lemma submodule.spanrank_eq_zero_iff : I.spanrank = 0 ↔ I = ⊥ :=
begin
  split,
  { intro e,
    have H : submodule.fg I,
    { rw [← submodule.spanrank_ne_top_iff, e], rintro ⟨⟩ },
    rw [H.spanrank_eq, ← with_top.coe_zero, with_top.coe_eq_coe] at e,
    have := H.exists_generator_eq_min_generator_card,
    rw e at this,
    obtain ⟨f, hf⟩ := this,
    rwa [show set.range f = ∅, by simp, submodule.span_empty, eq_comm] at hf },
  { rintro rfl,
    rw [← bot_eq_zero, eq_bot_iff, bot_eq_zero, bot_eq_zero, ← with_top.coe_zero,
      submodule.fg.min_generator_card_le_iff_exists],
    have f : fin 0 → R := λ _, 0,
    refine ⟨f, by rw [show set.range f = ∅, by simp, submodule.span_empty, bot_eq_zero]⟩ }
end

lemma submodule.spanrank_sup {p q : ideal R} :
  (p ⊔ q).spanrank ≤ p.spanrank + q.spanrank :=
begin
  by_cases hp : submodule.fg p,
  swap,
  { rw [← submodule.spanrank_ne_top_iff, not_ne_iff] at hp,
    rw [hp, top_add], exact le_top },
  by_cases hq : submodule.fg q,
  swap,
  { rw [← submodule.spanrank_ne_top_iff, not_ne_iff] at hq,
    rw [hq, add_top], exact le_top },
  obtain ⟨f, hf⟩ := hp.exists_generator_eq_min_generator_card,
  obtain ⟨g, hg⟩ := hq.exists_generator_eq_min_generator_card,
  rw submodule.fg_iff_spanrank_eq at hp hq,
  rw [hp, hq, ← with_top.coe_add, submodule.fg.min_generator_card_le_iff_exists],
  refine ⟨(sum.elim f g) ∘ fin_sum_fin_equiv.symm, _⟩,
  rw [set.range_comp, set.range_iff_surjective.mpr (equiv.surjective _), set.image_univ,
    set.sum.elim_range, submodule.span_union, hf, hg],
end

lemma submodule.spanrank_span_set_finite {s : set R} (hs : s.finite) :
  (submodule.span R s).spanrank ≤ hs.to_finset.card :=
begin
  rw submodule.fg.min_generator_card_le_iff_exists,
  refine ⟨subtype.val ∘ hs.to_finset.equiv_fin.symm, _⟩,
  rw [set.range_comp, set.range_iff_surjective.mpr (equiv.surjective _), set.image_univ,
    subtype.range_val],
  congr, ext, exact hs.mem_to_finset,
end

lemma submodule.spanrank_bot : (⊥ : ideal R).spanrank = 0 :=
submodule.spanrank_eq_zero_iff.mpr rfl

lemma mem_minimal_primes_of_height_eq {I J : ideal R} [J.is_prime] (e : I ≤ J)
  (e' : I.height = J.prime_height) [J.finite_height] : J ∈ I.minimal_primes :=
begin
  refine ⟨⟨infer_instance, e⟩, λ K hK e'', (eq_of_le_of_not_lt e'' _).symm.le⟩,
  intro e''',
  haveI := hK.1,
  rw ← lt_self_iff_false J.prime_height,
  calc J.prime_height = I.height       : e'.symm
                  ... ≤ K.height       : ideal.height_mono hK.2
                  ... = K.prime_height : K.height_eq_prime_height
                  ... < J.prime_height : ideal.prime_height_strict_mono e'''
end

lemma exists_spanrank_le_and_le_height_of_le_height [is_noetherian_ring R] (I : ideal R) (r : ℕ)
  (hr : ↑r ≤ I.height) :
  ∃ J ≤ I, J.spanrank ≤ r ∧ ↑r ≤ J.height :=
begin
  induction r with r H,
  { refine ⟨⊥, bot_le, _, zero_le _⟩, rw submodule.spanrank_bot, exact rfl.le },
  { obtain ⟨J, h₁, h₂, h₃⟩ := H ((with_top.coe_le_coe.mpr r.le_succ).trans hr),
    let S := { K | K ∈ J.minimal_primes ∧ ideal.height K = r },
    have hS : S.finite := set.finite.subset J.minimal_primes_finite (λ _ h, h.1),
    have : ¬ ↑I ⊆ ⋃ J ∈ hS.to_finset, (J : set R),
    { refine (ideal.subset_union_prime ⊥ ⊥ _).not.mpr _,
      { rintro K hK - -, rw set.finite.mem_to_finset at hK, exact hK.1.1.1 },
      { push_neg,
        intros K hK e,
        have := hr.trans (ideal.height_mono e),
        rw set.finite.mem_to_finset at hK,
        rw [hK.2, with_top.coe_le_coe, ← not_lt] at this,
        exact this r.lt_succ_self } },
    simp_rw [set.not_subset, set.mem_Union, not_exists, set.finite.mem_to_finset] at this,
    obtain ⟨x, hx₁, hx₂⟩ := this,
    refine ⟨J ⊔ ideal.span {x}, sup_le h₁ _, _, _⟩,
    { rwa [ideal.span_le, set.singleton_subset_iff] },
    { refine submodule.spanrank_sup.trans _,
      rw [nat.succ_eq_add_one, with_top.coe_add],
      refine add_le_add h₂ _,
      refine (submodule.spanrank_span_set_finite $ set.to_finite _).trans _,
      simp },
    { refine le_infi₂ _,
      intros p hp,
      haveI := hp.1.1,
      by_cases p.height = ⊤,
      { rw [← p.height_eq_prime_height, h], exact le_top },
      haveI : p.finite_height := ⟨or.inr h⟩,
      have := ideal.height_mono (le_sup_left.trans hp.1.2),
      suffices h : ↑r ≠ p.prime_height,
      { rw [nat.succ_eq_add_one, with_top.coe_add],
        have := h₃.trans this,
        rw ideal.height_eq_prime_height at this,
        exact enat.add_one_le_of_lt (lt_of_le_of_ne this h) },
      intro e,
      apply hx₂ p,
      { have : J.height = p.prime_height,
        { apply le_antisymm, { rwa ← p.height_eq_prime_height }, { rwa ← e } },
        refine ⟨mem_minimal_primes_of_height_eq (le_sup_left.trans hp.1.2) this, _⟩,
        rwa [p.height_eq_prime_height, eq_comm] },
      { apply hp.1.2,
        apply ideal.mem_sup_right,
        apply ideal.subset_span,
        exact set.mem_singleton _ } } }
end