/-
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 topology.order

/-!
# Specific classes of maps between topological spaces

This file introduces the following properties of a map `f : X → Y` between topological spaces:

* `is_open_map f` means the image of an open set under `f` is open.
* `is_closed_map f` means the image of a closed set under `f` is closed.

(Open and closed maps need not be continuous.)

* `inducing f` means the topology on `X` is the one induced via `f` from the topology on `Y`.
  These behave like embeddings except they need not be injective. Instead, points of `X` which
  are identified by `f` are also inseparable in the topology on `X`.
* `embedding f` means `f` is inducing and also injective. Equivalently, `f` identifies `X` with
  a subspace of `Y`.
* `open_embedding f` means `f` is an embedding with open image, so it identifies `X` with an
  open subspace of `Y`. Equivalently, `f` is an embedding and an open map.
* `closed_embedding f` similarly means `f` is an embedding with closed image, so it identifies
  `X` with a closed subspace of `Y`. Equivalently, `f` is an embedding and a closed map.

* `quotient_map f` is the dual condition to `embedding f`: `f` is surjective and the topology
  on `Y` is the one coinduced via `f` from the topology on `X`. Equivalently, `f` identifies
  `Y` with a quotient of `X`. Quotient maps are also sometimes known as identification maps.

## References

* <https://en.wikipedia.org/wiki/Open_and_closed_maps>
* <https://en.wikipedia.org/wiki/Embedding#General_topology>
* <https://en.wikipedia.org/wiki/Quotient_space_(topology)#Quotient_map>

## Tags

open map, closed map, embedding, quotient map, identification map

-/

open set filter
open_locale topological_space filter

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section inducing

/-- A function `f : α → β` between topological spaces is inducing if the topology on `α` is induced
by the topology on `β` through `f`, meaning that a set `s : set α` is open iff it is the preimage
under `f` of some open set `t : set β`. -/
structure inducing [tα : topological_space α] [tβ : topological_space β] (f : α → β) : Prop :=
(induced : tα = tβ.induced f)

variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

lemma inducing_id : inducing (@id α) :=
⟨induced_id.symm⟩

protected lemma inducing.comp {g : β → γ} {f : α → β} (hg : inducing g) (hf : inducing f) :
  inducing (g ∘ f) :=
⟨by rw [hf.induced, hg.induced, induced_compose]⟩

lemma inducing_of_inducing_compose {f : α → β} {g : β → γ} (hf : continuous f) (hg : continuous g)
  (hgf : inducing (g ∘ f)) : inducing f :=
⟨le_antisymm
    (by rwa ← continuous_iff_le_induced)
    (by { rw [hgf.induced, ← continuous_iff_le_induced], apply hg.comp continuous_induced_dom })⟩

lemma inducing.nhds_eq_comap {f : α → β} (hf : inducing f) :
  ∀ (a : α), 𝓝 a = comap f (𝓝 $ f a) :=
(induced_iff_nhds_eq f).1 hf.induced

lemma inducing.map_nhds_eq {f : α → β} (hf : inducing f) (a : α) :
  (𝓝 a).map f = 𝓝[range f] (f a) :=
hf.induced.symm ▸ map_nhds_induced_eq a

lemma inducing.map_nhds_of_mem {f : α → β} (hf : inducing f) (a : α) (h : range f ∈ 𝓝 (f a)) :
  (𝓝 a).map f = 𝓝 (f a) :=
hf.induced.symm ▸ map_nhds_induced_of_mem h

lemma inducing.image_mem_nhds_within {f : α → β} (hf : inducing f) {a : α} {s : set α}
  (hs : s ∈ 𝓝 a) : f '' s ∈ 𝓝[range f] (f a) :=
hf.map_nhds_eq a ▸ image_mem_map hs

lemma inducing.tendsto_nhds_iff {ι : Type*}
  {f : ι → β} {g : β → γ} {a : filter ι} {b : β} (hg : inducing g) :
  tendsto f a (𝓝 b) ↔ tendsto (g ∘ f) a (𝓝 (g b)) :=
by rw [hg.nhds_eq_comap, tendsto_comap_iff]

lemma inducing.continuous_at_iff {f : α → β} {g : β → γ} (hg : inducing g) {x : α} :
  continuous_at f x ↔ continuous_at (g ∘ f) x :=
by simp_rw [continuous_at, inducing.tendsto_nhds_iff hg]

lemma inducing.continuous_iff {f : α → β} {g : β → γ} (hg : inducing g) :
  continuous f ↔ continuous (g ∘ f) :=
by simp_rw [continuous_iff_continuous_at, hg.continuous_at_iff]

lemma inducing.continuous_at_iff' {f : α → β} {g : β → γ} (hf : inducing f) {x : α}
  (h : range f ∈ 𝓝 (f x)) : continuous_at (g ∘ f) x ↔ continuous_at g (f x) :=
by { simp_rw [continuous_at, filter.tendsto, ← hf.map_nhds_of_mem _ h, filter.map_map] }

protected lemma inducing.continuous {f : α → β} (hf : inducing f) : continuous f :=
hf.continuous_iff.mp continuous_id

protected lemma inducing.inducing_iff {f : α → β} {g : β → γ} (hg : inducing g) :
  inducing f ↔ inducing (g ∘ f) :=
begin
  refine ⟨λ h, hg.comp h, λ hgf, inducing_of_inducing_compose _ hg.continuous hgf⟩,
  rw hg.continuous_iff,
  exact hgf.continuous
end

lemma inducing.closure_eq_preimage_closure_image {f : α → β} (hf : inducing f) (s : set α) :
  closure s = f ⁻¹' closure (f '' s) :=
by { ext x, rw [set.mem_preimage, ← closure_induced, hf.induced] }

lemma inducing.is_closed_iff {f : α → β} (hf : inducing f) {s : set α} :
  is_closed s ↔ ∃ t, is_closed t ∧ f ⁻¹' t = s :=
by rw [hf.induced, is_closed_induced_iff]

lemma inducing.is_closed_iff' {f : α → β} (hf : inducing f) {s : set α} :
  is_closed s ↔ ∀ x, f x ∈ closure (f '' s) → x ∈ s :=
