/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.algebra.module.basic
import linear_algebra.multilinear.basic

/-!
# Continuous multilinear maps

We define continuous multilinear maps as maps from `Π(i : ι), M₁ i` to `M₂` which are multilinear
and continuous, by extending the space of multilinear maps with a continuity assumption.
Here, `M₁ i` and `M₂` are modules over a ring `R`, and `ι` is an arbitrary type, and all these
spaces are also topological spaces.

## Main definitions

* `continuous_multilinear_map R M₁ M₂` is the space of continuous multilinear maps from
  `Π(i : ι), M₁ i` to `M₂`. We show that it is an `R`-module.

## Implementation notes

We mostly follow the API of multilinear maps.

## Notation

We introduce the notation `M [×n]→L[R] M'` for the space of continuous `n`-multilinear maps from
`M^n` to `M'`. This is a particular case of the general notion (where we allow varying dependent
types as the arguments of our continuous multilinear maps), but arguably the most important one,
especially when defining iterated derivatives.
-/

open function fin set
open_locale big_operators

universes u v w w₁ w₁' w₂ w₃ w₄
variables {R : Type u} {ι : Type v} {n : ℕ} {M : fin n.succ → Type w} {M₁ : ι → Type w₁}
  {M₁' : ι → Type w₁'} {M₂ : Type w₂} {M₃ : Type w₃} {M₄ : Type w₄} [decidable_eq ι]

/-- Continuous multilinear maps over the ring `R`, from `Πi, M₁ i` to `M₂` where `M₁ i` and `M₂`
are modules over `R` with a topological structure. In applications, there will be compatibility
conditions between the algebraic and the topological structures, but this is not needed for the
definition. -/
structure continuous_multilinear_map (R : Type u) {ι : Type v} (M₁ : ι → Type w₁) (M₂ : Type w₂)
  [decidable_eq ι] [semiring R] [∀i, add_comm_monoid (M₁ i)] [add_comm_monoid M₂]
  [∀i, module R (M₁ i)] [module R M₂] [∀i, topological_space (M₁ i)] [topological_space M₂]
  extends multilinear_map R M₁ M₂ :=
(cont : continuous to_fun)

notation M `[×`:25 n `]→L[`:25 R `] ` M' := continuous_multilinear_map R (λ (i : fin n), M) M'

namespace continuous_multilinear_map

section semiring

