/-
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, Jeremy Avigad, Yury Kudryashov
-/
import order.filter.cofinite
import order.zorn_atoms

/-!
# Ultrafilters

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

An ultrafilter is a minimal (maximal in the set order) proper filter.
In this file we define

* `ultrafilter.of`: an ultrafilter that is less than or equal to a given filter;
* `ultrafilter`: subtype of ultrafilters;
* `ultrafilter.pure`: `pure x` as an `ultrafiler`;
* `ultrafilter.map`, `ultrafilter.bind`, `ultrafilter.comap` : operations on ultrafilters;
* `hyperfilter`: the ultrafilter extending the cofinite filter.
-/

universes u v
variables {α : Type u} {β : Type v} {γ : Type*}

open set filter function
open_locale classical filter

/-- `filter α` is an atomic type: for every filter there exists an ultrafilter that is less than or
equal to this filter. -/
instance : is_atomic (filter α) :=
is_atomic.of_is_chain_bounded $ λ c hc hne hb,
  ⟨Inf c, (Inf_ne_bot_of_directed' hne (show is_chain (≥) c, from hc.symm).directed_on hb).ne,
    λ x hx, Inf_le hx⟩

/-- An ultrafilter is a minimal (maximal in the set order) proper filter. -/
@[protect_proj]
structure ultrafilter (α : Type*) extends filter α :=
(ne_bot' : ne_bot to_filter)
(le_of_le : ∀ g, filter.ne_bot g → g ≤ to_filter → to_filter ≤ g)

namespace ultrafilter

variables {f g : ultrafilter α} {s t : set α} {p q : α → Prop}

instance : has_coe_t (ultrafilter α) (filter α) := ⟨ultrafilter.to_filter⟩

instance : has_mem (set α) (ultrafilter α) := ⟨λ s f, s ∈ (f : filter α)⟩

lemma unique (f : ultrafilter α) {g : filter α} (h : g ≤ f)
  (hne : ne_bot g . tactic.apply_instance) : g = f :=
le_antisymm h $ f.le_of_le g hne h

instance ne_bot (f : ultrafilter α) : ne_bot (f : filter α) := f.ne_bot'

protected lemma is_atom (f : ultrafilter α) : is_atom (f : filter α) :=
⟨f.ne_bot.ne, λ g hgf, by_contra $ λ hg, hgf.ne $ f.unique hgf.le ⟨hg⟩⟩

@[simp, norm_cast] lemma mem_coe : s ∈ (f : filter α) ↔ s ∈ f := iff.rfl

lemma coe_injective : injective (coe : ultrafilter α → filter α)
| ⟨f, h₁, h₂⟩ ⟨g, h₃, h₄⟩ rfl := by congr

lemma eq_of_le {f g : ultrafilter α} (h : (f : filter α) ≤ g) : f = g :=
coe_injective (g.unique h)

@[simp, norm_cast] lemma coe_le_coe {f g : ultrafilter α} : (f : filter α) ≤ g ↔ f = g :=
⟨λ h, eq_of_le h, λ h, h ▸ le_rfl⟩

@[simp, norm_cast] lemma coe_inj : (f : filter α) = g ↔ f = g := coe_injective.eq_iff

@[ext] lemma ext ⦃f g : ultrafilter α⦄ (h : ∀ s, s ∈ f ↔ s ∈ g) : f = g :=
coe_injective $ filter.ext h

lemma le_of_inf_ne_bot (f : ultrafilter α) {g : filter α} (hg : ne_bot (↑f ⊓ g)) : ↑f ≤ g :=
le_of_inf_eq (f.unique inf_le_left hg)

lemma le_of_inf_ne_bot' (f : ultrafilter α) {g : filter α} (hg : ne_bot (g ⊓ f)) : ↑f ≤ g :=
f.le_of_inf_ne_bot $ by rwa inf_comm

lemma inf_ne_bot_iff {f : ultrafilter α} {g : filter α} : ne_bot (↑f ⊓ g) ↔ ↑f ≤ g :=
⟨le_of_inf_ne_bot f, λ h, (inf_of_le_left h).symm ▸ f.ne_bot⟩

lemma disjoint_iff_not_le {f : ultrafilter α} {g : filter α} : disjoint ↑f g ↔ ¬↑f ≤ g :=
by rw [← inf_ne_bot_iff, ne_bot_iff, ne.def, not_not, disjoint_iff]

@[simp] lemma compl_not_mem_iff : sᶜ ∉ f ↔ s ∈ f :=
⟨λ hsc, le_principal_iff.1 $ f.le_of_inf_ne_bot
  ⟨λ h, hsc $ mem_of_eq_bot$ by rwa compl_compl⟩, compl_not_mem⟩

@[simp] lemma frequently_iff_eventually : (∃ᶠ x in f, p x) ↔ ∀ᶠ x in f, p x :=
compl_not_mem_iff

alias frequently_iff_eventually ↔ _root_.filter.frequently.eventually _

lemma compl_mem_iff_not_mem : sᶜ ∈ f ↔ s ∉ f := by rw [← compl_not_mem_iff, compl_compl]

lemma diff_mem_iff (f : ultrafilter α) : s \ t ∈ f ↔ s ∈ f ∧ t ∉ f :=
inter_mem_iff.trans $ and_congr iff.rfl compl_mem_iff_not_mem

/-- If `sᶜ ∉ f ↔ s ∈ f`, then `f` is an ultrafilter. The other implication is given by
`ultrafilter.compl_not_mem_iff`.  -/
def of_compl_not_mem_iff (f : filter α) (h : ∀ s, sᶜ ∉ f ↔ s ∈ f) : ultrafilter α :=
{ to_filter := f,
  ne_bot' := ⟨λ hf, by simpa [hf] using h⟩,
  le_of_le := λ g hg hgf s hs, (h s).1 $ λ hsc, by exactI compl_not_mem hs (hgf hsc) }

/-- If `f : filter α` is an atom, then it is an ultrafilter. -/
def of_atom (f : filter α) (hf : is_atom f) : ultrafilter α :=
{ to_filter := f,
  ne_bot' := ⟨hf.1⟩,
  le_of_le := λ g hg, (_root_.is_atom_iff.1 hf).2 g hg.ne }

lemma nonempty_of_mem (hs : s ∈ f) : s.nonempty := nonempty_of_mem hs
lemma ne_empty_of_mem (hs : s ∈ f) : s ≠ ∅ := (nonempty_of_mem hs).ne_empty
@[simp] lemma empty_not_mem : ∅ ∉ f := empty_not_mem f

@[simp] lemma le_sup_iff {u : ultrafilter α} {f g : filter α} : ↑u ≤ f ⊔ g ↔ ↑u ≤ f ∨ ↑u ≤ g :=
not_iff_not.1 $ by simp only [← disjoint_iff_not_le, not_or_distrib, disjoint_sup_right]

@[simp] lemma union_mem_iff : s ∪ t ∈ f ↔ s ∈ f ∨ t ∈ f :=
by simp only [← mem_coe, ← le_principal_iff, ← sup_principal, le_sup_iff]

lemma mem_or_compl_mem (f : ultrafilter α) (s : set α) : s ∈ f ∨ sᶜ ∈ f :=
or_iff_not_imp_left.2 compl_mem_iff_not_mem.2

protected lemma em (f : ultrafilter α) (p : α → Prop) :
  (∀ᶠ x in f, p x) ∨ ∀ᶠ x in f, ¬p x :=
f.mem_or_compl_mem {x | p x}

lemma eventually_or : (∀ᶠ x in f, p x ∨ q x) ↔ (∀ᶠ x in f, p x) ∨ ∀ᶠ x in f, q x :=
union_mem_iff

lemma eventually_not : (∀ᶠ x in f, ¬p x) ↔ ¬∀ᶠ x in f, p x := compl_mem_iff_not_mem

lemma eventually_imp : (∀ᶠ x in f, p x → q x) ↔ (∀ᶠ x in f, p x) → ∀ᶠ x in f, q x :=
by simp only [imp_iff_not_or, eventually_or, eventually_not]

lemma finite_sUnion_mem_iff {s : set (set α)} (hs : s.finite) : ⋃₀ s ∈ f ↔ ∃t∈s, t ∈ f :=
finite.induction_on hs (by simp) $ λ a s ha hs his,
  by simp [union_mem_iff, his, or_and_distrib_right, exists_or_distrib]

lemma finite_bUnion_mem_iff {is : set β} {s : β → set α} (his : is.finite) :
  (⋃i∈is, s i) ∈ f ↔ ∃i∈is, s i ∈ f :=
by simp only [← sUnion_image, finite_sUnion_mem_iff (his.image s), bex_image_iff]

/-- Pushforward for ultrafilters. -/
def map (m : α → β) (f : ultrafilter α) : ultrafilter β :=
of_compl_not_mem_iff (map m f) $ λ s, @compl_not_mem_iff _ f (m ⁻¹' s)

@[simp, norm_cast] lemma coe_map (m : α → β) (f : ultrafilter α) :
  (map m f : filter β) = filter.map m ↑f := rfl

@[simp] lemma mem_map {m : α → β} {f : ultrafilter α} {s : set β} :
  s ∈ map m f ↔ m ⁻¹' s ∈ f := iff.rfl

@[simp] lemma map_id (f : ultrafilter α) : f.map id = f := coe_injective map_id
@[simp] lemma map_id' (f : ultrafilter α) : f.map (λ x, x) = f := map_id _

@[simp] lemma map_map (f : ultrafilter α) (m : α → β) (n : β → γ) :
  (f.map m).map n = f.map (n ∘ m) :=
coe_injective map_map

/-- The pullback of an ultrafilter along an injection whose range is large with respect to the given
ultrafilter. -/
def comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) : ultrafilter α :=
{ to_filter := comap m u,
  ne_bot' := u.ne_bot'.comap_of_range_mem large,
  le_of_le := λ g hg hgu, by { resetI,
    simp only [← u.unique (map_le_iff_le_comap.2 hgu), comap_map inj, le_rfl] } }

@[simp] lemma mem_comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) {s : set α} :
  s ∈ u.comap inj large ↔ m '' s ∈ u :=
mem_comap_iff inj large

@[simp, norm_cast] lemma coe_comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) : (u.comap inj large : filter α) = filter.comap m u := rfl

@[simp] lemma comap_id (f : ultrafilter α) (h₀ : injective (id : α → α) := injective_id)
  (h₁ : range id ∈ f := by { rw range_id, exact univ_mem}) :
  f.comap h₀ h₁ = f :=
coe_injective comap_id

@[simp] lemma comap_comap (f : ultrafilter γ) {m : α → β} {n : β → γ} (inj₀ : injective n)
  (large₀ : range n ∈ f) (inj₁ : injective m) (large₁ : range m ∈ f.comap inj₀ large₀)
  (inj₂ : injective (n ∘ m) := inj₀.comp inj₁)
  (large₂ : range (n ∘ m) ∈ f := by { rw range_comp, exact image_mem_of_mem_comap large₀ large₁ }) :
  (f.comap inj₀ large₀).comap inj₁ large₁ = f.comap inj₂ large₂ :=
coe_injective comap_comap

/-- The principal ultrafilter associated to a point `x`. -/
instance : has_pure ultrafilter :=
⟨λ α a, of_compl_not_mem_iff (pure a) $ λ s, by simp⟩

@[simp] lemma mem_pure {a : α} {s : set α} : s ∈ (pure a : ultrafilter α) ↔ a ∈ s := iff.rfl
@[simp] lemma coe_pure (a : α) : ↑(pure a : ultrafilter α) = (pure a : filter α) := rfl
@[simp] lemma map_pure (m : α → β) (a : α) : map m (pure a) = pure (m a) := rfl
@[simp] lemma comap_pure {m : α → β} (a : α) (inj : injective m) (large) :
  comap (pure $ m a) inj large = pure a :=
coe_injective $ comap_pure.trans $
  by rw [coe_pure, ←principal_singleton, ←image_singleton, preimage_image_eq _ inj]

lemma pure_injective : injective (pure : α → ultrafilter α) :=
λ a b h, filter.pure_injective (congr_arg ultrafilter.to_filter h : _)

instance [inhabited α] : inhabited (ultrafilter α) := ⟨pure default⟩
instance [nonempty α] : nonempty (ultrafilter α) := nonempty.map pure infer_instance

