/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou, Yaël Dillies
-/
import data.set.pointwise
import order.filter.n_ary
import order.filter.ultrafilter

/-!
# Pointwise operations on filters

This file defines pointwise operations on filters. This is useful because usual algebraic operations
distribute over pointwise operations. For example,
* `(f₁ * f₂).map m  = f₁.map m * f₂.map m`
* `𝓝 (x * y) = 𝓝 x * 𝓝 y`

## Main declarations

* `0` (`filter.has_zero`): Pure filter at `0 : α`, or alternatively principal filter at `0 : set α`.
* `1` (`filter.has_one`): Pure filter at `1 : α`, or alternatively principal filter at `1 : set α`.
* `f + g` (`filter.has_add`): Addition, filter generated by all `s + t` where `s ∈ f` and `t ∈ g`.
* `f * g` (`filter.has_mul`): Multiplication, filter generated by all `s * t` where `s ∈ f` and
  `t ∈ g`.
* `-f` (`filter.has_neg`): Negation, filter of all `-s` where `s ∈ f`.
* `f⁻¹` (`filter.has_inv`): Inversion, filter of all `s⁻¹` where `s ∈ f`.
* `f - g` (`filter.has_sub`): Subtraction, filter generated by all `s - t` where `s ∈ f` and
  `t ∈ g`.
* `f / g` (`filter.has_div`): Division, filter generated by all `s / t` where `s ∈ f` and `t ∈ g`.
* `f +ᵥ g` (`filter.has_vadd`): Scalar addition, filter generated by all `s +ᵥ t` where `s ∈ f` and
  `t ∈ g`.
* `f -ᵥ g` (`filter.has_vsub`): Scalar subtraction, filter generated by all `s -ᵥ t` where `s ∈ f`
  and `t ∈ g`.
* `f • g` (`filter.has_smul`): Scalar multiplication, filter generated by all `s • t` where
  `s ∈ f` and `t ∈ g`.
* `a +ᵥ f` (`filter.has_vadd_filter`): Translation, filter of all `a +ᵥ s` where `s ∈ f`.
* `a • f` (`filter.has_smul_filter`): Scaling, filter of all `a • s` where `s ∈ f`.

For `α` a semigroup/monoid, `filter α` is a semigroup/monoid.
As an unfortunate side effect, this means that `n • f`, where `n : ℕ`, is ambiguous between
pointwise scaling and repeated pointwise addition. See note [pointwise nat action].

## Implementation notes