by rw [hf.induced, is_closed_induced_iff']

lemma inducing.is_open_iff {f : α → β} (hf : inducing f) {s : set α} :
  is_open s ↔ ∃ t, is_open t ∧ f ⁻¹' t = s :=
by rw [hf.induced, is_open_induced_iff]

lemma inducing.dense_iff {f : α → β} (hf : inducing f) {s : set α} :
  dense s ↔ ∀ x, f x ∈ closure (f '' s) :=
by simp only [dense, hf.closure_eq_preimage_closure_image, mem_preimage]

end inducing

section embedding

/-- A function between topological spaces is an embedding if it is injective,
  and for all `s : set α`, `s` is open iff it is the preimage of an open set. -/
structure embedding [tα : topological_space α] [tβ : topological_space β] (f : α → β)
  extends inducing f : Prop :=
(inj : function.injective f)

lemma function.injective.embedding_induced [t : topological_space β]
  {f : α → β} (hf : function.injective f) :
  @embedding α β (t.induced f) t f :=
{ induced := rfl,
  inj := hf }

variables [topological_space α] [topological_space β] [topological_space γ]

lemma embedding.mk' (f : α → β) (inj : function.injective f)
  (induced : ∀a, comap f (𝓝 (f a)) = 𝓝 a) : embedding f :=
⟨⟨(induced_iff_nhds_eq f).2 (λ a, (induced a).symm)⟩, inj⟩

lemma embedding_id : embedding (@id α) :=
⟨inducing_id, assume a₁ a₂ h, h⟩

lemma embedding.comp {g : β → γ} {f : α → β} (hg : embedding g) (hf : embedding f) :
  embedding (g ∘ f) :=
{ inj:= assume a₁ a₂ h, hf.inj $ hg.inj h,
  ..hg.to_inducing.comp hf.to_inducing }

lemma embedding_of_embedding_compose {f : α → β} {g : β → γ} (hf : continuous f) (hg : continuous g)
  (hgf : embedding (g ∘ f)) : embedding f :=
{ induced := (inducing_of_inducing_compose hf hg hgf.to_inducing).induced,
  inj := assume a₁ a₂ h, hgf.inj $ by simp [h, (∘)] }

protected lemma function.left_inverse.embedding {f : α → β} {g : β → α}
  (h : function.left_inverse f g) (hf : continuous f) (hg : continuous g) :
  embedding g :=
embedding_of_embedding_compose hg hf $ h.comp_eq_id.symm ▸ embedding_id

lemma embedding.map_nhds_eq {f : α → β} (hf : embedding f) (a : α) :
  (𝓝 a).map f = 𝓝[range f] (f a) :=
hf.1.map_nhds_eq a

lemma embedding.map_nhds_of_mem {f : α → β}
  (hf : embedding f) (a : α) (h : range f ∈ 𝓝 (f a)) : (𝓝 a).map f = 𝓝 (f a) :=
hf.1.map_nhds_of_mem a h

lemma embedding.tendsto_nhds_iff {ι : Type*}
  {f : ι → β} {g : β → γ} {a : filter ι} {b : β} (hg : embedding g) :
  tendsto f a (𝓝 b) ↔ tendsto (g ∘ f) a (𝓝 (g b)) :=
hg.to_inducing.tendsto_nhds_iff

lemma embedding.continuous_iff {f : α → β} {g : β → γ} (hg : embedding g) :
  continuous f ↔ continuous (g ∘ f) :=
inducing.continuous_iff hg.1

lemma embedding.continuous {f : α → β} (hf : embedding f) : continuous f :=
inducing.continuous hf.1

lemma embedding.closure_eq_preimage_closure_image {e : α → β} (he : embedding e) (s : set α) :
  closure s = e ⁻¹' closure (e '' s) :=
he.1.closure_eq_preimage_closure_image s

end embedding

/-- A function between topological spaces is a quotient map if it is surjective,
  and for all `s : set β`, `s` is open iff its preimage is an open set. -/
def quotient_map {α : Type*} {β : Type*} [tα : topological_space α] [tβ : topological_space β]
  (f : α → β) : Prop :=
function.surjective f ∧ tβ = tα.coinduced f

lemma quotient_map_iff {α β : Type*} [topological_space α] [topological_space β] {f : α → β} :
  quotient_map f ↔ function.surjective f ∧ ∀ s : set β, is_open s ↔ is_open (f ⁻¹' s) :=
and_congr iff.rfl topological_space_eq_iff

namespace quotient_map

variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]
  {g : β → γ} {f : α → β}

protected lemma id : quotient_map (@id α) :=
⟨assume a, ⟨a, rfl⟩, coinduced_id.symm⟩

protected lemma comp (hg : quotient_map g) (hf : quotient_map f) :
  quotient_map (g ∘ f) :=
⟨hg.left.comp hf.left, by rw [hg.right, hf.right, coinduced_compose]⟩

protected lemma of_quotient_map_compose (hf : continuous f) (hg : continuous g)
  (hgf : quotient_map (g ∘ f)) : quotient_map g :=
⟨hgf.1.of_comp,
  le_antisymm
    (by { rw [hgf.right, ← continuous_iff_coinduced_le], apply continuous_coinduced_rng.comp hf })
    (by rwa ← continuous_iff_coinduced_le)⟩

protected lemma continuous_iff (hf : quotient_map f) :
  continuous g ↔ continuous (g ∘ f) :=
by rw [continuous_iff_coinduced_le, continuous_iff_coinduced_le, hf.right, coinduced_compose]

protected lemma continuous (hf : quotient_map f) : continuous f :=
hf.continuous_iff.mp continuous_id

protected lemma surjective (hf : quotient_map f) : function.surjective f := hf.1

protected lemma is_open_preimage (hf : quotient_map f) {s : set β} :
  is_open (f ⁻¹' s) ↔ is_open s :=
((quotient_map_iff.1 hf).2 s).symm

protected

end quotient_map

/-- A map `f : α → β` is said to be an *open map*, if the image of any open `U : set α`
is open in `β`. -/
def is_open_map [topological_space α] [topological_space β] (f : α → β) :=
∀ U : set α, is_open U → is_open (f '' U)

namespace is_open_map
variables [topological_space α] [topological_space β] [topological_space γ] {f : α → β}
open function

protected lemma id : is_open_map (@id α) := assume s hs, by rwa [image_id]

protected lemma comp
  {g : β → γ} {f : α → β} (hg : is_open_map g) (hf : is_open_map f) : is_open_map (g ∘ f) :=
by intros s hs; rw [image_comp]; exact hg _ (hf _ hs)

lemma is_open_range (hf : is_open_map f) : is_open (range f) :=
by { rw ← image_univ, exact hf _ is_open_univ }

lemma image_mem_nhds (hf : is_open_map f) {x : α} {s : set α} (hx : s ∈ 𝓝 x) :
  f '' s ∈ 𝓝 (f x) :=
let ⟨t, hts, ht, hxt⟩ := mem_nhds_iff.1 hx in
mem_of_superset (is_open.mem_nhds (hf t ht) (mem_image_of_mem _ hxt)) (image_subset _ hts)

lemma maps_to_interior (hf : is_open_map f) {s : set α} {t : set β} (h : maps_to f s t) :
  maps_to f (interior s) (interior t) :=
maps_to'.2 $ interior_maximal (h.mono interior_subset subset.rfl).image_subset
  (hf _ is_open_interior)

lemma image_interior_subset (hf : is_open_map f) (s : set α) :
  f '' interior s ⊆ interior (f '' s) :=
(hf.maps_to_interior (maps_to_image f s)).image_subset

lemma nhds_le (hf : is_open_map f) (a : α) : 𝓝 (f a) ≤ (𝓝 a).map f :=
le_map $ λ s, hf.image_mem_nhds

lemma of_nhds_le (hf : ∀ a, 𝓝 (f a) ≤ map f (𝓝 a)) : is_open_map f :=
λ s hs, is_open_iff_mem_nhds.2 $ λ b ⟨a, has, hab⟩,
  hab ▸ hf _ (image_mem_map $ is_open.mem_nhds hs has)

lemma of_sections {f : α → β}
  (h : ∀ x, ∃ g : β → α, continuous_at g (f x) ∧ g (f x) = x ∧ right_inverse g f) :
  is_open_map f :=
of_nhds_le $ λ x, let ⟨g, hgc, hgx, hgf⟩ := h x in
calc 𝓝 (f x) = map f (map g (𝓝 (f x))) : by rw [map_map, hgf.comp_eq_id, map_id]
... ≤ map f (𝓝 (g (f x))) : map_mono hgc
... = map f (𝓝 x) : by rw hgx

lemma of_inverse {f : α → β} {f' : β → α}
  (h : continuous f') (l_inv : left_inverse f f') (r_inv : right_inverse f f') :
  is_open_map f :=
of_sections $ λ x, ⟨f', h.continuous_at, r_inv _, l_inv⟩

/-- A continuous surjective open map is a quotient map. -/
lemma to_quotient_map {f : α → β}
  (open_map : is_open_map f) (cont : continuous f) (surj : surjective f) :
  quotient_map f :=
quotient_map_iff.2 ⟨surj, λ s, ⟨λ h, h.preimage cont, λ h, surj.image_preimage s ▸ open_map _ h⟩⟩

lemma interior_preimage_subset_preimage_interior (hf : is_open_map f) {s : set β} :
  interior (f⁻¹' s) ⊆ f⁻¹' (interior s) :=
hf.maps_to_interior (maps_to_preimage _ _)

lemma preimage_interior_eq_interior_preimage (hf₁ : is_open_map f) (hf₂ : continuous f)
  (s : set β) :
  f⁻¹' (interior s) = interior (f⁻¹' s) :=
subset.antisymm
  (preimage_interior_subset_interior_preimage hf₂)
  (interior_preimage_subset_preimage_interior hf₁)

lemma preimage_closure_subset_closure_preimage (hf : is_open_map f) {s : set β} :
  f ⁻¹' (closure s) ⊆ closure (f ⁻¹' s) :=
begin
  rw ← compl_subset_compl,
  simp only [← interior_compl, ← preimage_compl, hf.interior_preimage_subset_preimage_interior]
end

lemma preimage_closure_eq_closure_preimage (hf : is_open_map f) (hfc : continuous f) (s : set β) :
  f ⁻¹' (closure s) = closure (f ⁻¹' s) :=
hf.preimage_closure_subset_closure_preimage.antisymm (hfc.closure_preimage_subset s)

lemma preimage_frontier_subset_frontier_preimage (hf : is_open_map f) {s : set β} :
  f ⁻¹' (frontier s) ⊆ frontier (f ⁻¹' s) :=
by simpa only [frontier_eq_closure_inter_closure, preimage_inter]
  using inter_subset_inter hf.preimage_closure_subset_closure_preimage
    hf.preimage_closure_subset_closure_preimage

lemma preimage_frontier_eq_frontier_preimage (hf : is_open_map f) (hfc : continuous f) (s : set β) :
  f ⁻¹' (frontier s) = frontier (f ⁻¹' s) :=
by simp only [frontier_eq_closure_inter_closure, preimage_inter, preimage_compl,
  hf.preimage_closure_eq_closure_preimage hfc]

end is_open_map

lemma is_open_map_iff_nhds_le [topological_space α] [topological_space β] {f : α → β} :
  is_open_map f ↔ ∀(a:α), 𝓝 (f a) ≤ (𝓝 a).map f :=
⟨λ hf, hf.nhds_le, is_open_map.of_nhds_le⟩

lemma is_open_map_iff_interior [topological_space α] [topological_space β] {f : α → β} :
  is_open_map f ↔ ∀ s, f '' (interior s) ⊆ interior (f '' s) :=
⟨is_open_map.image_interior_subset, λ hs u hu, subset_interior_iff_open.mp $
  calc f '' u = f '' (interior u) : by rw hu.interior_eq
          ... ⊆ interior (f '' u) : hs u⟩

/-- An inducing map with an open range is an open map. -/
protected lemma inducing.is_open_map [topological_space α] [topological_space β] {f : α → β}
  (hi : inducing f) (ho : is_open (range f)) :
  is_open_map f :=
is_open_map.of_nhds_le $ λ x, (hi.map_nhds_of_mem _ $ is_open.mem_nhds ho $ mem_range_self _).ge

section is_closed_map
variables [topological_space α] [topological_space β]

/-- A map `f : α → β` is said to be a *closed map*, if the image of any closed `U : set α`
is closed in `β`. -/
def is_closed_map (f : α → β) := ∀ U : set α, is_closed U → is_closed (f '' U)

end is_closed_map

namespace is_closed_map

variables [topological_space α] [topological_space β] [topological_space γ]
open function

protected lemma id : is_closed_map (@id α) := assume s hs, by rwa image_id

protected lemma comp {g : β → γ} {f : α → β} (hg : is_closed_map g) (hf : is_closed_map f) :
  is_closed_map (g ∘ f) :=
by { intros s hs, rw image_comp, exact hg _ (hf _ hs) }

lemma closure_image_subset {f : α → β} (hf : is_closed_map f) (s : set α) :
  closure (f '' s) ⊆ f '' closure s :=
closure_minimal (image_subset _ subset_closure) (hf _ is_closed_closure)