lemma eq_pure_of_finite_mem (h : s.finite) (h' : s ∈ f) : ∃ x ∈ s, f = pure x :=
begin
  rw ← bUnion_of_singleton s at h',
  rcases (ultrafilter.finite_bUnion_mem_iff h).mp h' with ⟨a, has, haf⟩,
  exact ⟨a, has, eq_of_le (filter.le_pure_iff.2 haf)⟩
end

lemma eq_pure_of_finite [finite α] (f : ultrafilter α) : ∃ a, f = pure a :=
(eq_pure_of_finite_mem finite_univ univ_mem).imp $ λ a ⟨_, ha⟩, ha

lemma le_cofinite_or_eq_pure (f : ultrafilter α) : (f : filter α) ≤ cofinite ∨ ∃ a, f = pure a :=
or_iff_not_imp_left.2 $ λ h,
  let ⟨s, hs, hfin⟩ := filter.disjoint_cofinite_right.1 (disjoint_iff_not_le.2 h),
      ⟨a, has, hf⟩ := eq_pure_of_finite_mem hfin hs
  in ⟨a, hf⟩

/-- Monadic bind for ultrafilters, coming from the one on filters
defined in terms of map and join.-/
def bind (f : ultrafilter α) (m : α → ultrafilter β) : ultrafilter β :=
of_compl_not_mem_iff (bind ↑f (λ x, ↑(m x))) $ λ s,
  by simp only [mem_bind', mem_coe, ← compl_mem_iff_not_mem, compl_set_of, compl_compl]

instance has_bind : has_bind ultrafilter := ⟨@ultrafilter.bind⟩
instance functor : functor ultrafilter := { map := @ultrafilter.map }
instance monad : monad ultrafilter := { map := @ultrafilter.map }

section

local attribute [instance] filter.monad filter.is_lawful_monad

instance is_lawful_monad : is_lawful_monad ultrafilter :=
{ id_map := assume α f, coe_injective (id_map f.1),
  pure_bind := assume α β a f, coe_injective (pure_bind a (coe ∘ f)),
  bind_assoc := assume α β γ f m₁ m₂, coe_injective (filter_eq rfl),
  bind_pure_comp_eq_map := assume α β f x, coe_injective (bind_pure_comp_eq_map f x.1) }

end

/-- The ultrafilter lemma: Any proper filter is contained in an ultrafilter. -/

alias exists_le ← _root_.filter.exists_ultrafilter_le

/-- Construct an ultrafilter extending a given filter.
  The ultrafilter lemma is the assertion that such a filter exists;
  we use the axiom of choice to pick one. -/
noncomputable def of (f : filter α) [ne_bot f] : ultrafilter α :=
classical.some (exists_le f)

lemma of_le (f : filter α) [ne_bot f] : ↑(of f) ≤ f := classical.some_spec (exists_le f)

lemma of_coe (f : ultrafilter α) : of ↑f = f :=
coe_inj.1 $ f.unique (of_le f)

lemma exists_ultrafilter_of_finite_inter_nonempty (S : set (set α))
  (cond : ∀ T : finset (set α), (↑T : set (set α)) ⊆ S → (⋂₀ (↑T : set (set α))).nonempty) :
  ∃ F : ultrafilter α, S ⊆ F.sets :=
begin
  haveI : ne_bot (generate S) := generate_ne_bot_iff.2
    (λ t hts ht, ht.coe_to_finset ▸ cond ht.to_finset (ht.coe_to_finset.symm ▸ hts)),
  exact ⟨of (generate S), λ t ht, (of_le $ generate S) $ generate_sets.basic ht⟩
end

end ultrafilter

namespace filter
variables {f : filter α} {s : set α} {a : α}

open ultrafilter

lemma is_atom_pure : is_atom (pure a : filter α) := (pure a : ultrafilter α).is_atom

protected lemma ne_bot.le_pure_iff (hf : f.ne_bot) : f ≤ pure a ↔ f = pure a :=
⟨ultrafilter.unique (pure a), le_of_eq⟩

@[simp] lemma lt_pure_iff : f < pure a ↔ f = ⊥ := is_atom_pure.lt_iff

lemma le_pure_iff' : f ≤ pure a ↔ f = ⊥ ∨ f = pure a := is_atom_pure.le_iff

@[simp] lemma Iic_pure (a : α) : Iic (pure a : filter α) = {⊥, pure a} := is_atom_pure.Iic_eq

lemma mem_iff_ultrafilter : s ∈ f ↔ ∀ g : ultrafilter α, ↑g ≤ f → s ∈ g :=
begin
  refine ⟨λ hf g hg, hg hf, λ H, by_contra $ λ hf, _⟩,
  set g : filter ↥sᶜ := comap coe f,
  haveI : ne_bot g := comap_ne_bot_iff_compl_range.2 (by simpa [compl_set_of]),
  simpa using H ((of g).map coe) (map_le_iff_le_comap.mpr (of_le g))
end

lemma le_iff_ultrafilter {f₁ f₂ : filter α} : f₁ ≤ f₂ ↔ ∀ g : ultrafilter α, ↑g ≤ f₁ → ↑g ≤ f₂ :=
⟨λ h g h₁, h₁.trans h, λ h s hs, mem_iff_ultrafilter.2 $ λ g hg, h g hg hs⟩

/-- A filter equals the intersection of all the ultrafilters which contain it. -/
lemma supr_ultrafilter_le_eq (f : filter α) :
  (⨆ (g : ultrafilter α) (hg : ↑g ≤ f), (g : filter α)) = f :=
eq_of_forall_ge_iff $ λ f', by simp only [supr_le_iff, ← le_iff_ultrafilter]

/-- The `tendsto` relation can be checked on ultrafilters. -/
lemma tendsto_iff_ultrafilter (f : α → β) (l₁ : filter α) (l₂ : filter β) :
  tendsto f l₁ l₂ ↔ ∀ g : ultrafilter α, ↑g ≤ l₁ → tendsto f g l₂ :=
by simpa only [tendsto_iff_comap] using le_iff_ultrafilter

lemma exists_ultrafilter_iff {f : filter α} : (∃ (u : ultrafilter α), ↑u ≤ f) ↔ ne_bot f :=
⟨λ ⟨u, uf⟩, ne_bot_of_le uf, λ h, @exists_ultrafilter_le _ _ h⟩

lemma forall_ne_bot_le_iff {g : filter α} {p : filter α → Prop} (hp : monotone p) :
  (∀ f : filter α, ne_bot f → f ≤ g → p f) ↔ ∀ f : ultrafilter α, ↑f ≤ g → p f :=
begin
  refine ⟨λ H f hf, H f f.ne_bot hf, _⟩,
  introsI H f hf hfg,
  exact hp (of_le f) (H _ ((of_le f).trans hfg))
end

section hyperfilter

variables (α) [infinite α]

/-- The ultrafilter extending the cofinite filter. -/
noncomputable def hyperfilter : ultrafilter α := ultrafilter.of cofinite

variable {α}

lemma hyperfilter_le_cofinite : ↑(hyperfilter α) ≤ @cofinite α :=
ultrafilter.of_le cofinite

@[simp] lemma bot_ne_hyperfilter : (⊥ : filter α) ≠ hyperfilter α :=
(by apply_instance : ne_bot ↑(hyperfilter α)).1.symm

theorem nmem_hyperfilter_of_finite {s : set α} (hf : s.finite) : s ∉ hyperfilter α :=
λ hy, compl_not_mem hy $ hyperfilter_le_cofinite hf.compl_mem_cofinite

alias nmem_hyperfilter_of_finite ← _root_.set.finite.nmem_hyperfilter

theorem compl_mem_hyperfilter_of_finite {s : set α} (hf : set.finite s) :
  sᶜ ∈ hyperfilter α :=
compl_mem_iff_not_mem.2 hf.nmem_hyperfilter

alias compl_mem_hyperfilter_of_finite ← _root_.set.finite.compl_mem_hyperfilter

theorem mem_hyperfilter_of_finite_compl {s : set α} (hf : set.finite sᶜ) :
  s ∈ hyperfilter α :=
compl_compl s ▸ hf.compl_mem_hyperfilter

end hyperfilter

end filter

namespace ultrafilter

open filter

variables {m : α → β} {s : set α} {g : ultrafilter β}

lemma comap_inf_principal_ne_bot_of_image_mem (h : m '' s ∈ g) :
  (filter.comap m g ⊓ 𝓟 s).ne_bot :=
filter.comap_inf_principal_ne_bot_of_image_mem g.ne_bot h

/-- Ultrafilter extending the inf of a comapped ultrafilter and a principal ultrafilter. -/
noncomputable def of_comap_inf_principal (h : m '' s ∈ g) : ultrafilter α :=
@of _ (filter.comap m g ⊓ 𝓟 s) (comap_inf_principal_ne_bot_of_image_mem h)

lemma of_comap_inf_principal_mem (h : m '' s ∈ g) : s ∈ of_comap_inf_principal h :=
begin
  let f := filter.comap m g ⊓ 𝓟 s,
  haveI : f.ne_bot := comap_inf_principal_ne_bot_of_image_mem h,
  have : s ∈ f := mem_inf_of_right (mem_principal_self s),
  exact le_def.mp (of_le _) s this
end

lemma of_comap_inf_principal_eq_of_map (h : m '' s ∈ g) :
  (of_comap_inf_principal h).map m = g :=
begin
  let f := filter.comap m g ⊓ 𝓟 s,
  haveI : f.ne_bot := comap_inf_principal_ne_bot_of_image_mem h,
  apply eq_of_le,
  calc filter.map m (of f) ≤ filter.map m f : map_mono (of_le _)
  ... ≤ (filter.map m $ filter.comap m g) ⊓ filter.map m (𝓟 s) : map_inf_le
  ... = (filter.map m $ filter.comap m g) ⊓ (𝓟 $ m '' s) : by rw map_principal
  ... ≤ g ⊓ (𝓟 $ m '' s) : inf_le_inf_right _ map_comap_le
  ... = g : inf_of_le_left (le_principal_iff.mpr h)
end

end ultrafilter


-- Pruebas de ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k
-- =========================================

import tactic

variable (n : ℤ)

-- ----------------------------------------------------
-- Ejercicio. Demostrar que si n es un número entero,
-- entonces
--    ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k
-- ----------------------------------------------------

-- 1ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
begin
  split,
  { intro h,
    intro k,
    intro hk,
    apply h,
    use k,
    exact hk, },
  { intro h1,
    intro h2,
    cases h2 with k hk,
    apply h1 k,
    exact hk, },
end

-- 2ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
begin
  split,
  { intros h k hk,
    exact h ⟨k, hk⟩ },
  { rintros h ⟨k, rfl⟩,
    apply h k,
    refl, },
end

-- 3ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
begin
  split,
  { intros h k hk,
    exact h ⟨k, hk⟩ },
  { rintros h ⟨k, rfl⟩,
    exact h k rfl },
end

-- 4ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
begin
  push_neg,
end

-- 5ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
by push_neg

-- 6ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  ( assume h1 : ¬(∃ k, n = 2*k),
    show ∀ k, n ≠ 2*k, from
      assume k,
      show n ≠ 2*k, from
        assume h2 : n = 2*k,
        have h3 : ∃ k, n = 2*k,
          from exists.intro k h2,
        show false,
          from h1 h3)
  ( assume h1 : ∀ k, n ≠ 2*k,
    show ¬(∃ k, n = 2*k), from
      assume h2 : ∃ k, n = 2*k,
      show false, from
        exists.elim h2
          ( assume k,
            assume hk : n = 2*k,
            have h3 : n ≠ 2*k,
              from h1 k,
            show false,
              from h3 hk))

-- 7ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  ( assume h1 : ¬(∃ k, n = 2*k),
    show ∀ k, n ≠ 2*k, from
      assume k,
      show n ≠ 2*k, from
        assume h2 : n = 2*k,
        have h3 : ∃ k, n = 2*k,
          from exists.intro k h2,
        h1 h3)
  ( assume h1 : ∀ k, n ≠ 2*k,
    show ¬(∃ k, n = 2*k), from
      assume h2 : ∃ k, n = 2*k,
      show false, from
        exists.elim h2
          ( assume k,
            assume hk : n = 2*k,
            have h3 : n ≠ 2*k,
              from h1 k,
            h3 hk))

-- 8ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  ( assume h1 : ¬(∃ k, n = 2*k),
    show ∀ k, n ≠ 2*k, from
      assume k,
      show n ≠ 2*k, from
        assume h2 : n = 2*k,
        h1 (exists.intro k h2))
  ( assume h1 : ∀ k, n ≠ 2*k,
    show ¬(∃ k, n = 2*k), from
      assume h2 : ∃ k, n = 2*k,
      show false, from
        exists.elim h2
          ( assume k,
            assume hk : n = 2*k,
            (h1 k) hk))

-- 9ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  ( assume h1 : ¬(∃ k, n = 2*k),
    show ∀ k, n ≠ 2*k, from
      assume k,
      λ h2, h1 (exists.intro k h2))
  ( assume h1 : ∀ k, n ≠ 2*k,
    show ¬(∃ k, n = 2*k), from
      assume h2 : ∃ k, n = 2*k,
      show false, from
        exists.elim h2
          (λ k hk, (h1 k) hk))

-- 10ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  ( assume h1 : ¬(∃ k, n = 2*k),
    λ k, λ h2, h1 (exists.intro k h2))
  ( assume h1 : ∀ k, n ≠ 2*k,
    show ¬(∃ k, n = 2*k), from
      assume h2 : ∃ k, n = 2*k,
      exists.elim h2 (λ k hk, (h1 k) hk))

-- 11ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
iff.intro
  (λ h1 k h2, h1 (exists.intro k h2))
  (λ h1 h2, exists.elim h2 (λ k hk, (h1 k) hk))

-- 12ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
⟨λ h1 k h2, h1 ⟨k, h2⟩,
 λ h1 h2, exists.elim h2 (λ k hk, (h1 k) hk)⟩

-- 13ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
-- by hint
by simp

-- 14ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
by finish

-- 15ª demostración
example : ¬(∃ k, n = 2*k) ↔ ∀ k, n ≠ 2*k :=
by norm_num


import tactic.noncomm_ring

local notation (name := commutator) `⁅`a`, `b`⁆` := a * b - b * a
local infix (name := op) ` ⚬ `:70 := λ a b, a * b + b * a

variables {R : Type*} [ring R]
variables (a b c : R)

example : 0 = 0 := by noncomm_ring
example : a = a := by noncomm_ring

example : (a + b) * c = a * c + b * c := by noncomm_ring
example : a * (b + c) = a * b + a * c := by noncomm_ring
example : a - b = a + -b := by noncomm_ring
example : a * b * c = a * (b * c) := by noncomm_ring
example : a + a = a * 2 := by noncomm_ring
example : a + a = 2 * a := by noncomm_ring
example : -a = (-1) * a := by noncomm_ring
example : a + a + a = 3 * a := by noncomm_ring
example : a ^ 2 = a * a := by noncomm_ring
example : a ^ 3 = a * a * a := by noncomm_ring
example : (-a) * b = -(a * b) := by noncomm_ring
example : a * (-b) = -(a * b) := by noncomm_ring
example : a * (b + c + b + c - 2*b) = 2*a*c := by noncomm_ring
example : a * (b + c + b + c - (2 : ℕ) • b) = 2*a*c := by noncomm_ring
example : (a + b)^2 = a^2 + a*b + b*a + b^2 := by noncomm_ring
example : (a - b)^2 = a^2 - a*b - b*a + b^2 := by noncomm_ring
example : (a + b)^3 = a^3 + a^2*b + a*b*a + a*b^2 + b*a^2 + b*a*b + b^2*a + b^3 := by noncomm_ring
example : (a - b)^3 = a^3 - a^2*b - a*b*a + a*b^2 - b*a^2 + b*a*b + b^2*a - b^3 := by noncomm_ring

example : ⁅a, a⁆ = 0 := by noncomm_ring
example : ⁅a, b⁆ = -⁅b, a⁆ := by noncomm_ring
example : ⁅a + b, c⁆ = ⁅a, c⁆ + ⁅b, c⁆ := by noncomm_ring
example : ⁅a, b + c⁆ = ⁅a, b⁆ + ⁅a, c⁆ := by noncomm_ring
example : ⁅a, ⁅b, c⁆⁆ + ⁅b, ⁅c, a⁆⁆ + ⁅c, ⁅a, b⁆⁆ = 0 := by noncomm_ring
example : ⁅⁅a, b⁆, c⁆ + ⁅⁅b, c⁆, a⁆ + ⁅⁅c, a⁆, b⁆ = 0 := by noncomm_ring
example : ⁅a, ⁅b, c⁆⁆ = ⁅⁅a, b⁆, c⁆ + ⁅b, ⁅a, c⁆⁆ := by noncomm_ring
example : ⁅⁅a, b⁆, c⁆ = ⁅⁅a, c⁆, b⁆ + ⁅a, ⁅b, c⁆⁆ := by noncomm_ring
example : ⁅a * b, c⁆ = a * ⁅b, c⁆ + ⁅a, c⁆ * b := by noncomm_ring
example : ⁅a, b * c⁆ = ⁅a, b⁆ * c + b * ⁅a, c⁆ := by noncomm_ring
example : ⁅3 * a, a⁆ = 0 := by noncomm_ring
example : ⁅a * -5, a⁆ = 0 := by noncomm_ring
example : ⁅a^3, a⁆ = 0 := by noncomm_ring

example : a ⚬ a = 2*a^2 := by noncomm_ring
example : (2 * a) ⚬ a = 4*a^2 := by noncomm_ring
example : a ⚬ b = b ⚬ a := by noncomm_ring
example : a ⚬ (b + c) = a ⚬ b + a ⚬ c := by noncomm_ring
example : (a + b) ⚬ c = a ⚬ c + b ⚬ c := by noncomm_ring
example : (a ⚬ b) ⚬ (a ⚬ a) = a ⚬ (b ⚬ (a ⚬ a)) := by noncomm_ring

example : ⁅a, b ⚬ c⁆ = ⁅a, b⁆ ⚬ c + b ⚬ ⁅a, c⁆ := by noncomm_ring
example : ⁅a ⚬ b, c⁆ = a ⚬ ⁅b, c⁆ + ⁅a, c⁆ ⚬ b := by noncomm_ring
example : (a ⚬ b) ⚬ c - a ⚬ (b ⚬ c) = -⁅⁅a, b⁆, c⁆ + ⁅a, ⁅b, c⁆⁆ := by noncomm_ring

example : a + -b = -b + a := by noncomm_ring


theorem test (p q : Prop) (hp : p) (hq : q) : p ∧ q ∧ p := by
  apply And.intro hp; exact And.intro hq hp

#check And


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finset.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Finsets of ordered types
-/

theorem directed.finset_le {α : Type u} {r : α → α → Prop} [is_trans α r] {ι : Type u_1}
    [hι : Nonempty ι] {f : ι → α} (D : directed r f) (s : finset ι) :
    ∃ (z : ι), ∀ (i : ι), i ∈ s → r (f i) (f z) :=
  sorry

theorem finset.exists_le {α : Type u} [Nonempty α] [directed_order α] (s : finset α) :
    ∃ (M : α), ∀ (i : α), i ∈ s → i ≤ M :=
  directed.finset_le directed_order.directed s

end Mathlib


example (P Q R : Type) : (P → (Q → R)) → ((P → Q) → (P → R)) :=
begin
intro f,
intro g,
intro h,
exact f(h)(g(h)),
end


import pq_to_group

universes u v

section word_induction

variables {Q : Type u} [power_quandle Q]

def create_list_from_pq : pre_pq_group Q → list Q
| pre_pq_group.unit := []
| (pre_pq_group.incl q) := [q]
| (pre_pq_group.mul a b) := (create_list_from_pq a) ++ (create_list_from_pq b)
| (pre_pq_group.inv a) := (create_list_from_pq a).reverse.map(λ q, q ^ (-1 : ℤ))

lemma create_list_from_pq_eq_id (x : pre_pq_group Q) : ((create_list_from_pq x).map(of)).prod = ⟦x⟧ :=
begin
  induction x,
  {
    unfold create_list_from_pq,
    refl,
  },
  {
    unfold create_list_from_pq,
    simp only [mul_one, list.prod_cons, list.prod_nil, list.map],
    refl,
  },
  {
    unfold create_list_from_pq,
    simp only [list.map_append, list.prod_append],
    rw x_ih_a,
    rw x_ih_b,
    refl,
  },
  {
    unfold create_list_from_pq,
    rw ←inv_def,
    rw ←x_ih,
    clear x_ih,
    induction x_a,
    {
      unfold create_list_from_pq,
      simp only [one_inv, list.prod_nil, list.map, list.reverse_nil],
    },
    {
      unfold create_list_from_pq,
      simp only [mul_one, list.reverse_singleton, list.prod_cons, list.prod_nil, list.map],
      rw of_pow_eq_pow_of,
      simp only [gpow_one, gpow_neg],
    },
    {
      unfold create_list_from_pq,
      simp only [list.map_reverse, mul_inv_rev, list.map_append, list.prod_append, list.reverse_append, list.map_map],
      rw ←x_a_ih_a,
      rw ←x_a_ih_b,
      simp only [list.map_reverse, list.map_map],
    },
    {
      unfold create_list_from_pq,
      simp only [list.map_reverse, list.reverse_reverse, list.map_map],
      have comp_is_id : (λ (q : Q), q ^ (-1 : ℤ)) ∘ (λ (q : Q), q ^ (-1 : ℤ)) = id,
      {
        funext,
        simp only [id.def, function.comp_app],
        rw power_quandle.pow_comp,
        norm_num,
        rw power_quandle.pow_one,
      },
      rw comp_is_id,
      simp only [function.comp.right_id],
      rw ←inv_inj,
      rw ←x_a_ih,
      simp only [list.map_reverse, inv_inv, list.map_map],
    },
  },
end

theorem pq_group_word_induction {P : pq_group Q → Prop}
(h1 : P 1)
(ih : ∀ x : pq_group Q, ∀ y : Q, P x → P (of y * x))
: ∀ x : pq_group Q, P x :=
begin
  intro x,
  induction x,
  {
    rw quot_mk_helper,
    let y := create_list_from_pq x,
    have y_def : y = create_list_from_pq x := rfl,
    have hy := create_list_from_pq_eq_id x,
    rw ←y_def at hy,
    rw ←hy,
    generalize : y = e,
    induction e,
    {
      simp only [list.prod_nil, list.map],
      exact h1,
    },
    {
      simp only [list.prod_cons, list.map],
      apply ih,
      exact e_ih,
    },
  },
  {refl,},
end

theorem pq_group_of_mul_induction {P : pq_group Q → Prop}
(hof : ∀ x : Q,  P (of x))
(hmul : ∀ x y : pq_group Q, P x → P y → P (x * y))
: ∀ x : pq_group Q, P x :=
begin
  refine pq_group_word_induction _ _,
  {
    convert hof 1,
    rw of_one,
  },
  {
    intros x y,
    apply hmul,
    apply hof,
  },
end

theorem pq_group_list {P : pq_group Q → Prop}
(hl : ∀ x : list Q, P (x.map of).prod)
: ∀ x : pq_group Q, P x :=
begin
  intro x,
  induction x,
  {
    rw quot_mk_helper,
    let y := create_list_from_pq x,
    have y_def : y = create_list_from_pq x := rfl,
    have hy := create_list_from_pq_eq_id x,
    rw ←y_def at hy,
    rw ←hy,
    apply hl,
  },
  {refl,},
end

variables {H : Type*}

def pq_group_list_data_pure (f : list Q → H)
(hf : ∀ x y : pre_pq_group Q, setoid.r x y → f (create_list_from_pq x) = f (create_list_from_pq y))
: pq_group Q → H :=
begin
  intro x,
  induction x,
  {
    exact f (create_list_from_pq x),
  },
  {
    simp only [eq_rec_constant],
    apply hf,
    exact x_p,
  },
end

/-

def pq_group_list_data_property (sub_pq : set (pq_group Q)) (f : (set.preimage (λ x : list Q, (list.map (of) x).prod) sub_pq) → H)
(hf : ∀ x y : pre_pq_group Q, ∀ hx : ⟦x⟧ ∈ sub_pq, ∀ hy : ⟦y⟧ ∈ sub_pq, setoid.r x y → f ⟨(create_list_from_pq x), begin
  refine set.mem_preimage.mpr _,
  rw create_list_from_pq_eq_id,
  exact hx,
end⟩ = f ⟨(create_list_from_pq y), begin
  refine set.mem_preimage.mpr _,
  rw create_list_from_pq_eq_id,
  exact hy,
end⟩)
: sub_pq → H :=
begin
  intro x,
  cases x with x hx,
  induction x,
  {
    exact f ⟨(create_list_from_pq x), begin
      refine set.mem_preimage.mpr _,
      rw create_list_from_pq_eq_id,
      exact hx,
    end⟩,
  },
  {
    have hab : ⟦x_a⟧ = ⟦x_b⟧,
    {
      apply quotient.sound,
      exact p,
    },
    funext,
    have hb := x,
    rw quot_mk_helper at hb,
    have ha : ⟦x_a⟧ ∈ sub_pq,
    {
      rw ←hab at hb,
      exact hb,
    },
    specialize hf x_a x_b ha hb p,
    rw ←hf,
    simp_rw hf,
    -- Perhaps we can use eq_rec_constant
    sorry,
  }
end

-/

/-
lemma pq_group_list_data_property_pre_aux (sub_pq : set (pq_group Q)) (x : pre_pq_group Q) (hx : ⟦x⟧ ∈ sub_pq) : (list.map of (create_list_from_pq x)).prod ∈ sub_pq :=
begin
  rw create_list_from_pq_eq_id,
  exact hx,
end

def pq_group_list_data_property_pre (sub_pq : set (pq_group Q)) (f : ∀ x : list Q, (list.map (of) x).prod ∈ sub_pq → H)
(hf : ∀ x y : pre_pq_group Q, ∀ hy : ⟦y⟧ ∈ sub_pq, ∀ hxy : ⟦x⟧ = ⟦y⟧ , f (create_list_from_pq x) (pq_group_list_data_property_pre_aux _ _ begin rw hxy, exact hy end) = f (create_list_from_pq y) (pq_group_list_data_property_pre_aux _ _ hy))
: sub_pq → H :=
begin
  intro x,
  cases x with x hx,
  induction x,
  {
    exact f (create_list_from_pq x) (pq_group_list_data_property_pre_aux _ _ hx),
  },
  {

    have hab : ⟦x_a⟧ = ⟦x_b⟧,
    {
      apply quotient.sound,
      exact p,
    },
    funext,
    have hb := x,
    rw quot_mk_helper at hb,
    have ha : ⟦x_a⟧ ∈ sub_pq,
    {
      rw ←hab at hb,
      exact hb,
    },
    specialize hf x_a x_b hb hab,
    rw ←hf,
    simp_rw hf,

    /-
    rw ←hf,
    have : ∀ h1 h2 : (list.map of (create_list_from_pq x_a)).prod ∈ sub_pq, f (create_list_from_pq x_a) h1 = f (create_list_from_pq x_a) h2,
    {
      intros h1 h2,
      refl,
    },
    simp_rw hf,
    -/

    sorry,
  }
end

-/

end word_induction

section cleaned_induction

variables {Q : Type u} [power_quandle Q]

-- Better to use pq_group_mul_of_induction
theorem pq_group_induction {P : pq_group Q → Prop}
(hof : ∀ q : Q, P (of q))
(hmul : ∀ a b : pq_group Q, P a → P b → P (a * b))
(hinv : ∀ a : pq_group Q, P a → P (a⁻¹))
: ∀ x : pq_group Q, P x :=
begin
  intro x,
  induction x,
  {
    rw quot_mk_helper,
    induction x,
    {
      rw incl_unit_eq_unit,
      convert hof 1,
      rw of_one,
    },
    {
      rw ←of_def,
      apply hof,
    },
    {
      rw ←mul_def,
      apply hmul,
      assumption,
      assumption,
    },
    {
      rw ←inv_def,
      apply hinv,
      assumption,
    },
  },
  {refl,},
end

end cleaned_induction

section morphism_equality

variables {Q : Type u} [power_quandle Q]

variables {G : Type v} [group G]

theorem morphism_equality (f g : pq_group Q →* G) (hfg : ∀ q : Q, f (of q) = g (of q)) : f = g :=
begin
  ext1,
  revert x,
  refine pq_group_word_induction _ _,
  {
    simp only [monoid_hom.map_one],
  },
  {
    intros x y hx,
    simp only [monoid_hom.map_mul, hx, hfg],
  },
end

theorem morphism_equality_elem (f g : pq_group Q →* G) (hfg : ∀ q : Q, f (of q) = g (of q)) (x : pq_group Q) : f x = g x :=
begin
  have me := morphism_equality f g hfg,
  rw me,
end

theorem morphism_equality_elem_id (f : pq_group Q →* pq_group Q) (hf : ∀ q : Q, f (of q) = of q) (x : pq_group Q) : f x = x :=
begin
  have me := morphism_equality_elem f (monoid_hom.id (pq_group Q)) hf x,
  simp only [monoid_hom.id_apply] at me,
  rw me,
end

variables {H : Type*} [group H]

theorem morphism_equality_comp_elem_id (f : pq_group Q →* H) (g : H →* pq_group Q) (hgf : ∀ q : Q, g (f (of q)) = of q) (x : pq_group Q) : g (f x) = x :=
begin
  revert x,
  refine pq_group_word_induction _ _,
  {
    simp only [monoid_hom.map_one],
  },
  {
    intros x y hx,
    simp only [hgf, hx, mul_right_inj, monoid_hom.map_mul],
  },
end

end morphism_equality

section counit_ker_induction

variables {G : Type u} [group G]

def counit_ker_decomp_pre : G → list G → list (G × G)
| y (a :: x) := (y, a) :: counit_ker_decomp_pre (y * a) x
| y [] := []

def counit_ker_decomp : list G → list (G × G) := λ x, counit_ker_decomp_pre 1 (x)

lemma counit_ker_pre_effect (x : list G) (a : G) : counit_ker_decomp_pre a x = (counit_ker_decomp x).map (λ b : (G × G), (a * b.1, b.2)) :=
begin
  induction x generalizing a,
  {
    refl,
  },
  {
    unfold counit_ker_decomp,
    unfold counit_ker_decomp_pre,
    simp only [true_and, mul_one, one_mul, eq_self_iff_true, list.map],
    rw x_ih,
    rw x_ih,
    simp only [list.map_map],
    congr,
    funext,
    simp only [and_true, prod.mk.inj_iff, eq_self_iff_true],
    rw mul_assoc,
  },
end

lemma counit_ker_decomp_append (x y : list G) : counit_ker_decomp (x ++ y) = counit_ker_decomp x ++ counit_ker_decomp_pre (x.prod) y :=
begin
  induction x,
  {
    simp only [list.nil_append, list.prod_nil],
    refl,
  },
  {
    simp only [list.cons_append, list.prod_cons],
    unfold counit_ker_decomp,
    unfold counit_ker_decomp_pre,
    simp only [true_and, one_mul, list.cons_append, eq_self_iff_true],
    rw counit_ker_pre_effect,
    rw counit_ker_pre_effect,
    rw counit_ker_pre_effect,
    rw x_ih,
    rw counit_ker_pre_effect,
    simp only [list.map_append, list.map_map],
    congr,
    funext,
    simp only [and_true, prod.mk.inj_iff, eq_self_iff_true],
    rw mul_assoc,
  },
end

lemma counit_ker_decomp_append_one (x : list G) (a : G) : counit_ker_decomp (x ++ [a]) = counit_ker_decomp x ++ [(x.prod, a)] :=
begin
  rw counit_ker_decomp_append,
  refl,
end

lemma counit_ker_decomp_comp (x : list G) : (x.map of).prod = ((counit_ker_decomp x).map (λ a : G × G, of a.1 * of a.2 * (of (a.1 * a.2))⁻¹)).prod * of (x.prod) :=
begin
  unfold counit_ker_decomp,
  induction x,
  {
    unfold counit_ker_decomp_pre,
    simp only [of_one, mul_one, list.prod_nil, list.map],
  },
  {
    unfold counit_ker_decomp_pre,
    simp only [of_one, one_mul, mul_right_inv, list.prod_cons, list.map],
    rw x_ih,
    clear x_ih,
    induction x_tl generalizing x_hd,
    {
      unfold counit_ker_decomp_pre,
      simp only [of_one, mul_one, one_mul, list.prod_nil, list.map],
    },
    {
      unfold counit_ker_decomp_pre,
      simp only [of_one, one_mul, mul_right_inv, list.prod_cons, list.map],
      have hx2 := x_tl_ih (x_hd * x_tl_hd),
      rw ←mul_assoc x_hd _ _,
      rw mul_assoc,
      rw ←hx2,
      clear hx2,
      rw ←mul_assoc,
      rw ←mul_assoc,
      simp only [inv_mul_cancel_right],
      have hx1 := x_tl_ih (x_tl_hd),
      rw mul_assoc,
      rw ←hx1,
      rw ←mul_assoc,
    },
  },
end

lemma counit_ker_decomp_comp_alt (x : list G) : (x.map of).prod * (of (x.prod))⁻¹ = ((counit_ker_decomp x).map (λ a : G × G, of a.1 * of a.2 * (of (a.1 * a.2))⁻¹)).prod :=
begin
  rw counit_ker_decomp_comp,
  simp only [mul_inv_cancel_right],
end

variables {H : Type*} [group H]

lemma hom_list_prod (x : list G) (f : G →* H) : f x.prod = (x.map f).prod :=
begin
  induction x,
  {
    simp only [list.prod_nil, list.map, monoid_hom.map_one],
  },
  {
    simp only [x_ih, monoid_hom.map_mul, list.prod_cons, list.map],
  },
end

lemma counit_ker_mem_list (x : list G) : (x.map of).prod ∈ (counit : pq_group G →* G).ker ↔ x.prod = 1 :=
begin
  rw counit.mem_ker,
  rw hom_list_prod,
  simp only [list.map_map],
  have : (counit ∘ of : G → G) = id,
  {
    funext,
    simp only [counit_of, id.def, function.comp_app],
  },
  rw this,
  simp only [list.map_id],
end

lemma counit_ker_decomp_comp_in_ker (x : list (G × G)) : ((x).map (λ a : G × G, of a.1 * of a.2 * (of (a.1 * a.2))⁻¹)).prod ∈ (counit : pq_group G →* G).ker :=
begin
  rw counit.mem_ker,
  rw hom_list_prod,
  simp only [list.map_map],
  suffices : counit ∘ (λ (a : G × G), of a.fst * of a.snd * (of (a.fst * a.snd))⁻¹) = λ (a : G × G), (1 : G),
  {
    rw this,
    simp only [list.prod_repeat, one_pow, list.map_const],
  },
  funext,
  simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, function.comp_app, monoid_hom.map_mul_inv],
  group,
end

theorem counit_ker_induction_list {P : (counit : pq_group G →* G).ker → Prop}
(hl : ∀ x : list (G × G), P ⟨(list.map (λ (a : G × G), of a.fst * of a.snd * (of (a.fst * a.snd))⁻¹) (x)).prod, counit_ker_decomp_comp_in_ker x⟩)
: ∀ x : (counit : pq_group G →* G).ker, P x :=
begin
  intro x,
  cases x with x hx,
  revert x,
  refine pq_group_list _,
  {
    intros x hx,
    have hx1 : x.prod = 1,
    {
      rw ←counit_ker_mem_list,
      exact hx,
    },
    have hx2 := counit_ker_decomp_comp x,
    generalize hxy : counit_ker_decomp x = y,
    rw hxy at hx2,
    rw hx1 at hx2,
    simp only [of_one, mul_one] at hx2,
    simp_rw hx2,
    exact hl y,
  },
end

theorem counit_ker_induction {P : (counit : pq_group G →* G).ker → Prop}
(hgen : ∀ a b : G, P ⟨of a * of b * (of (a*b))⁻¹, begin
  refine counit.mem_ker.mpr _,
  simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
  group,
end⟩)
(hmul : ∀ a b : (counit : pq_group G →* G).ker, P a → P b → P (a * b))
: ∀ x : (counit : pq_group G →* G).ker, P x :=
begin
  apply counit_ker_induction_list,
  intro x,
  induction x,
  {
    simp only [list.prod_nil, list.map],
    convert hgen 1 1,
    simp only [of_one, one_inv, mul_one],
  },
  {
    simp only [list.prod_cons, list.map],
    /-
    have alg_decomp : (⟨of x_hd.fst * of x_hd.snd * (of (x_hd.fst * x_hd.snd))⁻¹ * (list.map (λ (a : G × G), of a.fst * of a.snd * (of (a.fst * a.snd))⁻¹) x_tl).prod, _⟩ : (counit : pq_group G →* G).ker) = (⟨of x_hd.fst * of x_hd.snd * (of (x_hd.fst * x_hd.snd))⁻¹, begin
      refine counit.mem_ker.mpr _,
      simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
      group,
    end⟩ * ⟨(list.map (λ (a : G × G), of a.fst * of a.snd * (of (a.fst * a.snd))⁻¹) x_tl).prod, counit_ker_decomp_comp_in_ker x_tl⟩ : (counit : pq_group G →* G).ker) := rfl,
    simp_rw alg_decomp,
    -/
    show P (⟨of x_hd.fst * of x_hd.snd * (of (x_hd.fst * x_hd.snd))⁻¹, begin
      refine counit.mem_ker.mpr _,
      simp only [counit_of, mul_inv_rev, monoid_hom.map_mul, monoid_hom.map_mul_inv],
      group,
    end⟩ * ⟨(list.map (λ (a : G × G), of a.fst * of a.snd * (of (a.fst * a.snd))⁻¹) x_tl).prod, counit_ker_decomp_comp_in_ker x_tl⟩ : (counit : pq_group G →* G).ker),
    apply hmul,
    apply hgen,
    apply x_ih,
  },
end

end counit_ker_induction

/-
section conjugation_induction

variables {Q : Type u} [power_quandle Q]

theorem conjugation_induction {P : pq_group Q → Prop}
(hone : P 1)
(hof : ∀ x : Q, P (of x))
(hrhd : ∀ x y : pq_group Q, P x → P y → P (x ▷ y))
(hpow : ∀ x : pq_group Q, ∀ n : ℤ, P x → P (x ^ n))
: ∀ x : pq_group Q, P x :=
begin
  sorry,
end

end conjugation_induction
-/

/-
def pq_group_word_induction_pre (α : pq_group Q → Sort v)
(h1 : α 1)
(hof : ∀ x : Q, α (of x))
(ih : ∀ x : pq_group Q, ∀ y : Q, α x → α (x * (of y)))
(ihinv : ∀ x : pq_group Q, α x → α (x⁻¹))
: Π x : pre_pq_group Q, α ⟦x⟧
| pre_pq_group.unit := h1
| (pre_pq_group.incl x) := hof x
| (pre_pq_group.inv x) := ihinv ⟦x⟧ (pq_group_word_induction_pre x)
| (pre_pq_group.mul x (pre_pq_group.mul y z)) := begin
  have htype : α ⟦(x.mul y).mul z⟧ = α ⟦x.mul (y.mul z)⟧,
  {
    apply congr_arg,
    apply quotient.sound,
    apply pre_pq_group_rel.rel,
    apply pre_pq_group_rel'.assoc,
  },

  rw ←htype,

  exact pq_group_word_induction_pre ((x.mul y).mul z),
end
| (pre_pq_group.mul x (pre_pq_group.unit)) := begin

end
-/
/-
def linearize_pre_pq_group_tree : pre_pq_group Q → pre_pq_group Q
| (pre_pq_group.unit) := pre_pq_group.unit
| (pre_pq_group.incl q) := pre_pq_group.incl q
| (pre_pq_group.inv pre_pq_group.unit) := pre_pq_group.unit
| (pre_pq_group.inv (pre_pq_group.incl q)) := pre_pq_group.incl (q ^ (-1 : ℤ))
| (pre_pq_group.inv (pre_pq_group.inv x)) := x
| (pre_pq_group.inv (pre_pq_group.mul x y)) := pre_pq_group.mul (linearize_pre_pq_group_tree (pre_pq_group.inv y)) (linearize_pre_pq_group_tree (pre_pq_group.inv x))
| (pre_pq_group.mul x (pre_pq_group.unit)) := linearize_pre_pq_group_tree x
| (pre_pq_group.mul x (pre_pq_group.incl y)) := (linearize_pre_pq_group_tree x).mul (pre_pq_group.incl y)
| (pre_pq_group.mul x (pre_pq_group.mul y z)) := ((linearize_pre_pq_group_tree (x.mul y))).mul (linearize_pre_pq_group_tree z)
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.unit))) := (linearize_pre_pq_group_tree x)
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.incl q))) := (linearize_pre_pq_group_tree x).mul (pre_pq_group.incl (q ^ (-1 : ℤ)))
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.inv y))) := (linearize_pre_pq_group_tree x).mul (linearize_pre_pq_group_tree y)
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.mul y z))) := ((linearize_pre_pq_group_tree x).mul (linearize_pre_pq_group_tree (z.inv))).mul (linearize_pre_pq_group_tree (y.inv))

