/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.associated
import algebra.big_operators.basic
/-!
# Prime elements in rings
This file contains lemmas about prime elements of commutative rings.
-/

section cancel_comm_monoid_with_zero

variables {R : Type*} [cancel_comm_monoid_with_zero R]
open finset

open_locale big_operators

/-- If `x * y = a * ∏ i in s, p i` where `p i` is always prime, then
  `x` and `y` can both be written as a divisor of `a` multiplied by
  a product over a subset of `s`  -/
lemma mul_eq_mul_prime_prod {α : Type*} [decidable_eq α] {x y a : R} {s : finset α}
  {p : α → R} (hp : ∀ i ∈ s, prime (p i)) (hx : x * y = a * ∏ i in s, p i) :
  ∃ (t u : finset α) (b c : R),
      t ∪ u = s
    ∧ disjoint t u
    ∧ a = b * c
    ∧ x = b * ∏ i in t, p i
    ∧ y = c * ∏ i in u, p i :=
begin
  induction s using finset.induction with i s his ih generalizing x y a,
  { exact ⟨∅, ∅, x, y, by simp [hx]⟩ },
  { rw [prod_insert his, ← mul_assoc] at hx,
    have hpi : prime (p i), { exact hp i (mem_insert_self _ _) },
    rcases ih (λ i hi, hp i (mem_insert_of_mem hi)) hx with
      ⟨t, u, b, c, htus, htu, hbc, rfl, rfl⟩,
    have hit : i ∉ t, from λ hit, his (htus ▸ mem_union_left _ hit),
    have hiu : i ∉ u, from λ hiu, his (htus ▸ mem_union_right _ hiu),
    obtain ⟨d, rfl⟩ | ⟨d, rfl⟩ : p i ∣ b ∨ p i ∣ c,
      from hpi.dvd_or_dvd ⟨a, by rw [← hbc, mul_comm]⟩,
    { rw [mul_assoc, mul_comm a, mul_right_inj' hpi.ne_zero] at hbc,
      exact ⟨insert i t, u, d, c, by rw [insert_union, htus],
        disjoint_insert_left.2 ⟨hiu, htu⟩,
          by simp [hbc, prod_insert hit, mul_assoc, mul_comm, mul_left_comm]⟩ },
    { rw [← mul_assoc, mul_right_comm b, mul_left_inj' hpi.ne_zero] at hbc,
      exact ⟨t, insert i u, b, d, by rw [union_insert, htus],
        disjoint_insert_right.2 ⟨hit, htu⟩,
          by simp [← hbc, prod_insert hiu, mul_assoc, mul_comm, mul_left_comm]⟩ } }
end

/-- If ` x * y = a * p ^ n` where `p` is prime, then `x` and `y` can both be written
  as the product of a power of `p` and a divisor of `a`. -/
lemma mul_eq_mul_prime_pow {x y a p : R} {n : ℕ} (hp : prime p) (hx : x * y = a * p ^ n) :
  ∃ (i j : ℕ) (b c : R),
    i + j = n
  ∧ a = b * c
  ∧ x = b * p ^ i
  ∧ y = c * p ^ j :=
begin
  rcases mul_eq_mul_prime_prod (λ _ _, hp)
    (show x * y = a * (range n).prod (λ _, p), by simpa) with
    ⟨t, u, b, c, htus, htu, rfl, rfl, rfl⟩,
  exact ⟨t.card, u.card, b, c, by rw [← card_disjoint_union htu, htus, card_range], by simp⟩,
end

end cancel_comm_monoid_with_zero

section comm_ring

variables {α : Type*} [comm_ring α]

lemma prime.neg {p : α} (hp : prime p) : prime (-p) :=
begin
  obtain ⟨h1, h2, h3⟩ := hp,
  exact ⟨neg_ne_zero.mpr h1, by rwa is_unit.neg_iff, by simpa [neg_dvd] using h3⟩
end

lemma prime.abs [linear_order α] {p : α} (hp : prime p) : prime (abs p) :=
begin
  obtain h|h := abs_choice p; rw h,
  { exact hp },
  { exact hp.neg }
end

end comm_ring


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

Functions on lists of sigma types.
-/
import data.list.perm
import data.list.range
import data.sigma

universes u v

namespace list
variables {α : Type u} {β : α → Type v}

/- keys -/

/-- List of keys from a list of key-value pairs -/
def keys : list (sigma β) → list α :=
map sigma.fst

@[simp] theorem keys_nil : @keys α β [] = [] :=
rfl

@[simp] theorem keys_cons {s} {l : list (sigma β)} : (s :: l).keys = s.1 :: l.keys :=
rfl

theorem mem_keys_of_mem {s : sigma β} {l : list (sigma β)} : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {a} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a} {l : list (sigma β)} : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

theorem not_mem_keys {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ b : β a, sigma.mk a b ∉ l :=
(not_iff_not_of_iff mem_keys).trans not_exists

theorem not_eq_key {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ s : sigma β, s ∈ l → a ≠ s.1 :=
iff.intro
  (λ h₁ s h₂ e, absurd (mem_keys_of_mem h₂) (by rwa e at h₁))
  (λ f h₁, let ⟨b, h₂⟩ := exists_of_mem_keys h₁ in f _ h₂ rfl)

/- nodupkeys -/

def nodupkeys (l : list (sigma β)) : Prop :=
l.keys.nodup

theorem nodupkeys_iff_pairwise {l} : nodupkeys l ↔
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l := pairwise_map _

theorem nodupkeys.pairwise_ne {l} (h : nodupkeys l) :
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l :=
nodupkeys_iff_pairwise.1 h

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] := pairwise.nil

@[simp] theorem nodupkeys_cons {s : sigma β} {l : list (sigma β)} :
  nodupkeys (s::l) ↔ s.1 ∉ l.keys ∧ nodupkeys l :=
by simp [keys, nodupkeys]

theorem nodupkeys.eq_of_fst_eq {l : list (sigma β)}
  (nd : nodupkeys l) {s s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) :
  s.1 = s'.1 → s = s' :=
@forall_of_forall_of_pairwise _
  (λ s s' : sigma β, s.1 = s'.1 → s = s')
  (λ s s' H h, (H h.symm).symm) _ (λ x h _, rfl)
  ((nodupkeys_iff_pairwise.1 nd).imp (λ s s' h h', (h h').elim)) _ h _ h'

theorem nodupkeys.eq_of_mk_mem {a : α} {b b' : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' :=
by cases nd.eq_of_fst_eq h h' rfl; refl

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] := nodup_singleton _

theorem nodupkeys_of_sublist {l₁ l₂ : list (sigma β)} (h : l₁ <+ l₂) :
  nodupkeys l₂ → nodupkeys l₁ :=
nodup_of_sublist (h.map _)

theorem nodup_of_nodupkeys {l : list (sigma β)} : nodupkeys l → nodup l :=
nodup_of_nodup_map _

theorem perm_nodupkeys {l₁ l₂ : list (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
(h.map _).nodup_iff

theorem nodupkeys_join {L : list (list (sigma β))} :
  nodupkeys (join L) ↔ (∀ l ∈ L, nodupkeys l) ∧ pairwise disjoint (L.map keys) :=
begin
  rw [nodupkeys_iff_pairwise, pairwise_join, pairwise_map],
  refine and_congr (ball_congr $ λ l h, by simp [nodupkeys_iff_pairwise]) _,
  apply iff_of_eq, congr' with l₁ l₂,
  simp [keys, disjoint_iff_ne]
end

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

lemma mem_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodup) (nd₁ : l₁.nodup)
  (h : ∀ x, x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
begin
  induction l₀ with x xs generalizing l₁; cases l₁ with y ys,
  { constructor },
  iterate 2
  { specialize h x <|> specialize h y, simp at h,
    cases h },
  simp at nd₀ nd₁, classical,
  cases nd₀, cases nd₁,
  by_cases h' : x = y,
  { subst y, constructor, apply l₀_ih ‹ _ › ‹ nodup ys ›,
    intro a, specialize h a, simp at h,
    by_cases h' : a = x,
    { subst a, rw ← not_iff_not, split; intro; assumption },
    { simp [h'] at h, exact h } },
  { transitivity x :: y :: ys.erase x,
    { constructor, apply l₀_ih ‹ _ ›,
      { simp, split, { intro, apply nd₁_left, apply mem_of_mem_erase ‹_› },
        apply nodup_erase_of_nodup; assumption },
      { intro a, specialize h a, simp at h,
        by_cases h' : a = x,
        { subst a, rw ← not_iff_not, split; intro, simp [mem_erase_of_nodup,*], assumption },
        { simp [h'] at h, simp [h], apply or_congr, refl,
          simp [mem_erase_of_ne,*] } } },
    transitivity y :: x :: ys.erase x,
    { constructor },
    { constructor, symmetry, apply perm_cons_erase,
      specialize h x, simp [h'] at h, exact h } }
end

variables [decidable_eq α]

/- lookup -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup (a : α) : list (sigma β) → option (β a)
| []             := none
| (⟨a', b⟩ :: l) := if h : a' = a then some (eq.rec_on h b) else lookup l

@[simp] theorem lookup_nil (a : α) : lookup a [] = @none (β a) := rfl

@[simp] theorem lookup_cons_eq (l) (a : α) (b : β a) : lookup a (⟨a, b⟩::l) = some b :=
dif_pos rfl

@[simp] theorem lookup_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup a (s::l) = lookup a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_is_some {a : α} : ∀ {l : list (sigma β)},
  (lookup a l).is_some ↔ a ∈ l.keys
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_is_some] },
end

theorem lookup_eq_none {a : α} {l : list (sigma β)} :
  lookup a l = none ↔ a ∉ l.keys :=
by simp [← lookup_is_some, option.is_none_iff_eq_none]

theorem of_mem_lookup
  {a : α} {b : β a} : ∀ {l : list (sigma β)}, b ∈ lookup a l → sigma.mk a b ∈ l
| (⟨a', b'⟩ :: l) H := begin
  by_cases h : a = a',
  { subst a', simp at H, simp [H] },
  { simp [h] at H, exact or.inr (of_mem_lookup H) }
end

theorem mem_lookup {a} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys)
  (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
begin
  cases option.is_some_iff_exists.mp (lookup_is_some.mpr (mem_keys_of_mem h)) with b' h',
  cases nd.eq_of_mk_mem h (of_mem_lookup h'),
  exact h'
end

theorem map_lookup_eq_find (a : α) : ∀ l : list (sigma β),
  (lookup a l).map (sigma.mk a) = find (λ s, a = s.1) l
| [] := rfl
| (⟨a', b'⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, map_lookup_eq_find] }
end

theorem mem_lookup_iff {a : α} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys) :
  b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
⟨of_mem_lookup, mem_lookup nd⟩

theorem perm_lookup (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ :=
by ext b; simp [mem_lookup_iff, nd₁, nd₂]; exact p.mem_iff

lemma lookup_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodupkeys) (nd₁ : l₁.nodupkeys)
  (h : ∀ x y, y ∈ l₀.lookup x ↔ y ∈ l₁.lookup x) : l₀ ~ l₁ :=
mem_ext (nodup_of_nodupkeys nd₀) (nodup_of_nodupkeys nd₁)
  (λ ⟨a,b⟩, by rw [← mem_lookup_iff, ← mem_lookup_iff, h]; assumption)

/- lookup_all -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all (a : α) : list (sigma β) → list (β a)
| []             := []
| (⟨a', b⟩ :: l) := if h : a' = a then eq.rec_on h b :: lookup_all l else lookup_all l

@[simp]

@[simp] theorem lookup_all_cons_eq (l) (a : α) (b : β a) :
  lookup_all a (⟨a, b⟩::l) = b :: lookup_all a l :=
dif_pos rfl

@[simp] theorem lookup_all_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup_all a (s::l) = lookup_all a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_all_eq_nil {a : α} : ∀ {l : list (sigma β)},
  lookup_all a l = [] ↔ ∀ b : β a, sigma.mk a b ∉ l
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_all_eq_nil] },
end

theorem head_lookup_all (a : α) : ∀ l : list (sigma β),
  head' (lookup_all a l) = lookup a l
| []             := by simp
| (⟨a', b⟩ :: l) := by by_cases h : a = a'; [{subst h, simp}, simp *]

theorem mem_lookup_all {a : α} {b : β a} :
  ∀ {l : list (sigma β)}, b ∈ lookup_all a l ↔ sigma.mk a b ∈ l
| []              := by simp
| (⟨a', b'⟩ :: l) := by by_cases h : a = a'; [{subst h, simp *}, simp *]

theorem lookup_all_sublist (a : α) :
  ∀ l : list (sigma β), (lookup_all a l).map (sigma.mk a) <+ l
| []              := by simp
| (⟨a', b'⟩ :: l) := begin
    by_cases h : a = a',
    { subst h, simp, exact (lookup_all_sublist l).cons2 _ _ _ },
    { simp [h], exact (lookup_all_sublist l).cons _ _ _ }
  end

theorem lookup_all_length_le_one (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  length (lookup_all a l) ≤ 1 :=
by have := nodup_of_sublist ((lookup_all_sublist a l).map _) h;
   rw map_map at this; rwa [← nodup_repeat, ← map_const _ a]

theorem lookup_all_eq_lookup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  lookup_all a l = (lookup a l).to_list :=
begin
  rw ← head_lookup_all,
  have := lookup_all_length_le_one a h, revert this,
  rcases lookup_all a l with _|⟨b, _|⟨c, l⟩⟩; intro; try {refl},
  exact absurd this dec_trivial
end

theorem lookup_all_nodup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  (lookup_all a l).nodup :=
by rw lookup_all_eq_lookup a h; apply option.to_list_nodup

theorem perm_lookup_all (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ :=
by simp [lookup_all_eq_lookup, nd₁, nd₂, perm_lookup a nd₁ nd₂ p]

/- kreplace -/

def kreplace (a : α) (b : β a) : list (sigma β) → list (sigma β) :=
lookmap $ λ s, if h : a = s.1 then some ⟨a, b⟩ else none

theorem kreplace_of_forall_not (a : α) (b : β a) {l : list (sigma β)}
  (H : ∀ b : β a, sigma.mk a b ∉ l) : kreplace a b l = l :=
lookmap_of_forall_not _ $ begin
  rintro ⟨a', b'⟩ h, dsimp, split_ifs,
  { subst a', exact H _ h }, {refl}
end

theorem kreplace_self {a : α} {b : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
begin
  refine (lookmap_congr _).trans
    (lookmap_id' (option.guard (λ s, a = s.1)) _ _),
  { rintro ⟨a', b'⟩ h', dsimp [option.guard], split_ifs,
    { subst a', exact ⟨rfl, heq_of_eq $ nd.eq_of_mk_mem h h'⟩ },
    { refl } },
  { rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, dsimp [option.guard], split_ifs,
    { subst a₁, rintro ⟨⟩, simp }, { rintro ⟨⟩ } },
end

theorem keys_kreplace (a : α) (b : β a) : ∀ l : list (sigma β),
  (kreplace a b l).keys = l.keys :=
lookmap_map_eq _ _ $ by rintro ⟨a₁, b₂⟩ ⟨a₂, b₂⟩;
  dsimp; split_ifs; simp [h] {contextual := tt}

theorem kreplace_nodupkeys (a : α) (b : β a) {l : list (sigma β)} :
  (kreplace a b l).nodupkeys ↔ l.nodupkeys :=
by simp [nodupkeys, keys_kreplace]

theorem perm.kreplace {a : α} {b : β a} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ →
  kreplace a b l₁ ~ kreplace a b l₂ :=
perm_lookmap _ $ begin
  refine nd.pairwise_ne.imp _,
  intros x y h z h₁ w h₂,
  split_ifs at h₁ h₂; cases h₁; cases h₂,
  exact (h (h_2.symm.trans h_1)).elim
end

/- kerase -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : list (sigma β) → list (sigma β) :=
erasep $ λ s, a = s.1

@[simp] theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
rfl

@[simp, priority 990]
theorem kerase_cons_eq {a} {s : sigma β} {l : list (sigma β)} (h : a = s.1) :
  kerase a (s :: l) = l :=
by simp [kerase, h]

@[simp, priority 990]
theorem kerase_cons_ne {a} {s : sigma β} {l : list (sigma β)} (h : a ≠ s.1) :
  kerase a (s :: l) = s :: kerase a l :=
by simp [kerase, h]

@[simp, priority 980]
theorem kerase_of_not_mem_keys {a} {l : list (sigma β)} (h : a ∉ l.keys) :
  kerase a l = l :=
by induction l with _ _ ih;
   [refl, { simp [not_or_distrib] at h, simp [h.1, ih h.2] }]

theorem kerase_sublist (a : α) (l : list (sigma β)) : kerase a l <+ l :=
erasep_sublist _

theorem kerase_keys_subset (a) (l : list (sigma β)) :
  (kerase a l).keys ⊆ l.keys :=
((kerase_sublist a l).map _).subset

theorem mem_keys_of_mem_keys_kerase {a₁ a₂} {l : list (sigma β)} :
  a₁ ∈ (kerase a₂ l).keys → a₁ ∈ l.keys :=
@kerase_keys_subset _ _ _ _ _ _

theorem exists_of_kerase {a : α} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    kerase a l = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih {
    by_cases e : a = hd.1,
    { subst e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h e },
      case or.inr : h {
        rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem e h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

@[simp, priority 990]
theorem mem_keys_kerase_of_ne {a₁ a₂} {l : list (sigma β)} (h : a₁ ≠ a₂) :
  a₁ ∈ (kerase a₂ l).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, kerase a₂ l, exists_of_kerase q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [keys, h] using p
    end
  else
    by simp [q, p]

theorem keys_kerase {a} {l : list (sigma β)} : (kerase a l).keys = l.keys.erase a :=
by rw [keys, kerase, ←erasep_map sigma.fst l, erase_eq_erasep]

theorem kerase_kerase {a a'} {l : list (sigma β)} :
  (kerase a' l).kerase a = (kerase a l).kerase a' :=
begin
  by_cases a = a',
  { subst a' },
  induction l with x xs, { refl },
  { by_cases a' = x.1,
    { subst a', simp [kerase_cons_ne h,kerase_cons_eq rfl] },
    by_cases h' : a = x.1,
    { subst a, simp [kerase_cons_eq rfl,kerase_cons_ne (ne.symm h)] },
    { simp [kerase_cons_ne,*] } }
end

theorem kerase_nodupkeys (a : α) {l : list (sigma β)} : nodupkeys l → (kerase a l).nodupkeys :=
nodupkeys_of_sublist $ kerase_sublist _ _

theorem perm.kerase {a : α} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
perm.erasep _ $ (nodupkeys_iff_pairwise.1 nd).imp $
by rintro x y h rfl; exact h

@[simp] theorem not_mem_keys_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  a ∉ (kerase a l).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h : a = hd.1,
    { subst h, simp [nd.1] },
    { simp [h, ih nd.2] } }
end

@[simp] theorem lookup_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  lookup a (kerase a l) = none :=
lookup_eq_none.mpr (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {a a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kerase a' l) = lookup a l :=
begin
  induction l,
  case list.nil { refl },
  case list.cons : hd tl ih {
    cases hd with ah bh,
    by_cases h₁ : a = ah; by_cases h₂ : a' = ah,
    { substs h₁ h₂, cases ne.irrefl h },
    { subst h₁, simp [h₂] },
    { subst h₂, simp [h] },
    { simp [h₁, h₂, ih] }
  }
end

theorem kerase_append_left {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂
| []        _  h  := by cases h
| (s :: l₁) l₂ h₁ :=
  if h₂ : a = s.1 then
    by simp [h₂]
  else
    by simp at h₁;
       cases h₁;
       [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂
| []        _  h := rfl
| (_ :: l₁) l₂ h := by simp [not_or_distrib] at h;
                       simp [h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂) (l : list (sigma β)) :
  kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
if h : a₁ = a₂ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, kerase a₁ l, exists_of_kerase ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

lemma sizeof_kerase {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)] (x : α)
  (xs : list (sigma β)) :
  sizeof (list.kerase x xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with y ys,
  { simp },
  { by_cases x = y.1; simp [*, list.sizeof] },
end

/- kinsert -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert (a : α) (b : β a) (l : list (sigma β)) : list (sigma β) :=
⟨a, b⟩ :: kerase a l

@[simp] theorem kinsert_def {a} {b : β a} {l : list (sigma β)} :
  kinsert a b l = ⟨a, b⟩ :: kerase a l := rfl

theorem mem_keys_kinsert {a a'} {b' : β a'} {l : list (sigma β)} :
  a ∈ (kinsert a' b' l).keys ↔ a = a' ∨ a ∈ l.keys :=
by by_cases h : a = a'; simp [h]

theorem kinsert_nodupkeys (a) (b : β a) {l : list (sigma β)} (nd : l.nodupkeys) :
  (kinsert a b l).nodupkeys :=
nodupkeys_cons.mpr ⟨not_mem_keys_kerase a nd, kerase_nodupkeys a nd⟩

theorem perm.kinsert {a} {b : β a} {l₁ l₂ : list (sigma β)} (nd₁ : l₁.nodupkeys)
  (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
(p.kerase nd₁).cons _

theorem lookup_kinsert {a} {b : β a} (l : list (sigma β)) :
  lookup a (kinsert a b l) = some b :=
by simp only [kinsert, lookup_cons_eq]

theorem lookup_kinsert_ne {a a'} {b' : β a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kinsert a' b' l) = lookup a l :=
by simp [h]

/- kextract -/

def kextract (a : α) : list (sigma β) → option (β a) × list (sigma β)
| []     := (none, [])
| (s::l) := if h : s.1 = a then (some (eq.rec_on h s.2), l) else
  let (b', l') := kextract l in (b', s :: l')

@[simp] theorem kextract_eq_lookup_kerase (a : α) :
  ∀ l : list (sigma β), kextract a l = (lookup a l, kerase a l)
| []     := rfl
| (⟨a', b⟩::l) := begin
    simp [kextract], dsimp, split_ifs,
    { subst a', simp [kerase] },
    { simp [kextract, ne.symm h, kextract_eq_lookup_kerase l, kerase] }
  end

/- erase_dupkeys -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def erase_dupkeys : list (sigma β) → list (sigma β) :=
list.foldr (λ x, kinsert x.1 x.2) []

lemma erase_dupkeys_cons {x : sigma β} (l : list (sigma β)) :
  erase_dupkeys (x :: l) = kinsert x.1 x.2 (erase_dupkeys l) := rfl

lemma nodupkeys_erase_dupkeys (l : list (sigma β)) : nodupkeys (erase_dupkeys l) :=
begin
  dsimp [erase_dupkeys], generalize hl : nil = l',
  have : nodupkeys l', { rw ← hl, apply nodup_nil },
  clear hl,
  induction l with x xs,
  { apply this },
  { cases x, simp [erase_dupkeys], split,
    { simp [keys_kerase], apply mem_erase_of_nodup l_ih },
    apply kerase_nodupkeys _ l_ih, }
end

lemma lookup_erase_dupkeys (a : α) (l : list (sigma β)) : lookup a (erase_dupkeys l) = lookup a l :=
begin
  induction l, refl,
  cases l_hd with a' b,
  by_cases a = a',
  { subst a', rw [erase_dupkeys_cons,lookup_kinsert,lookup_cons_eq] },
  { rw [erase_dupkeys_cons,lookup_kinsert_ne h,l_ih,lookup_cons_ne], exact h },
end

lemma sizeof_erase_dupkeys {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)]
  (xs : list (sigma β)) :
  sizeof (list.erase_dupkeys xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with x xs,
  { simp [list.erase_dupkeys] },
  { simp only [erase_dupkeys_cons, list.sizeof, kinsert_def, add_le_add_iff_left, sigma.eta],
    transitivity, apply sizeof_kerase,
    assumption }
end

/- kunion -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion : list (sigma β) → list (sigma β) → list (sigma β)
| []        l₂ := l₂
| (s :: l₁) l₂ := s :: kunion l₁ (kerase s.1 l₂)

@[simp] theorem nil_kunion {l : list (sigma β)} : kunion [] l = l :=
rfl

@[simp] theorem kunion_nil : ∀ {l : list (sigma β)}, kunion l [] = l
| []       := rfl
| (_ :: l) := by rw [kunion, kerase_nil, kunion_nil]

@[simp] theorem kunion_cons {s} {l₁ l₂ : list (sigma β)} :
  kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase s.1 l₂) :=
rfl

@[simp] theorem mem_keys_kunion {a} {l₁ l₂ : list (sigma β)} :
  a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s l₁ ih { by_cases h : a = s.1; [simp [h], simp [h, ih]] }
end

@[simp] theorem kunion_kerase {a} : ∀ {l₁ l₂ : list (sigma β)},
  kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂)
| []       _ := rfl
| (s :: _) l := by by_cases h : a = s.1;
                   simp [h, kerase_comm a s.1 l, kunion_kerase]

theorem kunion_nodupkeys {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) : (kunion l₁ l₂).nodupkeys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp only [nil_kunion, nd₂] },
  case list.cons : s l₁ ih {
    simp at nd₁,
    simp [not_or_distrib, nd₁.1, nd₂, ih nd₁.2 (kerase_nodupkeys s.1 nd₂)] }
end

theorem perm.kunion_right {l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (l) :
  kunion l₁ l ~ kunion l₂ l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.cons : hd tl₁ tl₂ p ih {
    simp [ih (kerase hd.1 l), perm.cons] },
  case list.perm.swap : s₁ s₂ l {
    simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ {
    exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm.kunion_left : ∀ l {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
| []       _  _  _   p := p
| (s :: l) l₁ l₂ nd₁ p :=
  by simp [((p.kerase nd₁).kunion_left l (kerase_nodupkeys s.1 nd₁)).cons s]

theorem perm.kunion {l₁ l₂ l₃ l₄ : list (sigma β)} (nd₃ : l₃.nodupkeys)
  (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
(p₁₂.kunion_right l₃).trans (p₃₄.kunion_left l₂ nd₃)

@[simp] theorem lookup_kunion_left {a} {l₁ l₂ : list (sigma β)} (h : a ∈ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₁ :=
begin
  induction l₁ with s _ ih generalizing l₂; simp at h; cases h; cases s with a',
  { subst h, simp },
  { rw kunion_cons,
    by_cases h' : a = a',
    { subst h', simp },
    { simp [h', ih h] } }
end

@[simp] theorem lookup_kunion_right {a} {l₁ l₂ : list (sigma β)} (h : a ∉ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : _ _ ih { simp [not_or_distrib] at h, simp [h.1, ih h.2] }
end

@[simp] theorem mem_lookup_kunion {a} {b : β a} {l₁ l₂ : list (sigma β)} :
  b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s _ ih {
    cases s with a',
    by_cases h₁ : a = a',
    { subst h₁, simp },
    { let h₂ := @ih (kerase a' l₂), simp [h₁] at h₂, simp [h₁, h₂] } }
end

theorem mem_lookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : list (sigma β)}
  (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
  b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
match mem_lookup_kunion.mp h₁ with
| or.inl h := mem_lookup_kunion.mpr (or.inl (mem_lookup_kunion.mpr (or.inl h)))
| or.inr h := mem_lookup_kunion.mpr $
  or.inr ⟨mt mem_keys_kunion.mp (not_or_distrib.mpr ⟨h.1, h₂⟩), h.2⟩
end

end list


/-
Copyright (c) 2020 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.continued_fractions.computation.translations
import Mathlib.algebra.continued_fractions.continuants_recurrence
import Mathlib.algebra.continued_fractions.terminated_stable
import Mathlib.data.nat.fib
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Approximations for Continued Fraction Computations (`gcf.of`)

## Summary

Let us write `gcf` for `generalized_continued_fraction`. This file contains useful approximations
for the values involved in the continued fractions computation `gcf.of`.

## Main Theorems

- `gcf.of_part_num_eq_one`: shows that all partial numerators `aᵢ` are equal to one.
- `gcf.exists_int_eq_of_part_denom`: shows that all partial denominators `bᵢ` correspond to an integer.
- `gcf.one_le_of_nth_part_denom`: shows that `1 ≤ bᵢ`.
- `gcf.succ_nth_fib_le_of_nth_denom`: shows that the `n`th denominator `Bₙ` is greater than or equal to
  the `n + 1`th fibonacci number `nat.fib (n + 1)`.
- `gcf.le_of_succ_nth_denom`: shows that `Bₙ₊₁ ≥ bₙ * Bₙ`, where `bₙ` is the `n`th partial denominator
  of the continued fraction.

## References

- [*Hardy, GH and Wright, EM and Heath-Brown, Roger and Silverman, Joseph*][hardy2008introduction]
-/

namespace generalized_continued_fraction

/-
We begin with some lemmas about the stream of `int_fract_pair`s, which presumably are not
of great interest for the end user.
-/

namespace int_fract_pair

/-- Shows that the fractional parts of the stream are in `[0,1)`. -/
theorem nth_stream_fr_nonneg_lt_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {ifp_n : int_fract_pair K}
    (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) : 0 ≤ fr ifp_n ∧ fr ifp_n < 1 :=
  sorry

/-- Shows that the fractional parts of the stream are nonnegative. -/
theorem nth_stream_fr_nonneg {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {ifp_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) :
    0 ≤ fr ifp_n :=
  and.left (nth_stream_fr_nonneg_lt_one nth_stream_eq)

/-- Shows that the fractional parts of the stream smaller than one. -/
theorem nth_stream_fr_lt_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {ifp_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) :
    fr ifp_n < 1 :=
  and.right (nth_stream_fr_nonneg_lt_one nth_stream_eq)

/-- Shows that the integer parts of the stream are at least one. -/
theorem one_le_succ_nth_stream_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {ifp_succ_n : int_fract_pair K}
    (succ_nth_stream_eq : int_fract_pair.stream v (n + 1) = some ifp_succ_n) : 1 ≤ b ifp_succ_n :=
  sorry

/--
Shows that the `n + 1`th integer part `bₙ₊₁` of the stream is smaller or equal than the inverse of
the `n`th fractional part `frₙ` of the stream.
This result is straight-forward as `bₙ₊₁` is defined as the floor of `1 / frₙ`
-/
theorem succ_nth_stream_b_le_nth_stream_fr_inv {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {ifp_n : int_fract_pair K}
    {ifp_succ_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n)
    (succ_nth_stream_eq : int_fract_pair.stream v (n + 1) = some ifp_succ_n) :
    ↑(b ifp_succ_n) ≤ (fr ifp_n⁻¹) :=
  sorry

end int_fract_pair

/-
Next we translate above results about the stream of `int_fract_pair`s to the computed continued
fraction `gcf.of`.
-/

/-- Shows that the integer parts of the continued fraction are at least one. -/
theorem of_one_le_nth_part_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    1 ≤ b :=
  sorry

/--
Shows that the partial numerators `aᵢ` of the continued fraction are equal to one and the partial
denominators `bᵢ` correspond to integers.
-/
theorem of_part_num_eq_one_and_exists_int_part_denom_eq {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {gp : pair K}
    (nth_s_eq : seq.nth (s (generalized_continued_fraction.of v)) n = some gp) :
    pair.a gp = 1 ∧ ∃ (z : ℤ), pair.b gp = ↑z :=
  sorry

/-- Shows that the partial numerators `aᵢ` are equal to one. -/
theorem of_part_num_eq_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {a : K}
    (nth_part_num_eq :
      seq.nth (partial_numerators (generalized_continued_fraction.of v)) n = some a) :
    a = 1 :=
  sorry

/-- Shows that the partial denominators `bᵢ` correspond to an integer. -/
theorem exists_int_eq_of_part_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    ∃ (z : ℤ), b = ↑z :=
  sorry

/-
One of our next goals is to show that `Bₙ₊₁ ≥ bₙ * Bₙ`. For this, we first show that the partial
denominators `Bₙ` are bounded from below by the fibonacci sequence `nat.fib`. This then implies that
`0 ≤ Bₙ` and hence `Bₙ₊₂ = bₙ₊₁ * Bₙ₊₁ + Bₙ ≥ bₙ₊₁ * Bₙ₊₁ + 0 = bₙ₊₁ * Bₙ₊₁`.
-/

-- open `nat` as we will make use of fibonacci numbers.

theorem fib_le_of_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] :
    n ≤ 1 ∨ ¬terminated_at (generalized_continued_fraction.of v) (n - bit0 1) →
        ↑(nat.fib n) ≤ pair.b (continuants_aux (generalized_continued_fraction.of v) n) :=
  sorry

/-- Shows that the `n`th denominator is greater than or equal to the `n + 1`th fibonacci number,
that is `nat.fib (n + 1) ≤ Bₙ`. -/
theorem succ_nth_fib_le_of_nth_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] (hyp : n = 0 ∨ ¬terminated_at (generalized_continued_fraction.of v) (n - 1)) :
    ↑(nat.fib (n + 1)) ≤ denominators (generalized_continued_fraction.of v) n :=
  sorry

/- As a simple consequence, we can now derive that all denominators are nonnegative. -/

theorem zero_le_of_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] : 0 ≤ pair.b (continuants_aux (generalized_continued_fraction.of v) n) :=
  sorry

/-- Shows that all denominators are nonnegative. -/
theorem zero_le_of_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K] :
    0 ≤ denominators (generalized_continued_fraction.of v) n :=
  sorry

theorem le_of_succ_succ_nth_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    b * pair.b (continuants_aux (generalized_continued_fraction.of v) (n + 1)) ≤
        pair.b (continuants_aux (generalized_continued_fraction.of v) (n + bit0 1)) :=
  sorry

/-- Shows that `Bₙ₊₁ ≥ bₙ * Bₙ`, where `bₙ` is the `n`th partial denominator and `Bₙ₊₁` and `Bₙ` are
the `n + 1`th and `n`th denominator of the continued fraction. -/
theorem le_of_succ_nth_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    b * denominators (generalized_continued_fraction.of v) n ≤
        denominators (generalized_continued_fraction.of v) (n + 1) :=
  sorry

/-- Shows that the sequence of denominators is monotonically increasing, that is `Bₙ ≤ Bₙ₊₁`. -/
theorem of_denom_mono {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K] :
    denominators (generalized_continued_fraction.of v) n ≤
        denominators (generalized_continued_fraction.of v) (n + 1) :=
  sorry

end Mathlib


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.category.CommRing.basic
import algebra.ring.boolean_ring
import order.category.BoolAlg

/-!
# The category of Boolean rings

This file defines `BoolRing`, the category of Boolean rings.

## TODO

Finish the equivalence with `BoolAlg`.
-/

universes u

open category_theory order

/-- The category of Boolean rings. -/
def BoolRing := bundled boolean_ring

namespace BoolRing

instance : has_coe_to_sort BoolRing Type* := bundled.has_coe_to_sort
instance (X : BoolRing) : boolean_ring X := X.str

/-- Construct a bundled `BoolRing` from a `boolean_ring`. -/
def of (α : Type*) [boolean_ring α] : BoolRing := bundled.of α

@[simp] lemma coe_of (α : Type*) [boolean_ring α] : ↥(of α) = α := rfl

instance : inhabited BoolRing := ⟨of punit⟩

instance : bundled_hom.parent_projection @boolean_ring.to_comm_ring := ⟨⟩

attribute [derive [large_category, concrete_category]] BoolRing

@[simps] instance has_forget_to_CommRing : has_forget₂ BoolRing CommRing := bundled_hom.forget₂ _ _

/-- Constructs an isomorphism of Boolean rings from a ring isomorphism between them. -/
@[simps] def iso.mk {α β : BoolRing.{u}} (e : α ≃+* β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

end BoolRing

/-! ### Equivalence between `BoolAlg` and `BoolRing` -/

@[simps] instance BoolRing.has_forget_to_BoolAlg : has_forget₂ BoolRing BoolAlg :=
{ forget₂ := { obj := λ X, BoolAlg.of (as_boolalg X), map := λ X Y, ring_hom.as_boolalg } }


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot
-/
import group_theory.quotient_group
import order.filter.pointwise
import topology.algebra.monoid
import topology.compact_open
import topology.sets.compacts
import topology.algebra.constructions

/-!
# Topological groups

This file defines the following typeclasses:

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

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

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

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

## Tags

topological space, group, topological group
-/

open classical set filter topological_space function
open_locale classical topological_space filter pointwise

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

section continuous_mul_group

/-!
### Groups with continuous multiplication

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

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

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

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

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

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

@[to_additive is_open.left_add_coset]
lemma is_open.left_coset {U : set G} (h : is_open U) (x : G) : is_open (left_coset x U) :=
is_open_map_mul_left x _ h

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

@[to_additive is_closed.left_add_coset]
lemma is_closed.left_coset {U : set G} (h : is_closed U) (x : G) : is_closed (left_coset x U) :=
is_closed_map_mul_left x _ h

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

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

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

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

@[to_additive is_open.right_add_coset]
lemma is_open.right_coset {U : set G} (h : is_open U) (x : G) : is_open (right_coset U x) :=
is_open_map_mul_right x _ h

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

@[to_additive is_closed.right_add_coset]
lemma is_closed.right_coset {U : set G} (h : is_closed U) (x : G) : is_closed (right_coset U x) :=
is_closed_map_mul_right x _ h

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

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

end continuous_mul_group

/-!
### Topological operations on pointwise sums and products

A few results about interior and closure of the pointwise addition/multiplication of sets in groups
with continuous addition/multiplication. See also `submonoid.top_closure_mul_self_eq` in
`topology.algebra.monoid`.
-/

section pointwise
variables [topological_space α] [group α] [has_continuous_mul α] {s t : set α}

@[to_additive]
lemma is_open.mul_left (ht : is_open t) : is_open (s * t) :=
begin
  rw ←Union_mul_left_image,
  exact is_open_Union (λ a, is_open_Union $ λ ha, is_open_map_mul_left a t ht),
end

@[to_additive]
lemma is_open.mul_right (hs : is_open s) : is_open (s * t) :=
begin
  rw ←Union_mul_right_image,
  exact is_open_Union (λ a, is_open_Union $ λ ha, is_open_map_mul_right a s hs),
end

@[to_additive]
lemma subset_interior_mul_left : interior s * t ⊆ interior (s * t) :=
interior_maximal (set.mul_subset_mul_right interior_subset) is_open_interior.mul_right

@[to_additive]
lemma subset_interior_mul_right : s * interior t ⊆ interior (s * t) :=
interior_maximal (set.mul_subset_mul_left interior_subset) is_open_interior.mul_left

@[to_additive]
lemma subset_interior_mul : interior s * interior t ⊆ interior (s * t) :=
(set.mul_subset_mul_left interior_subset).trans subset_interior_mul_left

end pointwise

/-!
### `has_continuous_inv` and `has_continuous_neg`
-/

/-- Basic hypothesis to talk about a topological additive group. A topological additive group
over `M`, for example, is obtained by requiring the instances `add_group M` and
`has_continuous_add M` and `has_continuous_neg M`. -/
class has_continuous_neg (G : Type u) [topological_space G] [has_neg G] : Prop :=
(continuous_neg : continuous (λ a : G, -a))

/-- Basic hypothesis to talk about a topological group. A topological group over `M`, for example,
is obtained by requiring the instances `group M` and `has_continuous_mul M` and
`has_continuous_inv M`. -/
@[to_additive]
class has_continuous_inv (G : Type u) [topological_space G] [has_inv G] : Prop :=
(continuous_inv : continuous (λ a : G, a⁻¹))

export has_continuous_inv (continuous_inv)
export has_continuous_neg (continuous_neg)

section continuous_inv

variables [topological_space G] [has_inv G] [has_continuous_inv G]

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

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

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

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

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

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

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

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

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

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

@[to_additive]
instance [topological_space H] [has_inv H] [has_continuous_inv H] : has_continuous_inv (G × H) :=
⟨(continuous_inv.comp continuous_fst).prod_mk (continuous_inv.comp continuous_snd)⟩

variable {ι : Type*}

@[to_additive]
instance pi.has_continuous_inv {C : ι → Type*} [∀ i, topological_space (C i)]
  [∀ i, has_inv (C i)] [∀ i, has_continuous_inv (C i)] : has_continuous_inv (Π i, C i) :=
{ continuous_inv := continuous_pi (λ i, continuous.inv (continuous_apply i)) }

/-- A version of `pi.has_continuous_inv` for non-dependent functions. It is needed because sometimes
Lean fails to use `pi.has_continuous_inv` for non-dependent functions. -/
@[to_additive "A version of `pi.has_continuous_neg` for non-dependent functions. It is needed
because sometimes Lean fails to use `pi.has_continuous_neg` for non-dependent functions."]
instance pi.has_continuous_inv' : has_continuous_inv (ι → G) :=
pi.has_continuous_inv

@[priority 100, to_additive]
instance has_continuous_inv_of_discrete_topology [topological_space H]
  [has_inv H] [discrete_topology H] : has_continuous_inv H :=
⟨continuous_of_discrete_topology⟩

section pointwise_limits

variables (G₁ G₂ : Type*) [topological_space G₂] [t2_space G₂]

@[to_additive] lemma is_closed_set_of_map_inv [has_inv G₁] [has_inv G₂] [has_continuous_inv G₂] :
  is_closed {f : G₁ → G₂ | ∀ x, f x⁻¹ = (f x)⁻¹ } :=
begin
  simp only [set_of_forall],
  refine is_closed_Inter (λ i, is_closed_eq (continuous_apply _) (continuous_apply _).inv),
end

end pointwise_limits

instance additive.has_continuous_neg [h : topological_space H] [has_inv H]
  [has_continuous_inv H] : @has_continuous_neg (additive H) h _ :=
{ continuous_neg := @continuous_inv H _ _ _ }

instance multiplicative.has_continuous_inv [h : topological_space H] [has_neg H]
  [has_continuous_neg H] : @has_continuous_inv (multiplicative H) h _ :=
{ continuous_inv := @continuous_neg H _ _ _ }

end continuous_inv

@[to_additive]
lemma is_compact.inv [topological_space G] [has_involutive_inv G] [has_continuous_inv G]
  {s : set G} (hs : is_compact s) : is_compact (s⁻¹) :=
by { rw [← image_inv], exact hs.image continuous_inv }

section lattice_ops

variables {ι' : Sort*} [has_inv G] [has_inv H] {ts : set (topological_space G)}
  (h : Π t ∈ ts, @has_continuous_inv G t _) {ts' : ι' → topological_space G}
  (h' : Π i, @has_continuous_inv G (ts' i) _) {t₁ t₂ : topological_space G}
  (h₁ : @has_continuous_inv G t₁ _) (h₂ : @has_continuous_inv G t₂ _)
  {t : topological_space H} [has_continuous_inv H]

@[to_additive] lemma has_continuous_inv_Inf :
  @has_continuous_inv G (Inf ts) _ :=
{ continuous_inv := continuous_Inf_rng (λ t ht, continuous_Inf_dom ht
  (@has_continuous_inv.continuous_inv G t _ (h t ht))) }

include h'

@[to_additive] lemma has_continuous_inv_infi :
  @has_continuous_inv G (⨅ i, ts' i) _ :=
by {rw ← Inf_range, exact has_continuous_inv_Inf (set.forall_range_iff.mpr h')}

omit h'

include h₁ h₂

@[to_additive] lemma has_continuous_inv_inf :
  @has_continuous_inv G (t₁ ⊓ t₂) _ :=
by {rw inf_eq_infi, refine has_continuous_inv_infi (λ b, _), cases b; assumption}

end lattice_ops

section topological_group

/-!
### Topological groups

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

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

/-- A topological group is a group in which the multiplication and inversion operations are
continuous.

When you declare an instance that does not already have a `uniform_space` instance,
you should also provide an instance of `uniform_space` and `uniform_group` using
`topological_group.to_uniform_space` and `topological_group_is_uniform`. -/
@[to_additive]
class topological_group (G : Type*) [topological_space G] [group G]
  extends has_continuous_mul G, has_continuous_inv G : Prop

section conj

/-- we slightly weaken the type class assumptions here so that it will also apply to `ennreal`, but
we nevertheless leave it in the `topological_group` namespace. -/

variables [topological_space G] [has_inv G] [has_mul G]
[has_continuous_mul G]

/-- Conjugation is jointly continuous on `G × G` when both `mul` and `inv` are continuous. -/
@[to_additive "Conjugation is jointly continuous on `G × G` when both `mul` and `inv` are
continuous."]
lemma topological_group.continuous_conj_prod [has_continuous_inv G] :
  continuous (λ g : G × G, g.fst * g.snd * g.fst⁻¹) :=
continuous_mul.mul (continuous_inv.comp continuous_fst)

/-- Conjugation by a fixed element is continuous when `mul` is continuous. -/
@[to_additive "Conjugation by a fixed element is continuous when `add` is continuous."]
lemma topological_group.continuous_conj (g : G) : continuous (λ (h : G), g * h * g⁻¹) :=
(continuous_mul_right g⁻¹).comp (continuous_mul_left g)

/-- Conjugation acting on fixed element of the group is continuous when both `mul` and
`inv` are continuous. -/
@[to_additive "Conjugation acting on fixed element of the additive group is continuous when both
  `add` and `neg` are continuous."]
lemma topological_group.continuous_conj' [has_continuous_inv G]
  (h : G) : continuous (λ (g : G), g * h * g⁻¹) :=
(continuous_mul_right h).mul continuous_inv

end conj

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

section zpow

@[continuity, to_additive]
lemma continuous_zpow : ∀ z : ℤ, continuous (λ a : G, a ^ z)
| (int.of_nat n) := by simpa using continuous_pow n
| -[1+n] := by simpa using (continuous_pow (n + 1)).inv

instance add_group.has_continuous_const_smul_int {A} [add_group A] [topological_space A]
  [topological_add_group A] : has_continuous_const_smul ℤ A := ⟨continuous_zsmul⟩

instance add_group.has_continuous_smul_int {A} [add_group A] [topological_space A]
  [topological_add_group A] : has_continuous_smul ℤ A :=
⟨continuous_uncurry_of_discrete_topology continuous_zsmul⟩

@[continuity, to_additive]
lemma continuous.zpow {f : α → G} (h : continuous f) (z : ℤ) :
  continuous (λ b, (f b) ^ z) :=
(continuous_zpow z).comp h

@[to_additive]
lemma continuous_on_zpow {s : set G} (z : ℤ) : continuous_on (λ x, x ^ z) s :=
(continuous_zpow z).continuous_on

@[to_additive]
lemma continuous_at_zpow (x : G) (z : ℤ) : continuous_at (λ x, x ^ z) x :=
(continuous_zpow z).continuous_at

@[to_additive]
lemma filter.tendsto.zpow {α} {l : filter α} {f : α → G} {x : G} (hf : tendsto f l (𝓝 x)) (z : ℤ) :
  tendsto (λ x, f x ^ z) l (𝓝 (x ^ z)) :=
(continuous_at_zpow _ _).tendsto.comp hf

@[to_additive]
lemma continuous_within_at.zpow {f : α → G} {x : α} {s : set α} (hf : continuous_within_at f s x)
  (z : ℤ) : continuous_within_at (λ x, f x ^ z) s x :=
hf.zpow z

@[to_additive]
lemma continuous_at.zpow {f : α → G} {x : α} (hf : continuous_at f x) (z : ℤ) :
  continuous_at (λ x, f x ^ z) x :=
hf.zpow z

@[to_additive continuous_on.zsmul]
lemma continuous_on.zpow {f : α → G} {s : set α} (hf : continuous_on f s) (z : ℤ) :
  continuous_on (λ x, f x ^ z) s :=
λ x hx, (hf x hx).zpow z

end zpow

section ordered_comm_group

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

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

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

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

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

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

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

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

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

end ordered_comm_group

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

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

open mul_opposite

@[to_additive]
instance [group α] [has_continuous_inv α] : has_continuous_inv αᵐᵒᵖ :=
{ continuous_inv := continuous_induced_rng $ (@continuous_inv α _ _ _).comp continuous_unop }

/-- If multiplication is continuous in `α`, then it also is in `αᵐᵒᵖ`. -/
@[to_additive "If addition is continuous in `α`, then it also is in `αᵃᵒᵖ`."]
instance [group α] [topological_group α] :
  topological_group αᵐᵒᵖ := { }

variable (G)

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

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

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

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

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

variables {G}

@[to_additive]
lemma is_open.inv {s : set G} (hs : is_open s) : is_open s⁻¹ := hs.preimage continuous_inv

@[to_additive]
lemma is_closed.inv {s : set G} (hs : is_closed s) : is_closed s⁻¹ := hs.preimage continuous_inv

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

@[to_additive] lemma is_open.mul_closure {U : set G} (hU : is_open U) (s : set G) :
  U * closure s = U * s :=
begin
  refine subset.antisymm _ (mul_subset_mul subset.rfl subset_closure),
  rintro _ ⟨a, b, ha, hb, rfl⟩,
  rw mem_closure_iff at hb,
  have hbU : b ∈ U⁻¹ * {a * b},
    from ⟨a⁻¹, a * b, inv_mem_inv.2 ha, rfl, inv_mul_cancel_left _ _⟩,
  rcases hb _ hU.inv.mul_right hbU with ⟨_, ⟨c, d, hc, (rfl : d = _), rfl⟩, hcs⟩,
  exact ⟨c⁻¹, _, hc, hcs, inv_mul_cancel_left _ _⟩
end

@[to_additive] lemma is_open.closure_mul {U : set G} (hU : is_open U) (s : set G) :
  closure s * U = s * U :=
by rw [← inv_inv (closure s * U), set.mul_inv_rev, inv_closure, hU.inv.mul_closure,
  set.mul_inv_rev, inv_inv, inv_inv]

namespace subgroup

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

end subgroup

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

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

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

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

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

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

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

/-- The topological closure of a normal subgroup is normal.-/
@[to_additive "The topological closure of a normal additive subgroup is normal."]
lemma subgroup.is_normal_topological_closure {G : Type*} [topological_space G] [group G]
  [topological_group G] (N : subgroup G) [N.normal] :
  (subgroup.topological_closure N).normal :=
{ conj_mem := λ n hn g,
  begin
    apply mem_closure_of_continuous (topological_group.continuous_conj g) hn,
    intros m hm,
    exact subset_closure (subgroup.normal.conj_mem infer_instance m hm g),
  end }

@[to_additive] lemma mul_mem_connected_component_one {G : Type*} [topological_space G]
  [mul_one_class G] [has_continuous_mul G] {g h : G} (hg : g ∈ connected_component (1 : G))
  (hh : h ∈ connected_component (1 : G)) : g * h ∈ connected_component (1 : G) :=
begin
  rw connected_component_eq hg,
  have hmul: g ∈ connected_component (g*h),
  { apply continuous.image_connected_component_subset (continuous_mul_left g),
    rw ← connected_component_eq hh,
    exact ⟨(1 : G), mem_connected_component, by simp only [mul_one]⟩ },
  simpa [← connected_component_eq hmul] using (mem_connected_component)
end

@[to_additive] lemma inv_mem_connected_component_one {G : Type*} [topological_space G] [group G]
  [topological_group G] {g : G} (hg : g ∈ connected_component (1 : G)) :
  g⁻¹ ∈ connected_component (1 : G) :=
begin
  rw ← one_inv,
  exact continuous.image_connected_component_subset continuous_inv _
    ((set.mem_image _ _ _).mp ⟨g, hg, rfl⟩)
end

/-- The connected component of 1 is a subgroup of `G`. -/
@[to_additive "The connected component of 0 is a subgroup of `G`."]
def subgroup.connected_component_of_one (G : Type*) [topological_space G] [group G]
  [topological_group G] : subgroup G :=
{ carrier  := connected_component (1 : G),
  one_mem' := mem_connected_component,
  mul_mem' := λ g h hg hh, mul_mem_connected_component_one hg hh,
  inv_mem' := λ g hg, inv_mem_connected_component_one hg }

/-- If a subgroup of a topological group is commutative, then so is its topological closure. -/
@[to_additive "If a subgroup of an additive topological group is commutative, then so is its
topological closure."]
def subgroup.comm_group_topological_closure [t2_space G] (s : subgroup G)
  (hs : ∀ (x y : s), x * y = y * x) : comm_group s.topological_closure :=
{ ..s.topological_closure.to_group,
  ..s.to_submonoid.comm_monoid_topological_closure hs }

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

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

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

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

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

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

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

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

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

end topological_group

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

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

open quotient_group

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

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

end quotient_topological_group

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

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

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

export has_continuous_sub (continuous_sub)
export has_continuous_div (continuous_div')

section has_continuous_div

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

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

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

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

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

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

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

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

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

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

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

end has_continuous_div

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

/-- A version of `homeomorph.mul_left a b⁻¹` that is defeq to `a / b`. -/
@[to_additive /-" A version of `homeomorph.add_left a (-b)` that is defeq to `a - b`. "-/,
  simps {simp_rhs := tt}]
def homeomorph.div_left (x : G) : G ≃ₜ G :=
{ continuous_to_fun := continuous_const.div' continuous_id,
  continuous_inv_fun := continuous_inv.mul continuous_const,
  .. equiv.div_left x }

/-- A version of `homeomorph.mul_right a⁻¹ b` that is defeq to `b / a`. -/
@[to_additive /-" A version of `homeomorph.add_right (-a) b` that is defeq to `b - a`. "-/,
  simps {simp_rhs := tt}]
def homeomorph.div_right (x : G) : G ≃ₜ G :=
{ continuous_to_fun := continuous_id.div' continuous_const,
  continuous_inv_fun := continuous_id.mul continuous_const,
  .. equiv.div_right x }

@[to_additive]
lemma is_open_map_div_right (a : G) : is_open_map (λ x, x / a) :=
(homeomorph.div_right a).is_open_map

@[to_additive]
lemma is_closed_map_div_right (a : G) : is_closed_map (λ x, x / a) :=
(homeomorph.div_right a).is_closed_map

end div_in_topological_group

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

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

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

section filter_mul

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

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

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

local attribute [instance] topological_group.regular_space

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

end

section

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

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

/-- Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of `1`
  such that `K * V ⊆ U`. -/
@[to_additive "Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of
`0` such that `K + V ⊆ U`."]
lemma compact_open_separated_mul_right {K U : set G} (hK : is_compact K) (hU : is_open U)
  (hKU : K ⊆ U) : ∃ V ∈ 𝓝 (1 : G), K * V ⊆ U :=
begin
  apply hK.induction_on,
  { exact ⟨univ, by simp⟩ },
  { rintros s t hst ⟨V, hV, hV'⟩,
    exact ⟨V, hV, (mul_subset_mul_right hst).trans hV'⟩ },
  { rintros s t  ⟨V, V_in, hV'⟩ ⟨W, W_in, hW'⟩,
    use [V ∩ W, inter_mem V_in W_in],
    rw union_mul,
    exact union_subset ((mul_subset_mul_left (V.inter_subset_left W)).trans hV')
                       ((mul_subset_mul_left (V.inter_subset_right W)).trans hW') },
  { intros x hx,
    have := tendsto_mul (show U ∈ 𝓝 (x * 1), by simpa using hU.mem_nhds (hKU hx)),
    rw [nhds_prod_eq, mem_map, mem_prod_iff] at this,
    rcases this with ⟨t, ht, s, hs, h⟩,
    rw [← image_subset_iff, image_mul_prod] at h,
    exact ⟨t, mem_nhds_within_of_mem_nhds ht, s, hs, h⟩ }
end

open mul_opposite

/-- Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of `1`
  such that `V * K ⊆ U`. -/
@[to_additive "Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of
`0` such that `V + K ⊆ U`."]
lemma compact_open_separated_mul_left {K U : set G} (hK : is_compact K) (hU : is_open U)
  (hKU : K ⊆ U) : ∃ V ∈ 𝓝 (1 : G), V * K ⊆ U :=
begin
  rcases compact_open_separated_mul_right (hK.image continuous_op) (op_homeomorph.is_open_map U hU)
    (image_subset op hKU) with ⟨V, (hV : V ∈ 𝓝 (op (1 : G))), hV' : op '' K * V ⊆ op '' U⟩,
  refine ⟨op ⁻¹' V, continuous_op.continuous_at hV, _⟩,
  rwa [← image_preimage_eq V op_surjective, ← image_op_mul, image_subset_iff,
    preimage_image_eq _ op_injective] at hV'
end

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

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

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

end

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

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

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

end

end filter_mul

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

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

section quotient
variables [group G] [topological_space G] [topological_group G] {Γ : subgroup G}

@[to_additive]
instance quotient_group.has_continuous_const_smul : has_continuous_const_smul G (G ⧸ Γ) :=
{ continuous_const_smul := λ g₀, begin
    apply continuous_coinduced_dom,
    change continuous (λ g : G, quotient_group.mk (g₀ * g)),
    exact continuous_coinduced_rng.comp (continuous_mul_left g₀),
  end }

@[to_additive]
lemma quotient_group.continuous_smul₁ (x : G ⧸ Γ) : continuous (λ g : G, g • x) :=
begin
  obtain ⟨g₀, rfl⟩ : ∃ g₀, quotient_group.mk g₀ = x,
  { exact @quotient.exists_rep _ (quotient_group.left_rel Γ) x },
  change continuous (λ g, quotient_group.mk (g * g₀)),
  exact continuous_coinduced_rng.comp (continuous_mul_right g₀)
end

@[to_additive]
instance quotient_group.has_continuous_smul [locally_compact_space G] :
  has_continuous_smul G (G ⧸ Γ) :=
{ continuous_smul := begin
    let F : G × G ⧸ Γ → G ⧸ Γ := λ p, p.1 • p.2,
    change continuous F,
    have H : continuous (F ∘ (λ p : G × G, (p.1, quotient_group.mk p.2))),
    { change continuous (λ p : G × G, quotient_group.mk (p.1 * p.2)),
      refine continuous_coinduced_rng.comp continuous_mul },
    exact quotient_map.continuous_lift_prod_right quotient_map_quotient_mk H,
  end }

end quotient

namespace units

open mul_opposite (continuous_op continuous_unop)

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

@[to_additive] instance : topological_group αˣ :=
{ continuous_inv := continuous_induced_rng ((continuous_unop.comp
    (@continuous_embed_product α _ _).snd).prod_mk (continuous_op.comp continuous_coe)) }

/-- The topological group isomorphism between the units of a product of two monoids, and the product
    of the units of each monoid. -/
def homeomorph.prod_units : homeomorph (α × β)ˣ (αˣ × βˣ) :=
{ continuous_to_fun  :=
  begin
    show continuous (λ i : (α × β)ˣ, (map (monoid_hom.fst α β) i, map (monoid_hom.snd α β) i)),
    refine continuous.prod_mk _ _,
    { refine continuous_induced_rng ((continuous_fst.comp units.continuous_coe).prod_mk _),
      refine mul_opposite.continuous_op.comp (continuous_fst.comp _),
      simp_rw units.inv_eq_coe_inv,
      exact units.continuous_coe.comp continuous_inv, },
    { refine continuous_induced_rng ((continuous_snd.comp units.continuous_coe).prod_mk _),
      simp_rw units.coe_map_inv,
      exact continuous_op.comp (continuous_snd.comp (units.continuous_coe.comp continuous_inv)), }
  end,
  continuous_inv_fun :=
  begin
    refine continuous_induced_rng (continuous.prod_mk _ _),
    { exact (units.continuous_coe.comp continuous_fst).prod_mk
        (units.continuous_coe.comp continuous_snd), },
    { refine continuous_op.comp
        (units.continuous_coe.comp $ continuous_induced_rng $ continuous.prod_mk _ _),
      { exact (units.continuous_coe.comp (continuous_inv.comp continuous_fst)).prod_mk
          (units.continuous_coe.comp (continuous_inv.comp continuous_snd)) },
      { exact continuous_op.comp ((units.continuous_coe.comp continuous_fst).prod_mk
            (units.continuous_coe.comp continuous_snd)) }}
  end,
  ..mul_equiv.prod_units }

end units

section lattice_ops

variables {ι : Sort*} [group G] [group H] {ts : set (topological_space G)}
  (h : ∀ t ∈ ts, @topological_group G t _) {ts' : ι → topological_space G}
  (h' : ∀ i, @topological_group G (ts' i) _) {t₁ t₂ : topological_space G}
  (h₁ : @topological_group G t₁ _) (h₂ : @topological_group G t₂ _)
  {t : topological_space H} [topological_group H] {F : Type*}
  [monoid_hom_class F G H] (f : F)

@[to_additive] lemma topological_group_Inf :
  @topological_group G (Inf ts) _ :=
{ continuous_inv := @has_continuous_inv.continuous_inv G (Inf ts) _
    (@has_continuous_inv_Inf _ _ _
      (λ t ht, @topological_group.to_has_continuous_inv G t _ (h t ht))),
  continuous_mul := @has_continuous_mul.continuous_mul G (Inf ts) _
    (@has_continuous_mul_Inf _ _ _
      (λ t ht, @topological_group.to_has_continuous_mul G t _ (h t ht))) }

include h'

@[to_additive] lemma topological_group_infi :
  @topological_group G (⨅ i, ts' i) _ :=
by {rw ← Inf_range, exact topological_group_Inf (set.forall_range_iff.mpr h')}

omit h'

include h₁ h₂

@[to_additive] lemma topological_group_inf :
  @topological_group G (t₁ ⊓ t₂) _ :=
by {rw inf_eq_infi, refine topological_group_infi (λ b, _), cases b; assumption}

omit h₁ h₂

@[to_additive] lemma topological_group_induced :
  @topological_group G (t.induced f) _ :=
{ continuous_inv :=
    begin
      letI : topological_space G := t.induced f,
      refine continuous_induced_rng _,
      simp_rw [function.comp, map_inv],
      exact continuous_inv.comp (continuous_induced_dom : continuous f)
    end,
  continuous_mul := @has_continuous_mul.continuous_mul G (t.induced f) _
    (@has_continuous_mul_induced G H _ _ t _ _ _ f) }

end lattice_ops

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

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

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

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

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

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

attribute [to_additive] group_topology

namespace group_topology

variables [group α]

/-- A version of the global `continuous_mul` suitable for dot notation. -/
@[to_additive]
lemma continuous_mul' (g : group_topology α) :
  by haveI := g.to_topological_space; exact continuous (λ p : α × α, p.1 * p.2) :=
begin
  letI := g.to_topological_space,
  haveI := g.to_topological_group,
  exact continuous_mul,
end

/-- A version of the global `continuous_inv` suitable for dot notation. -/
@[to_additive]
lemma continuous_inv' (g : group_topology α) :
  by haveI := g.to_topological_space; exact continuous (has_inv.inv : α → α) :=
begin
  letI := g.to_topological_space,
  haveI := g.to_topological_group,
  exact continuous_inv,
end

@[to_additive]
lemma to_topological_space_injective :
  function.injective (to_topological_space : group_topology α → topological_space α):=
λ f g h, by { cases f, cases g, congr' }

@[ext, to_additive]
lemma ext' {f g : group_topology α} (h : f.is_open = g.is_open) : f = g :=
to_topological_space_injective $ topological_space_eq h

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

@[simp, to_additive] lemma to_topological_space_le {x y : group_topology α} :
  x.to_topological_space ≤ y.to_topological_space ↔ x ≤ y := iff.rfl

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

@[simp, to_additive] lemma to_topological_space_top :
  (⊤ : group_topology α).to_topological_space = ⊤ := rfl

@[to_additive]
instance : has_bot (group_topology α) :=
⟨{to_topological_space := ⊥,
  continuous_mul       := by continuity,
  continuous_inv       := continuous_bot}⟩

@[simp, to_additive] lemma to_topological_space_bot :
  (⊥ : group_topology α).to_topological_space = ⊥ := rfl

@[to_additive]
instance : bounded_order (group_topology α) :=
{ top := ⊤,
  le_top := λ x, show x.to_topological_space ≤ ⊤, from le_top,
  bot := ⊥,
  bot_le := λ x, show ⊥ ≤ x.to_topological_space, from bot_le }

@[to_additive]
instance : has_inf (group_topology α) :=
{ inf := λ x y,
  { to_topological_space := x.to_topological_space ⊓ y.to_topological_space,
    continuous_mul := continuous_inf_rng
      (continuous_inf_dom_left₂ x.continuous_mul') (continuous_inf_dom_right₂ y.continuous_mul'),
    continuous_inv := continuous_inf_rng
      (continuous_inf_dom_left x.continuous_inv') (continuous_inf_dom_right y.continuous_inv') } }

@[simp, to_additive]
lemma to_topological_space_inf (x y : group_topology α) :
  (x ⊓ y).to_topological_space = x.to_topological_space ⊓ y.to_topological_space := rfl

@[to_additive]
instance : semilattice_inf (group_topology α) :=
to_topological_space_injective.semilattice_inf _ to_topological_space_inf

@[to_additive]
instance : inhabited (group_topology α) := ⟨⊤⟩

local notation `cont` := @continuous _ _
@[to_additive "Infimum of a collection of additive group topologies"]
instance : has_Inf (group_topology α) :=
{ Inf := λ S,
  { to_topological_space := Inf (to_topological_space '' S),
    continuous_mul       := continuous_Inf_rng begin
      rintros _ ⟨⟨t, tr⟩, haS, rfl⟩, resetI,
      exact continuous_Inf_dom₂
        (set.mem_image_of_mem to_topological_space haS)
        (set.mem_image_of_mem to_topological_space haS) continuous_mul,
    end,
    continuous_inv       := continuous_Inf_rng begin
      rintros _ ⟨⟨t, tr⟩, haS, rfl⟩, resetI,
      exact continuous_Inf_dom (set.mem_image_of_mem to_topological_space haS) continuous_inv,
    end, } }

@[simp, to_additive]
lemma to_topological_space_Inf (s : set (group_topology α)) :
  (Inf s).to_topological_space = Inf (to_topological_space '' s) := rfl

@[simp, to_additive]
lemma to_topological_space_infi {ι} (s : ι → group_topology α) :
  (⨅ i, s i).to_topological_space = ⨅ i, (s i).to_topological_space :=
congr_arg Inf (range_comp _ _).symm

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

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

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

@[to_additive]
instance : complete_lattice (group_topology α) :=
{ inf := (⊓),
  top := ⊤,
  bot := ⊥,
  ..group_topology.bounded_order,
  ..group_topology.semilattice_inf,
  ..complete_lattice_of_complete_semilattice_Inf _ }

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

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

end group_topology