lemma of_inverse {f : α → β} {f' : β → α}
  (h : continuous f') (l_inv : left_inverse f f') (r_inv : right_inverse f f') :
  is_closed_map f :=
assume s hs,
have f' ⁻¹' s = f '' s, by ext x; simp [mem_image_iff_of_inverse r_inv l_inv],
this ▸ hs.preimage h

lemma of_nonempty {f : α → β} (h : ∀ s, is_closed s → s.nonempty → is_closed (f '' s)) :
  is_closed_map f :=
begin
  intros s hs, cases eq_empty_or_nonempty s with h2s h2s,
  { simp_rw [h2s, image_empty, is_closed_empty] },
  { exact h s hs h2s }
end

lemma closed_range {f : α → β} (hf : is_closed_map f) : is_closed (range f) :=
@image_univ _ _ f ▸ hf _ is_closed_univ

end is_closed_map

lemma inducing.is_closed_map [topological_space α] [topological_space β]
  {f : α → β} (hf : inducing f) (h : is_closed (range f)) : is_closed_map f :=
begin
  intros s hs,
  rcases hf.is_closed_iff.1 hs with ⟨t, ht, rfl⟩,
  rw image_preimage_eq_inter_range,
  exact ht.inter h
end

lemma is_closed_map_iff_closure_image [topological_space α] [topological_space β] {f : α → β} :
  is_closed_map f ↔ ∀ s, closure (f '' s) ⊆ f '' closure s :=
⟨is_closed_map.closure_image_subset, λ hs c hc, is_closed_of_closure_subset $
  calc closure (f '' c) ⊆ f '' (closure c) : hs c
                    ... = f '' c : by rw hc.closure_eq⟩

section open_embedding
variables [topological_space α] [topological_space β] [topological_space γ]

/-- An open embedding is an embedding with open image. -/
structure open_embedding (f : α → β) extends embedding f : Prop :=
(open_range : is_open $ range f)

lemma open_embedding.is_open_map {f : α → β} (hf : open_embedding f) : is_open_map f :=
hf.to_embedding.to_inducing.is_open_map hf.open_range

lemma open_embedding.map_nhds_eq {f : α → β} (hf : open_embedding f) (a : α) :
  map f (𝓝 a) = 𝓝 (f a) :=
hf.to_embedding.map_nhds_of_mem _ $ hf.open_range.mem_nhds $ mem_range_self _

lemma open_embedding.open_iff_image_open {f : α → β} (hf : open_embedding f)
  {s : set α} : is_open s ↔ is_open (f '' s) :=
⟨hf.is_open_map s,
 λ h, begin
   convert ← h.preimage hf.to_embedding.continuous,
   apply preimage_image_eq _ hf.inj
 end⟩

lemma open_embedding.tendsto_nhds_iff {ι : Type*}
  {f : ι → β} {g : β → γ} {a : filter ι} {b : β} (hg : open_embedding g) :
  tendsto f a (𝓝 b) ↔ tendsto (g ∘ f) a (𝓝 (g b)) :=
hg.to_embedding.tendsto_nhds_iff

lemma open_embedding.continuous {f : α → β} (hf : open_embedding f) : continuous f :=
hf.to_embedding.continuous

lemma open_embedding.open_iff_preimage_open {f : α → β} (hf : open_embedding f)
  {s : set β} (hs : s ⊆ range f) : is_open s ↔ is_open (f ⁻¹' s) :=
begin
  convert ←hf.open_iff_image_open.symm,
  rwa [image_preimage_eq_inter_range, inter_eq_self_of_subset_left]
end

lemma open_embedding_of_embedding_open {f : α → β} (h₁ : embedding f)
  (h₂ : is_open_map f) : open_embedding f :=
⟨h₁, h₂.is_open_range⟩

lemma open_embedding_of_continuous_injective_open {f : α → β} (h₁ : continuous f)
  (h₂ : function.injective f) (h₃ : is_open_map f) : open_embedding f :=
begin
  refine open_embedding_of_embedding_open ⟨⟨_⟩, h₂⟩ h₃,
  apply le_antisymm (continuous_iff_le_induced.mp h₁) _,
  intro s,
  change is_open _ → is_open _,
  rw is_open_induced_iff,
  refine λ hs, ⟨f '' s, h₃ s hs, _⟩,
  rw preimage_image_eq _ h₂
end

lemma open_embedding_id : open_embedding (@id α) :=
⟨embedding_id, is_open_map.id.is_open_range⟩

lemma open_embedding.comp {g : β → γ} {f : α → β}
  (hg : open_embedding g) (hf : open_embedding f) : open_embedding (g ∘ f) :=
⟨hg.1.comp hf.1, (hg.is_open_map.comp hf.is_open_map).is_open_range⟩

lemma open_embedding_of_open_embedding_compose {α β γ : Type*} [topological_space α]
  [topological_space β] [topological_space γ] (f : α → β) {g : β → γ} (hg : open_embedding g)
    (h : open_embedding (g ∘ f)) : open_embedding f :=
begin
  have hf := hg.to_embedding.continuous_iff.mpr h.continuous,
  split,
  { exact embedding_of_embedding_compose hf hg.continuous h.to_embedding },
  { rw [hg.open_iff_image_open, ← set.image_univ, ← set.image_comp, ← h.open_iff_image_open],
    exact is_open_univ }
end

lemma open_embedding_iff_open_embedding_compose {α β γ : Type*} [topological_space α]
  [topological_space β] [topological_space γ] (f : α → β) {g : β → γ} (hg : open_embedding g) :
    open_embedding (g ∘ f) ↔ open_embedding f :=
⟨open_embedding_of_open_embedding_compose f hg, hg.comp⟩

end open_embedding

section closed_embedding
variables [topological_space α] [topological_space β] [topological_space γ]

/-- A closed embedding is an embedding with closed image. -/
structure closed_embedding (f : α → β) extends embedding f : Prop :=
(closed_range : is_closed $ range f)

variables {f : α → β}

lemma closed_embedding.tendsto_nhds_iff {ι : Type*}
  {g : ι → α} {a : filter ι} {b : α} (hf : closed_embedding f) :
  tendsto g a (𝓝 b) ↔ tendsto (f ∘ g) a (𝓝 (f b)) :=
hf.to_embedding.tendsto_nhds_iff

lemma closed_embedding.continuous (hf : closed_embedding f) : continuous f :=
hf.to_embedding.continuous

lemma closed_embedding.is_closed_map (hf : closed_embedding f) : is_closed_map f :=
hf.to_embedding.to_inducing.is_closed_map hf.closed_range

lemma closed_embedding.closed_iff_image_closed (hf : closed_embedding f)
  {s : set α} : is_closed s ↔ is_closed (f '' s) :=
⟨hf.is_closed_map s,
 λ h, begin
   convert ←continuous_iff_is_closed.mp hf.continuous _ h,
   apply preimage_image_eq _ hf.inj
 end⟩

lemma closed_embedding.closed_iff_preimage_closed (hf : closed_embedding f)
  {s : set β} (hs : s ⊆ range f) : is_closed s ↔ is_closed (f ⁻¹' s) :=
begin
  convert ←hf.closed_iff_image_closed.symm,
  rwa [image_preimage_eq_inter_range, inter_eq_self_of_subset_left]
end

lemma closed_embedding_of_embedding_closed (h₁ : embedding f)
  (h₂ : is_closed_map f) : closed_embedding f :=
⟨h₁, by convert h₂ univ is_closed_univ; simp⟩

lemma closed_embedding_of_continuous_injective_closed (h₁ : continuous f)
  (h₂ : function.injective f) (h₃ : is_closed_map f) : closed_embedding f :=
begin
  refine closed_embedding_of_embedding_closed ⟨⟨_⟩, h₂⟩ h₃,
  apply le_antisymm (continuous_iff_le_induced.mp h₁) _,
  intro s',
  change is_open _ ≤ is_open _,
  rw [←is_closed_compl_iff, ←is_closed_compl_iff],
  generalize : s'ᶜ = s,
  rw is_closed_induced_iff,
  refine λ hs, ⟨f '' s, h₃ s hs, _⟩,
  rw preimage_image_eq _ h₂
end

lemma closed_embedding_id : closed_embedding (@id α) :=
⟨embedding_id, by convert is_closed_univ; apply range_id⟩

lemma closed_embedding.comp {g : β → γ} {f : α → β}
  (hg : closed_embedding g) (hf : closed_embedding f) : closed_embedding (g ∘ f) :=
⟨hg.to_embedding.comp hf.to_embedding, show is_closed (range (g ∘ f)),
 by rw [range_comp, ←hg.closed_iff_image_closed]; exact hf.closed_range⟩

lemma closed_embedding.closure_image_eq {f : α → β} (hf : closed_embedding f) (s : set α) :
  closure (f '' s) = f '' closure s :=
le_antisymm (is_closed_map_iff_closure_image.mp hf.is_closed_map _)
  (image_closure_subset_closure_image hf.continuous)

end closed_embedding


universe u v

theorem eqLitOfSize0 {α : Type u} (a : Array α) (hsz : a.size = 0) : a = #[] :=
a.toArrayLit_eq 0 hsz

theorem eqLitOfSize1 {α : Type u} (a : Array α) (hsz : a.size = 1) : a = #[a.getLit 0 hsz (of_decide_eq_true rfl)] :=
a.toArrayLit_eq 1 hsz

theorem eqLitOfSize2 {α : Type u} (a : Array α) (hsz : a.size = 2) : a = #[a.getLit 0 hsz (of_decide_eq_true rfl), a.getLit 1 hsz (of_decide_eq_true rfl)] :=
a.toArrayLit_eq 2 hsz

theorem eqLitOfSize3 {α : Type u} (a : Array α) (hsz : a.size = 3) :
  a = #[a.getLit 0 hsz (of_decide_eq_true rfl), a.getLit 1 hsz (of_decide_eq_true rfl), a.getLit 2 hsz (of_decide_eq_true rfl)] :=
a.toArrayLit_eq 3 hsz

/-
Matcher for the following patterns
```
| #[]           => _
| #[a₁]         => _
| #[a₁, a₂, a₃] => _
| a             => _
``` -/
def matchArrayLit {α : Type u} (C : Array α → Sort v) (a : Array α)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : C a :=
if h : a.size = 0 then
  @Eq.rec _ _ (fun x _ => C x) (h₁ ()) _ (a.toArrayLit_eq 0 h).symm
else if h : a.size = 1 then
  @Eq.rec _ _ (fun x _ => C x) (h₂ (a.getLit 0 h (of_decide_eq_true rfl))) _ (a.toArrayLit_eq 1 h).symm
else if h : a.size = 3 then
  @Eq.rec _ _ (fun x _ => C x) (h₃ (a.getLit 0 h (of_decide_eq_true rfl)) (a.getLit 1 h (of_decide_eq_true rfl)) (a.getLit 2 h (of_decide_eq_true rfl))) _ (a.toArrayLit_eq 3 h).symm
else
  h₄ a

/- Equational lemmas that should be generated automatically. -/
theorem matchArrayLit.eq1 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : matchArrayLit C #[] h₁ h₂ h₃ h₄ = h₁ () :=
rfl

theorem matchArrayLit.eq2 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ : α)
    : matchArrayLit C #[a₁] h₁ h₂ h₃ h₄ = h₂ a₁ :=
rfl

theorem matchArrayLit.eq3 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ a₂ a₃ : α)
    : matchArrayLit C #[a₁, a₂, a₃] h₁ h₂ h₃ h₄ = h₃ a₁ a₂ a₃ :=
rfl


/-
Copyright (c) 2019 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.category_theory.limits.shapes.terminal
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.limits.shapes.images
import Mathlib.PostPort

universes v u l u_1 v' u'

namespace Mathlib

/-!
# Zero morphisms and zero objects

A category "has zero morphisms" if there is a designated "zero morphism" in each morphism space,
and compositions of zero morphisms with anything give the zero morphism. (Notice this is extra
structure, not merely a property.)

A category "has a zero object" if it has an object which is both initial and terminal. Having a
zero object provides zero morphisms, as the unique morphisms factoring through the zero object.

## References

* https://en.wikipedia.org/wiki/Zero_morphism
* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
-/

namespace category_theory.limits

/-- A category "has zero morphisms" if there is a designated "zero morphism" in each morphism space,
and compositions of zero morphisms with anything give the zero morphism. -/
class has_zero_morphisms (C : Type u) [category C]
where
  has_zero : (X Y : C) → HasZero (X ⟶ Y)
  comp_zero' : autoParam (∀ {X Y : C} (f : X ⟶ Y), C → f ≫ 0 = 0)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  zero_comp' : autoParam (C → ∀ {Y Z : C} (f : Y ⟶ Z), 0 ≫ f = 0)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

theorem has_zero_morphisms.comp_zero {C : Type u} [category C] [c : has_zero_morphisms C] {X : C} {Y : C} (f : X ⟶ Y) (Z : C) : f ≫ 0 = 0 := sorry

theorem has_zero_morphisms.zero_comp {C : Type u} [category C] [c : has_zero_morphisms C] (X : C) {Y : C} {Z : C} (f : Y ⟶ Z) : 0 ≫ f = 0 := sorry

@[simp] theorem comp_zero {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {f : X ⟶ Y} {Z : C} : f ≫ 0 = 0 :=
  has_zero_morphisms.comp_zero f Z

@[simp] theorem zero_comp {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {Z : C} {f : Y ⟶ Z} : 0 ≫ f = 0 :=
  has_zero_morphisms.zero_comp X f

protected instance has_zero_morphisms_pempty : has_zero_morphisms (discrete pempty) :=
  has_zero_morphisms.mk

protected instance has_zero_morphisms_punit : has_zero_morphisms (discrete PUnit) :=
  has_zero_morphisms.mk

namespace has_zero_morphisms

/-- This lemma will be immediately superseded by `ext`, below. -/
/--
If you're tempted to use this lemma "in the wild", you should probably
carefully consider whether you've made a mistake in allowing two
instances of `has_zero_morphisms` to exist at all.

See, particularly, the note on `zero_morphisms_of_zero_object` below.
-/
theorem ext {C : Type u} [category C] (I : has_zero_morphisms C) (J : has_zero_morphisms C) : I = J := sorry

protected instance subsingleton {C : Type u} [category C] : subsingleton (has_zero_morphisms C) :=
  subsingleton.intro ext

end has_zero_morphisms

theorem zero_of_comp_mono {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} (g : Y ⟶ Z) [mono g] (h : f ≫ g = 0) : f = 0 :=
  eq.mp (Eq._oldrec (Eq.refl (f ≫ g = 0 ≫ g)) (propext (cancel_mono g)))
    (eq.mp (Eq._oldrec (Eq.refl (f ≫ g = 0)) (Eq.symm zero_comp)) h)

theorem zero_of_epi_comp {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y) {g : Y ⟶ Z} [epi f] (h : f ≫ g = 0) : g = 0 :=
  eq.mp (Eq._oldrec (Eq.refl (f ≫ g = f ≫ 0)) (propext (cancel_epi f)))
    (eq.mp (Eq._oldrec (Eq.refl (f ≫ g = 0)) (Eq.symm comp_zero)) h)

theorem eq_zero_of_image_eq_zero {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f] (w : image.ι f = 0) : f = 0 := sorry

theorem nonzero_image_of_nonzero {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {f : X ⟶ Y} [has_image f] (w : f ≠ 0) : image.ι f ≠ 0 :=
  fun (h : image.ι f = 0) => w (eq_zero_of_image_eq_zero h)

theorem equivalence_preserves_zero_morphisms {C : Type u} [category C] (D : Type u') [category D] [has_zero_morphisms C] [has_zero_morphisms D] (F : C ≌ D) (X : C) (Y : C) : functor.map (equivalence.functor F) 0 = 0 := sorry

@[simp] theorem is_equivalence_preserves_zero_morphisms {C : Type u} [category C] (D : Type u') [category D] [has_zero_morphisms C] [has_zero_morphisms D] (F : C ⥤ D) [is_equivalence F] (X : C) (Y : C) : functor.map F 0 = 0 := sorry

/-- A category "has a zero object" if it has an object which is both initial and terminal. -/
class has_zero_object (C : Type u) [category C]
where
  zero : C
  unique_to : (X : C) → unique (zero ⟶ X)
  unique_from : (X : C) → unique (X ⟶ zero)

protected instance has_zero_object_punit : has_zero_object (discrete PUnit) :=
  has_zero_object.mk PUnit.unit (fun (X : discrete PUnit) => punit.cases_on X (unique.mk sorry sorry))
    fun (X : discrete PUnit) => punit.cases_on X (unique.mk sorry sorry)

namespace has_zero_object

/--
Construct a `has_zero C` for a category with a zero object.
This can not be a global instance as it will trigger for every `has_zero C` typeclass search.
-/
protected def has_zero {C : Type u} [category C] [has_zero_object C] : HasZero C :=
  { zero := zero }

theorem to_zero_ext {C : Type u} [category C] [has_zero_object C] {X : C} (f : X ⟶ 0) (g : X ⟶ 0) : f = g :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f = g)) (unique.uniq (unique_from X) f)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inhabited.default = g)) (unique.uniq (unique_from X) g)))
      (Eq.refl Inhabited.default))