open pre_pq_group unit

#check string

example : string → string → string := string.append

instance pre_pq_group_has_repr [has_repr Q] : has_repr (pre_pq_group Q) := ⟨begin
  intro x,
  induction x,
  {
    exact "unit",
  },
  {
    exact "incl (" ++ (repr x) ++ ")",
  },
  {
    exact "(" ++ x_ih_a ++ ").mul (" ++ x_ih_b ++ ")",
  },
  {
    exact "(" ++ x_ih ++ ").inv",
  },
end⟩

def ex_val : pre_pq_group (unit) := ((incl star).mul ((incl star).mul ((incl star).mul (incl star))))

#eval linearize_pre_pq_group_tree ex_val

lemma linearized_pres : ∀ (x : pre_pq_group Q), ⟦x⟧ = ⟦linearize_pre_pq_group_tree x⟧
| (pre_pq_group.unit) := rfl
| (pre_pq_group.incl q) := rfl
| (pre_pq_group.inv pre_pq_group.unit) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  simp only [one_inv],
end
| (pre_pq_group.inv (pre_pq_group.incl q)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw of_pow_eq_pow_of,
  simp only [gpow_one, gpow_neg],
end
| (pre_pq_group.inv (pre_pq_group.inv x)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  simp only [inv_inv],
end
| (pre_pq_group.inv (pre_pq_group.mul x y)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres (x.inv),
  rw ←linearized_pres (y.inv),
  simp only [mul_inv_rev],
  refl,
end
| (pre_pq_group.mul x (pre_pq_group.unit)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres (x),
  simp only [mul_one],
end
| (pre_pq_group.mul x (pre_pq_group.incl y)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres x,
end
| (pre_pq_group.mul x (pre_pq_group.mul y z)) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, incl_unit_eq_unit],
  rw ←linearized_pres (x.mul y),
  rw ←linearized_pres z,
  rw ←mul_assoc,
  refl,
end
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.unit))) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres x,
  simp only [one_inv, mul_one],
end
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.incl q))) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres x,
  rw of_pow_eq_pow_of,
  simp only [gpow_one, gpow_neg],