variables [semiring R]
[Πi, add_comm_monoid (M i)] [Πi, add_comm_monoid (M₁ i)] [Πi, add_comm_monoid (M₁' i)]
  [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄] [Π i, module R (M i)]
  [Π i, module R (M₁ i)]  [Π i, module R (M₁' i)] [module R M₂]
  [module R M₃] [module R M₄]
  [Π i, topological_space (M i)] [Π i, topological_space (M₁ i)] [Π i, topological_space (M₁' i)]
  [topological_space M₂] [topological_space M₃] [topological_space M₄]
(f f' : continuous_multilinear_map R M₁ M₂)

instance : has_coe_to_fun (continuous_multilinear_map R M₁ M₂) (λ _, (Π i, M₁ i) → M₂) :=
⟨λ f, f.to_fun⟩

@[continuity] lemma coe_continuous : continuous (f : (Π i, M₁ i) → M₂) := f.cont

@[simp] lemma coe_coe : (f.to_multilinear_map : (Π i, M₁ i) → M₂) = f := rfl

theorem to_multilinear_map_inj :
  function.injective (continuous_multilinear_map.to_multilinear_map :
    continuous_multilinear_map R M₁ M₂ → multilinear_map R M₁ M₂)
| ⟨f, hf⟩ ⟨g, hg⟩ rfl := rfl

@[ext] theorem ext {f f' : continuous_multilinear_map R M₁ M₂} (H : ∀ x, f x = f' x) : f = f' :=
to_multilinear_map_inj $ multilinear_map.ext H

@[simp] lemma map_add (m : Πi, M₁ i) (i : ι) (x y : M₁ i) :
  f (update m i (x + y)) = f (update m i x) + f (update m i y) :=
f.map_add' m i x y

@[simp] lemma map_smul (m : Πi, M₁ i) (i : ι) (c : R) (x : M₁ i) :
  f (update m i (c • x)) = c • f (update m i x) :=
f.map_smul' m i c x

lemma map_coord_zero {m : Πi, M₁ i} (i : ι) (h : m i = 0) : f m = 0 :=
f.to_multilinear_map.map_coord_zero i h

@[simp] lemma map_zero [nonempty ι] : f 0 = 0 :=
f.to_multilinear_map.map_zero

instance : has_zero (continuous_multilinear_map R M₁ M₂) :=
⟨{ cont := continuous_const, ..(0 : multilinear_map R M₁ M₂) }⟩

instance : inhabited (continuous_multilinear_map R M₁ M₂) := ⟨0⟩

@[simp] lemma zero_apply (m : Πi, M₁ i) : (0 : continuous_multilinear_map R M₁ M₂) m = 0 := rfl

section has_continuous_add
variable [has_continuous_add M₂]

instance : has_add (continuous_multilinear_map R M₁ M₂) :=
⟨λ f f', ⟨f.to_multilinear_map + f'.to_multilinear_map, f.cont.add f'.cont⟩⟩

@[simp] lemma add_apply (m : Πi, M₁ i) : (f + f') m = f m + f' m := rfl

@[simp] lemma to_multilinear_map_add (f g : continuous_multilinear_map R M₁ M₂) :
  (f + g).to_multilinear_map = f.to_multilinear_map + g.to_multilinear_map :=
rfl

instance add_comm_monoid : add_comm_monoid (continuous_multilinear_map R M₁ M₂) :=
to_multilinear_map_inj.add_comm_monoid _ rfl (λ _ _, rfl)

/-- Evaluation of a `continuous_multilinear_map` at a vector as an `add_monoid_hom`. -/
def apply_add_hom (m : Π i, M₁ i) : continuous_multilinear_map R M₁ M₂ →+ M₂ :=
⟨λ f, f m, rfl, λ _ _, rfl⟩

@[simp] lemma sum_apply {α : Type*} (f : α → continuous_multilinear_map R M₁ M₂)
  (m : Πi, M₁ i) {s : finset α} : (∑ a in s, f a) m = ∑ a in s, f a m :=
(apply_add_hom m).map_sum f s

end has_continuous_add

/-- If `f` is a continuous multilinear map, then `f.to_continuous_linear_map m i` is the continuous
linear map obtained by fixing all coordinates but `i` equal to those of `m`, and varying the
`i`-th coordinate. -/
def to_continuous_linear_map (m : Πi, M₁ i) (i : ι) : M₁ i →L[R] M₂ :=
{ cont := f.cont.comp (continuous_const.update i continuous_id),
  .. f.to_multilinear_map.to_linear_map m i }

/-- The cartesian product of two continuous multilinear maps, as a continuous multilinear map. -/
def prod (f : continuous_multilinear_map R M₁ M₂) (g : continuous_multilinear_map R M₁ M₃) :
  continuous_multilinear_map R M₁ (M₂ × M₃) :=
{ cont := f.cont.prod_mk g.cont,
  .. f.to_multilinear_map.prod g.to_multilinear_map }

@[simp] lemma prod_apply
  (f : continuous_multilinear_map R M₁ M₂) (g : continuous_multilinear_map R M₁ M₃) (m : Πi, M₁ i) :
  (f.prod g) m = (f m, g m) := rfl

/-- Combine a family of continuous multilinear maps with the same domain and codomains `M' i` into a
continuous multilinear map taking values in the space of functions `Π i, M' i`. -/
def pi {ι' : Type*} {M' : ι' → Type*} [Π i, add_comm_monoid (M' i)] [Π i, topological_space (M' i)]
  [Π i, module R (M' i)] (f : Π i, continuous_multilinear_map R M₁ (M' i)) :
  continuous_multilinear_map R M₁ (Π i, M' i) :=
{ cont := continuous_pi $ λ i, (f i).coe_continuous,
  to_multilinear_map := multilinear_map.pi (λ i, (f i).to_multilinear_map) }

@[simp] lemma coe_pi {ι' : Type*} {M' : ι' → Type*} [Π i, add_comm_monoid (M' i)]
  [Π i, topological_space (M' i)] [Π i, module R (M' i)]
  (f : Π i, continuous_multilinear_map R M₁ (M' i)) :
  ⇑(pi f) = λ m j, f j m :=
rfl

lemma pi_apply {ι' : Type*} {M' : ι' → Type*} [Π i, add_comm_monoid (M' i)]
  [Π i, topological_space (M' i)] [Π i, module R (M' i)]
  (f : Π i, continuous_multilinear_map R M₁ (M' i)) (m : Π i, M₁ i) (j : ι') :
  pi f m j = f j m :=
rfl

/-- If `g` is continuous multilinear and `f` is a collection of continuous linear maps,
then `g (f₁ m₁, ..., fₙ mₙ)` is again a continuous multilinear map, that we call
`g.comp_continuous_linear_map f`. -/
def comp_continuous_linear_map
  (g : continuous_multilinear_map R M₁' M₄) (f : Π i : ι, M₁ i →L[R] M₁' i) :
  continuous_multilinear_map R M₁ M₄ :=
{ cont := g.cont.comp $ continuous_pi $ λj, (f j).cont.comp $ continuous_apply _,
  .. g.to_multilinear_map.comp_linear_map (λ i, (f i).to_linear_map) }

@[simp] lemma comp_continuous_linear_map_apply (g : continuous_multilinear_map R M₁' M₄)
  (f : Π i : ι, M₁ i →L[R] M₁' i) (m : Π i, M₁ i) :
  g.comp_continuous_linear_map f m = g (λ i, f i $ m i) :=
rfl

/-- Composing a continuous multilinear map with a continuous linear map gives again a
continuous multilinear map. -/
def _root_.continuous_linear_map.comp_continuous_multilinear_map
  (g : M₂ →L[R] M₃) (f : continuous_multilinear_map R M₁ M₂) :
  continuous_multilinear_map R M₁ M₃ :=
{ cont := g.cont.comp f.cont,
  .. g.to_linear_map.comp_multilinear_map f.to_multilinear_map }

@[simp] lemma _root_.continuous_linear_map.comp_continuous_multilinear_map_coe (g : M₂ →L[R] M₃)
  (f : continuous_multilinear_map R M₁ M₂) :
  ((g.comp_continuous_multilinear_map f) : (Πi, M₁ i) → M₃) =
  (g : M₂ → M₃) ∘ (f : (Πi, M₁ i) → M₂) :=
by { ext m, refl }

/-- `continuous_multilinear_map.pi` as an `equiv`. -/
@[simps]
def pi_equiv {ι' : Type*} {M' : ι' → Type*} [Π i, add_comm_monoid (M' i)]
  [Π i, topological_space (M' i)] [Π i, module R (M' i)] :
  (Π i, continuous_multilinear_map R M₁ (M' i)) ≃
  continuous_multilinear_map R M₁ (Π i, M' i) :=
{ to_fun := continuous_multilinear_map.pi,
  inv_fun := λ f i, (continuous_linear_map.proj i : _ →L[R] M' i).comp_continuous_multilinear_map f,
  left_inv := λ f, by { ext, refl },
  right_inv := λ f, by { ext, refl } }

/-- In the specific case of continuous multilinear maps on spaces indexed by `fin (n+1)`, where one
can build an element of `Π(i : fin (n+1)), M i` using `cons`, one can express directly the
additivity of a multilinear map along the first variable. -/
lemma cons_add (f : continuous_multilinear_map R M M₂) (m : Π(i : fin n), M i.succ) (x y : M 0) :
  f (cons (x+y) m) = f (cons x m) + f (cons y m) :=
f.to_multilinear_map.cons_add m x y

/-- In the specific case of continuous multilinear maps on spaces indexed by `fin (n+1)`, where one
can build an element of `Π(i : fin (n+1)), M i` using `cons`, one can express directly the
multiplicativity of a multilinear map along the first variable. -/
lemma cons_smul
  (f : continuous_multilinear_map R M M₂) (m : Π(i : fin n), M i.succ) (c : R) (x : M 0) :
  f (cons (c • x) m) = c • f (cons x m) :=
f.to_multilinear_map.cons_smul m c x

lemma map_piecewise_add (m m' : Πi, M₁ i) (t : finset ι) :
  f (t.piecewise (m + m') m') = ∑ s in t.powerset, f (s.piecewise m m') :=
f.to_multilinear_map.map_piecewise_add _ _ _

/-- Additivity of a continuous multilinear map along all coordinates at the same time,
writing `f (m + m')` as the sum  of `f (s.piecewise m m')` over all sets `s`. -/
lemma map_add_univ [fintype ι] (m m' : Πi, M₁ i) :
  f (m + m') = ∑ s : finset ι, f (s.piecewise m m') :=
f.to_multilinear_map.map_add_univ _ _

section apply_sum

open fintype finset

variables {α : ι → Type*} [fintype ι] (g : Π i, α i → M₁ i) (A : Π i, finset (α i))

/-- If `f` is continuous multilinear, then `f (Σ_{j₁ ∈ A₁} g₁ j₁, ..., Σ_{jₙ ∈ Aₙ} gₙ jₙ)` is the
sum of `f (g₁ (r 1), ..., gₙ (r n))` where `r` ranges over all functions with `r 1 ∈ A₁`, ...,
`r n ∈ Aₙ`. This follows from multilinearity by expanding successively with respect to each
coordinate. -/

lemma map_sum_finset  :
  f (λ i, ∑ j in A i, g i j) = ∑ r in pi_finset A, f (λ i, g i (r i)) :=
f.to_multilinear_map.map_sum_finset _ _

/-- If `f` is continuous multilinear, then `f (Σ_{j₁} g₁ j₁, ..., Σ_{jₙ} gₙ jₙ)` is the sum of
`f (g₁ (r 1), ..., gₙ (r n))` where `r` ranges over all functions `r`. This follows from
multilinearity by expanding successively with respect to each coordinate. -/
lemma map_sum [∀ i, fintype (α i)] :
  f (λ i, ∑ j, g i j) = ∑ r : Π i, α i, f (λ i, g i (r i)) :=
f.to_multilinear_map.map_sum _

end apply_sum

section restrict_scalar

variables (R) {A : Type*} [semiring A] [has_scalar R A] [Π (i : ι), module A (M₁ i)]
  [module A M₂] [∀ i, is_scalar_tower R A (M₁ i)] [is_scalar_tower R A M₂]

/-- Reinterpret an `A`-multilinear map as an `R`-multilinear map, if `A` is an algebra over `R`
and their actions on all involved modules agree with the action of `R` on `A`. -/
def restrict_scalars (f : continuous_multilinear_map A M₁ M₂) :
  continuous_multilinear_map R M₁ M₂ :=
{ to_multilinear_map := f.to_multilinear_map.restrict_scalars R,
  cont := f.cont }

@[simp] lemma coe_restrict_scalars (f : continuous_multilinear_map A M₁ M₂) :
  ⇑(f.restrict_scalars R) = f := rfl

end restrict_scalar

end semiring

section ring

variables [ring R] [∀i, add_comm_group (M₁ i)] [add_comm_group M₂]
[∀i, module R (M₁ i)] [module R M₂] [∀i, topological_space (M₁ i)] [topological_space M₂]
(f f' : continuous_multilinear_map R M₁ M₂)

@[simp] lemma map_sub (m : Πi, M₁ i) (i : ι) (x y : M₁ i) :
  f (update m i (x - y)) = f (update m i x) - f (update m i y) :=
f.to_multilinear_map.map_sub _ _ _ _

section topological_add_group
variable [topological_add_group M₂]

instance : has_neg (continuous_multilinear_map R M₁ M₂) :=
⟨λ f, {cont := f.cont.neg, ..(-f.to_multilinear_map)}⟩

@[simp] lemma neg_apply (m : Πi, M₁ i) : (-f) m = - (f m) := rfl

instance : has_sub (continuous_multilinear_map R M₁ M₂) :=
⟨λ f g, { cont := f.cont.sub g.cont, .. (f.to_multilinear_map - g.to_multilinear_map) }⟩

@[simp] lemma sub_apply (m : Πi, M₁ i) : (f - f') m = f m - f' m := rfl

instance : add_comm_group (continuous_multilinear_map R M₁ M₂) :=
to_multilinear_map_inj.add_comm_group _ rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)

end topological_add_group

end ring

section comm_semiring

variables [comm_semiring R]
[∀i, add_comm_monoid (M₁ i)] [add_comm_monoid M₂]
[∀i, module R (M₁ i)] [module R M₂]
[∀i, topological_space (M₁ i)] [topological_space M₂]
(f : continuous_multilinear_map R M₁ M₂)

lemma map_piecewise_smul (c : ι → R) (m : Πi, M₁ i) (s : finset ι) :
  f (s.piecewise (λ i, c i • m i) m) = (∏ i in s, c i) • f m :=
f.to_multilinear_map.map_piecewise_smul _ _ _

/-- Multiplicativity of a continuous multilinear map along all coordinates at the same time,
writing `f (λ i, c i • m i)` as `(∏ i, c i) • f m`. -/
lemma map_smul_univ [fintype ι] (c : ι → R) (m : Πi, M₁ i) :
  f (λ i, c i • m i) = (∏ i, c i) • f m :=
f.to_multilinear_map.map_smul_univ _ _

variables {R' A : Type*} [comm_semiring R'] [semiring A] [algebra R' A]
  [Π i, module A (M₁ i)] [module R' M₂] [module A M₂] [is_scalar_tower R' A M₂]
  [topological_space R'] [has_continuous_smul R' M₂]

instance : has_scalar R' (continuous_multilinear_map A M₁ M₂) :=
⟨λ c f, { cont := continuous_const.smul f.cont, .. c • f.to_multilinear_map }⟩

@[simp] lemma smul_apply (f : continuous_multilinear_map A M₁ M₂) (c : R') (m : Πi, M₁ i) :
  (c • f) m = c • f m := rfl

@[simp] lemma to_multilinear_map_smul (c : R') (f : continuous_multilinear_map A M₁ M₂) :
  (c • f).to_multilinear_map = c • f.to_multilinear_map :=
rfl

instance {R''} [comm_semiring R''] [has_scalar R' R''] [algebra R'' A]
  [module R'' M₂] [is_scalar_tower R'' A M₂] [is_scalar_tower R' R'' M₂]
  [topological_space R''] [has_continuous_smul R'' M₂]:
  is_scalar_tower R' R'' (continuous_multilinear_map A M₁ M₂) :=
⟨λ c₁ c₂ f, ext $ λ x, smul_assoc _ _ _⟩

variable [has_continuous_add M₂]

/-- The space of continuous multilinear maps over an algebra over `R` is a module over `R`, for the
pointwise addition and scalar multiplication. -/
instance : module R' (continuous_multilinear_map A M₁ M₂) :=
{ one_smul := λ f, ext $ λ x, one_smul _ _,
  mul_smul := λ c₁ c₂ f, ext $ λ x, mul_smul _ _ _,
  smul_zero := λ r, ext $ λ x, smul_zero _,
  smul_add := λ r f₁ f₂, ext $ λ x, smul_add _ _ _,
  add_smul := λ r₁ r₂ f, ext $ λ x, add_smul _ _ _,
  zero_smul := λ f, ext $ λ x, zero_smul _ _ }

/-- Linear map version of the map `to_multilinear_map` associating to a continuous multilinear map
the corresponding multilinear map. -/
@[simps] def to_multilinear_map_linear :
  (continuous_multilinear_map A M₁ M₂) →ₗ[R'] (multilinear_map A M₁ M₂) :=
{ to_fun    := λ f, f.to_multilinear_map,
  map_add'  := λ f g, rfl,
  map_smul' := λ c f, rfl }

/-- `continuous_multilinear_map.pi` as a `linear_equiv`. -/
@[simps {simp_rhs := tt}]
def pi_linear_equiv {ι' : Type*} {M' : ι' → Type*}
  [Π i, add_comm_monoid (M' i)] [Π i, topological_space (M' i)] [∀ i, has_continuous_add (M' i)]
  [Π i, module R' (M' i)] [Π i, module A (M' i)] [∀ i, is_scalar_tower R' A (M' i)]
  [Π i, has_continuous_smul R' (M' i)] :
  -- typeclass search doesn't find this instance, presumably due to struggles converting
  -- `Π i, module R (M' i)` to `Π i, has_scalar R (M' i)` in dependent arguments.
  let inst : has_continuous_smul R' (Π i, M' i) := pi.has_continuous_smul in
  (Π i, continuous_multilinear_map A M₁ (M' i)) ≃ₗ[R']
    continuous_multilinear_map A M₁ (Π i, M' i) :=
{ map_add' := λ x y, rfl,
  map_smul' := λ c x, rfl,
  .. pi_equiv }

end comm_semiring

end continuous_multilinear_map


import analysis.seminorm

noncomputable theory
--open_locale nnreal

set_option old_structure_cmd true

variables {R : Type*} (x y : R) (r : ℝ)

/-- A seminorm on a ring `R` is a function `f : R → ℝ` that preserves zero, takes nonnegative
  values, is subadditive and submultiplicative and such that `f (-x) = f x` for all `x ∈ R`. -/
structure ring_seminorm (R : Type*) [ring R]
  extends add_group_seminorm R :=
(mul_le' : ∀ x y : R, to_fun (x * y) ≤ to_fun x * to_fun y)

attribute [nolint doc_blame] ring_seminorm.to_add_group_seminorm

namespace ring_seminorm

variables [ring R]

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`. -/
instance : has_coe_to_fun (ring_seminorm R) (λ _, R → ℝ) := ⟨λ p, p.to_fun⟩

@[simp] lemma to_fun_eq_coe (p : ring_seminorm R) : p.to_fun = p := rfl

@[ext] lemma ext {p q : ring_seminorm R} (h : ∀ x, p x = q x) : p = q :=
by { cases p, cases q, simp only, ext, exact h x }

instance : has_zero (ring_seminorm R) :=
⟨{ mul_le' :=  λ _ _, eq.ge (zero_mul _),
  ..add_group_seminorm.has_zero.zero }⟩

instance : inhabited (ring_seminorm R) := ⟨0⟩

variables (p : ring_seminorm R)

protected lemma nonneg : 0 ≤ p x := p.nonneg' _
@[simp] protected lemma map_zero : p 0 = 0 := p.map_zero'
protected lemma add_le : p (x + y) ≤ p x + p y := p.add_le' _ _
@[simp] protected lemma neg : p (- x) = p x := p.neg' _
protected lemma mul_le : p (x * y) ≤ p x * p y := p.mul_le' _ _

lemma pow_le : ∀ {n : ℕ}, 0 < n → p (x ^ n) ≤ (p x) ^ n
| 1 h := by simp only [pow_one]
| (n + 2) h :=
by simpa only [pow_succ _ (n + 1)] using le_trans (p.mul_le x _)
  (mul_le_mul_of_nonneg_left (pow_le n.succ_pos) (p.nonneg _))

/-- A function `f : R → ℝ` from a ring `R` satisfies `is_norm_le_one_class` if `f 1 ≤ 1`. -/
def is_norm_le_one_class {R : Type*} [semiring R] (f : R → ℝ) : Prop := f 1 ≤ 1

/-- A function `f : R → ℝ` from a ring `R` satisfies `is_norm_one_class` if `f 1 = 1`. -/
def is_norm_one_class {R : Type*} [semiring R] (f : R → ℝ) : Prop := f 1 = 1

lemma is_norm_one_class_iff_nonzero (hp : is_norm_le_one_class p) :
  is_norm_one_class p ↔ ∃ x : R, p x ≠ 0 :=
begin
  rw is_norm_one_class,
  refine ⟨λ h, ⟨1, by {rw h, exact one_ne_zero}⟩, λ h, _⟩,
  { obtain ⟨x, hx⟩ := h,
    by_cases hp0 : p 1 = 0,
    { have hx' : p x ≤ 0,
      { rw ← mul_one x,
        apply le_trans (p.mul_le x 1) _,
        rw [hp0, mul_zero], },
      exact absurd (le_antisymm hx' (p.nonneg x) ) hx },
    { have h1 : p 1 * 1 ≤ p 1 * p 1,
      { conv_lhs { rw ← one_mul (1 : R) },
        convert p.mul_le 1 1,
        rw mul_one, },
      rw mul_le_mul_left (lt_of_le_of_ne (p.nonneg _) (ne.symm hp0)) at h1,
      exact le_antisymm hp h1, }}
end

end ring_seminorm

/-- The norm of a semi_normed_ring as a ring_seminorm. -/
def seminormed_ring.to_ring_seminorm (R : Type*) [semi_normed_ring R] :
  ring_seminorm R :=
{ to_fun    := (λ r : R, ∥r∥),
  map_zero' := norm_zero,
  nonneg'   := norm_nonneg,
  add_le'   := norm_add_le,
  neg'      := norm_neg,
  mul_le'   := norm_mul_le }

/-- A function `f : R → ℝ` is a norm if it is a seminorm and `f x = 0` implies `x = 0`. -/
structure ring_norm (R : Type*) [ring R] extends (ring_seminorm R) :=
(ne_zero : ∀ x, x ≠ 0 → 0 < to_fun x)

attribute [nolint doc_blame] ring_norm.to_ring_seminorm

namespace ring_norm

variable [ring R]

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`. -/
instance : has_coe_to_fun (ring_norm R) (λ _, R → ℝ) := ⟨λ p, p.to_fun⟩

@[simp] lemma to_fun_eq_coe (p : ring_norm R) : p.to_fun = p := rfl

@[ext] lemma ext {p q : ring_norm R} (h : ∀ x, p x = q x) : p = q :=
by { cases p, cases q, simp only, ext, exact h x }

variables (p : ring_norm R)

protected lemma nonneg : 0 ≤ p x := p.nonneg' _
@[simp] protected lemma map_zero : p 0 = 0 := p.map_zero'
protected lemma add_le : p (x + y) ≤ p x + p y := p.add_le' _ _
@[simp] protected lemma neg : p (- x) = p x := p.neg' _
protected lemma mul_le : p (x * y) ≤ p x * p y := p.mul_le' _ _

variable (R)

/-- The trivial norm on a ring `R` is the `ring_norm` taking value `0` at `0` and `1` at every
  other element. -/
def trivial_norm [decidable_eq R] : ring_norm R :=
{ to_fun    := λ x, if x = 0 then 0 else 1,
  map_zero' := by simp only [eq_self_iff_true, if_true],
  nonneg'   := λ x, begin split_ifs, exacts [le_refl _, zero_le_one] end,
  add_le'   := λ x y,
  begin
    by_cases hx : x = 0,
    { rw [if_pos hx, hx, zero_add, zero_add], },
    { rw if_neg hx, apply le_add_of_le_of_nonneg,
      { split_ifs, exacts [zero_le_one, le_refl _] },
      { split_ifs, exacts [le_refl _, zero_le_one] }}
  end,
  neg'      := λ x, by simp_rw neg_eq_zero,
  mul_le'   := λ x y,
  begin by_cases h : x * y = 0,
    { rw if_pos h, apply mul_nonneg;
      {split_ifs, exacts [le_refl _, zero_le_one]}},
    { rw [if_neg h, if_neg (left_ne_zero_of_mul h), if_neg (right_ne_zero_of_mul h), mul_one] }
  end,
  ne_zero   := λ x hx, by { rw if_neg hx, exact zero_lt_one }}

instance [decidable_eq R] : inhabited (ring_norm R) := ⟨trivial_norm R⟩

/-- A nonzero ring seminorm on a field `K` is a ring norm. -/
def of_ring_seminorm {K : Type*} [field K] (f : ring_seminorm K)
  (hnt : ∃ r : K, 0 ≠ f r) : ring_norm K :=
{ ne_zero := λ x hx, begin
    obtain ⟨c, hc⟩ := hnt,
    have hfx : 0 ≠ f x,
    { intro h0,
      have hc' : f c ≤ 0,
      { rw [← mul_one c, ← mul_inv_cancel hx, ← mul_assoc, mul_comm c, mul_assoc],
        refine le_trans (f.mul_le x _) _,
        rw [← h0, zero_mul] },
      exact hc (ge_antisymm hc' (f.nonneg _)), },
    exact lt_of_le_of_ne (f.nonneg _) hfx,
  end,
  ..f }

end ring_norm

/-- The norm of a normed_ring as a ring_norm. -/
def normed_ring.to_ring_norm (R : Type*) [normed_ring R] : ring_norm R :=
{ ne_zero := λ x, norm_pos_iff.mpr,
  ..seminormed_ring.to_ring_seminorm R}

/-- Given a ring `R` with a norm `f` and an `R`-algebra `A`, a function `g : A → ℝ` is an algebra
  norm if it is a norm on `A` and `g ((algebra_map R A r) * a) = f r * g a`. -/
structure algebra_norm (R : Type*) [comm_ring R] (f : ring_norm R)
  (A : Type*) [ring A] [algebra R A] extends (ring_norm A) :=
(smul : ∀ (r : R) (a : A) , to_fun ((algebra_map R A r) * a) = f r * to_fun a)

attribute [nolint doc_blame] algebra_norm.to_ring_norm

namespace algebra_norm

variables [comm_ring R] (A : Type*) [ring A] [algebra R A] (f : ring_norm R)

instance : has_coe_to_fun (algebra_norm R f A) (λ _, A → ℝ) := ⟨λ p, p.to_fun⟩

@[simp] lemma to_fun_eq_coe (p : algebra_norm R f A) : p.to_fun = p := rfl

lemma trivial_norm_of_ne_zero [decidable_eq R] {x : R} (hx : x ≠ 0) :
  ring_norm.trivial_norm R x = 1 := if_neg hx

instance [is_domain R] [decidable_eq R] :
  inhabited (algebra_norm R (ring_norm.trivial_norm R) R) := ⟨ {
  smul := λ r s,
  begin
    simp only [ring_norm.to_fun_eq_coe],
    by_cases hr : r = 0,
    { rw [hr, algebra.id.map_eq_id, ring_hom.id_apply, zero_mul, ring_norm.map_zero, zero_mul] },
    { rw [trivial_norm_of_ne_zero hr],
      by_cases hs : s = 0,
      { rw [hs, mul_zero, one_mul], },
      { have hrs : r * s ≠ 0,
        { exact mul_ne_zero hr hs, },
        rw [trivial_norm_of_ne_zero hs, algebra.id.map_eq_id, ring_hom.id_apply,
          trivial_norm_of_ne_zero (mul_ne_zero hr hs), one_mul], }}
  end
  ..(ring_norm.trivial_norm R) }⟩

end algebra_norm

variables [ring R]

/-- A function `f : R → ℝ≥0` is nonarchimedean if it satisfies the inequality
  `f (r + s) ≤ max (f r) (f s)`. -/
def is_nonarchimedean (f : R → ℝ) : Prop := ∀ r s, f (r + s) ≤ max (f r) (f s)

/-- A function `f : R → ℝ` is power-multiplicative if for all `r ∈ R` and all positive `n ∈ ℕ`,
  `f (r ^ n) = (f r) ^ n`. -/
def is_pow_mul {R : Type*} [ring R] (f : R → ℝ) :=
∀ (r : R) {n : ℕ} (hn : 1 ≤ n), f (r ^ n) = (f r) ^ n


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

import ..mynat.lt
import .equinumerous
import ..mylist.map

-- Definitions and theorems relating to finite sets

namespace hidden
namespace myset

universes u

variable {α : Type u}

open myset
open mynat

-- Exclude the actual value so there are m elements
def zero_to (m : mynat) : myset mynat := λ n, n < m

theorem emp_zero_to_zero : empty (zero_to 0) :=
begin
  intro m,
  assume hm,
  from lt_nzero hm,
end

def of_size (s : myset α) (m : mynat) : Prop :=
equinumerous s (zero_to m)
def finite (s : myset α) : Prop :=
∃ m : mynat, of_size s m
def infinite (s : myset α) : Prop := ¬finite s

theorem zero_to_le_subset (m n: mynat) (h: m ≤ n):
(zero_to m) ⊆ (zero_to n) :=
(λ k h', @lt_le_chain k n m h' h)

-- function swapping two naturals. Useful in proving things
-- by induction on finite sets
def swap_naturals (a b x: mynat): mynat
:= if x = a then b else if x = b then a else x

theorem swap_well_defined
(n a b: mynat) (ha: a < n) (hb: b < n):
well_defined (zero_to n) (zero_to n) (swap_naturals a b) :=
begin
  intro x,
  assume hx,
  unfold swap_naturals,
  by_cases hxa: x = a, {
    rw if_pos hxa,
    from hb,
  }, {
    rw if_neg hxa,
    by_cases hxb: x = b, {
      rw if_pos hxb,
      from ha,
    }, {
      rw if_neg hxb,
      from hx,
    },
  },
end

-- candidate for wlog_le? It's not clear because
-- we can have a = b
theorem swap_injective
(n a b: mynat) (ha: a < n) (hb: b < n):
injective (swap_well_defined n a b ha hb) :=
begin
  intros x y,
  assume hx hy,
  unfold swap_naturals,
  assume hswap_xy,
  by_cases hxy: x = y, {
    assumption,
  }, {
    exfalso,
    by_cases hxa: x = a, {
      rw if_pos hxa at hswap_xy,
      by_cases hya: y = a, {
        from hxy (eq.trans hxa hya.symm),
      }, {
        rw if_neg hya at hswap_xy,
        by_cases hyb: y = b, {
          rw if_pos hyb at hswap_xy,
          from hya (hswap_xy ▸ hyb),
        }, {
          rw if_neg hyb at hswap_xy,
          from hyb hswap_xy.symm,
        },
      },
    }, {
      rw if_neg hxa at hswap_xy,
      by_cases hxb: x = b, {
        rw if_pos hxb at hswap_xy,
        by_cases hya: y = a, {
          rw if_pos hya at hswap_xy,
          from (hswap_xy ▸ hxa) hxb,
        }, {
          rw if_neg hya at hswap_xy,
          by_cases hyb: y = b, {
            from (hyb ▸ hxy) hxb,
          }, {
            rw if_neg hyb at hswap_xy,
            from hya hswap_xy.symm,
          },
        },
      }, {
        rw if_neg hxb at hswap_xy,
        by_cases hya: y = a, {
          rw if_pos hya at hswap_xy,
          from hxb hswap_xy,
        }, {
          rw if_neg hya at hswap_xy,
          by_cases hyb: y = b, {
            rw if_pos hyb at hswap_xy,
            from hxa hswap_xy,
          }, {
            rw if_neg hyb at hswap_xy,
            from hxy hswap_xy,
          },
        },
      },
    },
  },
end

-- pigeonhole principle, basically
-- have I overthought this?
-- and can this be done without classical? probably..
theorem no_injection_from_zero_to_succ
(n: mynat) (f: mynat → mynat)
(hwf: well_defined (zero_to (n + 1)) (zero_to n) f):
¬injective hwf :=
begin
  assume h,
  revert f,
  induction n with n hn, {
    intro f, assume hwf,
    exfalso, revert hwf,
    apply @no_wdefined_func_nemp_to_emp
            _ _ (zero_to 1) (zero_to 0) f, {
      assume h,
      have : (0 : mynat) ∈ zero_to 1, {
        from zero_lt_one,
      },
      from h 0 this,
    }, {
      from emp_zero_to_zero,
    },
  }, {
    -- we are trying to show that if
    -- f: {0, ..., n + 1} → {0, ...,  n}
    -- is well-defined then it is not injective.
    -- Consider the pre-image of n. By injectivity, this at most one
    -- number. If it's empty, skip to the restriction.
    -- If not, call it x. Define f': {0, ..., n + 1} → {0, ..., n}
    -- by composing f with the function swapping n + 1 and x. This
    -- function is still injective and has n + 1 ↦ n, so we can
    -- restrict it to {0, ..., n} and its range will restrict to
    -- {0, ..., n - 1}. Then we are done by induction.
    sorry,
  },
end

theorem no_injection_if_gt
(m n: mynat) (f: mynat → mynat)
(hmn: n < m)
(hwf: well_defined (zero_to m) (zero_to n) f):
¬injective hwf :=
begin
  assume hif,
  cases m, {
    from lt_nzero hmn,
  }, {
    have hwf': well_defined (zero_to (succ m)) (zero_to m) f, {
      apply wf_by_inclusion (zero_to (succ m)) (zero_to n) (zero_to m) hwf,
      from zero_to_le_subset _ _ (le_iff_lt_succ.mpr hmn),
    },
    have hif': injective hwf' := hif,
    from no_injection_from_zero_to_succ _ _ _ hif',
  },
end

theorem equinum_zero_to_iff_eq {m n : mynat} :
equinumerous (zero_to m) (zero_to n) → m = n := sorry

-- A set cannot have two different natural sizes
theorem unique_size {α : Type u} (s : myset α) (m n : mynat) :
of_size s m → of_size s n → m = n :=
begin
  assume hm hn,
  unfold of_size at hm hn,
  have hm₂ := equinumerous_symm _ _ hm,
  have h := equinumerous_trans _ _ _ hm₂ hn,
  from equinum_zero_to_iff_eq h,
end

theorem naturals_infinite: infinite (all_of mynat) :=
begin
  assume hfinite,
  cases hfinite with n hn,
  cases hn with f hf,
  cases hf with hwf h,
  sorry,
end

theorem inf_iff_powerset_inf (s : myset α):
infinite s ↔ infinite (power_set s) :=
begin
  split; assume hinf, {
    sorry,
  }, {
    sorry,
  },
end

end myset
end hidden


/-
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
-/
import topology.tactic

/-!
# Ordering on topologies and (co)induced topologies

Topologies on a fixed type `α` are ordered, by reverse inclusion.
That is, for topologies `t₁` and `t₂` on `α`, we write `t₁ ≤ t₂`
if every set open in `t₂` is also open in `t₁`.
(One also calls `t₁` finer than `t₂`, and `t₂` coarser than `t₁`.)

Any function `f : α → β` induces
       `induced f : topological_space β → topological_space α`
and  `coinduced f : topological_space α → topological_space β`.
Continuity, the ordering on topologies and (co)induced topologies are
related as follows:
* The identity map (α, t₁) → (α, t₂) is continuous iff t₁ ≤ t₂.
* A map f : (α, t) → (β, u) is continuous
    iff             t ≤ induced f u   (`continuous_iff_le_induced`)
    iff coinduced f t ≤ u             (`continuous_iff_coinduced_le`).

Topologies on α form a complete lattice, with ⊥ the discrete topology
and ⊤ the indiscrete topology.

For a function f : α → β, (coinduced f, induced f) is a Galois connection
between topologies on α and topologies on β.

## Implementation notes

There is a Galois insertion between topologies on α (with the inclusion ordering)
and all collections of sets in α. The complete lattice structure on topologies
on α is defined as the reverse of the one obtained via this Galois insertion.

## Tags

finer, coarser, induced topology, coinduced topology

-/

open set filter classical
open_locale classical topological_space filter

universes u v w

namespace topological_space
variables {α : Type u}

/-- The open sets of the least topology containing a collection of basic sets. -/
inductive generate_open (g : set (set α)) : set α → Prop
| basic  : ∀s∈g, generate_open s
| univ   : generate_open univ
| inter  : ∀s t, generate_open s → generate_open t → generate_open (s ∩ t)
| sUnion : ∀k, (∀s∈k, generate_open s) → generate_open (⋃₀ k)

/-- The smallest topological space containing the collection `g` of basic sets -/
def generate_from (g : set (set α)) : topological_space α :=
{ is_open        := generate_open g,
  is_open_univ   := generate_open.univ,
  is_open_inter  := generate_open.inter,
  is_open_sUnion := generate_open.sUnion  }

lemma nhds_generate_from {g : set (set α)} {a : α} :
  @nhds α (generate_from g) a = (⨅s∈{s | a ∈ s ∧ s ∈ g}, 𝓟 s) :=
by rw nhds_def; exact le_antisymm
  (infi_le_infi $ assume s, infi_le_infi_const $ assume ⟨as, sg⟩, ⟨as, generate_open.basic _ sg⟩)
  (le_infi $ assume s, le_infi $ assume ⟨as, hs⟩,
    begin
      revert as, clear_, induction hs,
      case generate_open.basic : s hs
      { exact assume as, infi_le_of_le s $ infi_le _ ⟨as, hs⟩ },
      case generate_open.univ
      { rw [principal_univ],
        exact assume _, le_top },
      case generate_open.inter : s t hs' ht' hs ht
      { exact assume ⟨has, hat⟩, calc _ ≤ 𝓟 s ⊓ 𝓟 t : le_inf (hs has) (ht hat)
          ... = _ : inf_principal },
      case generate_open.sUnion : k hk' hk
      { exact λ ⟨t, htk, hat⟩, calc _ ≤ 𝓟 t : hk t htk hat
          ... ≤ _ : le_principal_iff.2 $ subset_sUnion_of_mem htk }
    end)

lemma tendsto_nhds_generate_from {β : Type*} {m : α → β} {f : filter α} {g : set (set β)} {b : β}
  (h : ∀s∈g, b ∈ s → m ⁻¹' s ∈ f) : tendsto m f (@nhds β (generate_from g) b) :=
by rw [nhds_generate_from]; exact
  (tendsto_infi.2 $ assume s, tendsto_infi.2 $ assume ⟨hbs, hsg⟩, tendsto_principal.2 $ h s hsg hbs)

/-- Construct a topology on α given the filter of neighborhoods of each point of α. -/
protected def mk_of_nhds (n : α → filter α) : topological_space α :=
{ is_open        := λs, ∀a∈s, s ∈ n a,
  is_open_univ   := assume x h, univ_mem_sets,
  is_open_inter  := assume s t hs ht x ⟨hxs, hxt⟩, inter_mem_sets (hs x hxs) (ht x hxt),
  is_open_sUnion := assume s hs a ⟨x, hx, hxa⟩,
    mem_sets_of_superset (hs x hx _ hxa) (set.subset_sUnion_of_mem hx) }

lemma nhds_mk_of_nhds (n : α → filter α) (a : α)
  (h₀ : pure ≤ n) (h₁ : ∀{a s}, s ∈ n a → ∃ t ∈ n a, t ⊆ s ∧ ∀a' ∈ t, s ∈ n a') :
  @nhds α (topological_space.mk_of_nhds n) a = n a :=
begin
  letI := topological_space.mk_of_nhds n,
  refine le_antisymm (assume s hs, _) (assume s hs, _),
  { have h₀ : {b | s ∈ n b} ⊆ s := assume b hb, mem_pure_sets.1 $ h₀ b hb,
    have h₁ : {b | s ∈ n b} ∈ 𝓝 a,
    { refine mem_nhds_sets (assume b (hb : s ∈ n b), _) hs,
      rcases h₁ hb with ⟨t, ht, hts, h⟩,
      exact mem_sets_of_superset ht h },
    exact mem_sets_of_superset h₁ h₀ },
  { rcases (@mem_nhds_sets_iff α (topological_space.mk_of_nhds n) _ _).1 hs with ⟨t, hts, ht, hat⟩,
    exact (n a).sets_of_superset (ht _ hat) hts },
end

end topological_space

section lattice

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

/-- The inclusion ordering on topologies on α. We use it to get a complete
   lattice instance via the Galois insertion method, but the partial order
   that we will eventually impose on `topological_space α` is the reverse one. -/
def tmp_order : partial_order (topological_space α) :=
{ le          := λt s, t.is_open ≤ s.is_open,
  le_antisymm := assume t s h₁ h₂, topological_space_eq $ le_antisymm h₁ h₂,
  le_refl     := assume t, le_refl t.is_open,
  le_trans    := assume a b c h₁ h₂, @le_trans _ _ a.is_open b.is_open c.is_open h₁ h₂ }

local attribute [instance] tmp_order

/- We'll later restate this lemma in terms of the correct order on `topological_space α`. -/
private lemma generate_from_le_iff_subset_is_open {g : set (set α)} {t : topological_space α} :
  topological_space.generate_from g ≤ t ↔ g ⊆ {s | t.is_open s} :=
iff.intro
  (assume ht s hs, ht _ $ topological_space.generate_open.basic s hs)
  (assume hg s hs, hs.rec_on (assume v hv, hg hv)
    t.is_open_univ (assume u v _ _, t.is_open_inter u v) (assume k _, t.is_open_sUnion k))

/-- If `s` equals the collection of open sets in the topology it generates,
  then `s` defines a topology. -/
protected def mk_of_closure (s : set (set α))
  (hs : {u | (topological_space.generate_from s).is_open u} = s) : topological_space α :=
{ is_open        := λu, u ∈ s,
  is_open_univ   := hs ▸ topological_space.generate_open.univ,
  is_open_inter  := hs ▸ topological_space.generate_open.inter,
  is_open_sUnion := hs ▸ topological_space.generate_open.sUnion }

lemma mk_of_closure_sets {s : set (set α)}
  {hs : {u | (topological_space.generate_from s).is_open u} = s} :
  mk_of_closure s hs = topological_space.generate_from s :=
topological_space_eq hs.symm

/-- The Galois insertion between `set (set α)` and `topological_space α` whose lower part
  sends a collection of subsets of α to the topology they generate, and whose upper part
  sends a topology to its collection of open subsets. -/
def gi_generate_from (α : Type*) :
  galois_insertion topological_space.generate_from (λt:topological_space α, {s | t.is_open s}) :=
{ gc        := assume g t, generate_from_le_iff_subset_is_open,
  le_l_u    := assume ts s hs, topological_space.generate_open.basic s hs,
  choice    := λg hg, mk_of_closure g
    (subset.antisymm hg $ generate_from_le_iff_subset_is_open.1 $ le_refl _),
  choice_eq := assume s hs, mk_of_closure_sets }

lemma generate_from_mono {α} {g₁ g₂ : set (set α)} (h : g₁ ⊆ g₂) :
  topological_space.generate_from g₁ ≤ topological_space.generate_from g₂ :=
(gi_generate_from _).gc.monotone_l h

/-- The complete lattice of topological spaces, but built on the inclusion ordering. -/
def tmp_complete_lattice {α : Type u} : complete_lattice (topological_space α) :=
(gi_generate_from α).lift_complete_lattice

/-- The ordering on topologies on the type `α`.
  `t ≤ s` if every set open in `s` is also open in `t` (`t` is finer than `s`). -/
instance : partial_order (topological_space α) :=
{ le          := λ t s, s.is_open ≤ t.is_open,
  le_antisymm := assume t s h₁ h₂, topological_space_eq $ le_antisymm h₂ h₁,
  le_refl     := assume t, le_refl t.is_open,
  le_trans    := assume a b c h₁ h₂, le_trans h₂ h₁ }

lemma le_generate_from_iff_subset_is_open {g : set (set α)} {t : topological_space α} :
  t ≤ topological_space.generate_from g ↔ g ⊆ {s | t.is_open s} :=
generate_from_le_iff_subset_is_open

/-- Topologies on `α` form a complete lattice, with `⊥` the discrete topology
  and `⊤` the indiscrete topology. The infimum of a collection of topologies
  is the topology generated by all their open sets, while the supremem is the
  topology whose open sets are those sets open in every member of the collection. -/
instance : complete_lattice (topological_space α) :=
@order_dual.complete_lattice _ tmp_complete_lattice

/-- A topological space is discrete if every set is open, that is,
  its topology equals the discrete topology `⊥`. -/
class discrete_topology (α : Type*) [t : topological_space α] : Prop :=
(eq_bot [] : t = ⊥)

@[priority 100]
instance discrete_topology_bot (α : Type*) : @discrete_topology α ⊥ :=
{ eq_bot := rfl }

@[simp] lemma is_open_discrete [topological_space α] [discrete_topology α] (s : set α) :
  is_open s :=
(discrete_topology.eq_bot α).symm ▸ trivial

@[simp] lemma is_closed_discrete [topological_space α] [discrete_topology α] (s : set α) :
  is_closed s :=
is_open_compl_iff.1 $ (discrete_topology.eq_bot α).symm ▸ trivial

lemma continuous_of_discrete_topology [topological_space α] [discrete_topology α]
  [topological_space β] {f : α → β} : continuous f :=
continuous_def.2 $ λs hs, is_open_discrete _

lemma nhds_bot (α : Type*) : (@nhds α ⊥) = pure :=
begin
  refine le_antisymm _ (@pure_le_nhds α ⊥),
  assume a s hs,
  exact @mem_nhds_sets α ⊥ a s trivial hs
end

lemma nhds_discrete (α : Type*) [topological_space α] [discrete_topology α] : (@nhds α _) = pure :=
(discrete_topology.eq_bot α).symm ▸ nhds_bot α

lemma le_of_nhds_le_nhds {t₁ t₂ : topological_space α} (h : ∀x, @nhds α t₁ x ≤ @nhds α t₂ x) :
  t₁ ≤ t₂ :=
assume s, show @is_open α t₂ s → @is_open α t₁ s,
  by { simp only [is_open_iff_nhds, le_principal_iff],  exact assume hs a ha, h _ $ hs _ ha }

lemma eq_of_nhds_eq_nhds {t₁ t₂ : topological_space α} (h : ∀x, @nhds α t₁ x = @nhds α t₂ x) :
  t₁ = t₂ :=
le_antisymm
  (le_of_nhds_le_nhds $ assume x, le_of_eq $ h x)
  (le_of_nhds_le_nhds $ assume x, le_of_eq $ (h x).symm)

lemma eq_bot_of_singletons_open {t : topological_space α} (h : ∀ x, t.is_open {x}) : t = ⊥ :=
bot_unique $ λ s hs, bUnion_of_singleton s ▸ is_open_bUnion (λ x _, h x)

lemma forall_open_iff_discrete {X : Type*} [topological_space X] :
  (∀ s : set X, is_open s) ↔ discrete_topology X :=
⟨λ h, ⟨by { ext U , show is_open U ↔ true, simp [h U] }⟩, λ a, @is_open_discrete _ _ a⟩

lemma singletons_open_iff_discrete {X : Type*} [topological_space X] :
  (∀ a : X, is_open ({a} : set X)) ↔ discrete_topology X :=
⟨λ h, ⟨eq_bot_of_singletons_open h⟩, λ a _, @is_open_discrete _ _ a _⟩

end lattice

section galois_connection
variables {α : Type*} {β : Type*} {γ : Type*}

/-- Given `f : α → β` and a topology on `β`, the induced topology on `α` is the collection of
  sets that are preimages of some open set in `β`. This is the coarsest topology that
  makes `f` continuous. -/
def topological_space.induced {α : Type u} {β : Type v} (f : α → β) (t : topological_space β) :
  topological_space α :=
{ is_open        := λs, ∃s', t.is_open s' ∧ f ⁻¹' s' = s,
  is_open_univ   := ⟨univ, t.is_open_univ, preimage_univ⟩,
  is_open_inter  := by rintro s₁ s₂ ⟨s'₁, hs₁, rfl⟩ ⟨s'₂, hs₂, rfl⟩;
    exact ⟨s'₁ ∩ s'₂, t.is_open_inter _ _ hs₁ hs₂, preimage_inter⟩,
  is_open_sUnion := assume s h,
  begin
    simp only [classical.skolem] at h,
    cases h with f hf,
    apply exists.intro (⋃(x : set α) (h : x ∈ s), f x h),
    simp only [sUnion_eq_bUnion, preimage_Union, (λx h, (hf x h).right)], refine ⟨_, rfl⟩,
    exact (@is_open_Union β _ t _ $ assume i,
      show is_open (⋃h, f i h), from @is_open_Union β _ t _ $ assume h, (hf i h).left)
  end }

lemma is_open_induced_iff [t : topological_space β] {s : set α} {f : α → β} :
  @is_open α (t.induced f) s ↔ (∃t, is_open t ∧ f ⁻¹' t = s) :=
iff.rfl

lemma is_closed_induced_iff [t : topological_space β] {s : set α} {f : α → β} :
  @is_closed α (t.induced f) s ↔ (∃t, is_closed t ∧ f ⁻¹' t = s) :=
begin
  simp only [← is_open_compl_iff, is_open_induced_iff],
  exact ⟨λ ⟨t, ht, heq⟩, ⟨tᶜ, by rwa compl_compl, by simp [preimage_compl, heq, compl_compl]⟩,
         λ ⟨t, ht, heq⟩, ⟨tᶜ, ht, by simp only [preimage_compl, heq.symm]⟩⟩
end

/-- Given `f : α → β` and a topology on `α`, the coinduced topology on `β` is defined
  such that `s:set β` is open if the preimage of `s` is open. This is the finest topology that
  makes `f` continuous. -/
def topological_space.coinduced {α : Type u} {β : Type v} (f : α → β) (t : topological_space α) :
  topological_space β :=
{ is_open        := λs, t.is_open (f ⁻¹' s),
  is_open_univ   := by rw preimage_univ; exact t.is_open_univ,
  is_open_inter  := assume s₁ s₂ h₁ h₂, by rw preimage_inter; exact t.is_open_inter _ _ h₁ h₂,
  is_open_sUnion := assume s h, by rw [preimage_sUnion]; exact (@is_open_Union _ _ t _ $ assume i,
    show is_open (⋃ (H : i ∈ s), f ⁻¹' i), from
      @is_open_Union _ _ t _ $ assume hi, h i hi) }

lemma is_open_coinduced {t : topological_space α} {s : set β} {f : α → β} :
  @is_open β (topological_space.coinduced f t) s ↔ is_open (f ⁻¹' s) :=
iff.rfl

variables {t t₁ t₂ : topological_space α} {t' : topological_space β} {f : α → β} {g : β → α}

lemma continuous.coinduced_le (h : @continuous α β t t' f) :
  t.coinduced f ≤ t' :=
λ s hs, (continuous_def.1 h s hs : _)

lemma coinduced_le_iff_le_induced {f : α → β} {tα : topological_space α}
  {tβ : topological_space β} :
  tα.coinduced f ≤ tβ ↔ tα ≤ tβ.induced f :=
iff.intro
  (assume h s ⟨t, ht, hst⟩, hst ▸ h _ ht)
  (assume h s hs, show tα.is_open (f ⁻¹' s), from h _ ⟨s, hs, rfl⟩)

lemma continuous.le_induced (h : @continuous α β t t' f) :
  t ≤ t'.induced f :=
coinduced_le_iff_le_induced.1 h.coinduced_le

lemma gc_coinduced_induced (f : α → β) :
  galois_connection (topological_space.coinduced f) (topological_space.induced f) :=
assume f g, coinduced_le_iff_le_induced

lemma induced_mono (h : t₁ ≤ t₂) : t₁.induced g ≤ t₂.induced g :=
(gc_coinduced_induced g).monotone_u h

lemma coinduced_mono (h : t₁ ≤ t₂) : t₁.coinduced f ≤ t₂.coinduced f :=
(gc_coinduced_induced f).monotone_l h

@[simp] lemma induced_top : (⊤ : topological_space α).induced g = ⊤ :=
(gc_coinduced_induced g).u_top

@[simp] lemma induced_inf : (t₁ ⊓ t₂).induced g = t₁.induced g ⊓ t₂.induced g :=
(gc_coinduced_induced g).u_inf

@[simp] lemma induced_infi {ι : Sort w} {t : ι → topological_space α} :
  (⨅i, t i).induced g = (⨅i, (t i).induced g) :=
(gc_coinduced_induced g).u_infi

@[simp] lemma coinduced_bot : (⊥ : topological_space α).coinduced f = ⊥ :=
(gc_coinduced_induced f).l_bot

@[simp] lemma coinduced_sup : (t₁ ⊔ t₂).coinduced f = t₁.coinduced f ⊔ t₂.coinduced f :=
(gc_coinduced_induced f).l_sup

@[simp] lemma coinduced_supr {ι : Sort w} {t : ι → topological_space α} :
  (⨆i, t i).coinduced f = (⨆i, (t i).coinduced f) :=
(gc_coinduced_induced f).l_supr

lemma induced_id [t : topological_space α] : t.induced id = t :=
topological_space_eq $ funext $ assume s, propext $
  ⟨assume ⟨s', hs, h⟩, h ▸ hs, assume hs, ⟨s, hs, rfl⟩⟩

lemma induced_compose [tγ : topological_space γ]
  {f : α → β} {g : β → γ} : (tγ.induced g).induced f = tγ.induced (g ∘ f) :=
topological_space_eq $ funext $ assume s, propext $
  ⟨assume ⟨s', ⟨s, hs, h₂⟩, h₁⟩, h₁ ▸ h₂ ▸ ⟨s, hs, rfl⟩,
    assume ⟨s, hs, h⟩, ⟨preimage g s, ⟨s, hs, rfl⟩, h ▸ rfl⟩⟩

lemma induced_const [t : topological_space α] {x : α} :
  t.induced (λ y : β, x) = ⊤ :=
le_antisymm le_top (@continuous_const β α ⊤ t x).le_induced

lemma coinduced_id [t : topological_space α] : t.coinduced id = t :=
topological_space_eq rfl

lemma coinduced_compose [tα : topological_space α]
  {f : α → β} {g : β → γ} : (tα.coinduced f).coinduced g = tα.coinduced (g ∘ f) :=
topological_space_eq rfl

end galois_connection

/- constructions using the complete lattice structure -/
section constructions
open topological_space

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

instance inhabited_topological_space {α : Type u} : inhabited (topological_space α) :=
⟨⊤⟩

@[priority 100]
instance subsingleton.unique_topological_space [subsingleton α] :
  unique (topological_space α) :=
{ default := ⊥,
  uniq := λ t, eq_bot_of_singletons_open $ λ x, subsingleton.set_cases
    (@is_open_empty _ t) (@is_open_univ _ t) ({x} : set α) }

@[priority 100]
instance subsingleton.discrete_topology [t : topological_space α] [subsingleton α] :
  discrete_topology α :=
⟨unique.eq_default t⟩

instance : topological_space empty := ⊥
instance : discrete_topology empty := ⟨rfl⟩
instance : topological_space pempty := ⊥
instance : discrete_topology pempty := ⟨rfl⟩
instance : topological_space punit := ⊥
instance : discrete_topology punit := ⟨rfl⟩
instance : topological_space bool := ⊥
instance : discrete_topology bool := ⟨rfl⟩
instance : topological_space ℕ := ⊥
instance : discrete_topology ℕ := ⟨rfl⟩
instance : topological_space ℤ := ⊥
instance : discrete_topology ℤ := ⟨rfl⟩

instance sierpinski_space : topological_space Prop :=
generate_from {{true}}

lemma le_generate_from {t : topological_space α} { g : set (set α) } (h : ∀s∈g, is_open s) :
  t ≤ generate_from g :=
le_generate_from_iff_subset_is_open.2 h

lemma induced_generate_from_eq {α β} {b : set (set β)} {f : α → β} :
  (generate_from b).induced f = topological_space.generate_from (preimage f '' b) :=
le_antisymm
  (le_generate_from $ ball_image_iff.2 $ assume s hs, ⟨s, generate_open.basic _ hs, rfl⟩)
  (coinduced_le_iff_le_induced.1 $ le_generate_from $ assume s hs,
    generate_open.basic _ $ mem_image_of_mem _ hs)

/-- This construction is left adjoint to the operation sending a topology on `α`
  to its neighborhood filter at a fixed point `a : α`. -/
protected def topological_space.nhds_adjoint (a : α) (f : filter α) : topological_space α :=
{ is_open        := λs, a ∈ s → s ∈ f,
  is_open_univ   := assume s, univ_mem_sets,
  is_open_inter  := assume s t hs ht ⟨has, hat⟩, inter_mem_sets (hs has) (ht hat),
  is_open_sUnion := assume k hk ⟨u, hu, hau⟩, mem_sets_of_superset (hk u hu hau)
    (subset_sUnion_of_mem hu) }

lemma gc_nhds (a : α) :
  galois_connection  (topological_space.nhds_adjoint a) (λt, @nhds α t a) :=
assume f t, by { rw le_nhds_iff, exact ⟨λ H s hs has, H _ has hs, λ H s has hs, H _ hs has⟩ }

lemma nhds_mono {t₁ t₂ : topological_space α} {a : α} (h : t₁ ≤ t₂) :
  @nhds α t₁ a ≤ @nhds α t₂ a := (gc_nhds a).monotone_u h

lemma nhds_infi {ι : Sort*} {t : ι → topological_space α} {a : α} :
  @nhds α (infi t) a = (⨅i, @nhds α (t i) a) := (gc_nhds a).u_infi

lemma nhds_Inf {s : set (topological_space α)} {a : α} :
  @nhds α (Inf s) a = (⨅t∈s, @nhds α t a) := (gc_nhds a).u_Inf

lemma nhds_inf {t₁ t₂ : topological_space α} {a : α} :
  @nhds α (t₁ ⊓ t₂) a = @nhds α t₁ a ⊓ @nhds α t₂ a := (gc_nhds a).u_inf

lemma nhds_top {a : α} : @nhds α ⊤ a = ⊤ := (gc_nhds a).u_top

local notation `cont` := @continuous _ _
local notation `tspace` := topological_space
open topological_space

variables {γ : Type*} {f : α → β} {ι : Sort*}

lemma continuous_iff_coinduced_le {t₁ : tspace α} {t₂ : tspace β} :
  cont t₁ t₂ f ↔ coinduced f t₁ ≤ t₂ :=
continuous_def.trans iff.rfl

lemma continuous_iff_le_induced {t₁ : tspace α} {t₂ : tspace β} :
  cont t₁ t₂ f ↔ t₁ ≤ induced f t₂ :=
iff.trans continuous_iff_coinduced_le (gc_coinduced_induced f _ _)

theorem continuous_generated_from {t : tspace α} {b : set (set β)}
  (h : ∀s∈b, is_open (f ⁻¹' s)) : cont t (generate_from b) f :=
continuous_iff_coinduced_le.2 $ le_generate_from h

@[continuity]
lemma continuous_induced_dom {t : tspace β} : cont (induced f t) t f :=
by { rw continuous_def, assume s h, exact ⟨_, h, rfl⟩ }

lemma continuous_induced_rng {g : γ → α} {t₂ : tspace β} {t₁ : tspace γ}
  (h : cont t₁ t₂ (f ∘ g)) : cont t₁ (induced f t₂) g :=
begin
  rw continuous_def,
  rintros s ⟨t, ht, s_eq⟩,
  simpa [← s_eq] using continuous_def.1 h t ht,
end

lemma continuous_induced_rng' [topological_space α] [topological_space β] [topological_space γ]
  {g : γ → α} (f : α → β) (H : ‹topological_space α› = ‹topological_space β›.induced f)
  (h : continuous (f ∘ g)) : continuous g :=
H.symm ▸ continuous_induced_rng h

lemma continuous_coinduced_rng {t : tspace α} : cont t (coinduced f t) f :=
by { rw continuous_def, assume s h, exact h }

lemma continuous_coinduced_dom {g : β → γ} {t₁ : tspace α} {t₂ : tspace γ}
  (h : cont t₁ t₂ (g ∘ f)) : cont (coinduced f t₁) t₂ g :=
begin
  rw continuous_def at h ⊢,
  assume s hs,
  exact h _ hs
end

lemma continuous_le_dom {t₁ t₂ : tspace α} {t₃ : tspace β}
  (h₁ : t₂ ≤ t₁) (h₂ : cont t₁ t₃ f) : cont t₂ t₃ f :=
begin
  rw continuous_def at h₂ ⊢,
  assume s h,
  exact h₁ _ (h₂ s h)
end

lemma continuous_le_rng {t₁ : tspace α} {t₂ t₃ : tspace β}
  (h₁ : t₂ ≤ t₃) (h₂ : cont t₁ t₂ f) : cont t₁ t₃ f :=
begin
  rw continuous_def at h₂ ⊢,
  assume s h,
  exact h₂ s (h₁ s h)
end

lemma continuous_sup_dom {t₁ t₂ : tspace α} {t₃ : tspace β}
  (h₁ : cont t₁ t₃ f) (h₂ : cont t₂ t₃ f) : cont (t₁ ⊔ t₂) t₃ f :=
begin
  rw continuous_def at h₁ h₂ ⊢,
  assume s h,
  exact ⟨h₁ s h, h₂ s h⟩
end

lemma continuous_sup_rng_left {t₁ : tspace α} {t₃ t₂ : tspace β} :
  cont t₁ t₂ f → cont t₁ (t₂ ⊔ t₃) f :=
continuous_le_rng le_sup_left

lemma continuous_sup_rng_right {t₁ : tspace α} {t₃ t₂ : tspace β} :
  cont t₁ t₃ f → cont t₁ (t₂ ⊔ t₃) f :=
continuous_le_rng le_sup_right

lemma continuous_Sup_dom {t₁ : set (tspace α)} {t₂ : tspace β}
  (h : ∀t∈t₁, cont t t₂ f) : cont (Sup t₁) t₂ f :=
continuous_iff_le_induced.2 $ Sup_le $ assume t ht, continuous_iff_le_induced.1 $ h t ht

lemma continuous_Sup_rng {t₁ : tspace α} {t₂ : set (tspace β)} {t : tspace β}
  (h₁ : t ∈ t₂) (hf : cont t₁ t f) : cont t₁ (Sup t₂) f :=
continuous_iff_coinduced_le.2 $ le_Sup_of_le h₁ $ continuous_iff_coinduced_le.1 hf

lemma continuous_supr_dom {t₁ : ι → tspace α} {t₂ : tspace β}
  (h : ∀i, cont (t₁ i) t₂ f) : cont (supr t₁) t₂ f :=
continuous_Sup_dom $ assume t ⟨i, (t_eq : t₁ i = t)⟩, t_eq ▸ h i

lemma continuous_supr_rng {t₁ : tspace α} {t₂ : ι → tspace β} {i : ι}
  (h : cont t₁ (t₂ i) f) : cont t₁ (supr t₂) f :=
continuous_Sup_rng ⟨i, rfl⟩ h

lemma continuous_inf_rng {t₁ : tspace α} {t₂ t₃ : tspace β}
  (h₁ : cont t₁ t₂ f) (h₂ : cont t₁ t₃ f) : cont t₁ (t₂ ⊓ t₃) f :=
continuous_iff_coinduced_le.2 $ le_inf
  (continuous_iff_coinduced_le.1 h₁)
  (continuous_iff_coinduced_le.1 h₂)

lemma continuous_inf_dom_left {t₁ t₂ : tspace α} {t₃ : tspace β} :
  cont t₁ t₃ f → cont (t₁ ⊓ t₂) t₃ f :=
continuous_le_dom inf_le_left

lemma continuous_inf_dom_right {t₁ t₂ : tspace α} {t₃ : tspace β} :
  cont t₂ t₃ f → cont (t₁ ⊓ t₂) t₃ f :=
continuous_le_dom inf_le_right

lemma continuous_Inf_dom {t₁ : set (tspace α)} {t₂ : tspace β} {t : tspace α} (h₁ : t ∈ t₁) :
  cont t t₂ f → cont (Inf t₁) t₂ f :=
continuous_le_dom $ Inf_le h₁

lemma continuous_Inf_rng {t₁ : tspace α} {t₂ : set (tspace β)}
  (h : ∀t∈t₂, cont t₁ t f) : cont t₁ (Inf t₂) f :=
continuous_iff_coinduced_le.2 $ le_Inf $ assume b hb, continuous_iff_coinduced_le.1 $ h b hb

lemma continuous_infi_dom {t₁ : ι → tspace α} {t₂ : tspace β} {i : ι} :
  cont (t₁ i) t₂ f → cont (infi t₁) t₂ f :=
continuous_le_dom $ infi_le _ _

lemma continuous_infi_rng {t₁ : tspace α} {t₂ : ι → tspace β}
  (h : ∀i, cont t₁ (t₂ i) f) : cont t₁ (infi t₂) f :=
continuous_iff_coinduced_le.2 $ le_infi $ assume i, continuous_iff_coinduced_le.1 $ h i

@[continuity] lemma continuous_bot {t : tspace β} : cont ⊥ t f :=
continuous_iff_le_induced.2 $ bot_le

@[continuity] lemma continuous_top {t : tspace α} : cont t ⊤ f :=
continuous_iff_coinduced_le.2 $ le_top

/- 𝓝 in the induced topology -/

theorem mem_nhds_induced [T : topological_space α] (f : β → α) (a : β) (s : set β) :
  s ∈ @nhds β (topological_space.induced f T) a ↔ ∃ u ∈ 𝓝 (f a), f ⁻¹' u ⊆ s :=
begin
  simp only [mem_nhds_sets_iff, is_open_induced_iff, exists_prop, set.mem_set_of_eq],
  split,
  { rintros ⟨u, usub, ⟨v, openv, ueq⟩, au⟩,
    exact ⟨v, ⟨v, set.subset.refl v, openv, by rwa ←ueq at au⟩, by rw ueq; exact usub⟩ },
  rintros ⟨u, ⟨v, vsubu, openv, amem⟩, finvsub⟩,
  exact ⟨f ⁻¹' v, set.subset.trans (set.preimage_mono vsubu) finvsub, ⟨⟨v, openv, rfl⟩, amem⟩⟩
end

theorem nhds_induced [T : topological_space α] (f : β → α) (a : β) :
  @nhds β (topological_space.induced f T) a = comap f (𝓝 (f a)) :=
by { ext s, rw [mem_nhds_induced, mem_comap_sets] }

lemma induced_iff_nhds_eq [tα : topological_space α] [tβ : topological_space β] (f : β → α) :
tβ = tα.induced f ↔ ∀ b, 𝓝 b = comap f (𝓝 $ f b) :=
⟨λ h a, h.symm ▸ nhds_induced f a, λ h, eq_of_nhds_eq_nhds $ λ x, by rw [h, nhds_induced]⟩

theorem map_nhds_induced_of_surjective [T : topological_space α]
    {f : β → α} (hf : function.surjective f) (a : β) :
  map f (@nhds β (topological_space.induced f T) a) = 𝓝 (f a) :=
by rw [nhds_induced, map_comap_of_surjective hf]

end constructions

section induced
open topological_space
variables {α : Type*} {β : Type*}
variables [t : topological_space β] {f : α → β}

theorem is_open_induced_eq {s : set α} :
  @is_open _ (induced f t) s ↔ s ∈ preimage f '' {s | is_open s} :=
iff.rfl

theorem is_open_induced {s : set β} (h : is_open s) : (induced f t).is_open (f ⁻¹' s) :=
⟨s, h, rfl⟩

lemma map_nhds_induced_eq (a : α) : map f (@nhds α (induced f t) a) = 𝓝[range f] (f a) :=
by rw [nhds_induced, filter.map_comap, nhds_within]

lemma map_nhds_induced_of_mem {a : α} (h : range f ∈ 𝓝 (f a)) :
  map f (@nhds α (induced f t) a) = 𝓝 (f a) :=
by rw [nhds_induced, filter.map_comap_of_mem h]

lemma closure_induced [t : topological_space β] {f : α → β} {a : α} {s : set α} :
  a ∈ @closure α (topological_space.induced f t) s ↔ f a ∈ closure (f '' s) :=
by simp only [mem_closure_iff_frequently, nhds_induced, frequently_comap, mem_image, and_comm]

end induced

section sierpinski
variables {α : Type*} [topological_space α]

@[simp] lemma is_open_singleton_true : is_open ({true} : set Prop) :=
topological_space.generate_open.basic _ (by simp)

lemma continuous_Prop {p : α → Prop} : continuous p ↔ is_open {x | p x} :=
⟨assume h : continuous p,
  have is_open (p ⁻¹' {true}),
    from is_open_singleton_true.preimage h,
  by simp [preimage, eq_true] at this; assumption,
  assume h : is_open {x | p x},
  continuous_generated_from $ assume s (hs : s ∈ {{true}}),
    by simp at hs; simp [hs, preimage, eq_true, h]⟩

lemma is_open_iff_continuous_mem {s : set α} : is_open s ↔ continuous (λ x, x ∈ s) :=
continuous_Prop.symm

end sierpinski

section infi
variables {α : Type u} {ι : Type v} {t : ι → topological_space α}

lemma is_open_supr_iff {s : set α} : @is_open _ (⨆ i, t i) s ↔ ∀ i, @is_open _ (t i) s :=
begin
  -- s defines a map from α to Prop, which is continuous iff s is open.
  suffices : @continuous _ _ (⨆ i, t i) _ s ↔ ∀ i, @continuous _ _ (t i) _ s,
  { simpa only [continuous_Prop] using this },
  simp only [continuous_iff_le_induced, supr_le_iff]
end

lemma is_closed_infi_iff {s : set α} : @is_closed _ (⨆ i, t i) s ↔ ∀ i, @is_closed _ (t i) s :=
by simp [← is_open_compl_iff, is_open_supr_iff]

end infi


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

/-!

# Monad homomorphism

A ***monad transformation*** is a natural transformation between monads which preserves `pure` and `bind`.
More precisely, for monads `m : Type u → Type v` and `n : Type u → Type w`, the type `MonadHom m n` consists of morphisms `app : {α : Type u} → m α → n α` satisfying the following:

```lean
MonadHom.app_pure : {α : Type u} : ∀ (a : α), app (pure a) = pure a
MonadHom.app_bind : {α β : Type u} : ∀ (x : m α) (f : α → m β) : app (x >>= f) = app x >>= app ∘ f
```

Note that the two conditions suffice to ensure `app` to be a natural transformation between endo-functors.

-/

universe u v v₁ v₂ v₃ w

/-- For monads `m : Type u → Type v` and `n : Type u → Type w`, a monad homomorphism from `m` to `n` is a family of maps `app : {α : Type u} → m α → n α` which respects `pure` and `bind`. -/
structure MonadHom (m : Type u → Type v) [Monad m] (n : Type u → Type w) [Monad n] where
  app {α : Type u} : m α → n α
  app_pure {α : Type u} (a : α) : app (pure a) = pure a
  app_bind {α β : Type u} (x : m α) (f : α → m β) : app (x >>= f) = app x >>= app ∘ f

namespace MonadHom

/-- Composition of two monad homomorphisms. @warning Be careful about the order of the arguments; here we follow the convention of `Mathlib.CategoryTheory`. -/
def comp {m₁ : Type u → Type v₁} [Monad m₁] {m₂ : Type u → Type v₂} [Monad m₂] {m₃ : Type u → Type v₃} [Monad m₃] (F : MonadHom m₁ m₂) (G : MonadHom m₂ m₃) : MonadHom m₁ m₃ where
  app := G.app ∘ F.app
  app_pure a := G.app_pure a ▸ F.app_pure a ▸ rfl
  app_bind x f := G.app_bind (F.app x) (F.app ∘ f) ▸ F.app_bind x f ▸ rfl

/-- Two monad homomorphisms `F` and `G` equal to each other provided `F.app = G.app` by virtue of the `proofIrrel` -/
theorem eq {m : Type u → Type v} [instm : Monad m] {n :Type u → Type w} [instn : Monad n] : {F G : @MonadHom m instm n instn} → @MonadHom.app m instm n instn F = @MonadHom.app m instm n instn G → F = G
| mk _ _ _, mk _ _ _, rfl => rfl

/-- Functional extensionality for monad homomorphisms. -/
theorem ext {m : Type u → Type v} [Monad m] {n : Type u → Type w} [Monad n] {F G : MonadHom m n} (h : ∀ {α : Type u} (x : m α), F.app x = G.app x) : F = G := by
  apply MonadHom.eq (m:=m)
  funext _ x
  exact h x

/-- Proof that the two conditions in `MonadHom` implies the naturality of `MonadHom.app` in the ordinary sense. -/
theorem naturality {m : Type u → Type v} [Monad m] [LawfulMonad m] {n :Type u → Type w} [Monad n] [LawfulMonad n] (F : MonadHom m n) {α β : Type u} (f : α → β) : F.app ∘ Functor.map f = Functor.map f ∘ F.app := by
  funext x; dsimp
  conv =>
    lhs; rw [map_eq_pure_bind, F.app_bind]; rhs; ext a; dsimp; rw [F.app_pure]
  rw [map_eq_pure_bind]

end MonadHom