theorem from_zero_ext {C : Type u} [category C] [has_zero_object C] {X : C} (f : 0 ⟶ X) (g : 0 ⟶ X) : f = g :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f = g)) (unique.uniq (unique_to X) f)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inhabited.default = g)) (unique.uniq (unique_to X) g))) (Eq.refl Inhabited.default))

protected instance category_theory.iso.subsingleton {C : Type u} [category C] [has_zero_object C] (X : C) : subsingleton (X ≅ 0) :=
  subsingleton.intro fun (a b : X ≅ 0) => iso.ext (of_as_true trivial)

protected instance category_theory.mono {C : Type u} [category C] [has_zero_object C] {X : C} (f : 0 ⟶ X) : mono f :=
  mono.mk fun (Z : C) (g h : Z ⟶ 0) (w : g ≫ f = h ≫ f) => to_zero_ext g h

protected instance category_theory.epi {C : Type u} [category C] [has_zero_object C] {X : C} (f : X ⟶ 0) : epi f :=
  epi.mk fun (Z : C) (g h : 0 ⟶ Z) (w : f ≫ g = f ≫ h) => from_zero_ext g h

/-- A category with a zero object has zero morphisms.

    It is rarely a good idea to use this. Many categories that have a zero object have zero
    morphisms for some other reason, for example from additivity. Library code that uses
    `zero_morphisms_of_zero_object` will then be incompatible with these categories because
    the `has_zero_morphisms` instances will not be definitionally equal. For this reason library
    code should generally ask for an instance of `has_zero_morphisms` separately, even if it already
    asks for an instance of `has_zero_objects`. -/
def zero_morphisms_of_zero_object {C : Type u} [category C] [has_zero_object C] : has_zero_morphisms C :=
  has_zero_morphisms.mk

/-- A zero object is in particular initial. -/
theorem has_initial {C : Type u} [category C] [has_zero_object C] : has_initial C :=
  has_initial_of_unique 0

/-- A zero object is in particular terminal. -/
theorem has_terminal {C : Type u} [category C] [has_zero_object C] : has_terminal C :=
  has_terminal_of_unique 0

end has_zero_object

@[simp] theorem id_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] : 𝟙 = 0 :=
  has_zero_object.from_zero_ext 𝟙 0

/--  An arrow ending in the zero object is zero -/
-- This can't be a `simp` lemma because the left hand side would be a metavariable.

theorem zero_of_to_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} (f : X ⟶ 0) : f = 0 :=
  has_zero_object.to_zero_ext f 0

theorem zero_of_target_iso_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} {Y : C} (f : X ⟶ Y) (i : Y ≅ 0) : f = 0 := sorry

/-- An arrow starting at the zero object is zero -/
theorem zero_of_from_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} (f : 0 ⟶ X) : f = 0 :=
  has_zero_object.from_zero_ext f 0

theorem zero_of_source_iso_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} {Y : C} (f : X ⟶ Y) (i : X ≅ 0) : f = 0 := sorry

theorem mono_of_source_iso_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} {Y : C} (f : X ⟶ Y) (i : X ≅ 0) : mono f := sorry

theorem epi_of_target_iso_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] {X : C} {Y : C} (f : X ⟶ Y) (i : Y ≅ 0) : epi f := sorry

/--
An object `X` has `𝟙 X = 0` if and only if it is isomorphic to the zero object.

Because `X ≅ 0` contains data (even if a subsingleton), we express this `↔` as an `≃`.
-/
def id_zero_equiv_iso_zero {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] (X : C) : 𝟙 = 0 ≃ (X ≅ 0) :=
  equiv.mk (fun (h : 𝟙 = 0) => iso.mk 0 0) sorry sorry sorry

@[simp] theorem id_zero_equiv_iso_zero_apply_hom {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] (X : C) (h : 𝟙 = 0) : iso.hom (coe_fn (id_zero_equiv_iso_zero X) h) = 0 :=
  rfl

@[simp] theorem id_zero_equiv_iso_zero_apply_inv {C : Type u} [category C] [has_zero_object C] [has_zero_morphisms C] (X : C) (h : 𝟙 = 0) : iso.inv (coe_fn (id_zero_equiv_iso_zero X) h) = 0 :=
  rfl

/--
A zero morphism `0 : X ⟶ Y` is an isomorphism if and only if
the identities on both `X` and `Y` are zero.
-/
def is_iso_zero_equiv {C : Type u} [category C] [has_zero_morphisms C] (X : C) (Y : C) : is_iso 0 ≃ 𝟙 = 0 ∧ 𝟙 = 0 :=
  equiv.mk sorry (fun (h : 𝟙 = 0 ∧ 𝟙 = 0) => is_iso.mk 0) sorry sorry

/--
A zero morphism `0 : X ⟶ X` is an isomorphism if and only if
the identity on `X` is zero.
-/
def is_iso_zero_self_equiv {C : Type u} [category C] [has_zero_morphisms C] (X : C) : is_iso 0 ≃ 𝟙 = 0 :=
  eq.mpr sorry (eq.mp sorry (is_iso_zero_equiv X X))

/--
A zero morphism `0 : X ⟶ Y` is an isomorphism if and only if
`X` and `Y` are isomorphic to the zero object.
-/
def is_iso_zero_equiv_iso_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] (X : C) (Y : C) : is_iso 0 ≃ (X ≅ 0) × (Y ≅ 0) :=
  equiv.trans (is_iso_zero_equiv X Y)
    (equiv.symm
      (equiv.mk sorry
        (fun (ᾰ : 𝟙 = 0 ∧ 𝟙 = 0) =>
          and.dcases_on ᾰ
            fun (hX : 𝟙 = 0) (hY : 𝟙 = 0) => (coe_fn (id_zero_equiv_iso_zero X) hX, coe_fn (id_zero_equiv_iso_zero Y) hY))
        sorry sorry))

/--
A zero morphism `0 : X ⟶ X` is an isomorphism if and only if
`X` is isomorphic to the zero object.
-/
def is_iso_zero_self_equiv_iso_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] (X : C) : is_iso 0 ≃ (X ≅ 0) :=
  equiv.trans (is_iso_zero_equiv_iso_zero X X) subsingleton_prod_self_equiv

/-- If there are zero morphisms, any initial object is a zero object. -/
protected instance has_zero_object_of_has_initial_object {C : Type u} [category C] [has_zero_morphisms C] [has_initial C] : has_zero_object C :=
  has_zero_object.mk (⊥_C) (fun (X : C) => unique.mk { default := 0 } sorry)
    fun (X : C) => unique.mk { default := 0 } sorry

/-- If there are zero morphisms, any terminal object is a zero object. -/
protected instance has_zero_object_of_has_terminal_object {C : Type u} [category C] [has_zero_morphisms C] [has_terminal C] : has_zero_object C :=
  has_zero_object.mk (⊤_C) (fun (X : C) => unique.mk { default := 0 } sorry)
    fun (X : C) => unique.mk { default := 0 } sorry

theorem image_ι_comp_eq_zero {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} [has_image f] [epi (factor_thru_image f)] (h : f ≫ g = 0) : image.ι f ≫ g = 0 := sorry

/--
The zero morphism has a `mono_factorisation` through the zero object.
-/
@[simp] theorem mono_factorisation_zero_e {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] (X : C) (Y : C) : mono_factorisation.e (mono_factorisation_zero X Y) = 0 :=
  Eq.refl (mono_factorisation.e (mono_factorisation_zero X Y))

/--
The factorisation through the zero object is an image factorisation.
-/
def image_factorisation_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] (X : C) (Y : C) : image_factorisation 0 :=
  image_factorisation.mk (mono_factorisation_zero X Y) (is_image.mk fun (F' : mono_factorisation 0) => 0)

protected instance has_image_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] {X : C} {Y : C} : has_image 0 :=
  has_image.mk (image_factorisation_zero X Y)

/-- The image of a zero morphism is the zero object. -/
def image_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] {X : C} {Y : C} : image 0 ≅ 0 :=
  is_image.iso_ext (image.is_image 0) (image_factorisation.is_image (image_factorisation_zero X Y))

/-- The image of a morphism which is equal to zero is the zero object. -/
def image_zero' {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] {X : C} {Y : C} {f : X ⟶ Y} (h : f = 0) [has_image f] : image f ≅ 0 :=
  image.eq_to_iso h ≪≫ image_zero

@[simp] theorem image.ι_zero {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] {X : C} {Y : C} [has_image 0] : image.ι 0 = 0 := sorry

/--
If we know `f = 0`,
it requires a little work to conclude `image.ι f = 0`,
because `f = g` only implies `image f ≅ image g`.
-/
@[simp] theorem image.ι_zero' {C : Type u} [category C] [has_zero_morphisms C] [has_zero_object C] [has_equalizers C] {X : C} {Y : C} {f : X ⟶ Y} (h : f = 0) [has_image f] : image.ι f = 0 := sorry