end
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.inv y))) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres x,
  rw ←linearized_pres y,
  simp only [inv_inv],
end
| (pre_pq_group.mul x (pre_pq_group.inv (pre_pq_group.mul y z))) := begin
  unfold linearize_pre_pq_group_tree,
  simp only [←mul_def, ←of_def, ←inv_def, incl_unit_eq_unit],
  rw ←linearized_pres x,
  rw ←linearized_pres z.inv,
  rw ←linearized_pres y.inv,
  simp only [mul_inv_rev, mul_assoc],
  refl,
end

lemma linearized_is_linear_mul : ∀ x : pre_pq_group Q,
 ∃ z : pre_pq_group Q, ∃ q : Q, linearize_pre_pq_group_tree (x) = z.mul (pre_pq_group.incl q) :=

-/


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Constructing equalizers from pullbacks and binary products.

If a category has pullbacks and binary products, then it has equalizers.

TODO: provide the dual result.
-/

namespace category_theory.limits

-- We hide the "implementation details" inside a namespace

namespace has_equalizers_of_pullbacks_and_binary_products

/-- Define the equalizing object -/
def construct_equalizer {C : Type u} [category C] [has_binary_products C] [has_pullbacks C]
    (F : walking_parallel_pair ⥤ C) : C :=
  pullback (prod.lift 𝟙 (functor.map F walking_parallel_pair_hom.left))
    (prod.lift 𝟙 (functor.map F walking_parallel_pair_hom.right))

/-- Define the equalizing morphism -/
def pullback_fst {C : Type u} [category C] [has_binary_products C] [has_pullbacks C]
    (F : walking_parallel_pair ⥤ C) :
    construct_equalizer F ⟶ functor.obj F walking_parallel_pair.zero :=
  pullback.fst

theorem pullback_fst_eq_pullback_snd {C : Type u} [category C] [has_binary_products C]
    [has_pullbacks C] (F : walking_parallel_pair ⥤ C) : pullback_fst F = pullback.snd :=
  sorry

/-- Define the equalizing cone -/
def equalizer_cone {C : Type u} [category C] [has_binary_products C] [has_pullbacks C]
    (F : walking_parallel_pair ⥤ C) : cone F :=
  cone.of_fork (fork.of_ι (pullback_fst F) sorry)

/-- Show the equalizing cone is a limit -/
def equalizer_cone_is_limit {C : Type u} [category C] [has_binary_products C] [has_pullbacks C]
    (F : walking_parallel_pair ⥤ C) : is_limit (equalizer_cone F) :=
  is_limit.mk
    fun (c : cone F) =>
      pullback.lift (nat_trans.app (cone.π c) walking_parallel_pair.zero)
        (nat_trans.app (cone.π c) walking_parallel_pair.zero) sorry

end has_equalizers_of_pullbacks_and_binary_products

/-- Any category with pullbacks and binary products, has equalizers. -/
-- This is not an instance, as it is not always how one wants to construct equalizers!

theorem has_equalizers_of_pullbacks_and_binary_products {C : Type u} [category C]
    [has_binary_products C] [has_pullbacks C] : has_equalizers C :=
  has_limits_of_shape.mk
    fun (F : walking_parallel_pair ⥤ C) => has_limit.mk (limit_cone.mk sorry sorry)

end Mathlib


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang

From: https://github.com/leanprover-community/mathlib/blob/master/src/algebra/graded_algebra/basic.lean
-/
import group_theory.subgroup.basic

import cicm2022.internal.decomposition
import cicm2022.internal.internal
import cicm2022.external.graded_ring
import cicm2022.external.graded_algebra

/-!
# Internally-graded rings and algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_ring 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  `direct_sum.decomposition 𝒜`.
* `graded_algebra 𝒜`: A convenience alias for `graded_ring` when `𝒜` is a family of submodules.
* `direct_sum.decompose_ring_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `direct_sum.decompose_alg_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open_locale direct_sum big_operators

variables {ι R A σ : Type*}
section graded_ring
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ)

include A

open direct_sum

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/
class graded_ring (𝒜 : ι → σ) extends set_like.graded_monoid 𝒜, direct_sum.decomposition 𝒜.

variables [graded_ring 𝒜]
namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
a ring to a direct sum of components. -/
def decompose_ring_equiv : A ≃+* ⨁ i, 𝒜 i := ring_equiv.symm
{ map_mul' := (coe_ring_hom 𝒜).map_mul,
  map_add' := (coe_ring_hom 𝒜).map_add,
  ..(decompose_add_equiv 𝒜).symm }

@[simp] lemma decompose_one : decompose 𝒜 (1 : A) = 1 := map_one (decompose_ring_equiv 𝒜)
@[simp] lemma decompose_symm_one : (decompose 𝒜).symm 1 = (1 : A) :=
map_one (decompose_ring_equiv 𝒜).symm

@[simp] lemma decompose_mul (x y : A) : decompose 𝒜 (x * y) = decompose 𝒜 x * decompose 𝒜 y :=
map_mul (decompose_ring_equiv 𝒜) x y
@[simp] lemma decompose_symm_mul (x y : ⨁ i, 𝒜 i) :
  (decompose 𝒜).symm (x * y) = (decompose 𝒜).symm x * (decompose 𝒜).symm y :=
map_mul (decompose_ring_equiv 𝒜).symm x y

end direct_sum

/-- The projection maps of a graded ring -/
def graded_ring.proj (i : ι) : A →+ A :=
(add_submonoid_class.subtype (𝒜 i)).comp $
  (dfinsupp.eval_add_monoid_hom i).comp $
  ring_hom.to_add_monoid_hom $ ring_equiv.to_ring_hom $ direct_sum.decompose_ring_equiv 𝒜

@[simp] lemma graded_ring.proj_apply (i : ι) (r : A) :
  graded_ring.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_ring.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_ring.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (direct_sum.of _ i (a i)) :=
by rw [graded_ring.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_ring.mem_support_iff [Π i (x : 𝒜 i), decidable (x ≠ 0)] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_ring.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans add_submonoid_class.coe_eq_zero.not.symm

end graded_ring

section graded_algebra
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝒜 : ι → submodule R A)