We put all instances in the locale `pointwise`, so that these instances are not available by
default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
since we expect the locale to be open whenever the instances are actually used (and making the
instances reducible changes the behavior of `simp`.

## Tags

filter multiplication, filter addition, pointwise addition, pointwise multiplication,
-/

open function set
open_locale filter pointwise

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

namespace filter

/-! ### `0`/`1` as filters -/

section has_one
variables [has_one α] {f : filter α} {s : set α}

/-- `1 : filter α` is defined as the filter of sets containing `1 : α` in locale `pointwise`. -/
@[to_additive "`0 : filter α` is defined as the filter of sets containing `0 : α` in locale
`pointwise`."]
protected def has_one : has_one (filter α) := ⟨pure 1⟩

localized "attribute [instance] filter.has_one filter.has_zero" in pointwise

@[simp, to_additive] lemma mem_one : s ∈ (1 : filter α) ↔ (1 : α) ∈ s := mem_pure
@[to_additive] lemma one_mem_one : (1 : set α) ∈ (1 : filter α) := mem_pure.2 one_mem_one
@[simp, to_additive] lemma pure_one : pure 1 = (1 : filter α) := rfl
@[simp, to_additive] lemma principal_one : 𝓟 1 = (1 : filter α) := principal_singleton _
@[to_additive] lemma one_ne_bot : (1 : filter α).ne_bot := filter.pure_ne_bot
@[simp, to_additive] protected lemma map_one' (f : α → β) : (1 : filter α).map f = pure (f 1) := rfl
@[simp, to_additive] lemma le_one_iff : f ≤ 1 ↔ (1 : set α) ∈ f := le_pure_iff
@[to_additive] protected lemma ne_bot.le_one_iff (h : f.ne_bot) : f ≤ 1 ↔ f = 1 := h.le_pure_iff
@[simp, to_additive] lemma eventually_one {p : α → Prop} : (∀ᶠ x in 1, p x) ↔ p 1 := eventually_pure
@[simp, to_additive] lemma tendsto_one {a : filter β} {f : β → α} :
   tendsto f a 1 ↔ ∀ᶠ x in a, f x = 1 :=
tendsto_pure

/-- `pure` as a `one_hom`. -/
@[to_additive "`pure` as a `zero_hom`."]
def pure_one_hom : one_hom α (filter α) := ⟨pure, pure_one⟩

@[simp, to_additive] lemma coe_pure_one_hom : (pure_one_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_one_hom_apply (a : α) : pure_one_hom a = pure a := rfl

variables [has_one β]

@[simp, to_additive]
protected lemma map_one [one_hom_class F α β] (φ : F) : map φ 1 = 1 :=
by rw [filter.map_one', map_one, pure_one]

end has_one

/-! ### Filter negation/inversion -/

section has_inv
variables [has_inv α] {f g : filter α} {s : set α} {a : α}

/-- The inverse of a filter is the pointwise preimage under `⁻¹` of its sets. -/
@[to_additive "The negation of a filter is the pointwise preimage under `-` of its sets."]
instance : has_inv (filter α) := ⟨map has_inv.inv⟩

@[simp, to_additive] protected lemma map_inv : f.map has_inv.inv = f⁻¹ := rfl
@[to_additive] lemma mem_inv : s ∈ f⁻¹ ↔ has_inv.inv ⁻¹' s ∈ f := iff.rfl
@[to_additive] protected lemma inv_le_inv (hf : f ≤ g) : f⁻¹ ≤ g⁻¹ := map_mono hf
@[simp, to_additive] lemma inv_pure : (pure a : filter α)⁻¹ = pure a⁻¹ := rfl
@[simp, to_additive] lemma inv_eq_bot_iff : f⁻¹ = ⊥ ↔ f = ⊥  := map_eq_bot_iff
@[simp, to_additive] lemma ne_bot_inv_iff : f⁻¹.ne_bot ↔ ne_bot f := map_ne_bot_iff _
@[to_additive] lemma ne_bot.inv : f.ne_bot → f⁻¹.ne_bot := λ h, h.map _

end has_inv

section has_involutive_inv
variables [has_involutive_inv α] {f : filter α} {s : set α}

@[to_additive] lemma inv_mem_inv (hs : s ∈ f) : s⁻¹ ∈ f⁻¹ := by rwa [mem_inv, inv_preimage, inv_inv]

/-- Inversion is involutive on `filter α` if it is on `α`. -/
@[to_additive "Negation is involutive on `filter α` if it is on `α`."]
protected def has_involutive_inv : has_involutive_inv (filter α) :=
{ inv_inv := λ f, map_map.trans $ by rw [inv_involutive.comp_self, map_id],
  ..filter.has_inv }

end has_involutive_inv

/-! ### Filter addition/multiplication -/

section has_mul
variables [has_mul α] [has_mul β] {f f₁ f₂ g g₁ g₂ h : filter α} {s t : set α} {a b : α}

/-- The filter `f * g` is generated by `{s * t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive "The filter `f + g` is generated by `{s + t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_mul : has_mul (filter α) :=
/- This is defeq to `map₂ (*) f g`, but the hypothesis unfolds to `t₁ * t₂ ⊆ s` rather than all the
way to `set.image2 (*) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s}, ..map₂ (*) f g }⟩

localized "attribute [instance] filter.has_mul filter.has_add" in pointwise

@[simp, to_additive] lemma map₂_mul : map₂ (*) f g = f * g := rfl
@[to_additive] lemma mem_mul : s ∈ f * g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s := iff.rfl
@[to_additive] lemma mul_mem_mul : s ∈ f → t ∈ g → s * t ∈ f * g := image2_mem_map₂
@[simp, to_additive] lemma bot_mul : ⊥ * g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma mul_bot : f * ⊥ = ⊥ := map₂_bot_right
@[simp, to_additive] lemma mul_eq_bot_iff : f * g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma mul_ne_bot_iff : (f * g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.mul : ne_bot f → ne_bot g → ne_bot (f * g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_mul_left : (f * g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_mul_right : (f * g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_mul : pure a * g = g.map ((*) a)  := map₂_pure_left
@[simp, to_additive] lemma mul_pure : f * pure b = f.map (* b)  := map₂_pure_right
@[simp, to_additive] lemma pure_mul_pure : (pure a : filter α) * pure b = pure (a * b) := map₂_pure
@[simp, to_additive] lemma le_mul_iff : h ≤ f * g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s * t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_mul : covariant_class (filter α) (filter α) (*) (≤) :=
⟨λ f g h, map₂_mono_left⟩

@[to_additive] instance covariant_swap_mul : covariant_class (filter α) (filter α) (swap (*)) (≤) :=
⟨λ f g h, map₂_mono_right⟩

@[to_additive]
protected lemma map_mul [mul_hom_class F α β] (m : F) : (f₁ * f₂).map m = f₁.map m * f₂.map m :=
map_map₂_distrib $ map_mul m

/-- `pure` operation as a `mul_hom`. -/
@[to_additive "The singleton operation as an `add_hom`."]
def pure_mul_hom : α →ₙ* filter α := ⟨pure, λ a b, pure_mul_pure.symm⟩

@[simp, to_additive] lemma coe_pure_mul_hom : (pure_mul_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_mul_hom_apply (a : α) : pure_mul_hom a = pure a := rfl

end has_mul

/-! ### Filter subtraction/division -/

section div
variables [has_div α] {f f₁ f₂ g g₁ g₂ h : filter α} {s t : set α} {a b : α}

/-- The filter `f / g` is generated by `{s / t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive "The filter `f - g` is generated by `{s - t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_div : has_div (filter α) :=
/- This is defeq to `map₂ (/) f g`, but the hypothesis unfolds to `t₁ / t₂ ⊆ s` rather than all the
way to `set.image2 (/) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ / t₂ ⊆ s}, ..map₂ (/) f g }⟩

localized "attribute [instance] filter.has_div filter.has_sub" in pointwise

@[simp, to_additive] lemma map₂_div : map₂ (/) f g = f / g := rfl
@[to_additive] lemma mem_div : s ∈ f / g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ / t₂ ⊆ s := iff.rfl
@[to_additive] lemma div_mem_div : s ∈ f → t ∈ g → s / t ∈ f / g := image2_mem_map₂
@[simp, to_additive] lemma bot_div : ⊥ / g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma div_bot : f / ⊥ = ⊥ := map₂_bot_right
@[simp, to_additive] lemma div_eq_bot_iff : f / g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma div_ne_bot_iff : (f / g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.div : ne_bot f → ne_bot g → ne_bot (f / g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_div_left : (f / g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_div_right : (f / g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_div : pure a / g = g.map ((/) a)  := map₂_pure_left
@[simp, to_additive] lemma div_pure : f / pure b = f.map (/ b)  := map₂_pure_right
@[simp, to_additive] lemma pure_div_pure : (pure a : filter α) / pure b = pure (a / b) := map₂_pure
@[to_additive] protected lemma div_le_div : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ / g₁ ≤ f₂ / g₂ := map₂_mono
@[to_additive] protected lemma div_le_div_left : g₁ ≤ g₂ → f / g₁ ≤ f / g₂ := map₂_mono_left
@[to_additive] protected lemma div_le_div_right : f₁ ≤ f₂ → f₁ / g ≤ f₂ / g := map₂_mono_right
@[simp, to_additive] protected lemma le_div_iff :
  h ≤ f / g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s / t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_div : covariant_class (filter α) (filter α) (/) (≤) :=
⟨λ f g h, map₂_mono_left⟩

@[to_additive] instance covariant_swap_div : covariant_class (filter α) (filter α) (swap (/)) (≤) :=
⟨λ f g h, map₂_mono_right⟩

end div

open_locale pointwise

/-- Repeated pointwise addition (not the same as pointwise repeated addition!) of a `filter`. See
Note [pointwise nat action].-/
protected def has_nsmul [has_zero α] [has_add α] : has_smul ℕ (filter α) := ⟨nsmul_rec⟩

/-- Repeated pointwise multiplication (not the same as pointwise repeated multiplication!) of a
`filter`. See Note [pointwise nat action]. -/
@[to_additive]
protected def has_npow [has_one α] [has_mul α] : has_pow (filter α) ℕ := ⟨λ s n, npow_rec n s⟩

/-- Repeated pointwise addition/subtraction (not the same as pointwise repeated
addition/subtraction!) of a `filter`. See Note [pointwise nat action]. -/
protected def has_zsmul [has_zero α] [has_add α] [has_neg α] : has_smul ℤ (filter α) :=
⟨zsmul_rec⟩

/-- Repeated pointwise multiplication/division (not the same as pointwise repeated
multiplication/division!) of a `filter`. See Note [pointwise nat action]. -/
@[to_additive] protected def has_zpow [has_one α] [has_mul α] [has_inv α] : has_pow (filter α) ℤ :=
⟨λ s n, zpow_rec n s⟩

localized "attribute [instance] filter.has_nsmul filter.has_npow filter.has_zsmul filter.has_zpow"
  in pointwise

/-- `filter α` is a `semigroup` under pointwise operations if `α` is.-/
@[to_additive "`filter α` is an `add_semigroup` under pointwise operations if `α` is."]
protected def semigroup [semigroup α] : semigroup (filter α) :=
{ mul := (*),
  mul_assoc := λ f g h, map₂_assoc mul_assoc }

/-- `filter α` is a `comm_semigroup` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_comm_semigroup` under pointwise operations if `α` is."]
protected def comm_semigroup [comm_semigroup α] : comm_semigroup (filter α) :=
{ mul_comm := λ f g, map₂_comm mul_comm,
  ..filter.semigroup }

section mul_one_class
variables [mul_one_class α] [mul_one_class β]

/-- `filter α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_zero_class` under pointwise operations if `α` is."]
protected def mul_one_class : mul_one_class (filter α) :=
{ one := 1,
  mul := (*),
  one_mul := λ f, by simp only [←pure_one, ←map₂_mul, map₂_pure_left, one_mul, map_id'],
  mul_one := λ f, by simp only [←pure_one, ←map₂_mul, map₂_pure_right, mul_one, map_id'] }

localized "attribute [instance] filter.semigroup filter.add_semigroup filter.comm_semigroup
  filter.add_comm_semigroup filter.mul_one_class filter.add_zero_class" in pointwise

/-- If `φ : α →* β` then `map_monoid_hom φ` is the monoid homomorphism
`filter α →* filter β` induced by `map φ`. -/
@[to_additive "If `φ : α →+ β` then `map_add_monoid_hom φ` is the monoid homomorphism
`filter α →+ filter β` induced by `map φ`."]
def map_monoid_hom [monoid_hom_class F α β] (φ : F) : filter α →* filter β :=
{ to_fun := map φ,
  map_one' := filter.map_one φ,
  map_mul' := λ _ _, filter.map_mul φ }

-- The other direction does not hold in general
@[to_additive]
lemma comap_mul_comap_le [mul_hom_class F α β] (m : F) {f g : filter β} :
  f.comap m * g.comap m ≤ (f * g).comap m  :=
λ s ⟨t, ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩, mt⟩,
  ⟨m ⁻¹' t₁, m ⁻¹' t₂, ⟨t₁, ht₁, subset.rfl⟩, ⟨t₂, ht₂, subset.rfl⟩,
    (preimage_mul_preimage_subset _).trans $ (preimage_mono t₁t₂).trans mt⟩

@[to_additive]
lemma tendsto.mul_mul [mul_hom_class F α β] (m : F) {f₁ g₁ : filter α} {f₂ g₂ : filter β} :
  tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ * g₁) (f₂ * g₂) :=
λ hf hg, (filter.map_mul m).trans_le $ mul_le_mul' hf hg

/-- `pure` as a `monoid_hom`. -/
@[to_additive "`pure` as an `add_monoid_hom`."]
def pure_monoid_hom : α →* filter α := { ..pure_mul_hom, ..pure_one_hom }

@[simp, to_additive] lemma coe_pure_monoid_hom : (pure_monoid_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_monoid_hom_apply (a : α) : pure_monoid_hom a = pure a := rfl

end mul_one_class

section monoid
variables [monoid α] {f g : filter α} {s : set α} {a : α} {m n : ℕ}

/-- `filter α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_monoid` under pointwise operations if `α` is."]
protected def monoid : monoid (filter α) :=
{ ..filter.mul_one_class, ..filter.semigroup, ..filter.has_npow }

localized "attribute [instance] filter.monoid filter.add_monoid" in pointwise

@[to_additive] lemma pow_mem_pow (hs : s ∈ f) : ∀ n : ℕ, s ^ n ∈ f ^ n
| 0 := by { rw pow_zero, exact one_mem_one }
| (n + 1) := by { rw pow_succ, exact mul_mem_mul hs (pow_mem_pow _) }

@[simp, to_additive nsmul_bot] lemma bot_pow {n : ℕ} (hn : n ≠ 0) : (⊥  : filter α) ^ n = ⊥ :=
by rw [←tsub_add_cancel_of_le (nat.succ_le_of_lt $ nat.pos_of_ne_zero hn), pow_succ, bot_mul]

@[to_additive] lemma mul_top_of_one_le (hf : 1 ≤ f) : f * ⊤ = ⊤ :=
begin
  refine top_le_iff.1 (λ s, _),
  simp only [mem_mul, mem_top, exists_and_distrib_left, exists_eq_left],
  rintro ⟨t, ht, hs⟩,
  rwa [mul_univ_of_one_mem (mem_one.1 $ hf ht), univ_subset_iff] at hs,
end

@[to_additive] lemma top_mul_of_one_le (hf : 1 ≤ f) : ⊤ * f = ⊤ :=
begin
  refine top_le_iff.1 (λ s, _),
  simp only [mem_mul, mem_top, exists_and_distrib_left, exists_eq_left],
  rintro ⟨t, ht, hs⟩,
  rwa [univ_mul_of_one_mem (mem_one.1 $ hf ht), univ_subset_iff] at hs,
end

@[simp, to_additive] lemma top_mul_top : (⊤ : filter α) * ⊤ = ⊤ := mul_top_of_one_le le_top

--TODO: `to_additive` trips up on the `1 : ℕ` used in the pattern-matching.
lemma nsmul_top {α : Type*} [add_monoid α] : ∀ {n : ℕ}, n ≠ 0 → n • (⊤ : filter α) = ⊤
| 0 := λ h, (h rfl).elim
| 1 := λ _, one_nsmul _
| (n + 2) := λ _, by { rw [succ_nsmul, nsmul_top n.succ_ne_zero, top_add_top] }

@[to_additive nsmul_top] lemma top_pow : ∀ {n : ℕ}, n ≠ 0 → (⊤ : filter α) ^ n = ⊤
| 0 := λ h, (h rfl).elim
| 1 := λ _, pow_one _
| (n + 2) := λ _, by { rw [pow_succ, top_pow n.succ_ne_zero, top_mul_top] }

@[to_additive] protected lemma _root_.is_unit.filter : is_unit a → is_unit (pure a : filter α) :=
is_unit.map (pure_monoid_hom : α →* filter α)

end monoid

/-- `filter α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_comm_monoid` under pointwise operations if `α` is."]
protected def comm_monoid [comm_monoid α] : comm_monoid (filter α) :=
{ ..filter.mul_one_class, ..filter.comm_semigroup }

open_locale pointwise

section division_monoid
variables [division_monoid α] {f g : filter α}

@[to_additive]
protected lemma mul_eq_one_iff : f * g = 1 ↔ ∃ a b, f = pure a ∧ g = pure b ∧ a * b = 1 :=
begin
  refine ⟨λ hfg, _, _⟩,
  { obtain ⟨t₁, t₂, h₁, h₂, h⟩ : (1 : set α) ∈ f * g := hfg.symm.subst one_mem_one,
    have hfg : (f * g).ne_bot := hfg.symm.subst one_ne_bot,
    rw [(hfg.nonempty_of_mem $ mul_mem_mul h₁ h₂).subset_one_iff, set.mul_eq_one_iff] at h,
    obtain ⟨a, b, rfl, rfl, h⟩ := h,
    refine ⟨a, b, _, _, h⟩,
    { rwa [←hfg.of_mul_left.le_pure_iff, le_pure_iff] },
    { rwa [←hfg.of_mul_right.le_pure_iff, le_pure_iff] } },
  { rintro ⟨a, b, rfl, rfl, h⟩,
    rw [pure_mul_pure, h, pure_one] }
end

/-- `filter α` is a division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_monoid "`filter α` is a subtraction monoid under pointwise
operations if `α` is."]
protected def division_monoid : division_monoid (filter α) :=
{ mul_inv_rev := λ s t, map_map₂_antidistrib mul_inv_rev,
  inv_eq_of_mul := λ s t h, begin
    obtain ⟨a, b, rfl, rfl, hab⟩ := filter.mul_eq_one_iff.1 h,
    rw [inv_pure, inv_eq_of_mul_eq_one_right hab],
  end,
  div_eq_mul_inv := λ f g, map_map₂_distrib_right div_eq_mul_inv,
  ..filter.monoid, ..filter.has_involutive_inv, ..filter.has_div, ..filter.has_zpow }

@[to_additive] lemma is_unit_iff : is_unit f ↔ ∃ a, f = pure a ∧ is_unit a :=
begin
  split,
  { rintro ⟨u, rfl⟩,
    obtain ⟨a, b, ha, hb, h⟩ := filter.mul_eq_one_iff.1 u.mul_inv,
    refine ⟨a, ha, ⟨a, b, h, pure_injective _⟩, rfl⟩,
    rw [←pure_mul_pure, ←ha, ←hb],
    exact u.inv_mul },
  { rintro ⟨a, rfl, ha⟩,
    exact ha.filter }
end

end division_monoid

/-- `filter α` is a commutative division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_comm_monoid "`filter α` is a commutative subtraction monoid under
pointwise operations if `α` is."]
protected def division_comm_monoid [division_comm_monoid α] : division_comm_monoid (filter α) :=
{ ..filter.division_monoid, ..filter.comm_semigroup }

/-- `filter α` has distributive negation if `α` has. -/
protected def has_distrib_neg [has_mul α] [has_distrib_neg α] : has_distrib_neg (filter α) :=
{ neg_mul := λ _ _, map₂_map_left_comm neg_mul,
  mul_neg := λ _ _, map_map₂_right_comm mul_neg,
  ..filter.has_involutive_neg }

localized "attribute [instance] filter.comm_monoid filter.add_comm_monoid filter.division_monoid
  filter.subtraction_monoid filter.division_comm_monoid filter.subtraction_comm_monoid
  filter.has_distrib_neg" in pointwise

section distrib
variables [distrib α] {f g h : filter α}

/-!
Note that `filter α` is not a `distrib` because `f * g + f * h` has cross terms that `f * (g + h)`
lacks.
-/

lemma mul_add_subset : f * (g + h) ≤ f * g + f * h := map₂_distrib_le_left mul_add
lemma add_mul_subset : (f + g) * h ≤ f * h + g * h := map₂_distrib_le_right add_mul

end distrib

section mul_zero_class
variables [mul_zero_class α] {f g : filter α}

/-! Note that `filter` is not a `mul_zero_class` because `0 * ⊥ ≠ 0`. -/

lemma ne_bot.mul_zero_nonneg (hf : f.ne_bot) : 0 ≤ f * 0 :=
le_mul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in ⟨_, _, ha, h₂, mul_zero _⟩

lemma ne_bot.zero_mul_nonneg (hg : g.ne_bot) : 0 ≤ 0 * g :=
le_mul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in ⟨_, _, h₁, hb, zero_mul _⟩

end mul_zero_class

section group
variables [group α] [division_monoid β] [monoid_hom_class F α β] (m : F) {f g f₁ g₁ : filter α}
  {f₂ g₂ : filter β}

/-! Note that `filter α` is not a group because `f / f ≠ 1` in general -/

@[simp, to_additive] protected lemma one_le_div_iff : 1 ≤ f / g ↔ ¬ disjoint f g :=
begin
  refine ⟨λ h hfg, _, _⟩,
  { obtain ⟨s, hs, t, ht, hst⟩ := hfg (mem_bot : ∅ ∈ ⊥),
    exact set.one_mem_div_iff.1 (h $ div_mem_div hs ht) (disjoint_iff.2 hst.symm) },
  { rintro h s ⟨t₁, t₂, h₁, h₂, hs⟩,
    exact hs (set.one_mem_div_iff.2 $ λ ht, h $ disjoint_of_disjoint_of_mem ht h₁ h₂) }
end

@[to_additive] lemma not_one_le_div_iff : ¬ 1 ≤ f / g ↔ disjoint f g :=
filter.one_le_div_iff.not_left

@[to_additive] lemma ne_bot.one_le_div (h : f.ne_bot) : 1 ≤ f / f :=
begin
  rintro s ⟨t₁, t₂, h₁, h₂, hs⟩,
  obtain ⟨a, ha₁, ha₂⟩ := set.not_disjoint_iff.1 (h.not_disjoint h₁ h₂),
  rw [mem_one, ←div_self' a],
  exact hs (set.div_mem_div ha₁ ha₂),
end

@[to_additive] lemma is_unit_pure (a : α) : is_unit (pure a : filter α) := (group.is_unit a).filter

@[simp] lemma is_unit_iff_singleton : is_unit f ↔ ∃ a, f = pure a :=
by simp only [is_unit_iff, group.is_unit, and_true]

include β

@[to_additive] lemma map_inv' : f⁻¹.map m = (f.map m)⁻¹ := map_comm (funext $ map_inv m) _

@[to_additive] lemma tendsto.inv_inv : tendsto m f₁ f₂ → tendsto m f₁⁻¹ f₂⁻¹ :=
λ hf, (filter.map_inv' m).trans_le $ filter.inv_le_inv hf

@[to_additive] protected lemma map_div : (f / g).map m = f.map m / g.map m :=
map_map₂_distrib $ map_div m

@[to_additive]
lemma tendsto.div_div : tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ / g₁) (f₂ / g₂) :=
λ hf hg, (filter.map_div m).trans_le $ filter.div_le_div hf hg

end group

open_locale pointwise

section group_with_zero
variables [group_with_zero α] {f g : filter α}

lemma ne_bot.div_zero_nonneg (hf : f.ne_bot) : 0 ≤ f / 0 :=
filter.le_div_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in
  ⟨_, _, ha, h₂, div_zero _⟩

lemma ne_bot.zero_div_nonneg (hg : g.ne_bot) : 0 ≤ 0 / g :=
filter.le_div_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in
  ⟨_, _, h₁, hb, zero_div _⟩

end group_with_zero

/-! ### Scalar addition/multiplication of filters -/

section smul
variables [has_smul α β] {f f₁ f₂ : filter α} {g g₁ g₂ h : filter β} {s : set α} {t : set β}
  {a : α} {b : β}

/-- The filter `f • g` is generated by `{s • t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive filter.has_vadd
"The filter `f +ᵥ g` is generated by `{s +ᵥ t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_smul : has_smul (filter α) (filter β) :=
/- This is defeq to `map₂ (•) f g`, but the hypothesis unfolds to `t₁ • t₂ ⊆ s` rather than all the
way to `set.image2 (•) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ • t₂ ⊆ s}, ..map₂ (•) f g }⟩

localized "attribute [instance] filter.has_smul filter.has_vadd" in pointwise

@[simp, to_additive] lemma map₂_smul : map₂ (•) f g = f • g := rfl
@[to_additive] lemma mem_smul : t ∈ f • g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ • t₂ ⊆ t := iff.rfl
@[to_additive] lemma smul_mem_smul : s ∈ f → t ∈ g → s • t ∈ f • g :=  image2_mem_map₂
@[simp, to_additive] lemma bot_smul : (⊥ : filter α) • g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma smul_bot : f • (⊥ : filter β) = ⊥ := map₂_bot_right
@[simp, to_additive] lemma smul_eq_bot_iff : f • g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma smul_ne_bot_iff : (f • g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.smul : ne_bot f → ne_bot g → ne_bot (f • g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_smul_left : (f • g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_smul_right : (f • g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_smul : (pure a : filter α) • g = g.map ((•) a)  := map₂_pure_left
@[simp, to_additive] lemma smul_pure : f • pure b = f.map (• b)  := map₂_pure_right
@[simp, to_additive] lemma pure_smul_pure :
  (pure a : filter α) • (pure b : filter β) = pure (a • b) := map₂_pure
@[to_additive] lemma smul_le_smul : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ • g₁ ≤ f₂ • g₂ := map₂_mono
@[to_additive] lemma smul_le_smul_left : g₁ ≤ g₂ → f • g₁ ≤ f • g₂ := map₂_mono_left
@[to_additive] lemma smul_le_smul_right : f₁ ≤ f₂ → f₁ • g ≤ f₂ • g := map₂_mono_right
@[simp, to_additive] lemma le_smul_iff : h ≤ f • g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s • t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_smul : covariant_class (filter α) (filter β) (•) (≤) :=
⟨λ f g h, map₂_mono_left⟩

end smul

/-! ### Scalar subtraction of filters -/

section vsub
variables [has_vsub α β] {f f₁ f₂ g g₁ g₂ : filter β} {h : filter α} {s t : set β} {a b : β}
include α

/-- The filter `f -ᵥ g` is generated by `{s -ᵥ t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
protected def has_vsub : has_vsub (filter α) (filter β) :=
/- This is defeq to `map₂ (-ᵥ) f g`, but the hypothesis unfolds to `t₁ -ᵥ t₂ ⊆ s` rather than all
the way to `set.image2 (-ᵥ) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ -ᵥ t₂ ⊆ s}, ..map₂ (-ᵥ) f g }⟩

localized "attribute [instance] filter.has_vsub" in pointwise

@[simp] lemma map₂_vsub : map₂ (-ᵥ) f g = f -ᵥ g := rfl
lemma mem_vsub {s : set α} : s ∈ f -ᵥ g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ -ᵥ t₂ ⊆ s := iff.rfl
lemma vsub_mem_vsub : s ∈ f → t ∈ g → s -ᵥ t ∈ f -ᵥ g :=  image2_mem_map₂
@[simp] lemma bot_vsub : (⊥ : filter β) -ᵥ g = ⊥ := map₂_bot_left
@[simp] lemma vsub_bot : f -ᵥ (⊥ : filter β) = ⊥ := map₂_bot_right
@[simp] lemma vsub_eq_bot_iff : f -ᵥ g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp] lemma vsub_ne_bot_iff : (f -ᵥ g : filter α).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
lemma ne_bot.vsub : ne_bot f → ne_bot g → ne_bot (f -ᵥ g) := ne_bot.map₂
lemma ne_bot.of_vsub_left : (f -ᵥ g : filter α).ne_bot → f.ne_bot := ne_bot.of_map₂_left
lemma ne_bot.of_vsub_right : (f -ᵥ g : filter α).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp] lemma pure_vsub : (pure a : filter β) -ᵥ g = g.map ((-ᵥ) a)  := map₂_pure_left
@[simp] lemma vsub_pure : f -ᵥ pure b = f.map (-ᵥ b)  := map₂_pure_right
@[simp] lemma pure_vsub_pure : (pure a : filter β) -ᵥ pure b = (pure (a -ᵥ b) : filter α) :=
map₂_pure
lemma vsub_le_vsub : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ -ᵥ g₁ ≤ f₂ -ᵥ g₂ := map₂_mono
lemma vsub_le_vsub_left : g₁ ≤ g₂ → f -ᵥ g₁ ≤ f -ᵥ g₂ := map₂_mono_left
lemma vsub_le_vsub_right : f₁ ≤ f₂ → f₁ -ᵥ g ≤ f₂ -ᵥ g := map₂_mono_right
@[simp] lemma le_vsub_iff : h ≤ f -ᵥ g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s -ᵥ t ∈ h := le_map₂_iff

end vsub

/-! ### Translation/scaling of filters -/

section smul
variables [has_smul α β] {f f₁ f₂ : filter β} {s : set β} {a : α}

/-- `a • f` is the map of `f` under `a •` in locale `pointwise`. -/
@[to_additive filter.has_vadd_filter
"`a +ᵥ f` is the map of `f` under `a +ᵥ` in locale `pointwise`."]
protected def has_smul_filter : has_smul α (filter β) := ⟨λ a, map ((•) a)⟩

localized "attribute [instance] filter.has_smul_filter filter.has_vadd_filter" in pointwise

@[simp, to_additive] lemma map_smul : map (λ b, a • b) f = a • f := rfl
@[to_additive] lemma mem_smul_filter : s ∈ a • f ↔ (•) a ⁻¹' s ∈ f := iff.rfl

@[to_additive] lemma smul_set_mem_smul_filter : s ∈ f → a • s ∈ a • f := image_mem_map
@[simp, to_additive] lemma smul_filter_bot : a • (⊥ : filter β) = ⊥ := map_bot
@[simp, to_additive] lemma smul_filter_eq_bot_iff : a • f = ⊥ ↔ f = ⊥ := map_eq_bot_iff
@[simp, to_additive] lemma smul_filter_ne_bot_iff : (a • f).ne_bot ↔ f.ne_bot := map_ne_bot_iff _
@[to_additive] lemma ne_bot.smul_filter : f.ne_bot → (a • f).ne_bot := λ h, h.map _
@[to_additive] lemma ne_bot.of_smul_filter : (a • f).ne_bot → f.ne_bot := ne_bot.of_map
@[to_additive] lemma smul_filter_le_smul_filter (hf : f₁ ≤ f₂) : a • f₁ ≤ a • f₂ :=
map_mono hf

@[to_additive] instance covariant_smul_filter : covariant_class α (filter β) (•) (≤) :=
⟨λ f, map_mono⟩

end smul

open_locale pointwise

@[to_additive]
instance smul_comm_class_filter [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class α β (filter γ) :=
⟨λ _ _ _,  map_comm (funext $ smul_comm _ _) _⟩

@[to_additive]
instance smul_comm_class_filter' [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class α (filter β) (filter γ) :=
⟨λ a f g, map_map₂_distrib_right $ smul_comm a⟩

@[to_additive]
instance smul_comm_class_filter'' [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class (filter α) β (filter γ) :=
by haveI := smul_comm_class.symm α β γ; exact smul_comm_class.symm _ _ _

@[to_additive]
instance smul_comm_class [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class (filter α) (filter β) (filter γ) :=
⟨λ f g h, map₂_left_comm smul_comm⟩

instance is_scalar_tower [has_smul α β] [has_smul α γ] [has_smul β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α β (filter γ) :=
⟨λ a b f, by simp only [←map_smul, map_map, smul_assoc]⟩

instance is_scalar_tower' [has_smul α β] [has_smul α γ] [has_smul β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α (filter β) (filter γ) :=
⟨λ a f g, by { refine (map_map₂_distrib_left $ λ _ _, _).symm, exact (smul_assoc a _ _).symm }⟩

instance is_scalar_tower'' [has_smul α β] [has_smul α γ] [has_smul β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower (filter α) (filter β) (filter γ) :=
⟨λ f g h, map₂_assoc smul_assoc⟩

instance is_central_scalar [has_smul α β] [has_smul αᵐᵒᵖ β] [is_central_scalar α β] :
  is_central_scalar α (filter β) :=
⟨λ a f, congr_arg (λ m, map m f) $ by exact funext (λ _, op_smul_eq_smul _ _)⟩

/-- A multiplicative action of a monoid `α` on a type `β` gives a multiplicative action of
`filter α` on `filter β`. -/
@[to_additive "An additive action of an additive monoid `α` on a type `β` gives an additive action
of `filter α` on `filter β`"]
protected def mul_action [monoid α] [mul_action α β] : mul_action (filter α) (filter β) :=
{ one_smul := λ f, map₂_pure_left.trans $ by simp_rw [one_smul, map_id'],
  mul_smul := λ f g h, map₂_assoc mul_smul }

/-- A multiplicative action of a monoid on a type `β` gives a multiplicative action on `filter β`.
-/
@[to_additive "An additive action of an additive monoid on a type `β` gives an additive action on
`filter β`."]
protected def mul_action_filter [monoid α] [mul_action α β] : mul_action α (filter β) :=
{ mul_smul := λ a b f, by simp only [←map_smul, map_map, function.comp, ←mul_smul],
  one_smul := λ f, by simp only [←map_smul, one_smul, map_id'] }

localized "attribute [instance] filter.mul_action filter.add_action filter.mul_action_filter
  filter.add_action_filter" in pointwise

/-- A distributive multiplicative action of a monoid on an additive monoid `β` gives a distributive
multiplicative action on `filter β`. -/
protected def distrib_mul_action_filter [monoid α] [add_monoid β] [distrib_mul_action α β] :
  distrib_mul_action α (filter β) :=
{ smul_add := λ _ _ _, map_map₂_distrib $ smul_add _,
  smul_zero := λ _, (map_pure _ _).trans $ by rw [smul_zero, pure_zero] }

/-- A multiplicative action of a monoid on a monoid `β` gives a multiplicative action on `set β`. -/
protected def mul_distrib_mul_action_filter [monoid α] [monoid β] [mul_distrib_mul_action α β] :
  mul_distrib_mul_action α (set β) :=
{ smul_mul := λ _ _ _, image_image2_distrib $ smul_mul' _,
  smul_one := λ _, image_singleton.trans $ by rw [smul_one, singleton_one] }

localized "attribute [instance] filter.distrib_mul_action_filter
  filter.mul_distrib_mul_action_filter" in pointwise

section smul_with_zero
variables [has_zero α] [has_zero β] [smul_with_zero α β] {f : filter α} {g : filter β}

/-!
Note that we have neither `smul_with_zero α (filter β)` nor `smul_with_zero (filter α) (filter β)`
because `0 * ⊥ ≠ 0`.
-/

lemma ne_bot.smul_zero_nonneg (hf : f.ne_bot) : 0 ≤ f • (0 : filter β) :=
le_smul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in
  ⟨_, _, ha, h₂, smul_zero' _ _⟩

lemma ne_bot.zero_smul_nonneg (hg : g.ne_bot) : 0 ≤ (0 : filter α) • g :=
le_smul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in ⟨_, _, h₁, hb, zero_smul _ _⟩

lemma zero_smul_filter_nonpos : (0 : α) • g ≤ 0 :=
begin
  refine λ s hs, mem_smul_filter.2 _,
  convert univ_mem,
  refine eq_univ_iff_forall.2 (λ a, _),
  rwa [mem_preimage, zero_smul],
end

lemma zero_smul_filter (hg : g.ne_bot) : (0 : α) • g = 0 :=
zero_smul_filter_nonpos.antisymm $ le_map_iff.2 $ λ s hs, begin
  simp_rw [set.image_eta, zero_smul, (hg.nonempty_of_mem hs).image_const],
  exact zero_mem_zero,
end

end smul_with_zero

end filter


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.Queue
import LeanColls.LazyList
import LeanColls.AuxLemmas

namespace LeanColls

/-!
# Real Time Queues

On any sequence of operations, this implementation
provides O(1) `enq` and `deq` (not amortized). However,
the constant is much larger than for `BatchQueue` and
`LazyBatchQueue`.

## References

See [Okasaki1996], Section 4.2

-/
structure RTQueue (τ) :=
  F : LazyList τ
  R : List τ
  S : LazyList τ
  h_lens : F.length = R.length + S.length

namespace RTQueue

private def model_fn : RTQueue τ → List τ :=
  λ ⟨F,R,_,_⟩ => F.toList ++ (R.reverse)

def empty : RTQueue τ :=
  ⟨ LazyList.nil,
    List.nil,
    LazyList.nil,
    by simp
  ⟩

@[inline] private def rotate (f : LazyList τ) (r : τ) (rs : List τ) (a : LazyList τ)
  (h : f.length = rs.length) : LazyList τ :=
  LazyList.delayed (Thunk.mk (λ () =>
    match h_f:f.force with
    | none =>  LazyList.cons r a
    | some (x, f') =>
    match h_r:rs with
    | [] => by
      rw [←LazyList.length_toList] at h
      simp[LazyList.toList_force_some h_f] at h
    | r'::rs' =>
      LazyList.cons x (rotate f' r' rs' (LazyList.cons r a) (by
        rw [←LazyList.length_toList] at h
        rw [LazyList.toList_force_some h_f] at h
        simp at h
        exact h
        ))
      )
  )

private theorem rotate_inv {F : LazyList α} {r rs acc}
  : (h : _) → (rotate F r rs acc h).toList = F.toList ++ rs.reverse ++ [r] ++ acc.toList
  := by
  intro h
  induction rs generalizing F r acc
  case nil =>
    have : F.toList = [] := by
      generalize hFl : F.toList = Fl
      rw [←LazyList.length_toList, hFl] at h
      match Fl with
      | [] => rfl
      | _ :: _ => simp at h
    unfold rotate
    simp [LazyList.force, Thunk.get]
    split
    case h_2 heq =>
      contradiction
    case h_1 =>
      simp [this]
  case cons hd tl ih =>
    have : ∃ x F', F.toList = x :: F' := by
      rw [←LazyList.length_toList] at h
      match hList : F.toList with
      | [] => rw [hList] at h; contradiction
      | x::F' => exact ⟨x,⟨F',rfl⟩⟩
    match this with
    | ⟨x, ⟨F', h⟩⟩ =>
    unfold rotate
    simp [Thunk.get]
    split
    case h_1 heq =>
      rw [LazyList.toList_force_none.mp heq] at h
      contradiction
    case h_2 x F' heq =>
      simp [this, ih]
      rw [LazyList.toList_force_some heq]
      rw [List.append_cons]
      simp [List.append_assoc]

@[inline] private def balance (F : LazyList τ) (R : List τ) (S : LazyList τ)
  (h_lens : F.length + 1 = R.length + S.length) : RTQueue τ :=
  match h:S.force with
  | some (_, S') =>
    ⟨F, R, S', by
      rw [←@LazyList.length_toList τ S] at h_lens
      rw [LazyList.toList_force_some h] at h_lens
      simp [Nat.add_succ] at h_lens
      assumption
    ⟩
  | none =>
  match R with
  | [] => by
    rw [←LazyList.length_toList S, LazyList.toList_force_none.mp h] at h_lens
    contradiction
  | r::rs =>
    let F' := rotate F r rs LazyList.nil (by
      rw [←@LazyList.length_toList τ S] at h_lens
      rw [LazyList.toList_force_none] at h
      rw [h] at h_lens
      simp at h_lens
      assumption
    )
    ⟨F', List.nil, F', by simp⟩

private theorem balance_inv {F : LazyList α} {R} {S} (h_lens)
  : model_fn (balance F R S h_lens) = F.toList ++ R.reverse
  := by
  simp [balance]
  split
  case h_1 _ S' heq =>
    simp [model_fn]
  case h_2 heq =>
    split
    case h_1 x y h_lens =>
      rw [←LazyList.length_toList S, LazyList.toList_force_none.mp heq] at h_lens
      contradiction
    case h_2 =>
      simp [model_fn, rotate_inv, List.append_assoc]

def enq (Q : RTQueue τ) (x : τ) : RTQueue τ :=
  let ⟨F, R, S, h_lens⟩ := Q
  balance F (List.cons x R) S (by
    simp [h_lens, Nat.add_one, Nat.succ_add])

def deq (Q : RTQueue τ) : Option (τ × RTQueue τ) :=
  let ⟨F, R, S, h_lens⟩ := Q
  match h:F.force with
  | some (x, F') => some (x, balance F' R S (by
      rw [←h_lens]
      simp
      rw [←LazyList.length_toList,←LazyList.length_toList]
      rw [LazyList.toList_force_some h]
      simp
    ))
  | none => none

instance : Queue (RTQueue τ) τ where
  empty := empty
  enq   := enq
  deq   := deq

instance : Queue.CorrectFIFO (@instQueueRTQueue τ) where
  model := model_fn
  h_empty := by simp [empty, model_fn]
  h_enq := by
    intros c x
    cases c; case mk F R S h_lens =>
    simp [Queue.enq, enq, balance_inv]
    simp [List.cons, model_fn]
    rw [←List.append_assoc]
  h_deq := by
    intro c
    cases c; case mk F R S h_lens =>
    simp [Queue.deq, deq]
    split
    case h_1 x S' hF =>
      simp [Option.map, Option.bind, balance_inv]
      simp [model_fn, LazyList.toList_force_some hF]
    case h_2 hF =>
      simp [Option.map, Option.bind, model_fn]
      simp [LazyList.toList_force_none.mp hF]
      suffices R = [] by
        simp [this, List.front?]
      suffices List.length R = 0 by
        cases R; simp; contradiction
      have : LazyList.length F = 0 := by
        rw [←LazyList.length_toList, LazyList.toList_force_none.mp hF]
        simp
      rw [this] at h_lens
      have := Nat.eq_zero_of_add_eq_zero h_lens.symm
      exact this.left


import mynat.definition
import mynat.add
import world8.level6
import world8.level9

namespace mynat

theorem add_left_eq_zero (a b : mynat) (h : a + b = 0) : b = 0 :=
begin [nat_num_game]
    cases b with d,
    {
        refl,
    },
    {
        exfalso,
        rw add_succ at h,
        apply succ_ne_zero (a + d),
        exact h,
    },
end

end mynat


import quantum_relative_entropy

import analysis.special_functions.complex.log
import order.liminf_limsup
import topology.sequences

open real filter

variables
{ℋ : Type} [complex_Hilbert_space ℋ]

/-- Hypothesis test -/
class test {n : ℕ} (Aₙ : ℋ^⨂n →ₗ[ℂ] ℋ^⨂n) :=
(geq_zero_leq_one : 0 ≤ Aₙ ∧ Aₙ ≤ 1)

variables
(ρ : ℋ^⨂1 →ₗ[ℂ] ℋ^⨂1) [quantum_state ρ]
(σ : ℋ^⨂1 →ₗ[ℂ] ℋ^⨂1) [quantum_state σ]

/-- Probability of guessing ρ^⊗n when actually σ^⊗n. -/
noncomputable def β {n : ℕ} (Aₙ : ℋ^⨂n →ₗ[ℂ] ℋ^⨂n) :=
tr(σ^⊗n * Aₙ)

/-- Probability of guessing σ^⊗n when actually ρ^⊗n. -/
noncomputable def α {n : ℕ} (Aₙ : ℋ^⨂n →ₗ[ℂ] ℋ^⨂n) :=
tr(ρ^⊗n * (1 - Aₙ))

/-- What is the minimum? -/
noncomputable def βmin (n : ℕ) (ε : ℝ) :=
Inf {prob : ℝ | ∃ (Aₙ : ℋ^⨂n →ₗ[ℂ] ℋ^⨂n) [test Aₙ], β σ Aₙ = prob ∧ α ρ Aₙ ≤ ε}

/- Quantum Stein's lemma -/
-- lemma log_inf_tends_to_quantum_relative_entropy  :
-- ∀ (ε : ℝ) [ε > 0],
-- lim at_top (λn:ℕ, log(βmin ρ σ n ε)/n) = - quantum_relative_entropy ρ σ :=
-- begin
--   sorry,
-- end


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.basic
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Completeness in terms of `cauchy` filters vs `is_cau_seq` sequences

In this file we apply `metric.complete_of_cauchy_seq_tendsto` to prove that a `normed_ring`
is complete in terms of `cauchy` filter if and only if it is complete in terms
of `cau_seq` Cauchy sequences.
-/

theorem cau_seq.tendsto_limit {β : Type v} [normed_ring β] [hn : is_absolute_value norm]
    (f : cau_seq β norm) [cau_seq.is_complete β norm] :
    filter.tendsto (⇑f) filter.at_top (nhds (cau_seq.lim f)) :=
  sorry

/-
 This section shows that if we have a uniform space generated by an absolute value, topological
 completeness and Cauchy sequence completeness coincide. The problem is that there isn't
 a good notion of "uniform space generated by an absolute value", so right now this is
 specific to norm. Furthermore, norm only instantiates is_absolute_value on normed_field.
 This needs to be fixed, since it prevents showing that ℤ_[hp] is complete
-/

protected instance normed_field.is_absolute_value {β : Type v} [normed_field β] :
    is_absolute_value norm :=
  is_absolute_value.mk norm_nonneg (fun (_x : β) => norm_eq_zero) norm_add_le normed_field.norm_mul

theorem cauchy_seq.is_cau_seq {β : Type v} [normed_field β] {f : ℕ → β} (hf : cauchy_seq f) :
    is_cau_seq norm f :=
  sorry

theorem cau_seq.cauchy_seq {β : Type v} [normed_field β] (f : cau_seq β norm) : cauchy_seq ⇑f :=
  sorry

/-- In a normed field, `cau_seq` coincides with the usual notion of Cauchy sequences. -/
theorem cau_seq_iff_cauchy_seq {α : Type u} [normed_field α] {u : ℕ → α} :
    is_cau_seq norm u ↔ cauchy_seq u :=
  { mp := fun (h : is_cau_seq norm u) => cau_seq.cauchy_seq { val := u, property := h },
    mpr := fun (h : cauchy_seq u) => cauchy_seq.is_cau_seq h }

/-- A complete normed field is complete as a metric space, as Cauchy sequences converge by
assumption and this suffices to characterize completeness. -/
protected instance complete_space_of_cau_seq_complete {β : Type v} [normed_field β]
    [cau_seq.is_complete β norm] : complete_space β :=
  sorry

end Mathlib


import order.atoms

import data.finite.basic
import order.hom.complete_lattice

universes u v

variables {α : Type u} {β : Type v}

section upper_lower

variables [preorder α] {x y z a b: α}

@[reducible] def lower_closure (s : set α) : set α := {x | ∃ y ∈ s, x ≤ y}
@[reducible] def upper_closure (s : set α) : set α := {x | ∃ y ∈ s, y ≤ x}

-- lemma lower_closure_preimage_invo [has_involution α] (s : set α) :
--   lower_closure (invo ⁻¹' s) = invo ⁻¹' (upper_closure s) :=
-- begin
--   ext x, simp only [set.mem_set_of_eq, set.mem_preimage, exists_prop],
--   exact ⟨λ ⟨y,hy,hxy⟩, ⟨yᵒ, hy, invo_le_iff.mpr hxy⟩,
--     λ ⟨y,hy,hxy⟩, ⟨yᵒ, (@invo_invo _ _ _ y).symm ▸ hy, le_invo_comm.mpr hxy⟩⟩,
-- end

-- lemma lower_closure_image_invo [has_involution α] (s : set α) :
--   lower_closure (invo '' s) = invo '' (upper_closure s) :=
-- by rw [image_invo_eq_preimage_invo, lower_closure_preimage_invo, image_invo_eq_preimage_invo]

-- lemma upper_closure_image_invo [has_involution α] (s : set α) :
--   upper_closure (invo '' s) = invo '' (lower_closure s) :=
-- by {nth_rewrite 1 ←(@invo_invo_image _ s), rw [lower_closure_image_invo, invo_invo_image]}

-- lemma upper_closure_preimage_invo [has_involution α] (s : set α):
--   upper_closure (invo ⁻¹' s) = invo ⁻¹' (lower_closure s) :=
-- by rw [←image_invo_eq_preimage_invo, ←image_invo_eq_preimage_invo, upper_closure_image_invo]

-- lemma set.Icc_dual''' (x y : α) : @set.Icc αᵒᵈ _ x y = @set.Icc α _ y x :=
--   set.dual_Icc

end upper_lower

section covby

variables [partial_order α] {x y z a b : α}

lemma covby.eq_of_le_of_lt (hab : a ⋖ b) (hax : a ≤ x) (hxb : x < b) : a = x :=
by_contra (λ h, hab.2 (hax.lt_of_ne h) hxb)

lemma covby.eq_of_lt_of_le (hab : a ⋖ b) (hax : a < x) (hxb : x ≤ b) : x = b :=
by_contra (λ h, hab.2 hax (hxb.lt_of_ne h))

lemma covby.eq_or_of_le_of_le (hab : a ⋖ b) (hax : a ≤ x) (hxb : x ≤ b) : x = a ∨ x = b :=
begin
  obtain ⟨rfl, hax⟩ := em (a = x),
    exact or.inl rfl,
  exact or.inr ((hab.eq_of_lt_of_le (hax.lt_of_ne h)) hxb),
end

lemma wcovby.covby_or_eq (hab : a ⩿ b) : a ⋖ b ∨ a = b := wcovby_iff_covby_or_eq.mp hab

end covby

section lattice

variables [lattice α]  {x y z a b: α}

lemma inf_le_inf_of_inf_le (h : a ⊓ x ≤ b) : a ⊓ x ≤ b ⊓ x := le_inf h inf_le_right

lemma sup_le_sup_of_le_sup (h : a ≤ b ⊔ x) : a ⊔ x ≤ b ⊔ x := sup_le h le_sup_right

lemma inf_eq_inf_of_le_of_le (h1 : a ⊓ x ≤ b) (h2 : b ⊓ x ≤ a) : a ⊓ x = b ⊓ x :=
  (le_inf h1 inf_le_right).antisymm (le_inf h2 inf_le_right)

lemma sup_eq_sup_of_le_of_le (h1 : a ≤ b ⊔ x) (h2 : b ≤ a ⊔ x) : a ⊔ x = b ⊔ x :=
  (sup_le h1 le_sup_right).antisymm (sup_le h2 le_sup_right)

end lattice

section modular

variables [lattice α] [is_modular_lattice α] {x y z a b: α}

lemma eq_of_le_of_inf_le_of_sup_le' (hxy : x ≤ y) (hinf : y ⊓ z ≤ x) (hsup : y ≤ x ⊔ z) : x = y :=
eq_of_le_of_inf_le_of_sup_le hxy (le_inf hinf inf_le_right) (sup_le hsup le_sup_right)

lemma inf_coatom_wcovby [order_top α] (x : α) (ha : is_coatom a) : x ⊓ a ⩿ x :=
begin
  by_cases hxa : x ≤ a,
  { rw inf_eq_left.mpr hxa, exact rfl.wcovby},
  refine covby.wcovby ⟨inf_le_left.lt_of_ne (λ h, hxa (inf_eq_left.mp h)), λ y hxy hyx, hyx.ne _⟩,
  refine @eq_of_le_of_inf_le_of_sup_le' _ _ _ _ _ a hyx.le hxy.le _,
  rw ha.2 (y ⊔ a) (le_sup_right.lt_of_ne (λ hay, _)),
  exact le_top,
  rw [eq_comm, sup_eq_right] at hay,
  exact (lt_of_lt_of_le hxy (le_inf hyx.le hay)).ne rfl,
end

lemma sup_atom_wcovby [order_bot α] (x : α) (ha : is_atom a) : x ⩿ x ⊔ a :=
(@inf_coatom_wcovby αᵒᵈ _ _ _ _ _ ha).to_dual

lemma sup_atom_covby_of_not_le [order_bot α] {x a : α} (ha : is_atom a) (hx : ¬ a ≤ x) :
  x ⋖ x ⊔ a :=
(sup_atom_wcovby x ha).covby_of_ne (λ h, hx (sup_eq_left.mp h.symm))

lemma inf_coatom_covby_of_not_le [order_top α] {x a : α} (ha : is_coatom a) (hx : ¬ x ≤ a) :
  x ⊓ a ⋖ x :=
(@sup_atom_covby_of_not_le αᵒᵈ _ _ _ x a ha hx).to_dual

end modular

section atoms

variables [complete_lattice α] [is_atomistic α] {x y z a b : α}

lemma le_of_forall_atom_le (h : ∀ a, is_atom a → a ≤ x → a ≤ y) : x ≤ y :=
by {obtain ⟨sx,rfl,hsx⟩ := eq_Sup_atoms x, exact Sup_le (λ b hb, h b (hsx b hb) (le_Sup hb))}

lemma le_iff_forall_atom_le : x ≤ y ↔ (∀ a, is_atom a → a ≤ x → a ≤ y) :=
⟨λ hxy a ha hax, hax.trans hxy, le_of_forall_atom_le⟩

lemma eq_of_atom_le_iff_atom_le (h : ∀ a, is_atom a → (a ≤ x ↔ a ≤ y)) : x = y :=
(le_of_forall_atom_le (λ a ha, (h a ha).mp)).antisymm (le_of_forall_atom_le (λ a ha, (h a ha).mpr))

lemma exists_atom_of_not_le (hxy : ¬ (x ≤ y)) : ∃ a, is_atom a ∧ a ≤ x ∧ ¬ (a ≤ y) :=
by_contra (λ h, hxy (le_of_forall_atom_le (by {push_neg at h, exact h})))

lemma exists_atom_of_lt (hxy : x < y) : ∃ a, is_atom a ∧ a ≤ y ∧ ¬ (a ≤ x) :=
exists_atom_of_not_le (not_le_of_lt hxy)

lemma exists_atom_le_of_ne_bot (hx : x ≠ ⊥) : ∃ a, is_atom a ∧ a ≤ x :=
by {obtain ⟨a,ha,hax,-⟩ := exists_atom_of_lt (bot_le.lt_of_ne' hx), exact ⟨a,ha,hax⟩}

lemma covby.exists_atom_sup (hxy : x ⋖ y) : ∃ a, is_atom a ∧ y = x ⊔ a :=
begin
  obtain ⟨a,ha,hxa,hay⟩ := exists_atom_of_lt hxy.lt,
  exact ⟨a, ha, (hxy.eq_of_lt_of_le (le_sup_left.lt_of_not_le (by simpa))
    (sup_le hxy.le hxa)).symm⟩,
end

lemma exists_sup_atom_of_inf_coatom_of_ne_bot [is_modular_lattice α] {x a : α} (hx : x ≠ ⊥)
(ha : is_coatom a) :
  ∃ b, is_atom b ∧ x = (x ⊓ a) ⊔ b :=
begin
  obtain ⟨b,hb,hbx⟩ := exists_atom_le_of_ne_bot hx,
  exact or.elim (inf_coatom_wcovby x ha).covby_or_eq (λ h, h.exists_atom_sup)
    (λ h, ⟨b, hb, by rw [h, sup_eq_left.mpr hbx]⟩),
end

end atoms

section coatoms

variables [complete_lattice α] [is_coatomistic α] {x y z a : α}

lemma le_of_le_forall_coatom (h : ∀ a, is_coatom a → y ≤ a → x ≤ a) : x ≤ y :=
@le_of_forall_atom_le αᵒᵈ _ _ _ _ h

lemma le_iff_le_forall_coatom : x ≤ y ↔ (∀ a, is_coatom a → y ≤ a → x ≤ a) :=
@le_iff_forall_atom_le αᵒᵈ_ _ _ _

lemma eq_of_le_coatom_iff_le_coatom (h : ∀ a, is_coatom a → (x ≤ a ↔ y ≤ a)) : x = y :=
@eq_of_atom_le_iff_atom_le αᵒᵈ _ _ _ _ h

lemma exists_coatom_of_not_le (hxy : ¬ (x ≤ y)) : ∃ a, is_coatom a ∧ y ≤ a ∧ ¬ (x ≤ a) :=
@exists_atom_of_not_le αᵒᵈ _ _ _ _ hxy

lemma exists_coatom_of_lt (hxy : x < y) : ∃ a, is_coatom a ∧ x ≤ a ∧ ¬ (y ≤ a) :=
@exists_atom_of_lt αᵒᵈ _ _ _ _ hxy

lemma exists_le_coatom_of_ne_top (hx : x ≠ ⊤) : ∃ b, is_coatom b ∧ x ≤ b :=
@exists_atom_le_of_ne_bot αᵒᵈ _ _ _ hx

lemma covby.exists_coatom_inf (hxy : x ⋖ y): ∃ a, is_coatom a ∧ x = y ⊓ a :=
@covby.exists_atom_sup αᵒᵈ _ _ _ _ hxy.to_dual

lemma exists_inf_coatom_of_sup_atom_of_ne_top [is_modular_lattice α] {x a : α} (hx : x ≠ ⊤)
(ha : is_atom a):
  ∃ b, is_coatom b ∧ x = (x ⊔ a) ⊓ b :=
@exists_sup_atom_of_inf_coatom_of_ne_bot αᵒᵈ _ _ _ _ _ hx ha

end coatoms

section finite

variables [finite α]

instance : finite αᵒᵈ := (infer_instance : finite α)

lemma finite.exists_maximal' [nonempty α] [preorder α] : ∃ x : α, ∀ y, ¬ (x < y) :=
begin
  haveI := fintype.of_finite α,
  exact (finset.univ.exists_maximal finset.univ_nonempty).imp
    (λ a h y hay, (exists.elim h (λ _ h', h' _ (finset.mem_univ _) hay))),
end

lemma finite.exists_minimal' [nonempty α] [preorder α] : ∃ x : α, ∀ y, ¬ (y < x) :=
@finite.exists_maximal' αᵒᵈ _ _ _

lemma set.finite.exists_maximal_mem' [preorder α] {s : set α} (hs : s.nonempty) :
  ∃ x ∈ s, ∀ y, y ∈ s → ¬ (x < y) :=
begin
  obtain ⟨⟨x,hx⟩,h⟩ :=  @finite.exists_maximal' s _ hs.to_subtype _,
  exact ⟨x,hx,λ y hy, λ hlt, h ⟨y,hy⟩ (subtype.mk_lt_mk.mpr hlt)⟩,
end

lemma set.finite.exists_minimal_mem' [preorder α] {s : set α} (hs : s.nonempty) :
  ∃ x ∈ s, ∀ y, y ∈ s → ¬ (y < x) :=
@set.finite.exists_maximal_mem' αᵒᵈ _ _ _ hs

lemma set.finite.exists_maximal_mem [partial_order α] {s : set α} (hs : s.nonempty) :
  ∃ x ∈ s, ∀ y, y ∈ s → x ≤ y → x = y :=
(set.finite.exists_maximal_mem' hs).imp
  (λ x h, h.imp (λ hxs hx y hys hxy, eq_of_le_of_not_lt hxy (hx _ hys)))

lemma set.finite.exists_minimal_mem [partial_order α] {s : set α} (hs : s.nonempty) :
  ∃ x ∈ s, ∀ y, y ∈ s → y ≤ x → y = x :=
(set.finite.exists_minimal_mem' hs).imp
  (λ x h, h.imp (λ hxs hx y hys hxy, eq_of_le_of_not_lt hxy (hx _ hys)))

end finite

section complete

variables [complete_lattice α] {a : α} {S T : set α} {f : α → α}

lemma Sup_image_sup_left_eq_sup_Sup_of_nonempty (hS : S.nonempty) :
  Sup ((λ x, a ⊔ x) '' S) = a ⊔ (Sup S) :=
let ⟨x,hx⟩ := hS in
(Sup_le (by {rintro _ ⟨y,hy,rfl⟩, refine sup_le_sup_left (le_Sup hy) _, })).antisymm
  (sup_le (le_sup_left.trans (le_Sup ((set.mem_image _ _ _).mpr ⟨x,hx,rfl⟩)))
  (Sup_le_Sup_of_forall_exists_le (λ y hy, ⟨a ⊔ y, ⟨⟨y,hy,rfl⟩,le_sup_right⟩⟩)))

lemma Sup_image_sup_right_eq_Sup_sup_of_nonempty (hS : S.nonempty) :
  Sup ((λ x, x ⊔ a) '' S) = (Sup S) ⊔ a :=
by {rw [sup_comm, ←Sup_image_sup_left_eq_sup_Sup_of_nonempty hS], simp_rw [sup_comm]}

lemma Inf_image_inf_right_eq_Inf_inf_of_nonempty (hS : S.nonempty) :
  Inf ((λ x, x ⊓ a) '' S) = (Inf S) ⊓ a :=
@Sup_image_sup_right_eq_Sup_sup_of_nonempty αᵒᵈ _ _ _ hS

lemma Inf_image_inf_left_eq_inf_Inf_of_nonempty (hS : S.nonempty) :
  Inf ((λ x, a ⊓ x) '' S) = a ⊓ (Inf S) :=
@Sup_image_sup_left_eq_sup_Sup_of_nonempty αᵒᵈ _ _ _ hS

-- these are already in mathlib : supr_sup etc . Maybe PR the below?

lemma bsupr_eq_supr_subtype :
  (⨆ (x : α) (H : x ∈ S), f x) = ⨆ (y : ↥S), f y :=
supr_subtype'

lemma bsupr_sup (hS : S.nonempty) :
  (⨆ (x ∈ S), (f x ⊔ a)) = (⨆ (x ∈ S), f x) ⊔ a :=
by {simpa [supr_subtype'] using (@supr_sup _ _ _ hS.to_subtype _ _).symm}

lemma sup_bsupr (hS : S.nonempty) :
  (⨆ (x ∈ S), (a ⊔ f x)) = a ⊔ (⨆ (x ∈ S), f x) :=
by {rw [sup_comm, ←bsupr_sup hS], simp_rw [sup_comm]}

lemma binf_inf (hS : S.nonempty) :
  (⨅ (x ∈ S), (f x ⊓ a)) = (⨅ (x ∈ S), f x) ⊓ a :=
@bsupr_sup αᵒᵈ _ _ _ _ hS

lemma inf_binf (hS : S.nonempty) :
  (⨅ (x ∈ S), (a ⊓ f x)) = a ⊓ (⨅ (x ∈ S), f x) :=
@sup_bsupr αᵒᵈ _ _ _ _ hS

lemma Inf_diff_singleton_inf_of_mem_eq (ha : a ∈ S) : (Inf (S \ {a})) ⊓ a = Inf S :=
begin
  nth_rewrite 1 ←(Inf_singleton : Inf {a} = a),
  rw [←Inf_union, set.diff_union_of_subset (set.singleton_subset_iff.mpr ha)],
end

lemma Sup_diff_singleton_sup_of_mem_eq (ha : a ∈ S) : (Sup (S \ {a})) ⊔ a = Sup S :=
@Inf_diff_singleton_inf_of_mem_eq αᵒᵈ _ _ _ ha

lemma supr_bool_eq' {f : bool → α} (i : bool) : (⨆ j, f j) = f i ⊔ f (!i) :=
by {rw supr_bool_eq, cases i; simp [sup_comm]}

lemma infi_bool_eq' {f : bool → α} (i : bool) : (⨅ j, f j) = f i ⊓ f (!i) :=
@supr_bool_eq' αᵒᵈ _ _ _

end complete

section intervals

open set subtype

instance [complete_lattice α] {a : α} : complete_lattice (Iic a) :=
{ Sup := λ S, ⟨_, (Sup_le (λ _ ⟨⟨_,hb⟩,_,rfl⟩, hb) : complete_lattice.Sup (coe '' S) ≤ a)⟩,
  Inf := λ S, ⟨_, @inf_le_left _ _ a (complete_lattice.Inf (coe '' S))⟩,
  le_Sup := λ _ _ h, coe_le_coe.mp (le_Sup (mem_image_of_mem _ h)),
  Sup_le := λ _ _ h, coe_le_coe.mp (Sup_le (by {rintros y ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)})),
  Inf_le := λ _ x h, coe_le_coe.mp (inf_le_of_right_le (Inf_le ⟨x,h,rfl⟩)),
  le_Inf := λ _ x h, coe_le_coe.mp (le_inf x.2
  (le_Inf (by {rintros _ ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)}))),
  .. (infer_instance : lattice (set.Iic a)),
  .. (infer_instance : bounded_order (set.Iic a)) }

instance [complete_lattice α] {a : α} : complete_lattice (Ici a) :=
{ Sup := λ S, ⟨_, (@le_sup_left _ _ a (complete_lattice.Sup (coe '' S)))⟩,
  Inf := λ S, ⟨complete_lattice.Inf (coe '' S), (le_Inf (λ _ ⟨⟨_,hb⟩,_,rfl⟩, hb))⟩,
  Inf_le := λ _ _ h, coe_le_coe.mp (Inf_le (mem_image_of_mem _ h)),
  le_Inf := λ _ _ h, coe_le_coe.mp (le_Inf (by {rintros _ ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)})),
  le_Sup := λ _ x h, coe_le_coe.mp (le_sup_of_le_right (le_Sup ⟨x,h,rfl⟩)),
  Sup_le := λ _ x h, coe_le_coe.mp
    (sup_le x.2 (Sup_le (by {rintros _ ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)}))),
  .. (infer_instance : lattice (set.Ici a)),
  .. (infer_instance : bounded_order (set.Ici a)) }

@[reducible] def Icc_complete_lattice [complete_lattice α] {a b : α} (hab : a ≤ b) :
  complete_lattice (Icc a b) :=
{ Sup := λ S, ⟨a ⊔ Sup (coe '' S),
    ⟨le_sup_left, sup_le hab (Sup_le (by {rintros _ ⟨⟨_,h⟩,_,rfl⟩, exact h.2}))⟩ ⟩,
  Inf := λ S, ⟨b ⊓ Inf (coe '' S),
    ⟨le_inf hab (le_Inf (by {rintros _ ⟨⟨_,h⟩,_,rfl⟩, exact h.1})), inf_le_left⟩⟩,
  Inf_le := λ _ x h, coe_le_coe.mp (inf_le_of_right_le (Inf_le (⟨x,h,rfl⟩))),
  le_Inf := λ _ x h, coe_le_coe.mp
    (le_inf x.2.2 (le_Inf (by {rintros _ ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)}))),
  le_Sup := λ _ x h, coe_le_coe.mp (le_sup_of_le_right (le_Sup ⟨x,h,rfl⟩)),
  Sup_le := λ _ x h,
    (sup_le x.2.1 (Sup_le (by {rintros _ ⟨z,p,rfl⟩, exact coe_le_coe.mpr (h z p)}))),
  .. (infer_instance : lattice (set.Icc a b)),
  .. (Icc.bounded_order hab) }

@[simp] lemma set.Iic.coe_Sup [complete_lattice α] {a : α} {S : set (Iic a)} :
  ((Sup S : Iic a) : α) = Sup ((coe : Iic a → α) '' S) := rfl

@[simp] lemma set.Iic.coe_Inf [complete_lattice α] {a : α} {S : set (Iic a)} :
  ((Inf S : Iic a) : α) = a ⊓ Inf ((coe : Iic a → α) '' S) := rfl

lemma set.Iic.coe_Inf_nonempty_eq [complete_lattice α] {a : α} {S : set (Iic a)} (hS : S.nonempty) :
  ((Inf S : Iic a) : α) = Inf ((coe : Iic a → α) '' S) := by
{ rw [set.Iic.coe_Inf, inf_eq_right],
  exact exists.elim hS (λ ⟨x,hxa⟩ hx, le_trans (Inf_le (⟨⟨x,hxa⟩,hx,rfl⟩)) hxa)}

@[simp] lemma set.Iic.coe_sup [semilattice_sup α] {a : α} {x y : Iic a} :
  (↑(x ⊔ y) : α) = (↑x ⊔ ↑y) := rfl

@[simp] lemma set.Iic.coe_inf [semilattice_inf α] {a : α} {x y : Iic a} :
  (↑(x ⊓ y) : α) = (↑x ⊓ ↑y) := rfl

@[simp] lemma set.Ici.coe_inf [semilattice_inf α] {a : α} {x y : Iic a} :
  (↑(x ⊓ y) : α) = (↑x ⊓ ↑y) := rfl

@[simp] lemma set.Ici.coe_sup [semilattice_sup α] {a : α} {x y : Iic a} :
  (↑(x ⊔ y) : α) = (↑x ⊔ ↑y) := rfl

@[simp] lemma set.Icc.coe_inf [semilattice_inf α] {a : α} {x y : Iic a} :
  (↑(x ⊓ y) : α) = (↑x ⊓ ↑y) := rfl

@[simp] lemma set.Icc.coe_sup [semilattice_sup α] {a : α} {x y : Iic a} :
  (↑(x ⊔ y) : α) = (↑x ⊔ ↑y) := rfl

@[simp] lemma set.Ioc.coe_inf [semilattice_inf α] {a : α} {x y : Iic a} :
  (↑(x ⊓ y) : α) = (↑x ⊓ ↑y) := rfl

@[simp] lemma set.Ioc.coe_sup [semilattice_sup α] {a : α} {x y : Iic a} :
  (↑(x ⊔ y) : α) = (↑x ⊔ ↑y) := rfl

@[simp] lemma set.Ico.coe_inf [semilattice_inf α] {a : α} {x y : Iic a} :
  (↑(x ⊓ y) : α) = (↑x ⊓ ↑y) := rfl

@[simp] lemma set.Ico.coe_sup [semilattice_sup α] {a : α} {x y : Iic a} :
  (↑(x ⊔ y) : α) = (↑x ⊔ ↑y) := rfl

-- etc etc... PR this?

-- @[simp, norm_cast] lemma coe_inf [semilattice_inf α] {P : α → Prop}
--   (Psup : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) (x y : subtype P) :
-- (@has_inf.inf _ (@semilattice_inf.to_has_inf _ (subtype.semilattice_inf Psup)) x y : α)
--   = x ⊓ y := rfl

@[simp, norm_cast] lemma subtype.coe_sup [semilattice_sup α] {P : α → Prop}
(Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) (x y : subtype P) :
(@has_sup.sup _ (@semilattice_sup.to_has_sup _ (subtype.semilattice_sup Psup)) x y : α)
  = x ⊔ y := rfl

@[simp, norm_cast] lemma subtype.coe_inf [semilattice_inf α] {P : α → Prop}
(Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) (x y : subtype P) :
(@has_inf.inf _ (@semilattice_inf.to_has_inf _ (subtype.semilattice_inf Pinf)) x y : α)
  = x ⊓ y := rfl

@[simp] lemma subtype.mk_sup [semilattice_sup α] {P : α → Prop}
(Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) {x y : α} (hx : P x) (hy : P y) :
(@has_sup.sup _ (@semilattice_sup.to_has_sup _ (subtype.semilattice_sup Psup)) ⟨x,hx⟩ ⟨y,hy⟩) =
  ⟨x ⊔ y, Psup hx hy⟩ := rfl

@[simp] lemma subtype.mk_inf [semilattice_inf α] {P : α → Prop}
(Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) {x y : α} (hx : P x) (hy : P y) :
(@has_inf.inf _ (@semilattice_inf.to_has_inf _ (subtype.semilattice_inf Pinf)) ⟨x,hx⟩ ⟨y,hy⟩) =
  ⟨x ⊓ y, Pinf hx hy⟩ := rfl

end intervals


/-
Copyright (c) 2022 Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémi Bottinelli
-/
import combinatorics.quiver.basic
/-!

# Pushing a quiver structure along a map

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

Given a map `σ : V → W` and a `quiver` instance on `V`, this files defines a `quiver` instance
on `W` by associating to each arrow `v ⟶ v'` in `V` an arrow `σ v ⟶ σ v'` in `W`.

-/

universes v v₁ v₂ u u₁ u₂

variables {V : Type*} [quiver V] {W : Type*} (σ : V → W)

namespace quiver

/-- The `quiver` instance obtained by pushing arrows of `V` along the map `σ : V → W` -/
@[nolint unused_arguments]
def push (σ : V → W) := W

instance [h : nonempty W] : nonempty (push σ) := h

/-- The quiver structure obtained by pushing arrows of `V` along the map `σ : V → W` -/
@[nolint has_nonempty_instance]
inductive push_quiver {V : Type u} [quiver.{v} V] {W : Type u₂} (σ : V → W) :
  W → W → Type (max u u₂ v)
| arrow {X Y : V} (f : X ⟶ Y) : push_quiver (σ X) (σ Y)

instance : quiver (push σ) := ⟨push_quiver σ⟩

namespace push

/-- The prefunctor induced by pushing arrows via `σ` -/
def of : V ⥤q push σ :=
{ obj := σ,
  map := λ X Y f, push_quiver.arrow f }

@[simp] lemma of_obj : (of σ).obj = σ := rfl

variables {W' : Type*} [quiver W'] (φ : V ⥤q W') (τ : W → W') (h : ∀ x, φ.obj x = τ (σ x) )

include φ h
/-- Given a function `τ : W → W'` and a prefunctor `φ : V ⥤q W'`, one can extend `τ` to be
a prefunctor `W ⥤q W'` if `τ` and `σ` factorize `φ` at the level of objects, where `W` is given
the pushforward quiver structure `push σ`. -/
def lift : push σ ⥤q W' :=
{ obj := τ,
  map := @push_quiver.rec V _ W σ
    (λ X Y f, τ X ⟶ τ Y)
    (λ X Y f, by { rw [←h X, ←h Y], exact φ.map f, }) }

lemma lift_obj : (lift σ φ τ h).obj = τ := rfl

lemma lift_comp : of σ ⋙q lift σ φ τ h = φ :=
begin
  fapply prefunctor.ext,
  { rintros, simp only [prefunctor.comp_obj], symmetry, exact h X, },
  { rintros _ _ f, simp only [prefunctor.comp_map],
    apply eq_of_heq,
    iterate 2 { apply (cast_heq _ _).trans },
    symmetry,
    iterate 2 { apply (eq_rec_heq _ _).trans },
    refl, },
end

lemma lift_unique (Φ : push σ ⥤q W') (Φ₀ : Φ.obj = τ) (Φcomp : of σ ⋙q Φ = φ) :
  Φ = lift σ φ τ h :=
begin
  dsimp only [of,lift],
  fapply prefunctor.ext,
  { rintros, simp_rw [←Φ₀], },
  { rintros _ _ ⟨⟩, subst_vars, simp only [prefunctor.comp_map, cast_eq], refl, }
end

end push

end quiver


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import from_mathlib.ring_seminorm
import analysis.special_functions.pow

/-!
# Equivalent power-multiplicative norms

In this file, we prove [BGR, Proposition 3.1.5/1]: if `R` is a normed commutative ring and `f₁` and
`f₂` are two power-multiplicative `R`-algebra norms on `S`, then if `f₁` and `f₂` are equivalent on
every subring `R[y]` for `y : S`, it follows that `f₁ = f₂`.

## Main Definitions
* `algebra_norm.restriction` : The restriction of an algebra norm to a subalgebra.
* `ring_hom.is_bounded_wrt` :A ring homomorphism `f : α →+* β` is bounded with respect to the
  functions `nα : α → ℝ` and `nβ : β → ℝ` if there exists a positive constant `C` such that for all
  `x` in `α`, `nβ (f x) ≤ C * nα x`.

## Main Results
* `eq_of_pow_mult_faithful` : the proof of [BGR, Proposition 3.1.5/1].

## References
* [S. Bosch, U. Güntzer, R. Remmert, *Non-Archimedean Analysis*][bosch-guntzer-remmert]

## Tags

norm, equivalent, power-multiplicative
-/

open_locale topology

/-- A homomorphism `f` between semi_normed_rings is bounded if there exists a positive
  constant `C` such that for all `x` in `α`, `norm (f x) ≤ C * norm x`. -/
def ring_hom.is_bounded {α : Type*} [semi_normed_ring α] {β : Type*} [semi_normed_ring β]
  (f : α →+* β) : Prop := ∃ C : ℝ, 0 < C ∧ ∀ x : α, norm (f x) ≤ C * norm x

/-- A ring homomorphism `f : α →+* β` is bounded with respect to the functions `nα : α → ℝ` and
  `nβ : β → ℝ` if there exists a positive constant `C` such that for all `x` in `α`,
  `nβ (f x) ≤ C * nα x`. -/
def ring_hom.is_bounded_wrt {α : Type*} [ring α] {β : Type*} [ring β] (nα : α → ℝ) (nβ : β → ℝ)
  (f : α →+* β) : Prop :=
∃ C : ℝ, 0 < C ∧ ∀ x : α, nβ (f x) ≤ C * nα x

/-- If `f : α →+* β` is bounded with respect to a ring seminorm `nα` on `α` and a
  power-multiplicative function `nβ : β → ℝ`, then `∀ x : α, nβ (f x) ≤ nα x`. -/
lemma contraction_of_is_pm_wrt {F : Type*} {α : out_param(Type*)} [ring α]
  [ring_seminorm_class F α ℝ] {β : Type*} [ring β] (nα : F) {nβ : β → ℝ} (hβ : is_pow_mul nβ)
  {f : α →+* β} (hf : f.is_bounded_wrt nα nβ) (x : α) :
  nβ (f x) ≤ nα x :=
begin
  obtain ⟨C, hC0, hC⟩ := hf,
  have hlim : filter.tendsto (λ n : ℕ, C ^ (1 / (n : ℝ)) * nα x) filter.at_top (𝓝 (nα x)),
  { have : (𝓝 (nα x)) = (𝓝 (1 * (nα x))) := by rw one_mul,
    rw this,
    apply filter.tendsto.mul,
    { apply filter.tendsto.comp _ (tendsto_const_div_at_top_nhds_0_nat 1),
      rw ← real.rpow_zero C,
      apply continuous_at.tendsto (real.continuous_at_const_rpow (ne_of_gt hC0)), },
    exact tendsto_const_nhds, },
  apply ge_of_tendsto hlim,
  simp only [filter.eventually_at_top, ge_iff_le],
  use 1,
  intros n hn,
  have h : (C^(1/n : ℝ))^n  = C,
  { have hn0 : (n : ℝ) ≠ 0 := nat.cast_ne_zero.mpr (ne_of_gt hn),
      rw [← real.rpow_nat_cast, ← real.rpow_mul (le_of_lt hC0), one_div, inv_mul_cancel hn0,
        real.rpow_one], },
  apply le_of_pow_le_pow n
    (mul_nonneg (real.rpow_nonneg_of_nonneg (le_of_lt hC0) _) (map_nonneg _ _)) hn,
  { rw [mul_pow, h, ← hβ _ hn, ← ring_hom.map_pow],
    apply le_trans (hC (x^n)),
    rw mul_le_mul_left hC0,
    exact map_pow_le_pow _ _ (nat.one_le_iff_ne_zero.mp hn), },
end

/-- Given a bounded `f : α →+* β` between seminormed rings, is the seminorm on `β` is
  power-multiplicative, then `f` is a contraction. -/
lemma contraction_of_is_pm {α : Type*} [semi_normed_ring α] {β : Type*} [semi_normed_ring β]
  (hβ : is_pow_mul (norm : β → ℝ)) {f : α →+* β} (hf : f.is_bounded) (x : α) :
  norm (f x) ≤ norm x :=
contraction_of_is_pm_wrt (seminormed_ring.to_ring_seminorm α) hβ hf x

/-- Given two power-multiplicative ring seminorms `f, g` on `α`, if `f` is bounded by a positive
  multiple of `g` and viceversa, then `f = g`. -/
lemma eq_seminorms {F : Type*}  {α : out_param(Type*)} [ring α] [ring_seminorm_class F α ℝ]
  (f g : F) (hfpm : is_pow_mul f) (hgpm : is_pow_mul g)
  (hfg : ∃ (r : ℝ) (hr : 0 < r), ∀ (a : α), f a ≤ r * g a)
  (hgf : ∃ (r : ℝ) (hr : 0 < r), ∀ (a : α), g a ≤ r * f a) : f = g :=
begin
  obtain ⟨r, hr0, hr⟩ := hfg,
  obtain ⟨s, hs0, hs⟩ := hgf,
  have hle : ring_hom.is_bounded_wrt f g (ring_hom.id _) := ⟨s, hs0, hs⟩,
  have hge : ring_hom.is_bounded_wrt g f (ring_hom.id _) := ⟨r, hr0, hr⟩,
  rw ← function.injective.eq_iff (ring_seminorm_class.coe_injective'),
  ext x,
  exact le_antisymm (contraction_of_is_pm_wrt g hfpm hge x) (contraction_of_is_pm_wrt f hgpm hle x)
end

variables {R S : Type*} [normed_comm_ring R] [comm_ring S] [algebra R S]

/-- The restriction of a power-multiplicative function to a subalgebra is power-multiplicative. -/
lemma is_pow_mul.restriction (A : subalgebra R S) {f : S → ℝ} (hf_pm : is_pow_mul f) :
  is_pow_mul (λ x : A, (f x.val)) :=
λ x n hn, by simpa [subtype.val_eq_coe,subsemiring_class.coe_pow] using (hf_pm ↑x hn)

/-- The restriction of an algebra norm to a subalgebra. -/
def algebra_norm.restriction (A : subalgebra R S) (f : algebra_norm R S) : algebra_norm R A :=
{ to_fun    := λ x : A, f x.val,
  map_zero' := map_zero f,
  add_le'   := λ x y, map_add_le_add _ _ _,
  neg'      := λ x, map_neg_eq_map _ _,
  mul_le'   := λ x y, map_mul_le_mul _ _ _,
  eq_zero_of_map_eq_zero' :=
  λ x hx, by {rw ← zero_mem_class.coe_eq_zero; exact eq_zero_of_map_eq_zero f hx},
  smul'      := λ r x, map_smul_eq_mul _ _ _ }

/-- If `R` is a normed commutative ring and `f₁` and `f₂` are two power-multiplicative `R`-algebra
  norms on `S`, then if `f₁` and `f₂` are equivalent on every  subring `R[y]` for `y : S`, it
  follows that `f₁ = f₂` [BGR, Proposition 3.1.5/1].  -/
lemma eq_of_pow_mult_faithful (f₁ : algebra_norm R S) (hf₁_pm : is_pow_mul f₁)
  (f₂ : algebra_norm R S) (hf₂_pm : is_pow_mul f₂)
  (h_eq : ∀ (y : S), ∃ (C₁ C₂ : ℝ) (hC₁ : 0 < C₁) (hC₂ : 0 < C₂), ∀ (x : (algebra.adjoin R {y})),
    f₁ x.val ≤ C₁ * (f₂ x.val) ∧ f₂ x.val ≤ C₂ * (f₁ x.val) ) :
  f₁ = f₂ :=
begin
  ext x,
  set g₁ : algebra_norm R (algebra.adjoin R ({x} : set S)) := algebra_norm.restriction _ f₁,
  set g₂ : algebra_norm R (algebra.adjoin R ({x} : set S)) := algebra_norm.restriction _ f₂,
  have hg₁_pm : is_pow_mul g₁ := is_pow_mul.restriction _ hf₁_pm,
  have hg₂_pm : is_pow_mul g₂ := is_pow_mul.restriction _ hf₂_pm,
  let y : algebra.adjoin R ({x} : set S) := ⟨x, algebra.self_mem_adjoin_singleton R x⟩,
  have hy : x = y.val := rfl,
  have h1 : f₁ y.val = g₁ y := rfl,
  have h2 : f₂ y.val = g₂ y := rfl,
  obtain ⟨C₁, C₂, hC₁_pos, hC₂_pos, hC⟩ := h_eq x,
  obtain ⟨hC₁, hC₂⟩ := forall_and_distrib.mp hC,
  rw [hy, h1, h2, eq_seminorms g₁ g₂ hg₁_pm  hg₂_pm ⟨C₁, hC₁_pos, hC₁⟩ ⟨C₂, hC₂_pos, hC₂⟩],
end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/

import category_theory.monad.types
import category_theory.monad.limits
import category_theory.equivalence
import topology.category.CompHaus
import topology.category.Profinite
import data.set.constructions

/-!

# Compacta and Compact Hausdorff Spaces

Recall that, given a monad `M` on `Type*`, an *algebra* for `M` consists of the following data:
- A type `X : Type*`
- A "structure" map `M X → X`.
This data must also satisfy a distributivity and unit axiom, and algebras for `M` form a category
in an evident way.

See the file `category_theory.monad.algebra` for a general version, as well as the following link.
https://ncatlab.org/nlab/show/monad

This file proves the equivalence between the category of *compact Hausdorff topological spaces*
and the category of algebras for the *ultrafilter monad*.

## Notation:

Here are the main objects introduced in this file.
- `Compactum` is the type of compacta, which we define as algebras for the ultrafilter monad.
- `Compactum_to_CompHaus` is the functor `Compactum ⥤ CompHaus`. Here `CompHaus` is the usual
  category of compact Hausdorff spaces.
- `Compactum_to_CompHaus.is_equivalence` is a term of type `is_equivalence Compactum_to_CompHaus`.

The proof of this equivalence is a bit technical. But the idea is quite simply that the structure
map `ultrafilter X → X` for an algebra `X` of the ultrafilter monad should be considered as the map
sending an ultrafilter to its limit in `X`. The topology on `X` is then defined by mimicking the
characterization of open sets in terms of ultrafilters.

Any `X : Compactum` is endowed with a coercion to `Type*`, as well as the following instances:
- `topological_space X`.
- `compact_space X`.
- `t2_space X`.

Any morphism `f : X ⟶ Y` of is endowed with a coercion to a function `X → Y`, which is shown to
be continuous in `continuous_of_hom`.

The function `Compactum.of_topological_space` can be used to construct a `Compactum` from a
topological space which satisfies `compact_space` and `t2_space`.

We also add wrappers around structures which already exist. Here are the main ones, all in the
`Compactum` namespace:

- `forget : Compactum ⥤ Type*` is the forgetful functor, which induces a `concrete_category`
  instance for `Compactum`.
- `free : Type* ⥤ Compactum` is the left adjoint to `forget`, and the adjunction is in `adj`.
- `str : ultrafilter X → X` is the structure map for `X : Compactum`.
  The notation `X.str` is preferred.
- `join : ultrafilter (ultrafilter X) → ultrafilter X` is the monadic join for `X : Compactum`.
  Again, the notation `X.join` is preferred.
- `incl : X → ultrafilter X` is the unit for `X : Compactum`. The notation `X.incl` is preferred.

## References

- E. Manes, Algebraic Theories, Graduate Texts in Mathematics 26, Springer-Verlag, 1976.
- https://ncatlab.org/nlab/show/ultrafilter

-/

universe u
open category_theory filter ultrafilter topological_space category_theory.limits has_finite_inter
open_locale classical topological_space

local notation `β` := of_type_monad ultrafilter

/-- The type `Compactum` of Compacta, defined as algebras for the ultrafilter monad. -/
@[derive [category, inhabited]]
def Compactum := monad.algebra β

namespace Compactum

/-- The forgetful functor to Type* -/
@[derive [creates_limits,faithful]]
def forget : Compactum ⥤ Type* := monad.forget _

/-- The "free" Compactum functor. -/
def free : Type* ⥤ Compactum := monad.free _

/-- The adjunction between `free` and `forget`. -/
def adj : free ⊣ forget := monad.adj _

-- Basic instances
instance : concrete_category Compactum := { forget := forget }
instance : has_coe_to_sort Compactum Type* := ⟨forget.obj⟩
instance {X Y : Compactum} : has_coe_to_fun (X ⟶ Y) (λ f, X → Y) := ⟨λ f, f.f⟩
instance : has_limits Compactum := has_limits_of_has_limits_creates_limits forget

/-- The structure map for a compactum, essentially sending an ultrafilter to its limit. -/
def str (X : Compactum) : ultrafilter X → X := X.a

/-- The monadic join. -/
def join (X : Compactum) : ultrafilter (ultrafilter X) → ultrafilter X := β .μ.app _

/-- The inclusion of `X` into `ultrafilter X`. -/
def incl (X : Compactum) : X → ultrafilter X := β .η.app _

@[simp] lemma str_incl (X : Compactum) (x : X) : X.str (X.incl x) = x :=
begin
  change (β .η.app _ ≫ X.a) _ = _,
  rw monad.algebra.unit,
  refl,
end

@[simp] lemma str_hom_commute (X Y : Compactum) (f : X ⟶ Y) (xs : ultrafilter X) :
  f (X.str xs) = Y.str (map f xs) :=
begin
  change (X.a ≫ f.f) _ = _,
  rw ←f.h,
  refl,
end

@[simp] lemma join_distrib (X : Compactum) (uux : ultrafilter (ultrafilter X)) :
  X.str (X.join uux) = X.str (map X.str uux) :=
begin
  change (β .μ.app _ ≫ X.a) _ = _,
  rw monad.algebra.assoc,
  refl,
end

instance {X : Compactum} : topological_space X :=
{ is_open := λ U, ∀ (F : ultrafilter X), X.str F ∈ U → U ∈ F,
  is_open_univ := λ _ _, filter.univ_sets _,
  is_open_inter := λ S T h3 h4 h5 h6,
    filter.inter_sets _ (h3 _ h6.1) (h4 _ h6.2),
  is_open_sUnion := λ S h1 F ⟨T,hT,h2⟩,
    mem_of_superset (h1 T hT _ h2) (set.subset_sUnion_of_mem hT) }

theorem is_closed_iff {X : Compactum} (S : set X) : is_closed S ↔
  (∀ F : ultrafilter X, S ∈ F → X.str F ∈ S) :=
begin
  rw ← is_open_compl_iff,
  split,
  { intros cond F h,
    by_contradiction c,
    specialize cond F c,
    rw compl_mem_iff_not_mem at cond,
    contradiction },
  { intros h1 F h2,
    specialize h1 F,
    cases F.mem_or_compl_mem S, exacts [absurd (h1 h) h2, h] }
end

instance {X : Compactum} : compact_space X :=
begin
  constructor,
  rw is_compact_iff_ultrafilter_le_nhds,
  intros F h,
  refine ⟨X.str F, by tauto, _⟩,
  rw le_nhds_iff,
  intros S h1 h2,
  exact h2 F h1
end

/-- A local definition used only in the proofs. -/
private def basic {X : Compactum} (A : set X) : set (ultrafilter X) := {F | A ∈ F}
/-- A local definition used only in the proofs. -/
private def cl {X : Compactum} (A : set X) : set X := X.str '' (basic A)

private lemma basic_inter {X : Compactum} (A B : set X) : basic (A ∩ B) = basic A ∩ basic B :=
begin
  ext G,
  split,
  { intro hG,
    split; filter_upwards [hG] with _,
    exacts [and.left, and.right] },
  { rintros ⟨h1, h2⟩,
    exact inter_mem h1 h2 }
end

private lemma subset_cl {X : Compactum} (A : set X) : A ⊆ cl A := λ a ha, ⟨X.incl a, ha,by simp⟩

private theorem cl_cl {X : Compactum} (A : set X) : cl (cl A) ⊆ cl A :=
begin
  rintros _ ⟨F,hF,rfl⟩,
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let C0 : ssu := {Z | ∃ B ∈ F, X.str ⁻¹' B = Z},
  let AA := {G : ultrafilter X | A ∈ G},
  let C1 := insert AA C0,
  let C2 := finite_inter_closure C1,
  -- C0 is closed under intersections.
  have claim1 : ∀ B C ∈ C0, B ∩ C ∈ C0,
  { rintros B ⟨Q,hQ,rfl⟩ C ⟨R,hR,rfl⟩,
    use Q ∩ R,
    simp only [and_true, eq_self_iff_true, set.preimage_inter, subtype.val_eq_coe],
    exact inter_sets _ hQ hR },
  -- All sets in C0 are nonempty.
  have claim2 : ∀ B ∈ C0, set.nonempty B,
  { rintros B ⟨Q,hQ,rfl⟩,
    obtain ⟨q⟩ := filter.nonempty_of_mem hQ,
    use X.incl q,
    simpa, },
  -- The intersection of AA with every set in C0 is nonempty.
  have claim3 : ∀ B ∈ C0, (AA ∩ B).nonempty,
  { rintros B ⟨Q,hQ,rfl⟩,
    have : (Q ∩ cl A).nonempty :=
      filter.nonempty_of_mem (inter_mem hQ hF),
    rcases this with ⟨q,hq1,P,hq2,hq3⟩,
    refine ⟨P,hq2,_⟩,
    rw ←hq3 at hq1,
    simpa },
  -- Suffices to show that the intersection of any finite subcollection of C1 is nonempty.
  suffices : ∀ (T : fsu), ι T ⊆ C1 → (⋂₀ ι T).nonempty,
  { obtain ⟨G, h1⟩ := exists_ultrafilter_of_finite_inter_nonempty _ this,
    use X.join G,
    have : G.map X.str = F :=
      ultrafilter.coe_le_coe.1 (λ S hS, h1 (or.inr ⟨S, hS, rfl⟩)),
    rw [join_distrib, this],
    exact ⟨h1 (or.inl rfl), rfl⟩ },
  -- C2 is closed under finite intersections (by construction!).
  have claim4 := finite_inter_closure_has_finite_inter C1,
  -- C0 is closed under finite intersections by claim1.
  have claim5 : has_finite_inter C0 :=
    ⟨⟨_, univ_mem, set.preimage_univ⟩, claim1⟩,
  -- Every element of C2 is nonempty.
  have claim6 : ∀ P ∈ C2, (P : set (ultrafilter X)).nonempty,
  { suffices : ∀ P ∈ C2, P ∈ C0 ∨ ∃ Q ∈ C0, P = AA ∩ Q,
    { intros P hP,
      cases this P hP,
      { exact claim2 _ h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim3 _ hQ } },
    intros P hP,
    exact claim5.finite_inter_closure_insert _ hP },
  intros T hT,
  -- Suffices to show that the intersection of the T's is contained in C2.
  suffices : ⋂₀ ι T ∈ C2, by exact claim6 _ this,
  -- Finish
  apply claim4.finite_inter_mem,
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht),
end

lemma is_closed_cl {X : Compactum} (A : set X) : is_closed (cl A) :=
begin
  rw is_closed_iff,
  intros F hF,
  exact cl_cl _ ⟨F, hF, rfl⟩,
end

lemma str_eq_of_le_nhds {X : Compactum} (F : ultrafilter X) (x : X) :
  ↑F ≤ 𝓝 x → X.str F = x :=
begin
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let T0 : ssu := { S | ∃ A ∈ F, S = basic A },
  let AA := (X.str ⁻¹' {x}),
  let T1 := insert AA T0,
  let T2 := finite_inter_closure T1,
  intro cond,
  -- If F contains a closed set A, then x is contained in A.
  have claim1 : ∀ (A : set X), is_closed A → A ∈ F → x ∈ A,
  { intros A hA h,
    by_contradiction H,
    rw le_nhds_iff at cond,
    specialize cond Aᶜ H hA.is_open_compl,
    rw [ultrafilter.mem_coe, ultrafilter.compl_mem_iff_not_mem] at cond,
    contradiction },
  -- If A ∈ F, then x ∈ cl A.
  have claim2 : ∀ (A : set X), A ∈ F → x ∈ cl A,
  { intros A hA,
    exact claim1 (cl A) (is_closed_cl A) (mem_of_superset hA (subset_cl A)) },
  -- T0 is closed under intersections.
  have claim3 : ∀ (S1 S2 ∈ T0), S1 ∩ S2 ∈ T0,
  { rintros S1 ⟨S1, hS1, rfl⟩ S2 ⟨S2, hS2, rfl⟩,
    exact ⟨S1 ∩ S2, inter_mem hS1 hS2, by simp [basic_inter]⟩ },
  -- For every S ∈ T0, the intersection AA ∩ S is nonempty.
  have claim4 : ∀ (S ∈ T0), (AA ∩ S).nonempty,
  { rintros S ⟨S, hS, rfl⟩,
    rcases claim2 _ hS with ⟨G, hG, hG2⟩,
    exact ⟨G, hG2, hG⟩ },
  -- Every element of T0 is nonempty.
  have claim5 : ∀ (S ∈ T0), set.nonempty S,
  { rintros S ⟨S, hS, rfl⟩,
    exact ⟨F, hS⟩ },
  -- Every element of T2 is nonempty.
  have claim6 : ∀ (S ∈ T2), set.nonempty S,
  { suffices : ∀ S ∈ T2, S ∈ T0 ∨ ∃ Q ∈ T0, S = AA ∩ Q,
    { intros S hS,
      cases this _ hS with h h,
      { exact claim5 S h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim4 Q hQ } },
    intros S hS,
    apply finite_inter_closure_insert,
    { split,
      { use set.univ,
        refine ⟨filter.univ_sets _, _⟩,
        ext,
        refine ⟨_, by tauto⟩,
        { intro,
          apply filter.univ_sets, } },
      { exact claim3 } },
    { exact hS} },
  -- It suffices to show that the intersection of any finite subset of T1 is nonempty.
  suffices : ∀ (F : fsu), ↑F ⊆ T1 → (⋂₀ ι F).nonempty,
  { obtain ⟨G,h1⟩ := ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ this,
    have c1 : X.join G = F := ultrafilter.coe_le_coe.1 (λ P hP, h1 (or.inr ⟨P, hP, rfl⟩)),
    have c2 : G.map X.str = X.incl x,
    { refine ultrafilter.coe_le_coe.1 (λ P hP, _),
      apply mem_of_superset (h1 (or.inl rfl)),
      rintros x ⟨rfl⟩,
      exact hP },
    simp [←c1, c2] },
  -- Finish...
  intros T hT,
  refine claim6 _ (finite_inter_mem (finite_inter_closure_has_finite_inter _) _ _),
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht)
end

lemma le_nhds_of_str_eq {X : Compactum} (F : ultrafilter X) (x : X) :
  X.str F = x → ↑F ≤ 𝓝 x := λ h, le_nhds_iff.mpr (λ s hx hs, hs _ $ by rwa h)

-- All the hard work above boils down to this t2_space instance.
instance {X : Compactum} : t2_space X :=
begin
  rw t2_iff_ultrafilter,
  intros _ _ F hx hy,
  rw [← str_eq_of_le_nhds _ _ hx, ← str_eq_of_le_nhds _ _ hy]
end

/-- The structure map of a compactum actually computes limits. -/
lemma Lim_eq_str {X : Compactum} (F : ultrafilter X) : F.Lim = X.str F :=
begin
  rw [ultrafilter.Lim_eq_iff_le_nhds, le_nhds_iff],
  tauto,
end

lemma cl_eq_closure {X : Compactum} (A : set X) : cl A = closure A :=
begin
  ext,
  rw mem_closure_iff_ultrafilter,
  split,
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, le_nhds_of_str_eq _ _ h2⟩ },
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, str_eq_of_le_nhds _ _ h2⟩ }
end

/-- Any morphism of compacta is continuous. -/
lemma continuous_of_hom {X Y : Compactum} (f : X ⟶ Y) : continuous f :=
begin
  rw continuous_iff_ultrafilter,
  intros x _ h,
  rw [tendsto, ← coe_map],
  apply le_nhds_of_str_eq,
  rw [← str_hom_commute, str_eq_of_le_nhds _ x h]
end

/-- Given any compact Hausdorff space, we construct a Compactum. -/
noncomputable def of_topological_space (X : Type*) [topological_space X]
  [compact_space X] [t2_space X] : Compactum :=
{ A := X,
  a := ultrafilter.Lim,
  unit' := by {ext x, exact Lim_eq (pure_le_nhds _) },
  assoc' := begin
    ext FF,
    change ultrafilter (ultrafilter X) at FF,
    set x := (ultrafilter.map ultrafilter.Lim FF).Lim with c1,
    have c2 : ∀ (U : set X) (F : ultrafilter X), F.Lim ∈ U → is_open U → U ∈ F,
    { intros U F h1 hU,
      exact c1 ▸ is_open_iff_ultrafilter.mp hU _ h1 _ (ultrafilter.le_nhds_Lim _) },
    have c3 : ↑(ultrafilter.map ultrafilter.Lim FF) ≤ 𝓝 x,
    { rw le_nhds_iff,
      intros U hx hU,
      exact mem_coe.2 (c2 _ _ (by rwa ← c1) hU) },
    have c4 : ∀ (U : set X), x ∈ U → is_open U → { G : ultrafilter X | U ∈ G } ∈ FF,
    { intros U hx hU,
      suffices : ultrafilter.Lim ⁻¹' U ∈ FF,
      { apply mem_of_superset this,
        intros P hP,
        exact c2 U P hP hU },
      exact @c3 U (is_open.mem_nhds hU hx) },
    apply Lim_eq,
    rw le_nhds_iff,
    exact c4,
  end }

/-- Any continuous map between Compacta is a morphism of compacta. -/
def hom_of_continuous {X Y : Compactum} (f : X → Y) (cont : continuous f) : X ⟶ Y :=
{ f := f,
  h' := begin
    rw continuous_iff_ultrafilter at cont,
    ext (F : ultrafilter X),
    specialize cont (X.str F) F (le_nhds_of_str_eq F (X.str F) rfl),
    have := str_eq_of_le_nhds (ultrafilter.map f F) _ cont,
    simpa only [←this, types_comp_apply, of_type_functor_map],
  end }

end Compactum

/-- The functor functor from Compactum to CompHaus. -/
def Compactum_to_CompHaus : Compactum ⥤ CompHaus :=
{ obj := λ X, { to_Top := { α := X } },
  map := λ X Y f,
  { to_fun := f,
    continuous_to_fun := Compactum.continuous_of_hom _ }}

namespace Compactum_to_CompHaus

/-- The functor Compactum_to_CompHaus is full. -/
def full : full Compactum_to_CompHaus.{u} :=
{ preimage := λ X Y f, Compactum.hom_of_continuous f.1 f.2 }

/-- The functor Compactum_to_CompHaus is faithful. -/
lemma faithful : faithful Compactum_to_CompHaus := {}

/-- This definition is used to prove essential surjectivity of Compactum_to_CompHaus. -/
noncomputable def iso_of_topological_space {D : CompHaus} :
  Compactum_to_CompHaus.obj (Compactum.of_topological_space D) ≅ D :=
{ hom :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $ λ _ h, by {rw is_open_iff_ultrafilter' at h, exact h} },
  inv :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $
      λ _ h1, by {rw is_open_iff_ultrafilter', intros _ h2, exact h1 _ h2} } }

/-- The functor Compactum_to_CompHaus is essentially surjective. -/
lemma ess_surj : ess_surj Compactum_to_CompHaus :=
{ mem_ess_image := λ X, ⟨Compactum.of_topological_space X, ⟨iso_of_topological_space⟩⟩ }

/-- The functor Compactum_to_CompHaus is an equivalence of categories. -/
noncomputable instance is_equivalence : is_equivalence Compactum_to_CompHaus :=
begin
  apply equivalence.of_fully_faithfully_ess_surj _,
  exact Compactum_to_CompHaus.full,
  exact Compactum_to_CompHaus.faithful,
  exact Compactum_to_CompHaus.ess_surj,
end

end Compactum_to_CompHaus

/-- The forgetful functors of `Compactum` and `CompHaus` are compatible via
`Compactum_to_CompHaus`. -/
def Compactum_to_CompHaus_comp_forget :
  Compactum_to_CompHaus ⋙ category_theory.forget CompHaus ≅ Compactum.forget :=
nat_iso.of_components (λ X, eq_to_iso rfl) $
by { intros X Y f, dsimp, simpa }

/-
TODO: `forget CompHaus` is monadic, as it is isomorphic to the composition
of an equivalence with the monadic functor `forget Compactum`.
Once we have the API to transfer monadicity of functors along such isomorphisms,
the instance `creates_limits (forget CompHaus)` can be deduced from this
monadicity.
-/

noncomputable
instance CompHaus.forget_creates_limits : creates_limits (forget CompHaus) :=
begin
  let e : forget CompHaus ≅ Compactum_to_CompHaus.inv ⋙ Compactum.forget :=
    _ ≪≫ iso_whisker_left _ Compactum_to_CompHaus_comp_forget,
  swap,
  refine _ ≪≫ functor.associator _ _ _,
  refine (functor.left_unitor _).symm ≪≫ _,
  refine iso_whisker_right _ _,
  exact Compactum_to_CompHaus.as_equivalence.symm.unit_iso,
  exact creates_limits_of_nat_iso e.symm,
end

noncomputable
instance Profinite.forget_creates_limits : creates_limits (forget Profinite) :=
begin
  change creates_limits (Profinite_to_CompHaus ⋙ forget _),
  apply_instance,
end