/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
protected instance split_mono_sigma_ι {C : Type u} [category C] {β : Type v} [DecidableEq β] [has_zero_morphisms C] (f : β → C) [has_colimit (discrete.functor f)] (b : β) : split_mono (sigma.ι f b) :=
  split_mono.mk
    (sigma.desc fun (b' : β) => dite (b' = b) (fun (h : b' = b) => eq_to_hom (congr_arg f h)) fun (h : ¬b' = b) => 0)

/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
protected instance split_epi_pi_π {C : Type u} [category C] {β : Type v} [DecidableEq β] [has_zero_morphisms C] (f : β → C) [has_limit (discrete.functor f)] (b : β) : split_epi (pi.π f b) :=
  split_epi.mk
    (pi.lift fun (b' : β) => dite (b = b') (fun (h : b = b') => eq_to_hom (congr_arg f h)) fun (h : ¬b = b') => 0)

/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
protected instance split_mono_coprod_inl {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} [has_colimit (pair X Y)] : split_mono coprod.inl :=
  split_mono.mk (coprod.desc 𝟙 0)

/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
protected instance split_mono_coprod_inr {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} [has_colimit (pair X Y)] : split_mono coprod.inr :=
  split_mono.mk (coprod.desc 0 𝟙)

/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
protected instance split_epi_prod_fst {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} [has_limit (pair X Y)] : split_epi prod.fst :=
  split_epi.mk (prod.lift 𝟙 0)

/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
protected instance split_epi_prod_snd {C : Type u} [category C] [has_zero_morphisms C] {X : C} {Y : C} [has_limit (pair X Y)] : split_epi prod.snd :=
  split_epi.mk (prod.lift 0 𝟙)


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.bifunctor
import Mathlib.control.traversable.basic
import Mathlib.PostPort

universes u l u_1 l_1

namespace Mathlib

/-!
# Bitraversable type class

Type class for traversing bifunctors. The concepts and laws are taken from
<https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

Simple examples of `bitraversable` are `prod` and `sum`. A more elaborate example is
to define an a-list as:

```
def alist (key val : Type) := list (key × val)
```

Then we can use `f : key → io key'` and `g : val → io val'` to manipulate the `alist`'s key
and value respectively with `bitraverse f g : alist key val → io (alist key' val')`

## Main definitions
  * bitraversable - exposes the `bitraverse` function
  * is_lawful_bitraversable - laws similar to is_lawful_traversable

## Tags

traversable bitraversable iterator functor bifunctor applicative

-/

class bitraversable (t : Type u → Type u → Type u) extends bifunctor t where
  bitraverse :
    {m : Type u → Type u} →
      [_inst_1 : Applicative m] →
        {α α' β β' : Type u} → (α → m α') → (β → m β') → t α β → m (t α' β')

def bisequence {t : Type u_1 → Type u_1 → Type u_1} {m : Type u_1 → Type u_1} [bitraversable t]
    [Applicative m] {α : Type u_1} {β : Type u_1} : t (m α) (m β) → m (t α β) :=
  bitraverse id id

class is_lawful_bitraversable (t : Type u → Type u → Type u) [bitraversable t]
    extends is_lawful_bifunctor t where
  id_bitraverse : ∀ {α β : Type u} (x : t α β), bitraverse id.mk id.mk x = id.mk x
  comp_bitraverse :
    ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G]
      [_inst_3 : is_lawful_applicative F] [_inst_4 : is_lawful_applicative G]
      {α α' β β' γ γ' : Type u} (f : β → F γ) (f' : β' → F γ') (g : α → G β) (g' : α' → G β')
      (x : t α α'),
      bitraverse (functor.comp.mk ∘ Functor.map f ∘ g) (functor.comp.mk ∘ Functor.map f' ∘ g') x =
        functor.comp.mk (bitraverse f f' <$> bitraverse g g' x)
  bitraverse_eq_bimap_id :
    ∀ {α α' β β' : Type u} (f : α → β) (f' : α' → β') (x : t α α'),
      bitraverse (id.mk ∘ f) (id.mk ∘ f') x = id.mk (bimap f f' x)
  binaturality :
    ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G]
      [_inst_3 : is_lawful_applicative F] [_inst_4 : is_lawful_applicative G]
      (η : applicative_transformation F G) {α α' β β' : Type u} (f : α → F β) (f' : α' → F β')
      (x : t α α'),
      coe_fn η (t β β') (bitraverse f f' x) = bitraverse (coe_fn η β ∘ f) (coe_fn η β' ∘ f') x

theorem is_lawful_bitraversable.bitraverse_id_id {t : Type l_1 → Type l_1 → Type l_1}
    [bitraversable t] [c : is_lawful_bitraversable t] {α : Type l_1} {β : Type l_1} :
    bitraverse id.mk id.mk = id.mk :=
  funext fun (x : t α β) => id_bitraverse x

theorem is_lawful_bitraversable.bitraverse_comp {t : Type l_1 → Type l_1 → Type l_1}
    [bitraversable t] [c : is_lawful_bitraversable t] {F : Type l_1 → Type l_1}
    {G : Type l_1 → Type l_1} :
    ∀ [_inst_1_1 : Applicative F] [_inst_2 : Applicative G] [_inst_3 : is_lawful_applicative F]
        [_inst_4 : is_lawful_applicative G] {α α' β β' γ γ' : Type l_1} (f : β → F γ)
        (f' : β' → F γ') (g : α → G β) (g' : α' → G β'),
        bitraverse (functor.comp.mk ∘ Functor.map f ∘ g) (functor.comp.mk ∘ Functor.map f' ∘ g') =
          functor.comp.mk ∘ Functor.map (bitraverse f f') ∘ bitraverse g g' :=
  fun (_inst_1_1 : Applicative F) (_inst_2 : Applicative G) (_inst_3 : is_lawful_applicative F)
    (_inst_4 : is_lawful_applicative G) (α α' β β' γ γ' : Type l_1) (f : β → F γ) (f' : β' → F γ')
    (g : α → G β) (g' : α' → G β') => funext fun (x : t α α') => comp_bitraverse f f' g g' x

theorem is_lawful_bitraversable.bitraverse_eq_bimap_id' {t : Type l_1 → Type l_1 → Type l_1}
    [bitraversable t] [c : is_lawful_bitraversable t] {α : Type l_1} {α' : Type l_1} {β : Type l_1}
    {β' : Type l_1} (f : α → β) (f' : α' → β') :
    bitraverse (id.mk ∘ f) (id.mk ∘ f') = id.mk ∘ bimap f f' :=
  funext fun (x : t α α') => bitraverse_eq_bimap_id f f' x

end Mathlib


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.algebra.tower

/-!

# The `restrict_scalars` type alias

See the documentation attached to the `restrict_scalars` definition for advice on how and when to
use this type alias. As described there, it is often a better choice to use the `is_scalar_tower`
typeclass instead.

## Main definitions

* `restrict_scalars R S M`: the `S`-module `M` viewed as an `R` module when `S` is an `R`-algebra.
  Note that by default we do *not* have a `module S (restrict_scalars R S M)` instance
  for the original action.
  This is available as a def `restrict_scalars.module_orig` if really needed.
* `restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M`: the additive equivalence
  between the restricted and original space (in fact, they are definitionally equal,
  but sometimes it is helpful to avoid using this fact, to keep instances from leaking).
* `restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A`: the ring equivalence
   between the restricted and original space when the module is an algebra.

## See also

There are many similarly-named definitions elsewhere which do not refer to this type alias. These
refer to restricting the scalar type in a bundled type, such as from `A →ₗ[R] B` to `A →ₗ[S] B`:

* `linear_map.restrict_scalars`
* `linear_equiv.restrict_scalars`
* `alg_hom.restrict_scalars`
* `alg_equiv.restrict_scalars`
* `submodule.restrict_scalars`
* `subalgebra.restrict_scalars`
-/

variables (R S M A : Type*)

/-- If we put an `R`-algebra structure on a semiring `S`, we get a natural equivalence from the
category of `S`-modules to the category of representations of the algebra `S` (over `R`). The type
synonym `restrict_scalars` is essentially this equivalence.

Warning: use this type synonym judiciously! Consider an example where we want to construct an
`R`-linear map from `M` to `S`, given:
```lean
variables (R S M : Type*)
variables [comm_semiring R] [semiring S] [algebra R S] [add_comm_monoid M] [module S M]
```
With the assumptions above we can't directly state our map as we have no `module R M` structure, but
`restrict_scalars` permits it to be written as:
```lean
-- an `R`-module structure on `M` is provided by `restrict_scalars` which is compatible
example : restrict_scalars R S M →ₗ[R] S := sorry
```
However, it is usually better just to add this extra structure as an argument:
```lean
-- an `R`-module structure on `M` and proof of its compatibility is provided by the user
example [module R M] [is_scalar_tower R S M] : M →ₗ[R] S := sorry
```
The advantage of the second approach is that it defers the duty of providing the missing typeclasses
`[module R M] [is_scalar_tower R S M]`. If some concrete `M` naturally carries these (as is often
the case) then we have avoided `restrict_scalars` entirely. If not, we can pass
`restrict_scalars R S M` later on instead of `M`.

Note that this means we almost always want to state definitions and lemmas in the language of
`is_scalar_tower` rather than `restrict_scalars`.

An example of when one might want to use `restrict_scalars` would be if one has a vector space
over a field of characteristic zero and wishes to make use of the `ℚ`-algebra structure. -/
@[nolint unused_arguments]
def restrict_scalars (R S M : Type*) : Type* := M

instance [I : inhabited M] : inhabited (restrict_scalars R S M) := I

instance [I : add_comm_monoid M] : add_comm_monoid (restrict_scalars R S M) := I

instance [I : add_comm_group M] : add_comm_group (restrict_scalars R S M) := I

section module

section
variables [semiring S] [add_comm_monoid M]

/-- We temporarily install an action of the original ring on `restrict_sclars R S M`. -/
def restrict_scalars.module_orig [I : module S M] :
  module S (restrict_scalars R S M) := I

variables [comm_semiring R] [algebra R S]
section
local attribute [instance] restrict_scalars.module_orig

/--
When `M` is a module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
module structure over `R`.

The preferred way of setting this up is `[module R M] [module S M] [is_scalar_tower R S M]`.
-/
instance [module S M] : module R (restrict_scalars R S M) :=
module.comp_hom M (algebra_map R S)

/--
This instance is only relevant when `restrict_scalars.module_orig` is available as an instance.
-/
instance [module S M] : is_scalar_tower R S (restrict_scalars R S M) :=
⟨λ r S M, by { rw [algebra.smul_def, mul_smul], refl }⟩

end

/--
When `M` is a right-module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
right-module structure over `R`.
The preferred way of setting this up is
`[module Rᵐᵒᵖ M] [module Sᵐᵒᵖ M] [is_scalar_tower Rᵐᵒᵖ Sᵐᵒᵖ M]`.
-/
instance restrict_scalars.op_module [module Sᵐᵒᵖ M] : module Rᵐᵒᵖ (restrict_scalars R S M) :=
begin
  letI : module Sᵐᵒᵖ (restrict_scalars R S M) := ‹module Sᵐᵒᵖ M›,
  exact module.comp_hom M (algebra_map R S).op
end

instance restrict_scalars.is_central_scalar [module S M] [module Sᵐᵒᵖ M] [is_central_scalar S M] :
  is_central_scalar R (restrict_scalars R S M) :=
{ op_smul_eq_smul := λ r x, (op_smul_eq_smul (algebra_map R S r) (_ : M) : _)}

/--
The `R`-algebra homomorphism from the original coefficient algebra `S` to endomorphisms
of `restrict_scalars R S M`.
-/
def restrict_scalars.lsmul [module S M] : S →ₐ[R] module.End R (restrict_scalars R S M) :=
begin
  -- We use `restrict_scalars.module_orig` in the implementation,
  -- but not in the type.
  letI : module S (restrict_scalars R S M) := restrict_scalars.module_orig R S M,
  exact algebra.lsmul R (restrict_scalars R S M),
end

end

variables [add_comm_monoid M]

/-- `restrict_scalars.add_equiv` is the additive equivalence with the original module. -/
@[simps] def restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M :=
add_equiv.refl M

variables [comm_semiring R] [semiring S] [algebra R S] [module S M]

lemma restrict_scalars_smul_def (c : R) (x : restrict_scalars R S M) :
  c • x = ((algebra_map R S c) • x : M) := rfl

@[simp] lemma restrict_scalars.add_equiv_map_smul (t : R) (x : restrict_scalars R S M) :
  restrict_scalars.add_equiv R S M (t • x)
  = (algebra_map R S t) • restrict_scalars.add_equiv R S M x :=
rfl

end module

section algebra

instance [I : semiring A] : semiring (restrict_scalars R S A) := I
instance [I : ring A] : ring (restrict_scalars R S A) := I
instance [I : comm_semiring A] : comm_semiring (restrict_scalars R S A) := I
instance [I : comm_ring A] : comm_ring (restrict_scalars R S A) := I

variables [semiring A]

/-- Tautological ring isomorphism `restrict_scalars R S A ≃+* A`. -/
def restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A := ring_equiv.refl _

variables [comm_semiring S] [algebra S A] [comm_semiring R] [algebra R S]

@[simp] lemma restrict_scalars.ring_equiv_map_smul (r : R) (x : restrict_scalars R S A) :
  restrict_scalars.ring_equiv R S A (r • x)
  = (algebra_map R S r) • restrict_scalars.ring_equiv R S A x :=
rfl

/-- `R ⟶ S` induces `S-Alg ⥤ R-Alg` -/
instance : algebra R (restrict_scalars R S A) :=
{ smul := (•),
  commutes' := λ r x, algebra.commutes _ _,
  smul_def' := λ _ _, algebra.smul_def _ _,
  .. (algebra_map S A).comp (algebra_map R S) }

@[simp] lemma restrict_scalars.ring_equiv_algebra_map (r : R) :
  restrict_scalars.ring_equiv R S A (algebra_map R (restrict_scalars R S A) r) =
    algebra_map S A (algebra_map R S r) :=
rfl

end algebra


import tactic.abel

import topology.algebra.group
import topology.algebra.uniform_ring
import ring_theory.subring

import for_mathlib.topology
import for_mathlib.filter
import for_mathlib.data.set.basic
import algebra.pointwise

/-
open filter function

universe u

class filter_at_one (α : Type u) [group α] :=
(F : filter α)
(one_in : pure 1 ≤ F) -- we could ask instead that Z ≠ ⊥
(mul {} : tendsto (uncurry' ((*) : α → α → α)) (F.prod F) F)
(inv {} : tendsto (λ x: α, x⁻¹) F F)
(conj {} : ∀ x₀ : α, tendsto (λ x: α, x₀*x*x₀⁻¹) F F).

namespace filter_at_one

def topology (α : Type u) [group α] [filter_at_one α] : topological_space α :=
topological_space.mk_of_nhds $ λa, map (λx, a*x) (F α)

local attribute [instance] topology
lemma topological_group (α : Type u) [group α] [filter_at_one α]: topological_group α :=
sorry

end filter_at_one

Using the above setup, we get :

filter_at_one.topological_group :
  ∀ (α : Type u_1) [_inst_1 : group α] [_inst_2 : @filter_at_one α _inst_1],
    @topological_group α (@filter_at_one.topology α _inst_1 _inst_2) _inst_1

So this lemma (which could be then turned into a local instance) is only about the
topology built by `filter_at_one.topology`. It doesn't not say anything about
a group endowed by a random topology that happens to satisfies the axioms of filter_at_one.
-/
universe u
open filter function set topological_space
local infixr ` ×ᶠ `:51 := filter.prod
local prefix 𝓝:100 := nhds

@[to_additive]
lemma topological_monoid.of_comm_of_nice_nhds_one (α : Type u) [comm_monoid α] [topological_space α]
  (hmul : tendsto (uncurry' ((*) : α → α → α)) (𝓝 1 ×ᶠ 𝓝 1) 𝓝 1)
  (hleft : ∀ x₀ : α, 𝓝 x₀ = map (λ x, x₀*x) 𝓝 1) : topological_monoid α :=
{ continuous_mul := begin
    rw continuous_iff_continuous_at,
    rintros ⟨x₀, y₀⟩,
    have key : (λ (p : α × α), x₀ * p.1 * (y₀ * p.2)) =
      ((λ x, x₀*y₀*x) ∘ (uncurry' (*))),
    { ext,
      change x₀ * x.1 * (y₀ * x.2) = x₀ * y₀ * (x.1 *  x.2),
      ac_refl },

    calc map (λ (p : α × α), p.1 * p.2) 𝓝 (x₀, y₀)
        = map (λ (p : α × α), p.1 * p.2) (𝓝 x₀ ×ᶠ 𝓝 y₀)
            : by rw nhds_prod_eq
    ... = map (λ (p : α × α), 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' (*))) ((𝓝 1) ×ᶠ (𝓝 1)) : by rw key
    ... = 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 }

protected meta def prove_conj : tactic unit :=
`[ intro x₀,
   convert continuous_id.continuous_at,
   simpa [mul_comm, inv_mul_cancel_left]]

@[to_additive]
lemma topological_group.of_nice_nhds_one (α : Type u) [group α] [topological_space α]
  (hmul : tendsto (uncurry' ((*) : α → α → α)) ((𝓝 1).prod 𝓝 1) 𝓝 1)
  (hinv : tendsto (λ x : α, x⁻¹) 𝓝 1 𝓝 1)
  (hleft : ∀ x₀ : α, 𝓝 x₀ = map (λ x, x₀*x) 𝓝 1)
  (hconj : ∀ x₀ : α, tendsto (λ x: α, x₀*x*x₀⁻¹) 𝓝 1 𝓝 1 . prove_conj) : topological_group α :=
{ continuous_mul := begin
    rw continuous_iff_continuous_at,
    rintros ⟨x₀, y₀⟩,
    have key : (λ (p : α × α), x₀ * p.1 * (y₀ * p.2)) =
      ((λ x, x₀*y₀*x) ∘ (uncurry' (*)) ∘ ((λ x, y₀⁻¹*x*y₀) ⨯ id)),
      by { ext, simp [uncurry', prod.map', mul_assoc] },
    specialize hconj y₀⁻¹, rw inv_inv at hconj,
    calc map (λ (p : α × α), p.1 * p.2) 𝓝 (x₀, y₀)
        = map (λ (p : α × α), p.1 * p.2) (𝓝 x₀ ×ᶠ 𝓝 y₀)
            : by rw nhds_prod_eq
    ... = map (λ (p : α × α), 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' (*))) ∘ ((λ 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, filter.map_prod_prod, 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 := 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_comm_of_nice_nhds_one (α : Type u) [comm_group α] [topological_space α]
  (hmul : tendsto (uncurry' ((*) : α → α → α)) ((𝓝 1).prod 𝓝 1) 𝓝 1)
  (hinv : tendsto (λ x : α, x⁻¹) 𝓝 1 𝓝 1)
  (hleft : ∀ x₀ : α, 𝓝 x₀ = map (λ x, x₀*x) 𝓝 1) : topological_group α :=
topological_group.of_nice_nhds_one α hmul hinv hleft

open set
local attribute [instance] pointwise_mul pointwise_add

class group_filter_basis (α : Type u) [group α] extends filter_basis α :=
(one : ∀ {U}, U ∈ sets → (1 : α) ∈ U)
(mul : ∀ {U}, U ∈ sets → ∃ V ∈ sets, V * V ⊆ U)
(inv : ∀ {U}, U ∈ sets → ∃ V ∈ sets, V ⊆ (λ x, x⁻¹) ⁻¹' U)
(conj : ∀ x₀, ∀ U ∈ sets, ∃ V ∈ sets, V ⊆ (λ x, x₀*x*x₀⁻¹) ⁻¹' U)

class add_group_filter_basis (α : Type u) [add_group α] extends filter_basis α :=
(zero : ∀ {U}, U ∈ sets → (0 : α) ∈ U)
(add : ∀ {U}, U ∈ sets → ∃ V ∈ sets, V + V ⊆ U)
(neg : ∀ {U}, U ∈ sets → ∃ V ∈ sets, V ⊆ (λ x, -x) ⁻¹' U)
(conj : ∀ x₀, ∀ U ∈ sets, ∃ V ∈ sets, V ⊆ (λ x, x₀+x-x₀) ⁻¹' U)

attribute [to_additive add_group_filter_basis] group_filter_basis
attribute [to_additive] group_filter_basis.one
attribute [to_additive] group_filter_basis.mul
attribute [to_additive] group_filter_basis.inv
attribute [to_additive] group_filter_basis.conj
attribute [to_additive] group_filter_basis.to_filter_basis

/- -- We didn't use class directly because we still want α to be an explicit argument of projections
attribute [class] group_filter_basis
attribute [class] add_group_filter_basis
 -/
instance group_filter_basis.has_mem {α : Type*} [group α] : has_mem (set α) (group_filter_basis α) := ⟨λ s f, s ∈ f.sets⟩
instance add_group_filter_basis.has_mem {α : Type*} [add_group α] : has_mem (set α) (add_group_filter_basis α) := ⟨λ s f, s ∈ f.sets⟩

attribute [to_additive] group_filter_basis.has_mem

namespace group_filter_basis
variables {α : Type*} [group α]

@[to_additive]
lemma prod_subset_self (f : group_filter_basis α) {U : set α} (h : U ∈ f) : U ⊆ U*U :=
λ x x_in, (mul_one x) ▸ mul_mem_pointwise_mul x_in $ group_filter_basis.one h

/-- The neighborhood function of a `group_filter_basis` -/
@[to_additive]
def N (f : group_filter_basis α) : α → filter α :=
λ x, map (λ y, x*y) f.to_filter_basis.filter

@[simp, to_additive]
lemma N_one (f : group_filter_basis α) : f.N 1 = f.to_filter_basis.filter :=
by simpa [N, map_id]

@[to_additive]
lemma mem_N (f : group_filter_basis α) (x : α) (U : set α) :
  U ∈ f.N x ↔ ∃ V ∈ f, (λ y, x*y) '' V ⊆ U :=
by simpa [N, mem_map, filter_basis.mem_filter, image_subset_iff]

@[to_additive]
lemma mem_N_of_mem (f : group_filter_basis α) (x : α) {U : set α} (h : U ∈ f) :
(λ y, x*y) '' U ∈ f.N x :=
by { rw mem_N, use [U, h] }

@[to_additive]
lemma N_is_nice (f : group_filter_basis α) :
  (pure ≤ f.N) ∧
  ∀ {a s}, s ∈ f.N a → ∃ t ∈ f.N a, t ⊆ s ∧ ∀ a' ∈ t, s ∈ f.N a' :=
begin
  split,
  { intros x U U_in,
    rw f.mem_N at U_in,
    rcases U_in with ⟨V, V_in, H⟩,
    simpa using H (mem_image_of_mem _ (group_filter_basis.one V_in)) },
  { intros x U U_in,
    rw f.mem_N at U_in,
    rcases U_in with ⟨V, V_in, H⟩,
    rcases group_filter_basis.mul V_in with ⟨W, W_in, hW⟩,
    use [(λ y, x*y) '' W, image_mem_map (filter_basis.mem_filter_of_mem W_in)],
    split,
    { rw image_subset_iff at H ⊢,
      exact subset.trans (subset.trans (f.prod_subset_self W_in) hW) H},
    { rintros y ⟨t, tW, rfl⟩,
      rw f.mem_N,
      use [W, W_in],
      apply subset.trans _ H, clear H,
      rintros z ⟨w, wW, rfl⟩,
      exact ⟨t*w, hW (mul_mem_pointwise_mul tW wW), by simp [mul_assoc]⟩ } },
end

@[to_additive]
lemma is_top_group {α : Type u} [group α] (basis : group_filter_basis α) [topological_space α]
  (hnhds : ∀ x₀ : α, 𝓝 x₀ = basis.N x₀) : topological_group α :=
begin
  have hnhds1 : 𝓝 1 = basis.to_filter_basis.filter, by rw [hnhds 1, N_one],
  apply topological_group.of_nice_nhds_one,
  { rw [hnhds1, ← basis.to_filter_basis.prod_filter, filter_basis.tendsto_both],
    intros V V_in,
    rcases group_filter_basis.mul V_in with ⟨W, W_in, hW⟩,
    use [set.prod W W, filter_basis.mem_prod_of_mem W_in W_in],
    rwa [pointwise_mul_eq_image, image_subset_iff] at hW },
  { rw [hnhds1, basis.to_filter_basis.tendsto_both],
    exact basis.inv },
  { exact hnhds1.symm ▸ hnhds },
  { intro x₀,
    rw [hnhds1, basis.to_filter_basis.tendsto_both],
    exact  group_filter_basis.conj x₀ }
end

/-- The topological space structure coming a group filter basis. -/
@[to_additive]
def topology {α : Type u} [group α] (basis : group_filter_basis α) : topological_space α :=
topological_space.mk_of_nhds basis.N

/-- The topological space structure coming a group filter basis. Version using tc resolution -/
@[to_additive]
def to_topological_space {α : Type u} [group α] [basis : group_filter_basis α] : topological_space α :=
basis.topology

@[to_additive]
lemma nhds_eq {α : Type u} [group α] (basis : group_filter_basis α)
  [t : topological_space α] (h : t = basis.topology) {x₀ : α} :
  𝓝 x₀ = basis.N x₀ :=
by rw [h, nhds_mk_of_nhds _ x₀ basis.N_is_nice.1 basis.N_is_nice.2]

@[to_additive]
lemma nhds_one_eq {α : Type u} [group α] (basis : group_filter_basis α)
  [t : topological_space α] (h : t = basis.topology) :
  𝓝 (1 : α) = basis.to_filter_basis.filter :=
by { rw basis.nhds_eq h, simp only [N, one_mul], exact map_id }

@[to_additive]
lemma mem_nhds {α : Type u} [group α] (basis : group_filter_basis α)
  [t : topological_space α] (h : t = basis.topology) {x₀ : α} {U : set α} :
  U ∈ 𝓝 x₀ ↔ ∃ V ∈ basis, V ⊆ (λ x, x₀ * x) ⁻¹' U :=
begin
  rw basis.nhds_eq h,
  exact filter_basis.mem_filter basis.to_filter_basis
end

@[to_additive]
lemma is_topological_group {α : Type u} [group α] (basis : group_filter_basis α)
  [t : topological_space α] (h : t = basis.topology) : topological_group α :=
begin
  apply basis.is_top_group,
  rw h,
  exact λ x, nhds_mk_of_nhds _ x basis.N_is_nice.1 basis.N_is_nice.2
end

/-- The neighborhood basis on a group coming from a group filter basis -/
@[to_additive]
def nhds_basis {α : Type u} [group α] (basis : group_filter_basis α)
  [t : topological_space α] (h : t = basis.topology) : nhds_basis α :=
{ B := λ x₀, filter_basis.map (λ x, x₀*x) basis.to_filter_basis,
  is_nhds := λ x₀, by rw [← filter_basis.map_filter, h,
                          nhds_mk_of_nhds _ x₀ basis.N_is_nice.1 basis.N_is_nice.2, N] }

local attribute [instance] group_filter_basis.to_topological_space

-- The following can be made an instance when needed
@[to_additive]
def to_nhds_basis {α : Type u} [group α] [basis : group_filter_basis α]
   : _root_.nhds_basis α := basis.nhds_basis rfl

local attribute [instance] group_filter_basis.to_nhds_basis add_group_filter_basis.to_nhds_basis

@[to_additive]
lemma mem_nhds_basis {α : Type u} [group α] [basis : group_filter_basis α] {s : set α} {x₀ : α} :
s ∈ nhds_basis.B x₀ ↔ (λ x, x₀*x) ⁻¹' s ∈ basis.to_filter_basis.sets :=
begin
  change s ∈ filter_basis.map (λ x, x₀*x) basis.to_filter_basis ↔ _,
  rw filter_basis.mem_map,
  split ; intro h,
  { rcases h with ⟨U, h, rfl⟩,
    rw preimage_image_eq,
    exact h,
    intros x y, simp },
  { use [(λ (x : α), x₀ * x) ⁻¹' s, h],
    rw image_preimage_eq,
    intros y,
    use [x₀⁻¹*y], simp }
end
end group_filter_basis

section
variables {G : Type u} [add_comm_group G]

def add_group_with_zero_nhd.of_open_add_subgroup
  (H : set G) [is_add_subgroup H] (t : topological_space H) (h : @topological_add_group H t _) :
  add_group_with_zero_nhd G :=
{ Z := (nhds (0 : H)).map $ (subtype.val : H → G),
  zero_Z := calc pure ((0 : H) : G) = map subtype.val (pure 0) : (filter.map_pure _ _).symm
                                ... ≤ _ : map_mono (pure_le_nhds _),
  sub_Z :=
  begin
    let δ_G := λ (p : G × G), p.1 - p.2,
    let δ_H := λ (p : H × H), p.1 - p.2,
    let ι : H → G := subtype.val,
    let N := 𝓝 (0 : H),
    let Z := map subtype.val N,
    change map δ_G (filter.prod Z Z) ≤ Z,
    have key₁: map δ_H (𝓝 (0, 0)) ≤ N,
    { rw [show N = nhds (δ_H (0, 0)), by simp [*]],
      exact continuous_sub.tendsto _ },
    have key₂ : δ_G ∘ ι⨯ι = ι ∘ δ_H,
    { ext p,
      change (p.1 : G) - (p.2 : G) = (p.1 - p.2 : G),
      simp [is_add_subgroup.coe_neg, is_add_submonoid.coe_add] },

    calc map δ_G (filter.prod Z Z)
          = map δ_G (map (ι ⨯ ι) $ filter.prod N N) : by rw prod_map_map_eq;refl
      ... = map ι (map δ_H $ filter.prod N N)       : map_comm key₂ _
      ... = map ι (map δ_H $ 𝓝 (0, 0))           : by rw ← nhds_prod_eq
      ... ≤ map ι N : map_mono key₁
  end,
  ..‹add_comm_group G› }

def of_open_add_subgroup {G : Type u} [str : add_comm_group G] (H : set G) [is_add_subgroup H]
  (t : topological_space H) (h : @topological_add_group H t _) : topological_space G :=
@add_group_with_zero_nhd.topological_space G
  (add_group_with_zero_nhd.of_open_add_subgroup H t h)

end

namespace add_group_with_zero_nhd

local attribute [instance] add_group_with_zero_nhd.topological_space
local notation `Z` := add_group_with_zero_nhd.Z

variables {α : Type*}
variables {G : Type*} [add_group_with_zero_nhd G]

lemma nhds_eq_comap (g : G) : nhds g = comap (λ g', g' + -g) (Z G) :=
by rw [← nhds_zero_eq_Z, nhds_translation_add_neg g]
end add_group_with_zero_nhd

namespace topological_group
variables {G : Type*} {H : Type*}
variables [group G] [topological_space G] [topological_group G]
variables [group H] [topological_space H] [topological_group H]
variables (f : G → H) [is_group_hom f]

-- TODO when PR'ing to mathlib, make sure to include _right in the name
-- of this and nhds_translation_mul_inv
@[to_additive]
lemma nhds_translation_mul (g : G) :
  map (λ h, h*g) (nhds 1) = nhds g :=
begin
  rw ← nhds_translation_mul_inv g,
  apply map_eq_comap_of_inverse ; ext ; simp
end

@[to_additive]
lemma nhds_translation_mul_inv_left (g : G) :
  comap (λ h, g⁻¹*h) (nhds 1) = nhds g :=
begin
  refine comap_eq_of_inverse (λ h, g*h) _ _ _,
  { funext x; simp },
  { suffices : tendsto (λ h,g⁻¹*h) (nhds g) (nhds (g⁻¹ * g)), by simpa,
    exact tendsto_const_nhds.mul tendsto_id },
  { suffices : tendsto (λ h, g*h) (nhds 1) (nhds (g*1)), by simpa,
    exact tendsto_const_nhds.mul tendsto_id }
end

@[to_additive]
lemma nhds_translation_mul_left (g : G) :
  map (λ h, g*h) (nhds 1) = nhds g :=
begin
  rw ← nhds_translation_mul_inv_left g,
  apply map_eq_comap_of_inverse ; ext ; simp
end

@[to_additive]
lemma continuous_of_continuous_at_one (h : continuous_at f 1) :
  continuous f :=
begin
  replace h : map f (nhds 1) ≤ nhds 1, by rw ← is_group_hom.map_one f ; exact h,
  rw continuous_iff_continuous_at,
  intro g,
  have key : (f ∘ λ (h : G), g * h) = (λ (h : H), (f g) * h) ∘ f,
    by ext ; simp [is_mul_hom.map_mul f],
  change map f (nhds g) ≤ nhds (f g),
  rw [← nhds_translation_mul_left g, ← nhds_translation_mul_left (f g),
      filter.map_comm key],
  exact map_mono h
end

@[to_additive topological_add_group.tendsto_nhds_iff']
lemma tendsto_nhds_iff {α : Type*} (f : α → H) (F : filter α) (h : H) :
  tendsto f F (nhds h) ↔ ∀ V ∈ nhds (1 : H), {a | f a * h⁻¹ ∈ V} ∈ F :=
let R := λ h', h' * h⁻¹,
    N := nhds (1 : H) in
calc tendsto f F (nhds h) ↔ map f F ≤ (nhds h) : iff.rfl
  ... ↔ map f F ≤ comap R N : by rw nhds_translation_mul_inv
  ... ↔ map R (map f F) ≤ N : map_le_iff_le_comap.symm
  ... ↔ map (λ a, f a * h⁻¹) F ≤ N : by rw filter.map_map

@[to_additive topological_add_group.tendsto_nhds_nhds_iff']
lemma tendsto_nhds_nhds_iff (f : G → H) (g : G) (h : H) :
  tendsto f (nhds g) (nhds h) ↔
  ∀ V ∈ nhds (1 : H), ∃ U ∈ nhds (1 : G), ∀ g', g'*g⁻¹ ∈ U → f g' * h⁻¹ ∈ V :=
by rw [tendsto_nhds_iff f, ← nhds_translation_mul_inv g] ; exact iff.rfl
end topological_group

namespace topological_add_group
-- `to_additive` generates statements using `g + -h` instead of `g-h`, let's fix that

variables {G : Type*} [add_group G] [topological_space G] [topological_add_group G]
variables {H : Type*} [add_group H] [topological_space H] [topological_add_group H]

lemma tendsto_nhds_iff {α : Type*} (f : α → H) (F : filter α) (h : H) :
    tendsto f F (nhds h) ↔ ∀ (V : set H), V ∈ nhds (0 : H) → {a : α | f a - h ∈ V} ∈ F :=
topological_add_group.tendsto_nhds_iff' _ _ _

lemma tendsto_nhds_nhds_iff (f : G → H) (g : G) (h : H) :
  tendsto f (nhds g) (nhds h) ↔
  ∀ V ∈ nhds (0 : H), ∃ U ∈ nhds (0 : G), ∀ g', g' - g ∈ U → f g' - h ∈ V :=
topological_add_group.tendsto_nhds_nhds_iff' _ _ _
end topological_add_group

namespace add_group_with_zero_nhd
variables {α : Type*} [add_group_with_zero_nhd α]
open filter

lemma nhds_eq' (a : α) : nhds a = map (λx, a + x) (Z α) :=
by convert nhds_eq a ; ext ; simp

end add_group_with_zero_nhd

section
open topological_add_group
variables (G : Type u) [add_comm_group G] [topological_space G] [topological_add_group G]

local attribute [instance] topological_add_group.to_uniform_space
local attribute [instance] topological_add_group_is_uniform

lemma topological_add_group.separated_iff_zero_closed : separated G ↔ is_closed ({0} : set G) :=
begin
  unfold separated,
  rw ← closure_eq_iff_is_closed,
  split ; intro h,
  { apply subset.antisymm,
    { intros x x_in,
      have := group_separation_rel x 0,
      rw sub_zero at this,
      rw [← this, h] at x_in,
      change x = 0 at x_in,
      simp [x_in] },
    { exact subset_closure  } },
  { ext p,
    cases p with x y,
    rw [group_separation_rel x, h, mem_singleton_iff, sub_eq_zero_iff_eq],
    refl }
end

lemma topological_add_group.separated_of_zero_sep
  (H : ∀ x : G, x ≠ 0 → ∃ U ∈ nhds (0 : G), x ∉ U) : separated G:=
begin
  rw topological_add_group.separated_iff_zero_closed,
  rw [← is_open_compl_iff, is_open_iff_mem_nhds],
  intros x x_not,
  have : x ≠ 0, from mem_compl_singleton_iff.mp x_not,
  rcases H x this with ⟨U, U_in, xU⟩,
  rw ← nhds_zero_symm G at U_in,
  rcases U_in with ⟨W, W_in, UW⟩,
  rw ← nhds_translation_add_neg_left x,
  use [W, W_in],
  rw subset_compl_comm,
  suffices : -x ∉ W, by simp[this],
  intro h,
  exact xU (UW h)
end

lemma topological_add_group.discrete_iff_open_zero {G : Type*} [add_group G] [topological_space G]
  [topological_add_group G] : discrete_topology G ↔ is_open ({0} : set G) :=
begin
  rw discrete_iff_open_singletons,
  split ; intro h,
  { exact h 0 },
  { intro x,
    convert (continuous_add_right (-x) : continuous (λ y, y - x)) _ h,
    ext z,
    erw [mem_singleton_iff, mem_preimage, mem_singleton_iff, sub_eq_zero_iff_eq] },
end

-- Wedhorn Definition 5.31 page 38
definition is_complete_hausdorff : Prop := is_complete (univ : set G) ∧ is_hausdorff G
end

-- I used to think I would need the next section soon, but I no longer do.
-- I keep it because we'll want some form of this in mathlib at some point
section top_mul_equiv
variables (G : Type*) [group G] [topological_space G] [topological_group G]
variables (H : Type*) [group H] [topological_space H] [topological_group H]

structure top_mul_equiv extends homeomorph G H :=
(hom : is_group_hom to_fun)

infix ` ≃*ₜ `:50 := top_mul_equiv

instance top_mul_equiv.is_group_hom (h : G ≃*ₜ H) : is_group_hom h.to_homeomorph :=
h.hom
end top_mul_equiv

namespace top_mul_equiv
variables (G : Type*) [group G] [topological_space G] [topological_group G]
variables (H : Type*) [group H] [topological_space H] [topological_group H]
variables (K : Type*) [group K] [topological_space K] [topological_group K]

@[refl] def refl : G ≃*ₜ G :=
{ hom := is_group_hom.id,
  continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  ..equiv.refl _}

@[symm] def symm (h : G ≃*ₜ H) : H ≃*ₜ G :=
{ hom := is_group_hom.mk' $ λ n₁ n₂, function.injective_of_left_inverse h.left_inv begin
   rw h.hom.map_mul, unfold equiv.symm, rw [h.right_inv, h.right_inv, h.right_inv], end,
  continuous_to_fun := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  ..h.to_equiv.symm}

@[trans] def trans (h1 : G ≃*ₜ H) (h2 : H ≃*ₜ K) : (G ≃*ₜ K) :=
{ hom := is_group_hom.comp h1.to_homeomorph.to_equiv.to_fun h2.to_homeomorph.to_equiv.to_fun,
  continuous_to_fun := h2.continuous_to_fun.comp h1.continuous_to_fun,
  continuous_inv_fun := h1.continuous_inv_fun.comp h2.continuous_inv_fun,
  ..equiv.trans h1.to_equiv h2.to_equiv }

end top_mul_equiv

-- Next secton will move to topology/basic.lean
section
variables {α : Type*} {β : Type*} [topological_space β]

/-- If a function is constant on some set of a proper filter then it converges along this filter -/
lemma exists_limit_of_ultimately_const {φ : α → β} {f : filter α} (hf : f ≠ ⊥)
{U : set α} (hU : U ∈ f) (h : ∀ x y ∈ U,  φ x = φ y) : ∃ b, tendsto φ f (nhds b) :=
begin
  obtain ⟨x₀, x₀_in⟩ : ∃ x₀, x₀ ∈ U, from nonempty_of_mem_sets hf hU,
  use φ x₀,
  have : U ⊆ φ ⁻¹' {φ x₀},
  { intros x x_in,
    simp [h x x₀ x_in x₀_in] },
  calc
   map φ f ≤ pure (φ x₀) : by { rw [le_pure_iff, mem_map], exact mem_sets_of_superset hU this}
       ... ≤ 𝓝 φ x₀ : pure_le_nhds _
end
end

-- The next section will be used to extend a valuation to the completion of a field (for the
-- valuation induced topology). The group Γ will be the value group, G = K^* and H = \hat{K}^*
-- (units of the completed field). φ will be the valuation restricted to K^*
section
open is_group_hom
variables {G : Type*} [group G] [topological_space G] [topological_group G]
variables {H : Type*} [group H] [topological_space H] [topological_group H]
variables {Γ : Type*} [group Γ] [topological_space Γ] [topological_group Γ] [regular_space Γ]

variables {ι : G → H} [is_group_hom ι] (dι : dense_inducing ι)
variables {φ : G → Γ} [is_group_hom φ]

-- misc missing lemma, nothing to do with extensions of stuff

lemma mul_right_nhds_one {U : set G} (U_in : U ∈ nhds (1 : G)) (g : G) :
  (λ x, x*g) '' U ∈ nhds g :=
begin
  have l : function.left_inverse (λ (x : G), x * g⁻¹) (λ (x : G), x * g), from λ x, by simp,
  have r : function.right_inverse (λ (x : G), x * g⁻¹) (λ (x : G), x * g), from λ x, by simp,
  rw image_eq_preimage_of_inverse l r,
  have : continuous (λ (x : G), x * g⁻¹), from continuous_id.mul continuous_const,
  apply this.tendsto g,
  simpa,
end

lemma continuous_extend_of_open_kernel (op_ker : is_open (ker φ)) : continuous (dι.extend φ) :=
begin
  have : ∃ V, V ∈ nhds (1 : H) ∧ ι ⁻¹' V ⊆ ker φ,
  { have : ker φ ∈ nhds (1 : G),
      from mem_nhds_sets op_ker (is_submonoid.one_mem (ker φ)),
    rw [dι.nhds_eq_comap, mem_comap_sets] at this,
    rcases this with ⟨V, V_in, hV⟩,
    rw map_one ι at V_in,
    use [V, V_in, hV] },
  rcases this with ⟨V, V_in, hV⟩,
  have : ∃ V' ∈ nhds (1 : H), ∀ x y ∈ V', x*y⁻¹ ∈ V,
    from exists_nhds_split_inv V_in,
  rcases this with ⟨V', V'_in, hV'⟩,
  refine dι.continuous_extend _,
  intro h,
  have : ι ⁻¹' ((λ x, x*h) '' V') ∈ comap ι (nhds h),
    from ⟨(λ (x : H), x * h) '' V', mul_right_nhds_one V'_in h, subset.refl _⟩,
  apply exists_limit_of_ultimately_const dι.comap_nhds_ne_bot this, clear this,
  intros x y x_in y_in,
  rw mem_preimage at x_in y_in,
  rcases x_in with ⟨vₓ, vₓ_in, hx⟩,
  rcases y_in with ⟨vy, vy_in, hy⟩,
  change vₓ * h = ι x at hx,
  change vy * h = ι y at hy,
  rw inv_iff_ker φ,
  apply hV,
  rw [mem_preimage, is_mul_hom.map_mul ι, map_inv ι, ← hx, ← hy, mul_assoc, mul_inv_rev, mul_inv_cancel_left],
  simp only [hV', *],
end
end

instance discrete_top_group {G : Type*} [group G] [topological_space G] [discrete_topology G] :
  topological_group G :=
{ continuous_mul := continuous_of_discrete_topology,
  continuous_inv := continuous_of_discrete_topology }

/- section top_group_extend
open is_group_hom
variables {G : Type*} [group G] [topological_space G] [topological_group G]
variables {H : Type*} [group H] [topological_space H] [topological_group H]
variables {L : Type*} [group L] [topological_space L] [topological_group L]
[t2_space L]

variables {ι : G → H} [is_group_hom ι] (de : dense_inducing ι)
variables {φ : G → L} [is_group_hom φ]

lemma topological_group.extend_is_group_hom (hφ : continuous φ) (h : continuous (de.extend φ)) :
  is_group_hom (de.extend φ) :=
sorry
-- TODO: Fix is_closed_property2 in mathlib. It has nothing to do with dense embedding. Need
-- dense_range.prod etc.
/- ⟨begin
  let Φ := de.extend φ,
  let P := λ x y : H, Φ (x*y) = Φ x*Φ y,
  have closed : is_closed { q : H × H | P q.1 q.2 } :=
    have c1 : continuous (λ q : H × H, Φ (q.1 * q.2)), from h.comp continuous_mul',
    have c2 : continuous (λ q : H × H, Φ q.1 * Φ q.2),
      from continuous_mul (h.comp continuous_fst) (h.comp continuous_snd),
  is_closed_eq c1 c2,

  apply is_closed_property2 de closed,
  intros x y,
  dsimp [P, Φ],
  rw ← is_group_hom.map_mul ι,
  repeat { rw dense_embedding.extend_e_eq },
  rw is_group_hom.map_mul φ
end⟩ -/
end top_group_extend
 -/