/-- A special case of `graded_ring` with `σ = submodule R A`. This is useful both because it
can avoid typeclass search, and because it provides a more concise name. -/
@[reducible]
def graded_algebra := graded_ring 𝒜

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def graded_algebra.of_alg_hom [set_like.graded_monoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
  (right_inv : (direct_sum.coe_alg_hom 𝒜).comp decompose = alg_hom.id R A)
  (left_inv : ∀ i (x : 𝒜 i), decompose (x : A) = direct_sum.of (λ i, ↥(𝒜 i)) i x) :
  graded_algebra 𝒜 :=
{ decompose' := decompose,
  left_inv := alg_hom.congr_fun right_inv,
  right_inv := begin
    suffices : decompose.comp (direct_sum.coe_alg_hom 𝒜) = alg_hom.id _ _,
    from alg_hom.congr_fun this,
    ext i x : 2,
    exact (decompose.congr_arg $ direct_sum.coe_alg_hom_of _ _ _).trans (left_inv i x),
  end}

variable [graded_algebra 𝒜]

namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
@[simps]
def decompose_alg_equiv : A ≃ₐ[R] ⨁ i, 𝒜 i := alg_equiv.symm
{ map_mul' := (coe_alg_hom 𝒜).map_mul,
  map_add' := (coe_alg_hom 𝒜).map_add,
  commutes' := (coe_alg_hom 𝒜).commutes,
  ..(decompose_add_equiv 𝒜).symm }

end direct_sum

open direct_sum

/-- The projection maps of graded algebra-/
def graded_algebra.proj (𝒜 : ι → submodule R A) [graded_algebra 𝒜] (i : ι) : A →ₗ[R] A :=
(𝒜 i).subtype.comp $
  (dfinsupp.lapply i).comp $
  (decompose_alg_equiv 𝒜).to_alg_hom.to_linear_map

@[simp] lemma graded_algebra.proj_apply (i : ι) (r : A) :
  graded_algebra.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_algebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_algebra.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (of _ i (a i)) :=
by rw [graded_algebra.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_algebra.mem_support_iff [decidable_eq A] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_algebra.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans submodule.coe_eq_zero.not.symm

end graded_algebra

section canonical_order

open graded_ring set_like.graded_monoid direct_sum

variables [semiring A] [decidable_eq ι]
variables [canonically_ordered_add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]

/--
If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def graded_ring.proj_zero_ring_hom : A →+* A :=
{ to_fun := λ a, decompose 𝒜 a 0,
  map_one' := decompose_of_mem_same 𝒜 one_mem,
  map_zero' := by simp,
  map_add' := λ _ _, by simp,
  map_mul' := λ x y, begin
    -- Convert the abstract add_submonoid into a concrete one. This is necessary as there is no
    -- lattice structure on the abstract ones.
    let 𝒜' : ι → add_submonoid A :=
      λ i, (⟨𝒜 i, λ _ _, add_mem_class.add_mem, zero_mem_class.zero_mem _⟩ : add_submonoid A),
    letI : graded_ring 𝒜' :=
      { decompose' := (direct_sum.decompose 𝒜 : A → ⨁ i, 𝒜 i),
        left_inv := direct_sum.decomposition.left_inv,
        right_inv := direct_sum.decomposition.right_inv,
        ..(by apply_instance : set_like.graded_monoid 𝒜), },
    have m : ∀ x, x ∈ supr 𝒜',
    { intro x,
      rw direct_sum.is_internal.add_submonoid_supr_eq_top 𝒜'
        (direct_sum.decomposition.is_internal 𝒜'),
      exact add_submonoid.mem_top x },
    refine add_submonoid.supr_induction 𝒜' (m x) (λ i c hc, _) _ _,
    { refine add_submonoid.supr_induction 𝒜' (m y) (λ j c' hc', _) _ _,
      { by_cases h : i + j = 0,
        { rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0, from h ▸ mul_mem hc hc'),
            decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0, from (add_eq_zero_iff.mp h).1 ▸ hc),
            decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0, from (add_eq_zero_iff.mp h).2 ▸ hc')] },
        { rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h],
          cases (show i ≠ 0 ∨ j ≠ 0, by rwa [add_eq_zero_iff, not_and_distrib] at h) with h' h',
          { simp only [decompose_of_mem_ne 𝒜 hc h', zero_mul] },
          { simp only [decompose_of_mem_ne 𝒜 hc' h', mul_zero] } } },
      { simp only [decompose_zero, zero_apply, add_submonoid_class.coe_zero, mul_zero], },
      { intros _ _ hd he,
        simp only [mul_add, decompose_add, add_apply, add_mem_class.coe_add, hd, he] } },
    { simp only [decompose_zero, zero_apply, add_submonoid_class.coe_zero, zero_mul] },
    { rintros _ _ ha hb,
      simp only [add_mul, decompose_add, add_apply, add_mem_class.coe_add, ha, hb] },
  end }

end canonical_order


/-
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, Kevin Buzzard, Yury Kudryashov, Frédéric Dupuis,
  Heather Macbeth
-/
import linear_algebra.basic
import order.omega_complete_partial_order

/-!
# The span of a set of vectors, as a submodule

* `submodule.span s` is defined to be the smallest submodule containing the set `s`.

## Notations

* We introduce the notation `R ∙ v` for the span of a singleton, `submodule.span R {v}`.  This is
  `\.`, not the same as the scalar multiplication `•`/`\bub`.

-/
variables {R R₂ K M M₂ V S : Type*}

namespace submodule

open function set
open_locale pointwise

section add_comm_monoid

variables [semiring R] [add_comm_monoid M] [module R M]
variables {x : M} (p p' : submodule R M)
variables [semiring R₂] {σ₁₂ : R →+* R₂}
variables [add_comm_monoid M₂] [module R₂ M₂]

section
variables (R)

/-- The span of a set `s ⊆ M` is the smallest submodule of M that contains `s`. -/
def span (s : set M) : submodule R M := Inf {p | s ⊆ p}
end

variables {s t : set M}
lemma mem_span : x ∈ span R s ↔ ∀ p : submodule R M, s ⊆ p → x ∈ p := mem_Inter₂

lemma subset_span : s ⊆ span R s :=
λ x h, mem_span.2 $ λ p hp, hp h

lemma span_le {p} : span R s ≤ p ↔ s ⊆ p :=
⟨subset.trans subset_span, λ ss x h, mem_span.1 h _ ss⟩

lemma span_mono (h : s ⊆ t) : span R s ≤ span R t :=
span_le.2 $ subset.trans h subset_span

lemma span_eq_of_le (h₁ : s ⊆ p) (h₂ : p ≤ span R s) : span R s = p :=
le_antisymm (span_le.2 h₁) h₂

lemma span_eq : span R (p : set M) = p :=
span_eq_of_le _ (subset.refl _) subset_span

lemma span_eq_span (hs : s ⊆ span R t) (ht : t ⊆ span R s) : span R s = span R t :=
le_antisymm (span_le.2 hs) (span_le.2 ht)

/-- A version of `submodule.span_eq` for when the span is by a smaller ring. -/
@[simp] lemma span_coe_eq_restrict_scalars
  [semiring S] [has_scalar S R] [module S M] [is_scalar_tower S R M] :
  span S (p : set M) = p.restrict_scalars S :=
span_eq (p.restrict_scalars S)

lemma map_span [ring_hom_surjective σ₁₂] (f : M →ₛₗ[σ₁₂] M₂) (s : set M) :
  (span R s).map f = span R₂ (f '' s) :=
eq.symm $ span_eq_of_le _ (set.image_subset f subset_span) $
map_le_iff_le_comap.2 $ span_le.2 $ λ x hx, subset_span ⟨x, hx, rfl⟩

alias submodule.map_span ← linear_map.map_span

lemma map_span_le [ring_hom_surjective σ₁₂] (f : M →ₛₗ[σ₁₂] M₂) (s : set M)
  (N : submodule R₂ M₂) : map f (span R s) ≤ N ↔ ∀ m ∈ s, f m ∈ N :=
begin
  rw [f.map_span, span_le, set.image_subset_iff],
  exact iff.rfl
end

alias submodule.map_span_le ← linear_map.map_span_le

@[simp] lemma span_insert_zero : span R (insert (0 : M) s) = span R s :=
begin
  refine le_antisymm _ (submodule.span_mono (set.subset_insert 0 s)),
  rw [span_le, set.insert_subset],
  exact ⟨by simp only [set_like.mem_coe, submodule.zero_mem], submodule.subset_span⟩,
end

/- See also `span_preimage_eq` below. -/
lemma span_preimage_le (f : M →ₛₗ[σ₁₂] M₂) (s : set M₂) :
  span R (f ⁻¹' s) ≤ (span R₂ s).comap f :=
by { rw [span_le, comap_coe], exact preimage_mono (subset_span), }

alias submodule.span_preimage_le  ← linear_map.span_preimage_le

/-- An induction principle for span membership. If `p` holds for 0 and all elements of `s`, and is
preserved under addition and scalar multiplication, then `p` holds for all elements of the span of
`s`. -/
@[elab_as_eliminator] lemma span_induction {p : M → Prop} (h : x ∈ span R s)
  (Hs : ∀ x ∈ s, p x) (H0 : p 0)
  (H1 : ∀ x y, p x → p y → p (x + y))
  (H2 : ∀ (a:R) x, p x → p (a • x)) : p x :=
(@span_le _ _ _ _ _ _ ⟨p, H1, H0, H2⟩).2 Hs h

/-- A dependent version of `submodule.span_induction`. -/
lemma span_induction' {p : Π x, x ∈ span R s → Prop}
  (Hs : ∀ x (h : x ∈ s), p x (subset_span h))
  (H0 : p 0 (submodule.zero_mem _))
  (H1 : ∀ x hx y hy, p x hx → p y hy → p (x + y) (submodule.add_mem _ ‹_› ‹_›))
  (H2 : ∀ (a : R) x hx, p x hx → p (a • x) (submodule.smul_mem _ _ ‹_›)) {x} (hx : x ∈ span R s) :
  p x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ span R s) (hc : p x hx), hc),
  refine span_induction hx (λ m hm, ⟨subset_span hm, Hs m hm⟩) ⟨zero_mem _, H0⟩
    (λ x y hx hy, exists.elim hx $ λ hx' hx, exists.elim hy $ λ hy' hy,
    ⟨add_mem hx' hy', H1 _ _ _ _ hx hy⟩) (λ r x hx, exists.elim hx $ λ hx' hx,
    ⟨smul_mem _ _ hx', H2 r _ _ hx⟩)
end

@[simp] lemma span_span_coe_preimage : span R ((coe : span R s → M) ⁻¹' s) = ⊤ :=
eq_top_iff.2 $ λ x, subtype.rec_on x $ λ x hx _, begin
  refine span_induction' (λ x hx, _) _ (λ x y _ _, _) (λ r x _, _) hx,
  { exact subset_span hx },
  { exact zero_mem _ },
  { exact add_mem },
  { exact smul_mem _ _ }
end

lemma span_nat_eq_add_submonoid_closure (s : set M) :
  (span ℕ s).to_add_submonoid = add_submonoid.closure s :=
begin
  refine eq.symm (add_submonoid.closure_eq_of_le subset_span _),
  apply add_submonoid.to_nat_submodule.symm.to_galois_connection.l_le _,
  rw span_le,
  exact add_submonoid.subset_closure,
end

@[simp] lemma span_nat_eq (s : add_submonoid M) : (span ℕ (s : set M)).to_add_submonoid = s :=
by rw [span_nat_eq_add_submonoid_closure, s.closure_eq]

lemma span_int_eq_add_subgroup_closure {M : Type*} [add_comm_group M] (s : set M) :
  (span ℤ s).to_add_subgroup = add_subgroup.closure s :=
eq.symm $ add_subgroup.closure_eq_of_le _ subset_span $ λ x hx, span_induction hx
  (λ x hx, add_subgroup.subset_closure hx) (add_subgroup.zero_mem _)
  (λ _ _, add_subgroup.add_mem _) (λ _ _ _, add_subgroup.zsmul_mem _ ‹_› _)

@[simp]

section
variables (R M)

/-- `span` forms a Galois insertion with the coercion from submodule to set. -/
protected def gi : galois_insertion (@span R M _ _ _) coe :=
{ choice := λ s _, span R s,
  gc := λ s t, span_le,
  le_l_u := λ s, subset_span,
  choice_eq := λ s h, rfl }

end

@[simp] lemma span_empty : span R (∅ : set M) = ⊥ :=
(submodule.gi R M).gc.l_bot

@[simp] lemma span_univ : span R (univ : set M) = ⊤ :=
eq_top_iff.2 $ set_like.le_def.2 $ subset_span

lemma span_union (s t : set M) : span R (s ∪ t) = span R s ⊔ span R t :=
(submodule.gi R M).gc.l_sup

lemma span_Union {ι} (s : ι → set M) : span R (⋃ i, s i) = ⨆ i, span R (s i) :=
(submodule.gi R M).gc.l_supr

lemma span_Union₂ {ι} {κ : ι → Sort*} (s : Π i, κ i → set M) :
  span R (⋃ i j, s i j) = ⨆ i j, span R (s i j) :=
(submodule.gi R M).gc.l_supr₂

lemma span_attach_bUnion [decidable_eq M] {α : Type*} (s : finset α) (f : s → finset M) :
  span R (s.attach.bUnion f : set M) = ⨆ x, span R (f x) :=
by simpa [span_Union]

lemma sup_span : p ⊔ span R s = span R (p ∪ s) :=
by rw [submodule.span_union, p.span_eq]

lemma span_sup : span R s ⊔ p = span R (s ∪ p) :=
by rw [submodule.span_union, p.span_eq]

lemma span_eq_supr_of_singleton_spans (s : set M) : span R s = ⨆ x ∈ s, span R {x} :=
by simp only [←span_Union, set.bUnion_of_singleton s]

lemma span_smul_le (s : set M) (r : R) :
  span R (r • s) ≤ span R s :=
begin
  rw span_le,
  rintros _ ⟨x, hx, rfl⟩,
  exact smul_mem (span R s) r (subset_span hx),
end

lemma subset_span_trans {U V W : set M} (hUV : U ⊆ submodule.span R V)
  (hVW : V ⊆ submodule.span R W) :
  U ⊆ submodule.span R W :=
(submodule.gi R M).gc.le_u_l_trans hUV hVW

/-- See `submodule.span_smul_eq` (in `ring_theory.ideal.operations`) for
`span R (r • s) = r • span R s` that holds for arbitrary `r` in a `comm_semiring`. -/
lemma span_smul_eq_of_is_unit (s : set M) (r : R) (hr : is_unit r) :
  span R (r • s) = span R s :=
begin
  apply le_antisymm,
  { apply span_smul_le },
  { convert span_smul_le (r • s) ((hr.unit ⁻¹ : _) : R),
    rw smul_smul,
    erw hr.unit.inv_val,
    rw one_smul }
end

@[simp] theorem coe_supr_of_directed {ι} [hι : nonempty ι]
  (S : ι → submodule R M) (H : directed (≤) S) :
  ((supr S : submodule R M) : set M) = ⋃ i, S i :=
begin
  refine subset.antisymm _ (Union_subset $ le_supr S),
  suffices : (span R (⋃ i, (S i : set M)) : set M) ⊆ ⋃ (i : ι), ↑(S i),
    by simpa only [span_Union, span_eq] using this,
  refine (λ x hx, span_induction hx (λ _, id) _ _ _);
    simp only [mem_Union, exists_imp_distrib],
  { exact hι.elim (λ i, ⟨i, (S i).zero_mem⟩) },
  { intros x y i hi j hj,
    rcases H i j with ⟨k, ik, jk⟩,
    exact ⟨k, add_mem (ik hi) (jk hj)⟩ },
  { exact λ a x i hi, ⟨i, smul_mem _ a hi⟩ },
end

@[simp] theorem mem_supr_of_directed {ι} [nonempty ι]
  (S : ι → submodule R M) (H : directed (≤) S) {x} :
  x ∈ supr S ↔ ∃ i, x ∈ S i :=
by { rw [← set_like.mem_coe, coe_supr_of_directed S H, mem_Union], refl }

theorem mem_Sup_of_directed {s : set (submodule R M)}
  {z} (hs : s.nonempty) (hdir : directed_on (≤) s) :
  z ∈ Sup s ↔ ∃ y ∈ s, z ∈ y :=
begin
  haveI : nonempty s := hs.to_subtype,
  simp only [Sup_eq_supr', mem_supr_of_directed _ hdir.directed_coe, set_coe.exists, subtype.coe_mk]
end

@[norm_cast, simp] lemma coe_supr_of_chain (a : ℕ →o submodule R M) :
  (↑(⨆ k, a k) : set M) = ⋃ k, (a k : set M) :=
coe_supr_of_directed a a.monotone.directed_le

/-- We can regard `coe_supr_of_chain` as the statement that `coe : (submodule R M) → set M` is
Scott continuous for the ω-complete partial order induced by the complete lattice structures. -/
lemma coe_scott_continuous : omega_complete_partial_order.continuous'
  (coe : submodule R M → set M) :=
⟨set_like.coe_mono, coe_supr_of_chain⟩

@[simp] lemma mem_supr_of_chain (a : ℕ →o submodule R M) (m : M) :
  m ∈ (⨆ k, a k) ↔ ∃ k, m ∈ a k :=
mem_supr_of_directed a a.monotone.directed_le

section

variables {p p'}

lemma mem_sup : x ∈ p ⊔ p' ↔ ∃ (y ∈ p) (z ∈ p'), y + z = x :=
⟨λ h, begin
  rw [← span_eq p, ← span_eq p', ← span_union] at h,
  apply span_induction h,
  { rintro y (h | h),
    { exact ⟨y, h, 0, by simp, by simp⟩ },
    { exact ⟨0, by simp, y, h, by simp⟩ } },
  { exact ⟨0, by simp, 0, by simp⟩ },
  { rintro _ _ ⟨y₁, hy₁, z₁, hz₁, rfl⟩ ⟨y₂, hy₂, z₂, hz₂, rfl⟩,
    exact ⟨_, add_mem hy₁ hy₂, _, add_mem hz₁ hz₂, by simp [add_assoc]; cc⟩ },
  { rintro a _ ⟨y, hy, z, hz, rfl⟩,
    exact ⟨_, smul_mem _ a hy, _, smul_mem _ a hz, by simp [smul_add]⟩ }
end,
by rintro ⟨y, hy, z, hz, rfl⟩; exact add_mem
  ((le_sup_left : p ≤ p ⊔ p') hy)
  ((le_sup_right : p' ≤ p ⊔ p') hz)⟩

lemma mem_sup' : x ∈ p ⊔ p' ↔ ∃ (y : p) (z : p'), (y:M) + z = x :=
mem_sup.trans $ by simp only [set_like.exists, coe_mk]

variables (p p')

lemma coe_sup : ↑(p ⊔ p') = (p + p' : set M) :=
by { ext, rw [set_like.mem_coe, mem_sup, set.mem_add], simp, }

lemma sup_to_add_submonoid :
  (p ⊔ p').to_add_submonoid = p.to_add_submonoid ⊔ p'.to_add_submonoid :=
begin
  ext x,
  rw [mem_to_add_submonoid, mem_sup, add_submonoid.mem_sup],
  refl,
end

lemma sup_to_add_subgroup {R M : Type*} [ring R] [add_comm_group M] [module R M]
  (p p' : submodule R M) :
  (p ⊔ p').to_add_subgroup = p.to_add_subgroup ⊔ p'.to_add_subgroup :=
begin
  ext x,
  rw [mem_to_add_subgroup, mem_sup, add_subgroup.mem_sup],
  refl,
end

end

/- This is the character `∙`, with escape sequence `\.`, and is thus different from the scalar
multiplication character `•`, with escape sequence `\bub`. -/
notation R`∙`:1000 x := span R (@singleton _ _ set.has_singleton x)

lemma mem_span_singleton_self (x : M) : x ∈ R ∙ x := subset_span rfl

lemma nontrivial_span_singleton {x : M} (h : x ≠ 0) : nontrivial (R ∙ x) :=
⟨begin
    use [0, x, submodule.mem_span_singleton_self x],
    intros H,
    rw [eq_comm, submodule.mk_eq_zero] at H,
    exact h H
end⟩

lemma mem_span_singleton {y : M} : x ∈ (R ∙ y) ↔ ∃ a:R, a • y = x :=
⟨λ h, begin
  apply span_induction h,
  { rintro y (rfl|⟨⟨⟩⟩), exact ⟨1, by simp⟩ },
  { exact ⟨0, by simp⟩ },
  { rintro _ _ ⟨a, rfl⟩ ⟨b, rfl⟩,
    exact ⟨a + b, by simp [add_smul]⟩ },
  { rintro a _ ⟨b, rfl⟩,
    exact ⟨a * b, by simp [smul_smul]⟩ }
end,
by rintro ⟨a, y, rfl⟩; exact
  smul_mem _ _ (subset_span $ by simp)⟩

lemma le_span_singleton_iff {s : submodule R M} {v₀ : M} :
  s ≤ (R ∙ v₀) ↔ ∀ v ∈ s, ∃ r : R, r • v₀ = v :=
by simp_rw [set_like.le_def, mem_span_singleton]

variables (R)

lemma span_singleton_eq_top_iff (x : M) : (R ∙ x) = ⊤ ↔ ∀ v, ∃ r : R, r • x = v :=
by { rw [eq_top_iff, le_span_singleton_iff], tauto }

@[simp] lemma span_zero_singleton : (R ∙ (0:M)) = ⊥ :=
by { ext, simp [mem_span_singleton, eq_comm] }

lemma span_singleton_eq_range (y : M) : ↑(R ∙ y) = range ((• y) : R → M) :=
set.ext $ λ x, mem_span_singleton

lemma span_singleton_smul_le {S} [monoid S] [has_scalar S R] [mul_action S M]
  [is_scalar_tower S R M] (r : S) (x : M) : (R ∙ (r • x)) ≤ R ∙ x :=
begin
  rw [span_le, set.singleton_subset_iff, set_like.mem_coe],
  exact smul_of_tower_mem _ _ (mem_span_singleton_self _)
end

lemma span_singleton_group_smul_eq {G} [group G] [has_scalar G R] [mul_action G M]
  [is_scalar_tower G R M] (g : G) (x : M) : (R ∙ (g • x)) = R ∙ x :=
begin
  refine le_antisymm (span_singleton_smul_le R g x) _,
  convert span_singleton_smul_le R (g⁻¹) (g • x),
  exact (inv_smul_smul g x).symm
end

variables {R}

lemma span_singleton_smul_eq {r : R} (hr : is_unit r) (x : M) : (R ∙ (r • x)) = R ∙ x :=
begin
  lift r to Rˣ using hr,
  rw ←units.smul_def,
  exact span_singleton_group_smul_eq R r x,
end

lemma disjoint_span_singleton {K E : Type*} [division_ring K] [add_comm_group E] [module K E]
  {s : submodule K E} {x : E} :
  disjoint s (K ∙ x) ↔ (x ∈ s → x = 0) :=
begin
  refine disjoint_def.trans ⟨λ H hx, H x hx $ subset_span $ mem_singleton x, _⟩,
  assume H y hy hyx,
  obtain ⟨c, rfl⟩ := mem_span_singleton.1 hyx,
  by_cases hc : c = 0,
  { rw [hc, zero_smul] },
  { rw [s.smul_mem_iff hc] at hy,
    rw [H hy, smul_zero] }
end

lemma disjoint_span_singleton' {K E : Type*} [division_ring K] [add_comm_group E] [module K E]
  {p : submodule K E} {x : E} (x0 : x ≠ 0) :
  disjoint p (K ∙ x) ↔ x ∉ p :=
disjoint_span_singleton.trans ⟨λ h₁ h₂, x0 (h₁ h₂), λ h₁ h₂, (h₁ h₂).elim⟩

lemma mem_span_singleton_trans {x y z : M} (hxy : x ∈ R ∙ y) (hyz : y ∈ R ∙ z) :
  x ∈ R ∙ z :=
begin
  rw [← set_like.mem_coe, ← singleton_subset_iff] at *,
  exact submodule.subset_span_trans hxy hyz
end

lemma mem_span_insert {y} : x ∈ span R (insert y s) ↔ ∃ (a:R) (z ∈ span R s), x = a • y + z :=
begin
  simp only [← union_singleton, span_union, mem_sup, mem_span_singleton, exists_prop,
    exists_exists_eq_and],
  rw [exists_comm],
  simp only [eq_comm, add_comm, exists_and_distrib_left]
end

lemma span_insert (x) (s : set M) : span R (insert x s) = span R ({x} : set M) ⊔ span R s :=
by rw [insert_eq, span_union]

lemma span_insert_eq_span (h : x ∈ span R s) : span R (insert x s) = span R s :=
span_eq_of_le _ (set.insert_subset.mpr ⟨h, subset_span⟩) (span_mono $ subset_insert _ _)

lemma span_span : span R (span R s : set M) = span R s := span_eq _

variables (R S s)

/-- If `R` is "smaller" ring than `S` then the span by `R` is smaller than the span by `S`. -/
lemma span_le_restrict_scalars [semiring S] [has_scalar R S] [module S M] [is_scalar_tower R S M] :
  span R s ≤ (span S s).restrict_scalars R :=
submodule.span_le.2 submodule.subset_span

/-- A version of `submodule.span_le_restrict_scalars` with coercions. -/
@[simp] lemma span_subset_span [semiring S] [has_scalar R S] [module S M] [is_scalar_tower R S M] :
  ↑(span R s) ⊆ (span S s : set M) :=
span_le_restrict_scalars R S s

/-- Taking the span by a large ring of the span by the small ring is the same as taking the span
by just the large ring. -/
lemma span_span_of_tower [semiring S] [has_scalar R S] [module S M] [is_scalar_tower R S M] :
  span S (span R s : set M) = span S s :=
le_antisymm (span_le.2 $ span_subset_span R S s) (span_mono subset_span)

variables {R S s}

lemma span_eq_bot : span R (s : set M) = ⊥ ↔ ∀ x ∈ s, (x:M) = 0 :=
eq_bot_iff.trans ⟨
  λ H x h, (mem_bot R).1 $ H $ subset_span h,
  λ H, span_le.2 (λ x h, (mem_bot R).2 $ H x h)⟩

@[simp] lemma span_singleton_eq_bot : (R ∙ x) = ⊥ ↔ x = 0 :=
span_eq_bot.trans $ by simp

@[simp] lemma span_zero : span R (0 : set M) = ⊥ := by rw [←singleton_zero, span_singleton_eq_bot]

lemma span_singleton_eq_span_singleton {R M : Type*} [ring R] [add_comm_group M] [module R M]
  [no_zero_smul_divisors R M] {x y : M} : (R ∙ x) = (R ∙ y) ↔ ∃ z : Rˣ, z • x = y :=
begin
  by_cases hx : x = 0,
  { rw [hx, span_zero_singleton, eq_comm, span_singleton_eq_bot],
    exact ⟨λ hy, ⟨1, by rw [hy, smul_zero]⟩, λ ⟨_, hz⟩, by rw [← hz, smul_zero]⟩ },
  by_cases hy : y = 0,
  { rw [hy, span_zero_singleton, span_singleton_eq_bot],
    exact ⟨λ hx, ⟨1, by rw [hx, smul_zero]⟩, λ ⟨z, hz⟩, (smul_eq_zero_iff_eq z).mp hz⟩ },
  split,
  { intro hxy,
    cases mem_span_singleton.mp (by { rw [hxy], apply mem_span_singleton_self }) with v hv,
    cases mem_span_singleton.mp (by { rw [← hxy], apply mem_span_singleton_self }) with i hi,
    have vi : v * i = 1 :=
    by { rw [← one_smul R y, ← hi, smul_smul] at hv, exact smul_left_injective R hy hv },
    have iv : i * v = 1 :=
    by { rw [← one_smul R x, ← hv, smul_smul] at hi, exact smul_left_injective R hx hi },
    exact ⟨⟨v, i, vi, iv⟩, hv⟩ },
  { rintro ⟨v, rfl⟩,
    rw span_singleton_group_smul_eq }
end

@[simp] lemma span_image [ring_hom_surjective σ₁₂] (f : M →ₛₗ[σ₁₂] M₂) :
  span R₂ (f '' s) = map f (span R s) :=
(map_span f s).symm

lemma apply_mem_span_image_of_mem_span
   [ring_hom_surjective σ₁₂] (f : M →ₛₗ[σ₁₂] M₂) {x : M} {s : set M} (h : x ∈ submodule.span R s) :
   f x ∈ submodule.span R₂ (f '' s) :=
begin
  rw submodule.span_image,
  exact submodule.mem_map_of_mem h
end

@[simp] lemma map_subtype_span_singleton {p : submodule R M} (x : p) :
  map p.subtype (R ∙ x) = R ∙ (x : M) :=
by simp [← span_image]

/-- `f` is an explicit argument so we can `apply` this theorem and obtain `h` as a new goal. -/
lemma not_mem_span_of_apply_not_mem_span_image
   [ring_hom_surjective σ₁₂] (f : M →ₛₗ[σ₁₂] M₂) {x : M} {s : set M}
   (h : f x ∉ submodule.span R₂ (f '' s)) :
   x ∉ submodule.span R s :=
h.imp (apply_mem_span_image_of_mem_span f)

lemma supr_eq_span {ι : Sort*} (p : ι → submodule R M) :
  (⨆ (i : ι), p i) = submodule.span R (⋃ (i : ι), ↑(p i)) :=
le_antisymm
  (supr_le $ assume i, subset.trans (assume m hm, set.mem_Union.mpr ⟨i, hm⟩) subset_span)
  (span_le.mpr $ Union_subset_iff.mpr $ assume i m hm, mem_supr_of_mem i hm)

lemma supr_to_add_submonoid {ι : Sort*} (p : ι → submodule R M) :
  (⨆ i, p i).to_add_submonoid = ⨆ i, (p i).to_add_submonoid :=
begin
  refine le_antisymm (λ x, _) (supr_le $ λ i, to_add_submonoid_mono $ le_supr _ i),
  simp_rw [supr_eq_span, add_submonoid.supr_eq_closure, mem_to_add_submonoid, coe_to_add_submonoid],
  intros hx,
  refine submodule.span_induction hx (λ x hx, _) _ (λ x y hx hy, _) (λ r x hx, _),
  { exact add_submonoid.subset_closure hx },
  { exact add_submonoid.zero_mem _ },
  { exact add_submonoid.add_mem _ hx hy },
  { apply add_submonoid.closure_induction hx,
    { rintros x ⟨_, ⟨i, rfl⟩, hix : x ∈ p i⟩,
      apply add_submonoid.subset_closure (set.mem_Union.mpr ⟨i, _⟩),
      exact smul_mem _ r hix },
    { rw smul_zero,
      exact add_submonoid.zero_mem _ },
    { intros x y hx hy,
      rw smul_add,
      exact add_submonoid.add_mem _ hx hy, } }
end

/-- An induction principle for elements of `⨆ i, p i`.
If `C` holds for `0` and all elements of `p i` for all `i`, and is preserved under addition,
then it holds for all elements of the supremum of `p`. -/
@[elab_as_eliminator]
lemma supr_induction {ι : Sort*} (p : ι → submodule R M) {C : M → Prop} {x : M} (hx : x ∈ ⨆ i, p i)
  (hp : ∀ i (x ∈ p i), C x)
  (h0 : C 0)
  (hadd : ∀ x y, C x → C y → C (x + y)) : C x :=
begin
  rw [←mem_to_add_submonoid, supr_to_add_submonoid] at hx,
  exact add_submonoid.supr_induction _ hx hp h0 hadd,
end

/-- A dependent version of `submodule.supr_induction`. -/
@[elab_as_eliminator]
lemma supr_induction' {ι : Sort*} (p : ι → submodule R M) {C : Π x, (x ∈ ⨆ i, p i) → Prop}
  (hp : ∀ i (x ∈ p i), C x (mem_supr_of_mem i ‹_›))
  (h0 : C 0 (zero_mem _))
  (hadd : ∀ x y hx hy, C x hx → C y hy → C (x + y) (add_mem ‹_› ‹_›))
  {x : M} (hx : x ∈ ⨆ i, p i) : C x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ ⨆ i, p i) (hc : C x hx), hc),
  refine supr_induction p hx (λ i x hx, _) _ (λ x y, _),
  { exact ⟨_, hp _ _ hx⟩ },
  { exact ⟨_, h0⟩ },
  { rintro ⟨_, Cx⟩ ⟨_, Cy⟩,
    refine ⟨_, hadd _ _ _ _ Cx Cy⟩ },
end

@[simp] lemma span_singleton_le_iff_mem (m : M) (p : submodule R M) : (R ∙ m) ≤ p ↔ m ∈ p :=
by rw [span_le, singleton_subset_iff, set_like.mem_coe]

lemma singleton_span_is_compact_element (x : M) :
  complete_lattice.is_compact_element (span R {x} : submodule R M) :=
begin
  rw complete_lattice.is_compact_element_iff_le_of_directed_Sup_le,
  intros d hemp hdir hsup,
  have : x ∈ Sup d, from (set_like.le_def.mp hsup) (mem_span_singleton_self x),
  obtain ⟨y, ⟨hyd, hxy⟩⟩ := (mem_Sup_of_directed hemp hdir).mp this,
  exact ⟨y, ⟨hyd, by simpa only [span_le, singleton_subset_iff]⟩⟩,
end

/-- The span of a finite subset is compact in the lattice of submodules. -/
lemma finset_span_is_compact_element (S : finset M) :
  complete_lattice.is_compact_element (span R S : submodule R M) :=
begin
  rw span_eq_supr_of_singleton_spans,
  simp only [finset.mem_coe],
  rw ←finset.sup_eq_supr,
  exact complete_lattice.finset_sup_compact_of_compact S
    (λ x _, singleton_span_is_compact_element x),
end

/-- The span of a finite subset is compact in the lattice of submodules. -/
lemma finite_span_is_compact_element (S : set M) (h : S.finite) :
  complete_lattice.is_compact_element (span R S : submodule R M) :=
finite.coe_to_finset h ▸ (finset_span_is_compact_element h.to_finset)

instance : is_compactly_generated (submodule R M) :=
⟨λ s, ⟨(λ x, span R {x}) '' s, ⟨λ t ht, begin
  rcases (set.mem_image _ _ _).1 ht with ⟨x, hx, rfl⟩,
  apply singleton_span_is_compact_element,
end, by rw [Sup_eq_supr, supr_image, ←span_eq_supr_of_singleton_spans, span_eq]⟩⟩⟩

lemma lt_sup_iff_not_mem {I : submodule R M} {a : M} : I < I ⊔ (R ∙ a) ↔ a ∉ I :=
begin
  split,
  { intro h,
    by_contra akey,
    have h1 : I ⊔ (R ∙ a) ≤ I,
    { simp only [sup_le_iff],
      split,
      { exact le_refl I, },
      { exact (span_singleton_le_iff_mem a I).mpr akey, } },
    have h2 := gt_of_ge_of_gt h1 h,
    exact lt_irrefl I h2, },
  { intro h,
    apply set_like.lt_iff_le_and_exists.mpr, split,
    simp only [le_sup_left],
    use a,
    split, swap, { assumption, },
    { have : (R ∙ a) ≤ I ⊔ (R ∙ a) := le_sup_right,
      exact this (mem_span_singleton_self a), } },
end

lemma mem_supr {ι : Sort*} (p : ι → submodule R M) {m : M} :
  (m ∈ ⨆ i, p i) ↔ (∀ N, (∀ i, p i ≤ N) → m ∈ N) :=
begin
  rw [← span_singleton_le_iff_mem, le_supr_iff],
  simp only [span_singleton_le_iff_mem],
end

section

open_locale classical

/-- For every element in the span of a set, there exists a finite subset of the set
such that the element is contained in the span of the subset. -/
lemma mem_span_finite_of_mem_span {S : set M} {x : M} (hx : x ∈ span R S) :
  ∃ T : finset M, ↑T ⊆ S ∧ x ∈ span R (T : set M) :=
begin
  refine span_induction hx (λ x hx, _) _ _ _,
  { refine ⟨{x}, _, _⟩,
    { rwa [finset.coe_singleton, set.singleton_subset_iff] },
    { rw finset.coe_singleton,
      exact submodule.mem_span_singleton_self x } },
  { use ∅, simp },
  { rintros x y ⟨X, hX, hxX⟩ ⟨Y, hY, hyY⟩,
    refine ⟨X ∪ Y, _, _⟩,
    { rw finset.coe_union,
      exact set.union_subset hX hY },
    rw [finset.coe_union, span_union, mem_sup],
    exact ⟨x, hxX, y, hyY, rfl⟩, },
  { rintros a x ⟨T, hT, h2⟩,
    exact ⟨T, hT, smul_mem _ _ h2⟩ }
end

end

variables {M' : Type*} [add_comm_monoid M'] [module R M'] (q₁ q₁' : submodule R M')

/-- The product of two submodules is a submodule. -/
def prod : submodule R (M × M') :=
{ carrier   := (p : set M) ×ˢ (q₁ : set M'),
  smul_mem' := by rintro a ⟨x, y⟩ ⟨hx, hy⟩; exact ⟨smul_mem _ a hx, smul_mem _ a hy⟩,
  .. p.to_add_submonoid.prod q₁.to_add_submonoid }

@[simp] lemma prod_coe :
  (prod p q₁ : set (M × M')) = (p : set M) ×ˢ (q₁ : set M') := rfl

@[simp] lemma mem_prod {p : submodule R M} {q : submodule R M'} {x : M × M'} :
  x ∈ prod p q ↔ x.1 ∈ p ∧ x.2 ∈ q := set.mem_prod

lemma span_prod_le (s : set M) (t : set M') :
  span R (s ×ˢ t) ≤ prod (span R s) (span R t) :=
span_le.2 $ set.prod_mono subset_span subset_span

@[simp] lemma prod_top : (prod ⊤ ⊤ : submodule R (M × M')) = ⊤ :=
by ext; simp

@[simp] lemma prod_bot : (prod ⊥ ⊥ : submodule R (M × M')) = ⊥ :=
by ext ⟨x, y⟩; simp [prod.zero_eq_mk]

lemma prod_mono {p p' : submodule R M} {q q' : submodule R M'} :
  p ≤ p' → q ≤ q' → prod p q ≤ prod p' q' := prod_mono

@[simp] lemma prod_inf_prod : prod p q₁ ⊓ prod p' q₁' = prod (p ⊓ p') (q₁ ⊓ q₁') :=
set_like.coe_injective set.prod_inter_prod

@[simp] lemma prod_sup_prod : prod p q₁ ⊔ prod p' q₁' = prod (p ⊔ p') (q₁ ⊔ q₁') :=
begin
  refine le_antisymm (sup_le
    (prod_mono le_sup_left le_sup_left)
    (prod_mono le_sup_right le_sup_right)) _,
  simp [set_like.le_def], intros xx yy hxx hyy,
  rcases mem_sup.1 hxx with ⟨x, hx, x', hx', rfl⟩,
  rcases mem_sup.1 hyy with ⟨y, hy, y', hy', rfl⟩,
  refine mem_sup.2 ⟨(x, y), ⟨hx, hy⟩, (x', y'), ⟨hx', hy'⟩, rfl⟩
end

end add_comm_monoid

section add_comm_group

variables [ring R] [add_comm_group M] [module R M]

@[simp] lemma span_neg (s : set M) : span R (-s) = span R s :=
calc span R (-s) = span R ((-linear_map.id : M →ₗ[R] M) '' s) : by simp
 ... = map (-linear_map.id) (span R s) : ((-linear_map.id).map_span _).symm
... = span R s : by simp

lemma mem_span_insert' {x y} {s : set M} : x ∈ span R (insert y s) ↔ ∃(a:R), x + a • y ∈ span R s :=
begin
  rw mem_span_insert, split,
  { rintro ⟨a, z, hz, rfl⟩, exact ⟨-a, by simp [hz, add_assoc]⟩ },
  { rintro ⟨a, h⟩, exact ⟨-a, _, h, by simp [add_comm, add_left_comm]⟩ }
end

instance : is_modular_lattice (submodule R M) :=
⟨λ x y z xz a ha, begin
  rw [mem_inf, mem_sup] at ha,
  rcases ha with ⟨⟨b, hb, c, hc, rfl⟩, haz⟩,
  rw mem_sup,
  refine ⟨b, hb, c, mem_inf.2 ⟨hc, _⟩, rfl⟩,
  rw [← add_sub_cancel c b, add_comm],
  apply z.sub_mem haz (xz hb),
end⟩

end add_comm_group

section add_comm_group

variables [semiring R] [semiring R₂]
variables [add_comm_group M] [module R M] [add_comm_group M₂] [module R₂ M₂]
variables {τ₁₂ : R →+* R₂} [ring_hom_surjective τ₁₂]

lemma comap_map_eq (f : M →ₛₗ[τ₁₂] M₂) (p : submodule R M) :
  comap f (map f p) = p ⊔ f.ker :=
begin
  refine le_antisymm _ (sup_le (le_comap_map _ _) (comap_mono bot_le)),
  rintro x ⟨y, hy, e⟩,
  exact mem_sup.2 ⟨y, hy, x - y, by simpa using sub_eq_zero.2 e.symm, by simp⟩
end

lemma comap_map_eq_self {f : M →ₛₗ[τ₁₂] M₂} {p : submodule R M} (h : f.ker ≤ p) :
  comap f (map f p) = p :=
by rw [submodule.comap_map_eq, sup_of_le_left h]

end add_comm_group

end submodule

namespace linear_map

open submodule function

section add_comm_group

variables [semiring R] [semiring R₂]
variables [add_comm_group M] [add_comm_group M₂]
variables [module R M] [module R₂ M₂]
variables {τ₁₂ : R →+* R₂} [ring_hom_surjective τ₁₂]
include R

protected lemma map_le_map_iff (f : M →ₛₗ[τ₁₂] M₂) {p p'} : map f p ≤ map f p' ↔ p ≤ p' ⊔ ker f :=
by rw [map_le_iff_le_comap, submodule.comap_map_eq]

theorem map_le_map_iff' {f : M →ₛₗ[τ₁₂] M₂} (hf : ker f = ⊥) {p p'} :
  map f p ≤ map f p' ↔ p ≤ p' :=
by rw [linear_map.map_le_map_iff, hf, sup_bot_eq]

theorem map_injective {f : M →ₛₗ[τ₁₂] M₂} (hf : ker f = ⊥) : injective (map f) :=
λ p p' h, le_antisymm ((map_le_map_iff' hf).1 (le_of_eq h)) ((map_le_map_iff' hf).1 (ge_of_eq h))

theorem map_eq_top_iff {f : M →ₛₗ[τ₁₂] M₂} (hf : range f = ⊤) {p : submodule R M} :
  p.map f = ⊤ ↔ p ⊔ f.ker = ⊤ :=
by simp_rw [← top_le_iff, ← hf, range_eq_map, linear_map.map_le_map_iff]

end add_comm_group

section
variables (R) (M) [semiring R] [add_comm_monoid M] [module R M]

/-- Given an element `x` of a module `M` over `R`, the natural map from
    `R` to scalar multiples of `x`.-/
@[simps] def to_span_singleton (x : M) : R →ₗ[R] M := linear_map.id.smul_right x

/-- The range of `to_span_singleton x` is the span of `x`.-/
lemma span_singleton_eq_range (x : M) : (R ∙ x) = (to_span_singleton R M x).range :=
submodule.ext $ λ y, by {refine iff.trans _ linear_map.mem_range.symm, exact mem_span_singleton }

lemma to_span_singleton_one (x : M) : to_span_singleton R M x 1 = x := one_smul _ _

end

section add_comm_monoid

variables [semiring R] [add_comm_monoid M] [module R M]
variables [semiring R₂] [add_comm_monoid M₂] [module R₂ M₂]
variables {σ₁₂ : R →+* R₂}

/-- If two linear maps are equal on a set `s`, then they are equal on `submodule.span s`.

See also `linear_map.eq_on_span'` for a version using `set.eq_on`. -/
lemma eq_on_span {s : set M} {f g : M →ₛₗ[σ₁₂] M₂} (H : set.eq_on f g s) ⦃x⦄ (h : x ∈ span R s) :
  f x = g x :=
by apply span_induction h H; simp {contextual := tt}

/-- If two linear maps are equal on a set `s`, then they are equal on `submodule.span s`.

This version uses `set.eq_on`, and the hidden argument will expand to `h : x ∈ (span R s : set M)`.
See `linear_map.eq_on_span` for a version that takes `h : x ∈ span R s` as an argument. -/
lemma eq_on_span' {s : set M} {f g : M →ₛₗ[σ₁₂] M₂} (H : set.eq_on f g s) :
  set.eq_on f g (span R s : set M) :=
eq_on_span H

/-- If `s` generates the whole module and linear maps `f`, `g` are equal on `s`, then they are
equal. -/
lemma ext_on {s : set M} {f g : M →ₛₗ[σ₁₂] M₂} (hv : span R s = ⊤) (h : set.eq_on f g s) :
  f = g :=
linear_map.ext (λ x, eq_on_span h (eq_top_iff'.1 hv _))

/-- If the range of `v : ι → M` generates the whole module and linear maps `f`, `g` are equal at
each `v i`, then they are equal. -/
lemma ext_on_range {ι : Type*} {v : ι → M} {f g : M →ₛₗ[σ₁₂] M₂} (hv : span R (set.range v) = ⊤)
  (h : ∀i, f (v i) = g (v i)) : f = g :=
ext_on hv (set.forall_range_iff.2 h)

end add_comm_monoid

section field

variables {K V} [field K] [add_comm_group V] [module K V]

noncomputable theory
open_locale classical

lemma span_singleton_sup_ker_eq_top (f : V →ₗ[K] K) {x : V} (hx : f x ≠ 0) :
  (K ∙ x) ⊔ f.ker = ⊤ :=
eq_top_iff.2 (λ y hy, submodule.mem_sup.2 ⟨(f y * (f x)⁻¹) • x,
  submodule.mem_span_singleton.2 ⟨f y * (f x)⁻¹, rfl⟩,
    ⟨y - (f y * (f x)⁻¹) • x,
      by rw [linear_map.mem_ker, f.map_sub, f.map_smul, smul_eq_mul, mul_assoc,
             inv_mul_cancel hx, mul_one, sub_self],
      by simp only [add_sub_cancel'_right]⟩⟩)

variables (K V)

lemma ker_to_span_singleton {x : V} (h : x ≠ 0) : (to_span_singleton K V x).ker = ⊥ :=
begin
  ext c, split,
  { intros hc, rw submodule.mem_bot, rw mem_ker at hc, by_contra hc',
    have : x = 0,
      calc x = c⁻¹ • (c • x) : by rw [← mul_smul, inv_mul_cancel hc', one_smul]
      ... = c⁻¹ • ((to_span_singleton K V x) c) : rfl
      ... = 0 : by rw [hc, smul_zero],
    tauto },
  { rw [mem_ker, submodule.mem_bot], intros h, rw h, simp }
end

end field

end linear_map

open linear_map

namespace linear_equiv

section field

variables (K V) [field K] [add_comm_group V] [module K V]

/-- Given a nonzero element `x` of a vector space `V` over a field `K`, the natural
    map from `K` to the span of `x`, with invertibility check to consider it as an
    isomorphism.-/
def to_span_nonzero_singleton (x : V) (h : x ≠ 0) : K ≃ₗ[K] (K ∙ x) :=
linear_equiv.trans
  (linear_equiv.of_injective
    (linear_map.to_span_singleton K V x) (ker_eq_bot.1 $ linear_map.ker_to_span_singleton K V h))
  (linear_equiv.of_eq (to_span_singleton K V x).range (K ∙ x)
    (span_singleton_eq_range K V x).symm)

lemma to_span_nonzero_singleton_one (x : V) (h : x ≠ 0) :
  linear_equiv.to_span_nonzero_singleton K V x h 1 =
    (⟨x, submodule.mem_span_singleton_self x⟩ : K ∙ x) :=
begin
  apply set_like.coe_eq_coe.mp,
  have : ↑(to_span_nonzero_singleton K V x h 1) = to_span_singleton K V x 1 := rfl,
  rw [this, to_span_singleton_one, submodule.coe_mk],
end

/-- Given a nonzero element `x` of a vector space `V` over a field `K`, the natural map
    from the span of `x` to `K`.-/
abbreviation coord (x : V) (h : x ≠ 0) : (K ∙ x) ≃ₗ[K] K :=
(to_span_nonzero_singleton K V x h).symm

lemma coord_self (x : V) (h : x ≠ 0) :
  (coord K V x h) (⟨x, submodule.mem_span_singleton_self x⟩ : K ∙ x) = 1 :=
by rw [← to_span_nonzero_singleton_one K V x h, linear_equiv.symm_apply_apply]

end field

end linear_equiv


/-
Copyright (c) 2019 Reid Barton. 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.separation
import topology.bases

/-!
# Dense embeddings

This file defines three properties of functions:

* `dense_range f`      means `f` has dense image;
* `dense_inducing i`   means `i` is also `inducing`;
* `dense_embedding e`  means `e` is also an `embedding`.

The main theorem `continuous_extend` gives a criterion for a function
`f : X → Z` to a regular (T₃) space Z to extend along a dense embedding
`i : X → Y` to a continuous function `g : Y → Z`. Actually `i` only
has to be `dense_inducing` (not necessarily injective).

-/

noncomputable theory

open set filter
open_locale classical topological_space filter

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

/-- `i : α → β` is "dense inducing" if it has dense range and the topology on `α`
  is the one induced by `i` from the topology on `β`. -/
structure dense_inducing [topological_space α] [topological_space β] (i : α → β)
  extends inducing i : Prop :=
(dense : dense_range i)

namespace dense_inducing
variables [topological_space α] [topological_space β]
variables {i : α → β} (di : dense_inducing i)

lemma nhds_eq_comap (di : dense_inducing i) :
  ∀ a : α, 𝓝 a = comap i (𝓝 $ i a) :=
di.to_inducing.nhds_eq_comap

protected lemma continuous (di : dense_inducing i) : continuous i :=
di.to_inducing.continuous

lemma closure_range : closure (range i) = univ :=
di.dense.closure_range

lemma self_sub_closure_image_preimage_of_open {s : set β} (di : dense_inducing i) :
  is_open s → s ⊆ closure (i '' (i ⁻¹' s)) :=
begin
  intros s_op b b_in_s,
  rw [image_preimage_eq_inter_range, mem_closure_iff],
  intros U U_op b_in,
  rw ←inter_assoc,
  exact (dense_iff_inter_open.1 di.dense) _ (is_open_inter U_op s_op) ⟨b, b_in, b_in_s⟩
end

lemma closure_image_nhds_of_nhds {s : set α} {a : α} (di : dense_inducing i) :
  s ∈ 𝓝 a → closure (i '' s) ∈ 𝓝 (i a) :=
begin
  rw [di.nhds_eq_comap a, mem_comap_sets],
  intro h,
  rcases h with ⟨t, t_nhd, sub⟩,
  rw mem_nhds_sets_iff at t_nhd,
  rcases t_nhd with ⟨U, U_sub, ⟨U_op, e_a_in_U⟩⟩,
  have := calc i ⁻¹' U ⊆ i⁻¹' t : preimage_mono U_sub
                   ... ⊆ s      : sub,
  have := calc U ⊆ closure (i '' (i ⁻¹' U)) : self_sub_closure_image_preimage_of_open di U_op
             ... ⊆ closure (i '' s)         : closure_mono (image_subset i this),
  have U_nhd : U ∈ 𝓝 (i a) := mem_nhds_sets U_op e_a_in_U,
  exact (𝓝 (i a)).sets_of_superset U_nhd this
end

/-- The product of two dense inducings is a dense inducing -/
protected lemma prod [topological_space γ] [topological_space δ]
  {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_inducing e₁) (de₂ : dense_inducing e₂) :
  dense_inducing (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ induced := (de₁.to_inducing.prod_mk de₂.to_inducing).induced,
  dense := de₁.dense.prod_map de₂.dense }

open topological_space

/-- If the domain of a `dense_inducing` map is a separable space, then so is the codomain. -/
protected lemma separable_space [separable_space α] : separable_space β :=
di.dense.separable_space di.continuous

variables [topological_space δ] {f : γ → α} {g : γ → δ} {h : δ → β}
/--
 γ -f→ α
g↓     ↓e
 δ -h→ β
-/
lemma tendsto_comap_nhds_nhds  {d : δ} {a : α} (di : dense_inducing i)
  (H : tendsto h (𝓝 d) (𝓝 (i a))) (comm : h ∘ g = i ∘ f) : tendsto f (comap g (𝓝 d)) (𝓝 a) :=
begin
  have lim1 : map g (comap g (𝓝 d)) ≤ 𝓝 d := map_comap_le,
  replace lim1 : map h (map g (comap g (𝓝 d))) ≤ map h (𝓝 d) := map_mono lim1,
  rw [filter.map_map, comm, ← filter.map_map, map_le_iff_le_comap] at lim1,
  have lim2 :  comap i (map h (𝓝 d)) ≤  comap i  (𝓝 (i a)) := comap_mono H,
  rw ← di.nhds_eq_comap at lim2,
  exact le_trans lim1 lim2,
end

protected lemma nhds_within_ne_bot (di : dense_inducing i) (b : β) :
  ne_bot (𝓝[range i] b) :=
di.dense.nhds_within_ne_bot b

lemma comap_nhds_ne_bot (di : dense_inducing i) (b : β) : ne_bot (comap i (𝓝 b)) :=
comap_ne_bot $ λ s hs,
let ⟨_, ⟨ha, a, rfl⟩⟩ := mem_closure_iff_nhds.1 (di.dense b) s hs in ⟨a, ha⟩

variables [topological_space γ]

/-- If `i : α → β` is a dense inducing, then any function `f : α → γ` "extends"
  to a function `g = extend di f : β → γ`. If `γ` is Hausdorff and `f` has a
  continuous extension, then `g` is the unique such extension. In general,
  `g` might not be continuous or even extend `f`. -/
def extend (di : dense_inducing i) (f : α → γ) (b : β) : γ :=
@@lim _ ⟨f (di.dense.some b)⟩ (comap i (𝓝 b)) f

lemma extend_eq_of_tendsto [t2_space γ] {b : β} {c : γ} {f : α → γ}
  (hf : tendsto f (comap i (𝓝 b)) (𝓝 c)) :
  di.extend f b = c :=
by haveI := di.comap_nhds_ne_bot; exact hf.lim_eq

lemma extend_eq_at [t2_space γ] {f : α → γ} (a : α) (hf : continuous_at f a) :
  di.extend f (i a) = f a :=
extend_eq_of_tendsto _ $ di.nhds_eq_comap a ▸ hf

lemma extend_eq [t2_space γ] {f : α → γ} (hf : continuous f) (a : α) :
  di.extend f (i a) = f a :=
di.extend_eq_at a hf.continuous_at

lemma extend_unique_at [t2_space γ] {b : β} {f : α → γ} {g : β → γ} (di : dense_inducing i)
  (hf : ∀ᶠ x in comap i (𝓝 b), g (i x) = f x) (hg : continuous_at g b) :
  di.extend f b = g b :=
begin
  refine di.extend_eq_of_tendsto (λ s hs, mem_map.2 _),
  suffices : ∀ᶠ (x : α) in comap i (𝓝 b), g (i x) ∈ s,
    from hf.mp (this.mono $ λ x hgx hfx, hfx ▸ hgx),
  clear hf f,
  refine eventually_comap.2 ((hg.eventually hs).mono _),
  rintros _ hxs x rfl,
  exact hxs
end

lemma extend_unique [t2_space γ] {f : α → γ} {g : β → γ} (di : dense_inducing i)
  (hf : ∀ x, g (i x) = f x) (hg : continuous g) :
  di.extend f = g :=
funext $ λ b, extend_unique_at di (eventually_of_forall hf) hg.continuous_at

lemma continuous_at_extend [regular_space γ] {b : β} {f : α → γ} (di : dense_inducing i)
  (hf : ∀ᶠ x in 𝓝 b, ∃c, tendsto f (comap i $ 𝓝 x) (𝓝 c)) :
  continuous_at (di.extend f) b :=
begin
  set φ := di.extend f,
  haveI := di.comap_nhds_ne_bot,
  suffices : ∀ V' ∈ 𝓝 (φ b), is_closed V' → φ ⁻¹' V' ∈ 𝓝 b,
    by simpa [continuous_at, (closed_nhds_basis _).tendsto_right_iff],
  intros V' V'_in V'_closed,
  set V₁ := {x | tendsto f (comap i $ 𝓝 x) (𝓝 $ φ x)},
  have V₁_in : V₁ ∈ 𝓝 b,
  { filter_upwards [hf],
    rintros x ⟨c, hc⟩,
    dsimp [V₁, φ],
    rwa di.extend_eq_of_tendsto hc },
  obtain ⟨V₂, V₂_in, V₂_op, hV₂⟩ : ∃ V₂ ∈ 𝓝 b, is_open V₂ ∧ ∀ x ∈ i ⁻¹' V₂, f x ∈ V',
  { simpa [and_assoc] using ((nhds_basis_opens' b).comap i).tendsto_left_iff.mp
                            (mem_of_nhds V₁_in : b ∈ V₁) V' V'_in },
  suffices : ∀ x ∈ V₁ ∩ V₂, φ x ∈ V',
  { filter_upwards [inter_mem_sets V₁_in V₂_in], exact this },
  rintros x ⟨x_in₁, x_in₂⟩,
  have hV₂x : V₂ ∈ 𝓝 x := mem_nhds_sets V₂_op x_in₂,
  apply V'_closed.mem_of_tendsto x_in₁,
  use V₂,
  tauto,
end

lemma continuous_extend [regular_space γ] {f : α → γ} (di : dense_inducing i)
  (hf : ∀b, ∃c, tendsto f (comap i (𝓝 b)) (𝓝 c)) : continuous (di.extend f) :=
continuous_iff_continuous_at.mpr $ assume b, di.continuous_at_extend $ univ_mem_sets' hf

lemma mk'
  (i : α → β)
  (c     : continuous i)
  (dense : ∀x, x ∈ closure (range i))
  (H     : ∀ (a:α) s ∈ 𝓝 a,
    ∃t ∈ 𝓝 (i a), ∀ b, i b ∈ t → b ∈ s) :
  dense_inducing i :=
{ induced := (induced_iff_nhds_eq i).2 $
    λ a, le_antisymm (tendsto_iff_comap.1 $ c.tendsto _) (by simpa [le_def] using H a),
  dense := dense }
end dense_inducing

/-- A dense embedding is an embedding with dense image. -/
structure dense_embedding [topological_space α] [topological_space β] (e : α → β)
  extends dense_inducing e : Prop :=
(inj : function.injective e)

theorem dense_embedding.mk'
  [topological_space α] [topological_space β] (e : α → β)
  (c     : continuous e)
  (dense : dense_range e)
  (inj   : function.injective e)
  (H     : ∀ (a:α) s ∈ 𝓝 a,
    ∃t ∈ 𝓝 (e a), ∀ b, e b ∈ t → b ∈ s) :
  dense_embedding e :=
{ inj := inj,
  ..dense_inducing.mk' e c dense H}

namespace dense_embedding
open topological_space
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]
variables {e : α → β} (de : dense_embedding e)

lemma inj_iff {x y} : e x = e y ↔ x = y := de.inj.eq_iff

lemma to_embedding : embedding e :=
{ induced := de.induced,
  inj := de.inj }

/-- If the domain of a `dense_embedding` is a separable space, then so is its codomain. -/
protected lemma separable_space [separable_space α] : separable_space β :=
de.to_dense_inducing.separable_space

/-- The product of two dense embeddings is a dense embedding. -/
protected lemma prod {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_embedding e₁)
  (de₂ : dense_embedding e₂) :
  dense_embedding (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ inj := assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    by simp; exact assume h₁ h₂, ⟨de₁.inj h₁, de₂.inj h₂⟩,
  ..dense_inducing.prod de₁.to_dense_inducing de₂.to_dense_inducing }

/-- The dense embedding of a subtype inside its closure. -/
def subtype_emb {α : Type*} (p : α → Prop) (e : α → β) (x : {x // p x}) :
  {x // x ∈ closure (e '' {x | p x})} :=
⟨e x, subset_closure $ mem_image_of_mem e x.prop⟩

protected lemma subtype (p : α → Prop) : dense_embedding (subtype_emb p e) :=
{ dense_embedding .
  dense   := assume ⟨x, hx⟩, closure_subtype.mpr $
    have (λ (x : {x // p x}), e x) = e ∘ coe, from rfl,
    begin
      rw ← image_univ,
      simp [(image_comp _ _ _).symm, (∘), subtype_emb, -image_univ],
      rw [this, image_comp, subtype.coe_image],
      simp,
      assumption
    end,
  inj     := assume ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq $ de.inj $ @@congr_arg subtype.val h,
  induced := (induced_iff_nhds_eq _).2 (assume ⟨x, hx⟩,
    by simp [subtype_emb, nhds_subtype_eq_comap, de.to_inducing.nhds_eq_comap, comap_comap, (∘)]) }

end dense_embedding

lemma is_closed_property [topological_space β] {e : α → β} {p : β → Prop}
  (he : dense_range e) (hp : is_closed {x | p x}) (h : ∀a, p (e a)) :
  ∀b, p b :=
have univ ⊆ {b | p b},
  from calc univ = closure (range e) : he.closure_range.symm
    ... ⊆ closure {b | p b} : closure_mono $ range_subset_iff.mpr h
    ... = _ : hp.closure_eq,
assume b, this trivial

lemma is_closed_property2 [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂)) :
  ∀b₁ b₂, p b₁ b₂ :=
have ∀q:β×β, p q.1 q.2,
  from is_closed_property (he.prod_map he) hp $ λ _, h _ _,
assume b₁ b₂, this ⟨b₁, b₂⟩

lemma is_closed_property3 [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2})
  (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃)) :
  ∀b₁ b₂ b₃, p b₁ b₂ b₃ :=
have ∀q:β×β×β, p q.1 q.2.1 q.2.2,
  from is_closed_property (he.prod_map $ he.prod_map he) hp $ λ _, h _ _ _,
assume b₁ b₂ b₃, this ⟨b₁, b₂, b₃⟩

@[elab_as_eliminator]
lemma dense_range.induction_on [topological_space β] {e : α → β} (he : dense_range e) {p : β → Prop}
  (b₀ : β) (hp : is_closed {b | p b}) (ih : ∀a:α, p $ e a) : p b₀ :=
is_closed_property he hp ih b₀

@[elab_as_eliminator]
lemma dense_range.induction_on₂ [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂))
  (b₁ b₂ : β) : p b₁ b₂ := is_closed_property2 he hp h _ _

@[elab_as_eliminator]
lemma dense_range.induction_on₃ [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2})
  (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃))
  (b₁ b₂ b₃ : β) : p b₁ b₂ b₃ := is_closed_property3 he hp h _ _ _

section
variables [topological_space β] [topological_space γ] [t2_space γ]
variables {f : α → β}

/-- Two continuous functions to a t2-space that agree on the dense range of a function are equal. -/
lemma dense_range.equalizer (hfd : dense_range f)
  {g h : β → γ} (hg : continuous g) (hh : continuous h) (H : g ∘ f = h ∘ f) :
  g = h :=
funext $ λ y, hfd.induction_on y (is_closed_eq hg hh) $ congr_fun H
end