import .macros .algebra

open classical

constant real : Type
notation `ℝ` := real

constant real_field : discrete_linear_ordered_field ℝ
noncomputable instance
  : discrete_linear_ordered_field real := real_field
noncomputable instance : decidable_linear_ordered_comm_group real :=
  { decidable_le := λ x y, prop_decidable _,
  ..real_field }

def upper_bound {F} [linear_order F] (S : set F)
  : F → Prop
  := λ B, ∀ x ∈ S, x ≤ B

def least_upper_bound {F} [decidable_linear_ordered_comm_group F] (S : set F)
  : F → Prop
  := λ B, upper_bound S B ∧ (∀ C, upper_bound S C → B ≤ C)

axiom real.complete
  : ∀ S : set ℝ, (∃ B, upper_bound S B) → (∃ B, least_upper_bound S B)

lemma eight_pos : (8:ℝ) > 0 := by {
  rw (_ : (8 : ℝ) = 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1),
  tactic.swap, dsimp [bit0], ac_refl,
  tactic.one_sum_gt
}

lemma lt_of_sq_lt : ∀ x y : ℝ, 0 < y → x * x < y * y → x < y :=
begin
  intros x y hy h,
  by_cases hx : x > 0, tactic.swap, { exact lt_of_le_of_lt (le_of_not_gt hx) hy },
  have : y*y - x*x > 0, apply sub_pos_of_lt h,
  apply lt_of_sub_pos, rw difference_of_squares at this,
  apply pos_of_mul_pos_right this, apply le_of_lt,
  apply add_pos hy hx
end

lemma real.exists_squareroot : ∀ x : ℝ, x ≥ 0 → ∃ y, y ≥ 0 ∧ y * y = x :=
begin
  intros x hx,
  by_cases x = 0, existsi (0 : ℝ), subst h, exact and.intro hx (mul_zero 0),
  have : x > 0 := lt_of_le_of_ne hx (ne.symm h), clear h hx, rename this hx,
  cases real.complete { y | y*y ≤ x } ⟨x+1, _⟩ with y hy,
  have hy' : y > 0,
  { by_cases 1 ≤ x,
    { apply lt_of_lt_of_le zero_lt_one, apply hy.left,
      suffices : 1 * 1 ≤ x, exact this, rw one_mul, exact h },
    { have : x ≤ 1, apply le_of_not_ge h,
      apply lt_of_lt_of_le hx, apply hy.left,
      suffices : x*x ≤ x*1, rw mul_one at this, exact this,
      apply mul_le_mul_of_nonneg_left this (le_of_lt hx) } },
  existsi y,
  { have h2 : 0 < 2*y, { rw [(_ : (2 : ℝ) = 1 + 1), right_distrib, one_mul], apply add_pos hy' hy', refl },
    have h3 : 0 < 4*y, { rw [(_ : (4:ℝ) = 2 + 2), right_distrib], apply add_pos h2 h2, refl },
    cases lt_trichotomy (y*y) x,
    exfalso,
    let ε := min ((x-y*y)/(8*y)) (2*y),
    have h1 : 2 * y + ε ≤ 4*y,
    { rw (_ : 4*y = 2*y + 2*y),
      apply add_le_add (le_refl (2*y)) (min_le_right _ _),
      transitivity (2 + 2) * y, refl, apply right_distrib },
    have h4 : 0 < ε,
    { apply lt_min, apply lt_div_of_mul_lt,
      apply mul_pos eight_pos hy', rw zero_mul,
      apply sub_pos_of_lt h, exact h2 },
    have : ε * (2 * y + ε) < x - y*y,
    { apply @lt_of_le_of_lt _ _ _ (ε * (4*y)),
      apply mul_le_mul_of_nonneg_left h1,
      exact le_of_lt h4,
      apply @lt_of_le_of_lt _ _ _ (((x - y * y) / (8 * y)) * (4*y)),
      apply mul_le_mul_of_nonneg_right, apply min_le_left,
      exact le_of_lt h3,
      rw [div_eq_mul_one_div, mul_assoc, mul_comm _ (4*y), ← div_eq_mul_one_div],
      rw (_ : 8 * y = (4  * y) * 2),
      rw ← field.div_div_eq_div_mul, rw div_self,
      rw ← mul_one (x - y * y), rw mul_assoc,
      apply mul_lt_mul_of_pos_left,
      { rw one_mul, apply div_lt_of_mul_lt_of_pos,
        apply add_pos zero_lt_one zero_lt_one, rw one_mul,
        apply lt_add_of_pos_right _ zero_lt_one, },
      apply sub_pos_of_lt h,
      apply ne.symm (ne_of_lt h3),
      apply ne.symm (ne_of_lt h3),
      refine ne_of_gt _, apply add_pos zero_lt_one zero_lt_one,
      rw [mul_comm _ (2 : ℝ), ← mul_assoc], congr,
      simp [bit0], rw [right_distrib, one_mul], ac_refl },
    { rw left_distrib at this,
      have := add_lt_of_lt_sub_left this,
      rw (_ : (2 : ℝ) = 1 + 1) at this,
      rw [right_distrib, one_mul, left_distrib] at this,
      rw (_ : y * y + (ε * y + ε * y + ε * ε) = (y + ε)*(y + ε)) at this,
      apply not_lt_of_ge (hy.left (y + ε) (le_of_lt this)),
      apply lt_add_of_pos_right, assumption,
      rw FOIL, ac_refl, refl },
    cases h, { constructor, exact le_of_lt hy', assumption },
    exfalso,
    let ε := (y*y-x)/(2*y),
    have h4 : ε > 0,
    { apply lt_div_of_mul_lt, rw (_ : 2 = 1 + (1:ℝ)),
      rw [right_distrib, one_mul], apply add_pos hy' hy', refl,
      rw zero_mul, apply sub_pos_of_lt h },
    have : ε * (2 * y - ε) < y*y - x,
    { apply @lt_of_lt_of_le _ _ _ (ε * (2*y)) _,
      apply mul_lt_mul_of_pos_left, apply sub_lt_self, exact h4, exact h4,
      dsimp [ε], rw [div_eq_mul_one_div, mul_assoc, mul_comm _ (2*y), ← div_eq_mul_one_div],
      rw div_self, rw mul_one, apply ne.symm (ne_of_lt h2) },
    { rw mul_sub at this,
      have := add_lt_of_lt_sub_left this,
      rw add_sub at this,
      have := lt_add_of_sub_left_lt this,
      have := lt_sub_right_of_add_lt this,
      rw (_ : ε * ε + y*y - ε * (2 * y) = (y - ε)*(y-ε)) at this,
      have : upper_bound {y : ℝ | y * y ≤ x} (y - ε),
      { intros y' h', apply le_of_lt, apply lt_of_sq_lt,
        apply sub_pos_of_lt, dsimp [ε],
        apply div_lt_of_mul_lt_of_pos h2,
        rw (_ : y * (2*y) = y*y+y*y),
        apply lt_add_of_pos_of_lt, apply mul_pos hy' hy',
        rw ← sub_eq_add_neg, apply sub_lt_self _ hx,
        rw  (_ : (2 : ℝ) =  1 + 1), rw [right_distrib, left_distrib],
        rw one_mul, refl, apply lt_of_le_of_lt h' this },
      apply not_lt_of_ge (hy.right _ this),
      apply sub_lt_self _ h4, rw FOIL_neg_square,
      rw ← neg_add, rw add_right_comm, rw add_comm, congr,
      rw mul_comm, rw mul_assoc, rw (_ : (2 : ℝ) =  1 + 1),
      rw right_distrib, rw one_mul, refl } },
  intros y hy,
  by_cases y ≤ 1,
  { rw ← zero_add y, apply add_le_add (le_of_lt hx) h },
  { transitivity (y*y), have : 1 ≤ y := le_of_not_le h,
    apply @le_mul_of_ge_one_right _ _ y y (le_trans zero_le_one this) this,
    transitivity x, assumption, apply le_add_of_nonneg_right zero_le_one }
end

noncomputable
def sqrt (x : ℝ) : ℝ :=
  if h : 0 ≤ x
  then some $ real.exists_squareroot x h
  else 0
notation `√` := sqrt
lemma sqrt_sq {x : ℝ} (h : 0 ≤ x) : √x * √x = x :=
  by { dsimp [sqrt], rw dif_pos h, exact (and.right $ some_spec $ real.exists_squareroot x h), }
lemma sqrt_nonneg (x : ℝ) : √x ≥ 0 :=
by { dsimp [sqrt], by_cases h : 0 ≤ x,
     rw dif_pos h, have := some_spec (real.exists_squareroot x h), cases this, assumption,
     rw dif_neg h, apply le_refl }

lemma eq_of_nonneg_and_sq_eq : ∀ {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y), x*x = y*y → x = y :=
begin
  intros x y hx hy h, generalize h' : x*x = u, rw h' at h,
  have h1 : (min x y) * (min x y) = u, { min_tac x y },
  have h2 : (max x y) * (max x y) = u, { min_tac x y },
  have h3 : (min x y) * (min x y) ≤ (min x y) * (max x y),
  { apply mul_le_mul_of_nonneg_left; min_tac x y },
  have h4 : (min x y) * (max x y) ≤ (max x y) * (max x y),
  { apply mul_le_mul_of_nonneg_right; min_tac x y },
  rw h1 at h3, rw h2 at h4,
  have : (min x y) * (max x y) = u := le_antisymm h4 h3,
  rw (_ : (min x y) * (max x y) = x * y) at this,
  rw h at this,
  by_cases h : y = 0,
  { subst h, rw [h, mul_zero] at h', apply eq_zero_of_sqr_eq_zero h' },
  rw [← eq_div_iff_mul_eq _ _ h, mul_div_cancel _ h] at this,
  exact this,
  by_cases x ≤ y; unfold max min; simp [*, if_pos, if_neg], rw mul_comm,
end

lemma sqrt_unique : ∀ {x y} (hx : 0 ≤ x) (hy : 0 ≤ y), y*y = x → y = √x :=
by { intros, apply eq_of_nonneg_and_sq_eq, assumption, apply sqrt_nonneg,
     transitivity x, assumption, symmetry, apply sqrt_sq hx, }

lemma abs_eq_sq_sqrt : ∀ x, abs x = √ (x*x) :=
begin
  intro x, apply sqrt_unique (mul_self_nonneg x) (abs_nonneg x),
  dsimp [abs], min_tac x (-x)
end

lemma eq_of_sqrt_eq {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) (h : √x = √y) : x = y :=
by rw [← sqrt_sq hx, ← sqrt_sq hy, h]

lemma le_zero_of_sqrt_eq_zero : ∀ {x}, √x = 0 → x ≤ 0 :=
begin
  intros, cases le_or_gt 0 x,
  { rw (_ : x = 0), transitivity √x * √x,
    symmetry, apply sqrt_sq h, rw a, apply zero_mul },
  apply le_of_lt h
end

lemma eq_one_of_sqrt_eq_one : ∀ {x}, √x = 1 → x = 1 :=
begin
  intros x h, have hx : 0 ≤ x, { by_contradiction, dsimp [sqrt] at h, rw dif_neg at h, exact zero_ne_one h, assumption },
  rw (_ : 1 = √1) at h, apply eq_of_sqrt_eq hx zero_le_one h,
  apply sqrt_unique zero_le_one zero_le_one (one_mul 1)
end

lemma sqrt_pos_of_pos {x : ℝ} : x > 0 → √ x > 0 :=
begin
  intro hx, apply lt_of_le_of_ne, apply sqrt_nonneg,
  intro h, refine not_lt_of_ge _ hx, apply le_zero_of_sqrt_eq_zero,
  symmetry, assumption
end

lemma inv_sqrt : ∀ {x}, x > 0 → (√x)⁻¹ = √(x⁻¹) :=
begin
  intros x hx, have : 0 < √ x := sqrt_pos_of_pos hx,
  apply sqrt_unique,
  repeat { rw inv_eq_one_div, apply div_nonneg_of_nonneg_of_pos, exact zero_le_one, assumption },
  transitivity (√x * √x)⁻¹, rw inv_eq_one_div, rw inv_eq_one_div,
  rw eq_div_iff_mul_eq _ _ (ne.symm $ ne_of_lt $ mul_pos this this),
  rw [mul_assoc, mul_left_comm _ (√ x) _, ← mul_assoc],
  rw mul_comm (1 / √ x) (√ x), rw ← div_eq_mul_one_div,
  rw div_self (ne.symm $ ne_of_lt this), apply mul_one,
  rw sqrt_sq (le_of_lt hx),
end

lemma sqrt_monotone : ∀ {x y}, x ≤ y → √ x ≤ √ y :=
begin
  intros x y hxy, by_cases 0 < x,
  { by_cases x = y, rw h, apply le_of_lt,
    have : 0 < y, refine lt_of_lt_of_le _ hxy, assumption,
    apply lt_of_sq_lt (√ x) (√ y) (sqrt_pos_of_pos this) _,
    rw [sqrt_sq, sqrt_sq], apply lt_of_le_of_ne; assumption,
    all_goals { apply le_of_lt, assumption } },
  { rw (_ : √ x = 0), apply sqrt_nonneg,
    by_cases x = 0, { rw h, symmetry, apply sqrt_unique, refl, refl, apply zero_mul },
    simp [sqrt], rw dif_neg, intro h, cases lt_or_eq_of_le h, trivial, have := eq.symm h_1, trivial }
end

lemma eq_of_really_close : ∀ {x y : ℝ}, (∀ ε, ε > 0 → abs (x - y) < ε) → x = y :=
begin
  suffices : ∀ x y : ℝ, x < y → ∃ ε, ε > 0 ∧ abs (x - y) ≥ ε,
  { intros x y h, cases (lt_trichotomy x y),
    { exfalso, cases this x y h_1 with ε, cases h_2,
      exact not_lt_of_ge h_2_right (h ε h_2_left) },
    cases h_1, assumption,
    { exfalso, cases this y x h_1 with ε, cases h_2,
      rw abs_sub at h_2_right, exact not_lt_of_ge h_2_right (h ε h_2_left) } },
  intros x y hxy, rw abs_sub, have : y - x > 0 := sub_pos_of_lt hxy,
  existsi (y - x), constructor, assumption,
  rw abs_of_nonneg (le_of_lt this), apply le_refl
end

lemma real.triangle_inequality : ∀ (x y : ℝ), abs (x + y) ≤ abs x + abs y :=
begin
  intros,
  have h1 : x + y ≤ abs x + abs y,
  { apply add_le_add; apply le_abs_self },
  have h2 : -x + -y ≤ abs (-x) + abs (-y),
  { apply add_le_add; apply le_abs_self },
  rw [← neg_add, abs_neg, abs_neg] at h2,
  apply max_le; assumption,
end

lemma real.triangle_inequality' : ∀ (x y z : ℝ), abs (x - y) ≤ abs (x - z) + abs (z - y) :=
begin
  intros, rw (_ : x - y = (x - z) + (z - y)),
  apply real.triangle_inequality,
  rw [← add_sub_assoc, sub_add_cancel]
end

lemma real.lt_of_lt_triangle_lt (x y z ε : ℝ) :
  abs (x - z) < ε/2 → abs (y - z) < ε/2 → abs (x - y) < ε :=
by { intros h h', rw abs_sub at h', apply lt_of_le_of_lt (real.triangle_inequality' x y z),
     rw [← add_self_div_two ε, ← div_add_div_same], exact add_lt_add h h' }

noncomputable def sgn (x : ℝ) : ℝ := if x = 0 then 0 else if x > 0 then 1 else -1

lemma abs_div_self_eq_sgn (x : ℝ) : abs x / x = sgn x :=
begin
  dsimp [sgn],
  by_cases x = 0, { subst h, rw div_zero, rw if_pos rfl, },
  by_cases x > 0,
  { rw abs_of_nonneg, rw div_self, rw if_neg, rw if_pos,
    assumption', apply le_of_lt, assumption },
  { rw abs_of_neg, rw neg_div, rw div_self,
    rw [if_neg, if_neg], assumption',
    apply lt_of_not_ge, intro h, cases (lt_or_eq_of_le h),
    trivial, have := eq.symm h_1, trivial, }
end

lemma sgn_mul_abs_eq_self (x : ℝ) : sgn x * abs x = x :=
begin
  dsimp [sgn],
  by_cases x = 0, { subst h, rw abs_zero, rw mul_zero },
  by_cases x > 0,
  { rw abs_of_nonneg, rw if_neg, rw if_pos, apply one_mul,
    assumption', apply le_of_lt, assumption },
  { rw abs_of_neg, rw [if_neg, if_neg], assumption',
    rw mul_neg_eq_neg_mul_symm, rw neg_mul_eq_neg_mul_symm,
    rw neg_neg, rw one_mul,
    apply lt_of_not_ge, intro h, cases (lt_or_eq_of_le h),
    trivial, have := eq.symm h_1, trivial, }
end

lemma abs_mul_abs_eq_self_mul_self (x : ℝ) : abs x * abs x = x * x :=
by dsimp [abs]; min_tac x (-x)


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Anatole Dedecker
-/

import analysis.seminorm
import analysis.locally_convex.bounded
import topology.algebra.filter_basis
import topology.algebra.module.locally_convex

/-!
# Topology induced by a family of seminorms

## Main definitions

* `seminorm_family.basis_sets`: The set of open seminorm balls for a family of seminorms.
* `seminorm_family.module_filter_basis`: A module filter basis formed by the open balls.
* `seminorm.is_bounded`: A linear map `f : E →ₗ[𝕜] F` is bounded iff every seminorm in `F` can be
bounded by a finite number of seminorms in `E`.

## Main statements

* `with_seminorms.to_locally_convex_space`: A space equipped with a family of seminorms is locally
convex.
* `with_seminorms.first_countable`: A space is first countable if it's topology is induced by a
countable family of seminorms.

## Continuity of semilinear maps

If `E` and `F` are topological vector space with the topology induced by a family of seminorms, then
we have a direct method to prove that a linear map is continuous:
* `seminorm.continuous_from_bounded`: A bounded linear map `f : E →ₗ[𝕜] F` is continuous.

If the topology of a space `E` is induced by a family of seminorms, then we can characterize von
Neumann boundedness in terms of that seminorm family. Together with
`linear_map.continuous_of_locally_bounded` this gives general criterion for continuity.

* `with_seminorms.is_vonN_bounded_iff_finset_seminorm_bounded`
* `with_seminorms.is_vonN_bounded_iff_seminorm_bounded`
* `with_seminorms.image_is_vonN_bounded_iff_finset_seminorm_bounded`
* `with_seminorms.image_is_vonN_bounded_iff_seminorm_bounded`

## Tags

seminorm, locally convex
-/

open normed_field set seminorm topological_space
open_locale big_operators nnreal pointwise topology

variables {𝕜 𝕜₂ 𝕝 𝕝₂ E F G ι ι' : Type*}

section filter_basis

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]

variables (𝕜 E ι)

/-- An abbreviation for indexed families of seminorms. This is mainly to allow for dot-notation. -/
abbreviation seminorm_family := ι → seminorm 𝕜 E

variables {𝕜 E ι}

namespace seminorm_family

/-- The sets of a filter basis for the neighborhood filter of 0. -/
def basis_sets (p : seminorm_family 𝕜 E ι) : set (set E) :=
⋃ (s : finset ι) r (hr : 0 < r), singleton $ ball (s.sup p) (0 : E) r

variables (p : seminorm_family 𝕜 E ι)

lemma basis_sets_iff {U : set E} :
  U ∈ p.basis_sets ↔ ∃ (i : finset ι) r (hr : 0 < r), U = ball (i.sup p) 0 r :=
by simp only [basis_sets, mem_Union, mem_singleton_iff]

lemma basis_sets_mem (i : finset ι) {r : ℝ} (hr : 0 < r) :
  (i.sup p).ball 0 r ∈ p.basis_sets :=
(basis_sets_iff _).mpr ⟨i,_,hr,rfl⟩

lemma basis_sets_singleton_mem (i : ι) {r : ℝ} (hr : 0 < r) :
  (p i).ball 0 r ∈ p.basis_sets :=
(basis_sets_iff _).mpr ⟨{i},_,hr, by rw finset.sup_singleton⟩

lemma basis_sets_nonempty [nonempty ι] : p.basis_sets.nonempty :=
begin
  let i := classical.arbitrary ι,
  refine set.nonempty_def.mpr ⟨(p i).ball 0 1, _⟩,
  exact p.basis_sets_singleton_mem i zero_lt_one,
end

lemma basis_sets_intersect
  (U V : set E) (hU : U ∈ p.basis_sets) (hV : V ∈ p.basis_sets) :
  ∃ (z : set E) (H : z ∈ p.basis_sets), z ⊆ U ∩ V :=
begin
  classical,
  rcases p.basis_sets_iff.mp hU with ⟨s, r₁, hr₁, hU⟩,
  rcases p.basis_sets_iff.mp hV with ⟨t, r₂, hr₂, hV⟩,
  use ((s ∪ t).sup p).ball 0 (min r₁ r₂),
  refine ⟨p.basis_sets_mem (s ∪ t) (lt_min_iff.mpr ⟨hr₁, hr₂⟩), _⟩,
  rw [hU, hV, ball_finset_sup_eq_Inter _ _ _ (lt_min_iff.mpr ⟨hr₁, hr₂⟩),
    ball_finset_sup_eq_Inter _ _ _ hr₁, ball_finset_sup_eq_Inter _ _ _ hr₂],
  exact set.subset_inter
    (set.Inter₂_mono' $ λ i hi, ⟨i, finset.subset_union_left _ _ hi, ball_mono $ min_le_left _ _⟩)
    (set.Inter₂_mono' $ λ i hi, ⟨i, finset.subset_union_right _ _ hi, ball_mono $
    min_le_right _ _⟩),
end

lemma basis_sets_zero (U) (hU : U ∈ p.basis_sets) :
  (0 : E) ∈ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨ι', r, hr, hU⟩,
  rw [hU, mem_ball_zero, map_zero],
  exact hr,
end

lemma basis_sets_add (U) (hU : U ∈ p.basis_sets) :
  ∃ (V : set E) (H : V ∈ p.basis_sets), V + V ⊆ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  use (s.sup p).ball 0 (r/2),
  refine ⟨p.basis_sets_mem s (div_pos hr zero_lt_two), _⟩,
  refine set.subset.trans (ball_add_ball_subset (s.sup p) (r/2) (r/2) 0 0) _,
  rw [hU, add_zero, add_halves'],
end

lemma basis_sets_neg (U) (hU' : U ∈ p.basis_sets) :
  ∃ (V : set E) (H : V ∈ p.basis_sets), V ⊆ (λ (x : E), -x) ⁻¹' U :=
begin
  rcases p.basis_sets_iff.mp hU' with ⟨s, r, hr, hU⟩,
  rw [hU, neg_preimage, neg_ball (s.sup p), neg_zero],
  exact ⟨U, hU', eq.subset hU⟩,
end

/-- The `add_group_filter_basis` induced by the filter basis `seminorm_basis_zero`. -/
protected def add_group_filter_basis [nonempty ι] : add_group_filter_basis E :=
add_group_filter_basis_of_comm p.basis_sets p.basis_sets_nonempty
  p.basis_sets_intersect p.basis_sets_zero p.basis_sets_add p.basis_sets_neg

lemma basis_sets_smul_right (v : E) (U : set E)
  (hU : U ∈ p.basis_sets) : ∀ᶠ (x : 𝕜) in 𝓝 0, x • v ∈ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  rw [hU, filter.eventually_iff],
  simp_rw [(s.sup p).mem_ball_zero, map_smul_eq_mul],
  by_cases h : 0 < (s.sup p) v,
  { simp_rw (lt_div_iff h).symm,
    rw ←_root_.ball_zero_eq,
    exact metric.ball_mem_nhds 0 (div_pos hr h) },
  simp_rw [le_antisymm (not_lt.mp h) (map_nonneg _ v), mul_zero, hr],
  exact is_open.mem_nhds is_open_univ (mem_univ 0),
end

variables [nonempty ι]

lemma basis_sets_smul (U) (hU : U ∈ p.basis_sets) :
  ∃ (V : set 𝕜) (H : V ∈ 𝓝 (0 : 𝕜)) (W : set E)
  (H : W ∈ p.add_group_filter_basis.sets), V • W ⊆ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  refine ⟨metric.ball 0 r.sqrt, metric.ball_mem_nhds 0 (real.sqrt_pos.mpr hr), _⟩,
  refine ⟨(s.sup p).ball 0 r.sqrt, p.basis_sets_mem s (real.sqrt_pos.mpr hr), _⟩,
  refine set.subset.trans (ball_smul_ball (s.sup p) r.sqrt r.sqrt) _,
  rw [hU, real.mul_self_sqrt (le_of_lt hr)],
end

lemma basis_sets_smul_left (x : 𝕜) (U : set E)
  (hU : U ∈ p.basis_sets) : ∃ (V : set E)
  (H : V ∈ p.add_group_filter_basis.sets), V ⊆ (λ (y : E), x • y) ⁻¹' U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  rw hU,
  by_cases h : x ≠ 0,
  { rw [(s.sup p).smul_ball_preimage 0 r x h, smul_zero],
    use (s.sup p).ball 0 (r / ‖x‖),
    exact ⟨p.basis_sets_mem s (div_pos hr (norm_pos_iff.mpr h)), subset.rfl⟩ },
  refine ⟨(s.sup p).ball 0 r, p.basis_sets_mem s hr, _⟩,
  simp only [not_ne_iff.mp h, subset_def, mem_ball_zero, hr, mem_univ, map_zero,
    implies_true_iff, preimage_const_of_mem, zero_smul],
end

/-- The `module_filter_basis` induced by the filter basis `seminorm_basis_zero`. -/
protected def module_filter_basis : module_filter_basis 𝕜 E :=
{ to_add_group_filter_basis := p.add_group_filter_basis,
  smul' := p.basis_sets_smul,
  smul_left' := p.basis_sets_smul_left,
  smul_right' := p.basis_sets_smul_right }

lemma filter_eq_infi (p : seminorm_family 𝕜 E ι) :
  p.module_filter_basis.to_filter_basis.filter = ⨅ i, (𝓝 0).comap (p i) :=
begin
  refine le_antisymm (le_infi $ λ i, _) _,
  { rw p.module_filter_basis.to_filter_basis.has_basis.le_basis_iff
      (metric.nhds_basis_ball.comap _),
    intros ε hε,
    refine ⟨(p i).ball 0 ε, _, _⟩,
    { rw ← (finset.sup_singleton : _ = p i),
      exact p.basis_sets_mem {i} hε, },
    { rw [id, (p i).ball_zero_eq_preimage_ball] } },
  { rw p.module_filter_basis.to_filter_basis.has_basis.ge_iff,
    rintros U (hU : U ∈ p.basis_sets),
    rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, rfl⟩,
    rw [id, seminorm.ball_finset_sup_eq_Inter _ _ _ hr, s.Inter_mem_sets],
    exact λ i hi, filter.mem_infi_of_mem i ⟨metric.ball 0 r, metric.ball_mem_nhds 0 hr,
      eq.subset ((p i).ball_zero_eq_preimage_ball).symm⟩, },
end

end seminorm_family

end filter_basis

section bounded

namespace seminorm

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [normed_field 𝕜₂] [add_comm_group F] [module 𝕜₂ F]
variables {σ₁₂ : 𝕜 →+* 𝕜₂} [ring_hom_isometric σ₁₂]

-- Todo: This should be phrased entirely in terms of the von Neumann bornology.

/-- The proposition that a linear map is bounded between spaces with families of seminorms. -/
def is_bounded (p : ι → seminorm 𝕜 E) (q : ι' → seminorm 𝕜₂ F) (f : E →ₛₗ[σ₁₂] F) : Prop :=
  ∀ i, ∃ s : finset ι, ∃ C : ℝ≥0, (q i).comp f ≤ C • s.sup p

lemma is_bounded_const (ι' : Type*) [nonempty ι']
  {p : ι → seminorm 𝕜 E} {q : seminorm 𝕜₂ F} (f : E →ₛₗ[σ₁₂] F) :
  is_bounded p (λ _ : ι', q) f ↔ ∃ (s : finset ι) C : ℝ≥0, q.comp f ≤ C • s.sup p :=
by simp only [is_bounded, forall_const]

lemma const_is_bounded (ι : Type*) [nonempty ι]
  {p : seminorm 𝕜 E} {q : ι' → seminorm 𝕜₂ F} (f : E →ₛₗ[σ₁₂] F) :
  is_bounded (λ _ : ι, p) q f ↔ ∀ i, ∃ C : ℝ≥0, (q i).comp f ≤ C • p :=
begin
  split; intros h i,
  { rcases h i with ⟨s, C, h⟩,
    exact ⟨C, le_trans h (smul_le_smul (finset.sup_le (λ _ _, le_rfl)) le_rfl)⟩ },
  use [{classical.arbitrary ι}],
  simp only [h, finset.sup_singleton],
end

lemma is_bounded_sup {p : ι → seminorm 𝕜 E} {q : ι' → seminorm 𝕜₂ F}
  {f : E →ₛₗ[σ₁₂] F} (hf : is_bounded p q f) (s' : finset ι') :
  ∃ (C : ℝ≥0) (s : finset ι), (s'.sup q).comp f ≤ C • (s.sup p) :=
begin
  classical,
  obtain rfl | hs' := s'.eq_empty_or_nonempty,
  { exact ⟨1, ∅, by simp [seminorm.bot_eq_zero]⟩ },
  choose fₛ fC hf using hf,
  use [s'.card • s'.sup fC, finset.bUnion s' fₛ],
  have hs : ∀ i : ι', i ∈ s' → (q i).comp f ≤ s'.sup fC • ((finset.bUnion s' fₛ).sup p) :=
  begin
    intros i hi,
    refine (hf i).trans (smul_le_smul _ (finset.le_sup hi)),
    exact finset.sup_mono (finset.subset_bUnion_of_mem fₛ hi),
  end,
  refine (comp_mono f (finset_sup_le_sum q s')).trans _,
  simp_rw [←pullback_apply, add_monoid_hom.map_sum, pullback_apply],
  refine (finset.sum_le_sum hs).trans _,
  rw [finset.sum_const, smul_assoc],
  exact le_rfl,
end

end seminorm

end bounded

section topology

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι]

/-- The proposition that the topology of `E` is induced by a family of seminorms `p`. -/
structure with_seminorms (p : seminorm_family 𝕜 E ι) [t : topological_space E] : Prop :=
(topology_eq_with_seminorms : t = p.module_filter_basis.topology)

lemma with_seminorms.with_seminorms_eq {p : seminorm_family 𝕜 E ι} [t : topological_space E]
  (hp : with_seminorms p) : t = p.module_filter_basis.topology := hp.1

variables [topological_space E]
variables {p : seminorm_family 𝕜 E ι}

lemma with_seminorms.topological_add_group (hp : with_seminorms p) : topological_add_group E :=
begin
  rw hp.with_seminorms_eq,
  exact add_group_filter_basis.is_topological_add_group _
end

lemma with_seminorms.has_basis (hp : with_seminorms p) : (𝓝 (0 : E)).has_basis
  (λ (s : set E), s ∈ p.basis_sets) id :=
begin
  rw (congr_fun (congr_arg (@nhds E) hp.1) 0),
  exact add_group_filter_basis.nhds_zero_has_basis _,
end

lemma with_seminorms.has_basis_zero_ball (hp : with_seminorms p) : (𝓝 (0 : E)).has_basis
  (λ sr : finset ι × ℝ, 0 < sr.2) (λ sr, (sr.1.sup p).ball 0 sr.2) :=
begin
  refine ⟨λ V, _⟩,
  simp only [hp.has_basis.mem_iff, seminorm_family.basis_sets_iff, prod.exists],
  split,
  { rintros ⟨-, ⟨s, r, hr, rfl⟩, hV⟩,
    exact ⟨s, r, hr, hV⟩ },
  { rintros ⟨s, r, hr, hV⟩,
    exact ⟨_, ⟨s, r, hr, rfl⟩, hV⟩ }
end

lemma with_seminorms.has_basis_ball (hp : with_seminorms p) {x : E} : (𝓝 (x : E)).has_basis
  (λ sr : finset ι × ℝ, 0 < sr.2) (λ sr, (sr.1.sup p).ball x sr.2) :=
begin
  haveI : topological_add_group E := hp.topological_add_group,
  rw [← map_add_left_nhds_zero],
  convert (hp.has_basis_zero_ball.map ((+) x)),
  ext sr : 1,
  have : (sr.fst.sup p).ball (x +ᵥ 0) sr.snd = x +ᵥ (sr.fst.sup p).ball 0 sr.snd
    := eq.symm (seminorm.vadd_ball (sr.fst.sup p)),
  rwa [vadd_eq_add, add_zero] at this,
end

/-- The `x`-neighbourhoods of a space whose topology is induced by a family of seminorms
are exactly the sets which contain seminorm balls around `x`.-/
lemma with_seminorms.mem_nhds_iff (hp : with_seminorms p) (x : E) (U : set E) :
  U ∈ nhds x ↔ ∃ (s : finset ι) (r > 0), (s.sup p).ball x r ⊆ U :=
by rw [hp.has_basis_ball.mem_iff, prod.exists]

/-- The open sets of a space whose topology is induced by a family of seminorms
are exactly the sets which contain seminorm balls around all of their points.-/
lemma with_seminorms.is_open_iff_mem_balls (hp : with_seminorms p) (U : set E) :
  is_open U ↔ ∀ x ∈ U, ∃ (s : finset ι) (r > 0), (s.sup p).ball x r ⊆ U :=
by simp_rw [←with_seminorms.mem_nhds_iff hp _ U, is_open_iff_mem_nhds]

/- Note that through the following lemmas, one also immediately has that separating families
of seminorms induce T₂ and T₃ topologies by `topological_add_group.t2_space`
and `topological_add_group.t3_space` -/
/-- A separating family of seminorms induces a T₁ topology. -/
lemma with_seminorms.t1_of_separating (hp : with_seminorms p) (h : ∀ x ≠ 0, ∃ i, p i x ≠ 0) :
  t1_space E :=
begin
  haveI := hp.topological_add_group,
  refine topological_add_group.t1_space _ _,
  rw [← is_open_compl_iff, hp.is_open_iff_mem_balls],
  rintros x (hx : x ≠ 0),
  cases h x hx with i pi_nonzero,
  refine ⟨{i}, p i x, by positivity, subset_compl_singleton_iff.mpr _⟩,
  rw [finset.sup_singleton, mem_ball, zero_sub, map_neg_eq_map, not_lt]
end

/-- A family of seminorms inducing a T₁ topology is separating. -/
lemma with_seminorms.separating_of_t1 [t1_space E] (hp : with_seminorms p) (x : E) (hx : x ≠ 0) :
  ∃ i, p i x ≠ 0 :=
begin
  have := ((t1_space_tfae E).out 0 9).mp infer_instance,
  by_contra' h,
  refine hx (this _),
  rw hp.has_basis_zero_ball.specializes_iff,
  rintros ⟨s, r⟩ (hr : 0 < r),
  simp only [ball_finset_sup_eq_Inter _ _ _ hr, mem_Inter₂, mem_ball_zero, h, hr, forall_true_iff],
end

/-- A family of seminorms is separating iff it induces a T₁ topology. -/
lemma with_seminorms.separating_iff_t1 (hp : with_seminorms p) :
  (∀ x ≠ 0, ∃ i, p i x ≠ 0) ↔ t1_space E :=
begin
  refine ⟨with_seminorms.t1_of_separating hp, _⟩,
  introI,
  exact with_seminorms.separating_of_t1 hp,
end

end topology

section tendsto

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι] [topological_space E]
variables {p : seminorm_family 𝕜 E ι}

/-- Convergence along filters for `with_seminorms`.

Variant with `finset.sup`. -/
lemma with_seminorms.tendsto_nhds' (hp : with_seminorms p) (u : F → E) {f : filter F} (y₀ : E) :
  filter.tendsto u f (𝓝 y₀) ↔ ∀ (s : finset ι) ε, 0 < ε → ∀ᶠ x in f, s.sup p (u x - y₀) < ε :=
by simp [hp.has_basis_ball.tendsto_right_iff]

/-- Convergence along filters for `with_seminorms`. -/
lemma with_seminorms.tendsto_nhds (hp : with_seminorms p) (u : F → E) {f : filter F} (y₀ : E) :
  filter.tendsto u f (𝓝 y₀) ↔ ∀ i ε, 0 < ε → ∀ᶠ x in f, p i (u x - y₀) < ε :=
begin
  rw hp.tendsto_nhds' u y₀,
  exact ⟨λ h i, by simpa only [finset.sup_singleton] using h {i},
    λ h s ε hε, (s.eventually_all.2 $ λ i _, h i ε hε).mono (λ _, finset_sup_apply_lt hε)⟩,
end

variables [semilattice_sup F] [nonempty F]

/-- Limit `→ ∞` for `with_seminorms`. -/
lemma with_seminorms.tendsto_nhds_at_top (hp : with_seminorms p) (u : F → E) (y₀ : E) :
  filter.tendsto u filter.at_top (𝓝 y₀) ↔ ∀ i ε, 0 < ε → ∃ x₀, ∀ x, x₀ ≤ x → p i (u x - y₀) < ε :=
begin
  rw hp.tendsto_nhds u y₀,
  exact forall₃_congr (λ _ _ _, filter.eventually_at_top),
end

end tendsto

section topological_add_group

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [t : topological_space E] [topological_add_group E]
variables [nonempty ι]

include t

lemma seminorm_family.with_seminorms_of_nhds (p : seminorm_family 𝕜 E ι)
  (h : 𝓝 (0 : E) = p.module_filter_basis.to_filter_basis.filter) :
  with_seminorms p :=
begin
  refine ⟨topological_add_group.ext infer_instance
    (p.add_group_filter_basis.is_topological_add_group) _⟩,
  rw add_group_filter_basis.nhds_zero_eq,
  exact h,
end

lemma seminorm_family.with_seminorms_of_has_basis (p : seminorm_family 𝕜 E ι)
  (h : (𝓝 (0 : E)).has_basis (λ (s : set E), s ∈ p.basis_sets) id) :
  with_seminorms p :=
p.with_seminorms_of_nhds $ filter.has_basis.eq_of_same_basis h
  p.add_group_filter_basis.to_filter_basis.has_basis

lemma seminorm_family.with_seminorms_iff_nhds_eq_infi (p : seminorm_family 𝕜 E ι) :
  with_seminorms p ↔ (𝓝 0 : filter E) = ⨅ i, (𝓝 0).comap (p i) :=
begin
  rw ← p.filter_eq_infi,
  refine ⟨λ h, _, p.with_seminorms_of_nhds⟩,
  rw h.topology_eq_with_seminorms,
  exact add_group_filter_basis.nhds_zero_eq _,
end

lemma with_seminorms.continuous_seminorm [nontrivially_normed_field 𝕝]
  [module 𝕝 E] [has_continuous_const_smul 𝕝 E] {p : seminorm_family 𝕝 E ι} (hp : with_seminorms p)
  (i : ι) : continuous (p i) :=
begin
  refine seminorm.continuous one_pos _,
  rw [p.with_seminorms_iff_nhds_eq_infi.mp hp, ball_zero_eq_preimage_ball],
  exact filter.mem_infi_of_mem i (filter.preimage_mem_comap $ metric.ball_mem_nhds _ one_pos)
end

/-- The topology induced by a family of seminorms is exactly the infimum of the ones induced by
each seminorm individually. We express this as a characterization of `with_seminorms p`. -/
lemma seminorm_family.with_seminorms_iff_topological_space_eq_infi (p : seminorm_family 𝕜 E ι) :
  with_seminorms p ↔ t = ⨅ i, (p i).to_add_group_seminorm.to_seminormed_add_comm_group
    .to_uniform_space.to_topological_space :=
begin
  rw [p.with_seminorms_iff_nhds_eq_infi, topological_add_group.ext_iff infer_instance
        (topological_add_group_infi $ λ i, infer_instance), nhds_infi],
  congrm (_ = ⨅ i, _),
  exact @comap_norm_nhds_zero _ (p i).to_add_group_seminorm.to_seminormed_add_group,
  all_goals {apply_instance}
end

omit t

/-- The uniform structure induced by a family of seminorms is exactly the infimum of the ones
induced by each seminorm individually. We express this as a characterization of
`with_seminorms p`. -/
lemma seminorm_family.with_seminorms_iff_uniform_space_eq_infi [u : uniform_space E]
  [uniform_add_group E] (p : seminorm_family 𝕜 E ι) :
  with_seminorms p ↔ u = ⨅ i, (p i).to_add_group_seminorm.to_seminormed_add_comm_group
    .to_uniform_space :=
begin
  rw [p.with_seminorms_iff_nhds_eq_infi, uniform_add_group.ext_iff infer_instance
        (uniform_add_group_infi $ λ i, infer_instance), to_topological_space_infi, nhds_infi],
  congrm (_ = ⨅ i, _),
  exact @comap_norm_nhds_zero _ (p i).to_add_group_seminorm.to_seminormed_add_group,
  all_goals {apply_instance}
end

end topological_add_group

section normed_space

/-- The topology of a `normed_space 𝕜 E` is induced by the seminorm `norm_seminorm 𝕜 E`. -/
lemma norm_with_seminorms (𝕜 E) [normed_field 𝕜] [seminormed_add_comm_group E] [normed_space 𝕜 E] :
  with_seminorms (λ (_ : fin 1), norm_seminorm 𝕜 E) :=
begin
  let p : seminorm_family 𝕜 E (fin 1) := λ _, norm_seminorm 𝕜 E,
  refine ⟨seminormed_add_comm_group.to_topological_add_group.ext
    p.add_group_filter_basis.is_topological_add_group _⟩,
  refine filter.has_basis.eq_of_same_basis metric.nhds_basis_ball _,
  rw ←ball_norm_seminorm 𝕜 E,
  refine filter.has_basis.to_has_basis p.add_group_filter_basis.nhds_zero_has_basis _
    (λ r hr, ⟨(norm_seminorm 𝕜 E).ball 0 r, p.basis_sets_singleton_mem 0 hr, rfl.subset⟩),
  rintros U (hU : U ∈ p.basis_sets),
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  use [r, hr],
  rw [hU, id.def],
  by_cases h : s.nonempty,
  { rw finset.sup_const h },
  rw [finset.not_nonempty_iff_eq_empty.mp h, finset.sup_empty, ball_bot _ hr],
  exact set.subset_univ _,
end

end normed_space

section nontrivially_normed_field

variables [nontrivially_normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι]
variables {p : seminorm_family 𝕜 E ι}
variables [topological_space E]

lemma with_seminorms.is_vonN_bounded_iff_finset_seminorm_bounded {s : set E}
  (hp : with_seminorms p) :
  bornology.is_vonN_bounded 𝕜 s ↔ ∀ I : finset ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), I.sup p x < r :=
begin
  rw (hp.has_basis).is_vonN_bounded_basis_iff,
  split,
  { intros h I,
    simp only [id.def] at h,
    specialize h ((I.sup p).ball 0 1) (p.basis_sets_mem I zero_lt_one),
    rcases h with ⟨r, hr, h⟩,
    cases normed_field.exists_lt_norm 𝕜 r with a ha,
    specialize h a (le_of_lt ha),
    rw [seminorm.smul_ball_zero (norm_pos_iff.1 $ hr.trans ha), mul_one] at h,
    refine ⟨‖a‖, lt_trans hr ha, _⟩,
    intros x hx,
    specialize h hx,
    exact (finset.sup I p).mem_ball_zero.mp h },
  intros h s' hs',
  rcases p.basis_sets_iff.mp hs' with ⟨I, r, hr, hs'⟩,
  rw [id.def, hs'],
  rcases h I with ⟨r', hr', h'⟩,
  simp_rw ←(I.sup p).mem_ball_zero at h',
  refine absorbs.mono_right _ h',
  exact (finset.sup I p).ball_zero_absorbs_ball_zero hr,
end

lemma with_seminorms.image_is_vonN_bounded_iff_finset_seminorm_bounded (f : G → E) {s : set G}
  (hp : with_seminorms p) : bornology.is_vonN_bounded 𝕜 (f '' s) ↔
  ∀ I : finset ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), I.sup p (f x) < r :=
by simp_rw [hp.is_vonN_bounded_iff_finset_seminorm_bounded, set.ball_image_iff]

lemma with_seminorms.is_vonN_bounded_iff_seminorm_bounded {s : set E} (hp : with_seminorms p) :
  bornology.is_vonN_bounded 𝕜 s ↔ ∀ i : ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), p i x < r :=
begin
  rw hp.is_vonN_bounded_iff_finset_seminorm_bounded,
  split,
  { intros hI i,
    convert hI {i},
    rw [finset.sup_singleton] },
  intros hi I,
  by_cases hI : I.nonempty,
  { choose r hr h using hi,
    have h' : 0 < I.sup' hI r :=
    by { rcases hI.bex with ⟨i, hi⟩, exact lt_of_lt_of_le (hr i) (finset.le_sup' r hi) },
    refine ⟨I.sup' hI r, h', λ x hx, finset_sup_apply_lt h' (λ i hi, _)⟩,
    refine lt_of_lt_of_le (h i x hx) _,
    simp only [finset.le_sup'_iff, exists_prop],
    exact ⟨i, hi, (eq.refl _).le⟩ },
  simp only [finset.not_nonempty_iff_eq_empty.mp hI, finset.sup_empty, coe_bot, pi.zero_apply,
    exists_prop],
  exact ⟨1, zero_lt_one, λ _ _, zero_lt_one⟩,
end

lemma with_seminorms.image_is_vonN_bounded_iff_seminorm_bounded (f : G → E) {s : set G}
  (hp : with_seminorms p) :
  bornology.is_vonN_bounded 𝕜 (f '' s) ↔ ∀ i : ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), p i (f x) < r :=
by simp_rw [hp.is_vonN_bounded_iff_seminorm_bounded, set.ball_image_iff]

end nontrivially_normed_field
section continuous_bounded

namespace seminorm

variables [nontrivially_normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [normed_field 𝕝] [module 𝕝 E]
variables [nontrivially_normed_field 𝕜₂] [add_comm_group F] [module 𝕜₂ F]
variables [normed_field 𝕝₂] [module 𝕝₂ F]
variables {σ₁₂ : 𝕜 →+* 𝕜₂} [ring_hom_isometric σ₁₂]
variables {τ₁₂ : 𝕝 →+* 𝕝₂} [ring_hom_isometric τ₁₂]
variables [nonempty ι] [nonempty ι']

lemma continuous_of_continuous_comp {q : seminorm_family 𝕝₂ F ι'}
  [topological_space E] [topological_add_group E]
  [topological_space F] [topological_add_group F] (hq : with_seminorms q)
  (f : E →ₛₗ[τ₁₂] F) (hf : ∀ i, continuous ((q i).comp f)) : continuous f :=
begin
  refine continuous_of_continuous_at_zero f _,
  simp_rw [continuous_at, f.map_zero, q.with_seminorms_iff_nhds_eq_infi.mp hq, filter.tendsto_infi,
            filter.tendsto_comap_iff],
  intros i,
  convert (hf i).continuous_at,
  exact (map_zero _).symm
end

lemma continuous_iff_continuous_comp
  {q : seminorm_family 𝕜₂ F ι'} [topological_space E] [topological_add_group E]
  [topological_space F] [topological_add_group F] [has_continuous_const_smul 𝕜₂ F]
  (hq : with_seminorms q) (f : E →ₛₗ[σ₁₂] F) :
  continuous f ↔ ∀ i, continuous ((q i).comp f) :=
⟨λ h i, continuous.comp (hq.continuous_seminorm i) h, continuous_of_continuous_comp hq f⟩

lemma continuous_from_bounded {p : seminorm_family 𝕝 E ι} {q : seminorm_family 𝕝₂ F ι'}
  [topological_space E] [topological_add_group E] (hp : with_seminorms p)
  [topological_space F] [topological_add_group F] (hq : with_seminorms q)
  (f : E →ₛₗ[τ₁₂] F) (hf : seminorm.is_bounded p q f) : continuous f :=
begin
  refine continuous_of_continuous_comp hq _ (λ i, seminorm.continuous_of_continuous_at_zero _),
  rw [metric.continuous_at_iff', map_zero],
  intros r hr,
  rcases hf i with ⟨s₁, C, hf⟩,
  have hC' : 0 < C + 1 := by positivity,
  rw hp.has_basis.eventually_iff,
  refine ⟨(s₁.sup p).ball 0 (r/(C + 1)), p.basis_sets_mem _ (by positivity), _⟩,
  simp_rw [ ←metric.mem_ball, ←mem_preimage, ←ball_zero_eq_preimage_ball],
  refine subset.trans _ (ball_antitone hf),
  norm_cast,
  rw ← ball_smul (s₁.sup p) hC',
  refine ball_antitone (smul_le_smul le_rfl _),
  simp only [le_add_iff_nonneg_right, zero_le'],
end

lemma cont_with_seminorms_normed_space (F) [seminormed_add_comm_group F] [normed_space 𝕝₂ F]
  [uniform_space E] [uniform_add_group E]
  {p : ι → seminorm 𝕝 E} (hp : with_seminorms p) (f : E →ₛₗ[τ₁₂] F)
  (hf : ∃ (s : finset ι) C : ℝ≥0, (norm_seminorm 𝕝₂ F).comp f ≤ C • s.sup p) :
  continuous f :=
begin
  rw ←seminorm.is_bounded_const (fin 1) at hf,
  exact continuous_from_bounded hp (norm_with_seminorms 𝕝₂ F) f hf,
end

lemma cont_normed_space_to_with_seminorms (E) [seminormed_add_comm_group E] [normed_space 𝕝 E]
  [uniform_space F] [uniform_add_group F]
  {q : ι → seminorm 𝕝₂ F} (hq : with_seminorms q) (f : E →ₛₗ[τ₁₂] F)
  (hf : ∀ i : ι, ∃ C : ℝ≥0, (q i).comp f ≤ C • (norm_seminorm 𝕝 E)) : continuous f :=
begin
  rw ←seminorm.const_is_bounded (fin 1) at hf,
  exact continuous_from_bounded (norm_with_seminorms 𝕝 E) hq f hf,
end

end seminorm

end continuous_bounded

section locally_convex_space

open locally_convex_space

variables [nonempty ι] [normed_field 𝕜] [normed_space ℝ 𝕜]
  [add_comm_group E] [module 𝕜 E] [module ℝ E] [is_scalar_tower ℝ 𝕜 E] [topological_space E]
  [topological_add_group E]

lemma with_seminorms.to_locally_convex_space {p : seminorm_family 𝕜 E ι} (hp : with_seminorms p) :
  locally_convex_space ℝ E :=
begin
  apply of_basis_zero ℝ E id (λ s, s ∈ p.basis_sets),
  { rw [hp.1, add_group_filter_basis.nhds_eq _, add_group_filter_basis.N_zero],
    exact filter_basis.has_basis _ },
  { intros s hs,
    change s ∈ set.Union _ at hs,
    simp_rw [set.mem_Union, set.mem_singleton_iff] at hs,
    rcases hs with ⟨I, r, hr, rfl⟩,
    exact convex_ball _ _ _ }
end

end locally_convex_space

section normed_space

variables (𝕜) [normed_field 𝕜] [normed_space ℝ 𝕜] [seminormed_add_comm_group E]

/-- Not an instance since `𝕜` can't be inferred. See `normed_space.to_locally_convex_space` for a
slightly weaker instance version. -/
lemma normed_space.to_locally_convex_space' [normed_space 𝕜 E] [module ℝ E]
  [is_scalar_tower ℝ 𝕜 E] : locally_convex_space ℝ E :=
(norm_with_seminorms 𝕜 E).to_locally_convex_space

/-- See `normed_space.to_locally_convex_space'` for a slightly stronger version which is not an
instance. -/
instance normed_space.to_locally_convex_space [normed_space ℝ E] :
  locally_convex_space ℝ E :=
normed_space.to_locally_convex_space' ℝ

end normed_space

section topological_constructions

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [normed_field 𝕜₂] [add_comm_group F] [module 𝕜₂ F]
variables {σ₁₂ : 𝕜 →+* 𝕜₂} [ring_hom_isometric σ₁₂]

/-- The family of seminorms obtained by composing each seminorm by a linear map. -/
def seminorm_family.comp (q : seminorm_family 𝕜₂ F ι) (f : E →ₛₗ[σ₁₂] F) :
  seminorm_family 𝕜 E ι :=
λ i, (q i).comp f

lemma seminorm_family.comp_apply (q : seminorm_family 𝕜₂ F ι) (i : ι) (f : E →ₛₗ[σ₁₂] F) :
  q.comp f i = (q i).comp f :=
rfl

lemma seminorm_family.finset_sup_comp (q : seminorm_family 𝕜₂ F ι) (s : finset ι)
  (f : E →ₛₗ[σ₁₂] F) : (s.sup q).comp f = s.sup (q.comp f) :=
begin
  ext x,
  rw [seminorm.comp_apply, seminorm.finset_sup_apply, seminorm.finset_sup_apply],
  refl
end

variables [topological_space F] [topological_add_group F]

lemma linear_map.with_seminorms_induced [hι : nonempty ι] {q : seminorm_family 𝕜₂ F ι}
  (hq : with_seminorms q) (f : E →ₛₗ[σ₁₂] F) :
  @with_seminorms 𝕜 E ι _ _ _ _ (q.comp f) (induced f infer_instance) :=
begin
  letI : topological_space E := induced f infer_instance,
  letI : topological_add_group E := topological_add_group_induced f,
  rw [(q.comp f).with_seminorms_iff_nhds_eq_infi, nhds_induced, map_zero,
      q.with_seminorms_iff_nhds_eq_infi.mp hq, filter.comap_infi],
  refine infi_congr (λ i, _),
  exact filter.comap_comap
end

lemma inducing.with_seminorms [hι : nonempty ι] {q : seminorm_family 𝕜₂ F ι}
  (hq : with_seminorms q) [topological_space E] {f : E →ₛₗ[σ₁₂] F} (hf : inducing f) :
  with_seminorms (q.comp f) :=
begin
  rw hf.induced,
  exact f.with_seminorms_induced hq
end

end topological_constructions

section topological_properties

variables [nontrivially_normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι] [countable ι]
variables {p : seminorm_family 𝕜 E ι}
variables [uniform_space E] [uniform_add_group E]

/-- If the topology of a space is induced by a countable family of seminorms, then the topology
is first countable. -/
lemma with_seminorms.first_countable (hp : with_seminorms p) :
  topological_space.first_countable_topology E :=
begin
  haveI : (𝓝 (0 : E)).is_countably_generated,
  { rw p.with_seminorms_iff_nhds_eq_infi.mp hp,
    exact filter.infi.is_countably_generated _ },
  haveI : (uniformity E).is_countably_generated := uniform_add_group.uniformity_countably_generated,
  exact uniform_space.first_countable_topology E,
end

end topological_properties


/-
Copyright (c) 2022 Siddhartha Prasad, Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Siddhartha Prasad, Yaël Dillies
-/
import algebra.order.ring.canonical
import algebra.ring.pi
import algebra.ring.prod
import order.hom.complete_lattice

/-!
# Kleene Algebras

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

This file defines idempotent semirings and Kleene algebras, which are used extensively in the theory
of computation.

An idempotent semiring is a semiring whose addition is idempotent. An idempotent semiring is
naturally a semilattice by setting `a ≤ b` if `a + b = b`.

A Kleene algebra is an idempotent semiring equipped with an additional unary operator `∗`, the
Kleene star.

## Main declarations

* `idem_semiring`: Idempotent semiring
* `idem_comm_semiring`: Idempotent commutative semiring
* `kleene_algebra`: Kleene algebra

## Notation

`a∗` is notation for `kstar a` in locale `computability`.

## References

* [D. Kozen, *A completeness theorem for Kleene algebras and the algebra of regular events*]
  [kozen1994]
* https://planetmath.org/idempotentsemiring
* https://encyclopediaofmath.org/wiki/Idempotent_semi-ring
* https://planetmath.org/kleene_algebra

## TODO

Instances for `add_opposite`, `mul_opposite`, `ulift`, `subsemiring`, `subring`, `subalgebra`.

## Tags

kleene algebra, idempotent semiring
-/

set_option old_structure_cmd true

open function

universe u
variables {α β ι : Type*} {π : ι → Type*}

/-- An idempotent semiring is a semiring with the additional property that addition is idempotent.
-/
@[protect_proj]
class idem_semiring (α : Type u) extends semiring α, semilattice_sup α :=
(sup := (+))
(add_eq_sup : ∀ a b : α, a + b = a ⊔ b . try_refl_tac)
(bot : α := 0)
(bot_le : ∀ a, bot ≤ a)

/-- An idempotent commutative semiring is a commutative semiring with the additional property that
addition is idempotent. -/
@[protect_proj]
class idem_comm_semiring (α : Type u) extends comm_semiring α, idem_semiring α

/-- Notation typeclass for the Kleene star `∗`. -/
@[protect_proj]
class has_kstar (α : Type*) :=
(kstar : α → α)

localized "postfix `∗`:1025 := has_kstar.kstar" in computability

/-- A Kleene Algebra is an idempotent semiring with an additional unary operator `kstar` (for Kleene
star) that satisfies the following properties:
* `1 + a * a∗ ≤ a∗`
* `1 + a∗ * a ≤ a∗`
* If `a * c + b ≤ c`, then `a∗ * b ≤ c`
* If `c * a + b ≤ c`, then `b * a∗ ≤ c`
-/
@[protect_proj]
class kleene_algebra (α : Type*) extends idem_semiring α, has_kstar α :=
(one_le_kstar : ∀ a : α, 1 ≤ a∗)
(mul_kstar_le_kstar : ∀ a : α, a * a∗ ≤ a∗)
(kstar_mul_le_kstar : ∀ a : α, a∗ * a ≤ a∗)
(mul_kstar_le_self : ∀ a b : α, b * a ≤ b → b * a∗ ≤ b)
(kstar_mul_le_self : ∀ a b : α, a * b ≤ b → a∗ * b ≤ b)

@[priority 100] -- See note [lower instance priority]
instance idem_semiring.to_order_bot [idem_semiring α] : order_bot α := { ..‹idem_semiring α› }

/-- Construct an idempotent semiring from an idempotent addition. -/
@[reducible] -- See note [reducible non-instances]
def idem_semiring.of_semiring [semiring α] (h : ∀ a : α, a + a = a) : idem_semiring α :=
{ le := λ a b, a + b = b,
  le_refl := h,
  le_trans := λ a b c (hab : _ = _) (hbc : _ = _), by { change _ = _, rw [←hbc, ←add_assoc, hab] },
  le_antisymm := λ a b (hab : _ = _) (hba : _ = _), by rwa [←hba, add_comm],
  sup := (+),
  le_sup_left := λ a b, by { change _ = _, rw [←add_assoc, h] },
  le_sup_right := λ a b, by { change _ = _, rw [add_comm, add_assoc, h] },
  sup_le := λ a b c hab (hbc : _ = _), by { change _ = _, rwa [add_assoc, hbc] },
  bot := 0,
  bot_le := zero_add,
  ..‹semiring α› }

section idem_semiring
variables [idem_semiring α] {a b c : α}

@[simp] lemma add_eq_sup (a b : α) : a + b = a ⊔ b := idem_semiring.add_eq_sup _ _
lemma add_idem (a : α) : a + a = a := by simp

lemma nsmul_eq_self : ∀ {n : ℕ} (hn : n ≠ 0) (a : α), n • a = a
| 0 h := (h rfl).elim
| 1 h := one_nsmul
| (n + 2) h := λ a, by rw [succ_nsmul, nsmul_eq_self n.succ_ne_zero, add_idem]

lemma add_eq_left_iff_le : a + b = a ↔ b ≤ a := by simp
lemma add_eq_right_iff_le : a + b = b ↔ a ≤ b := by simp

alias add_eq_left_iff_le ↔ _ has_le.le.add_eq_left
alias add_eq_right_iff_le ↔ _ has_le.le.add_eq_right

lemma add_le_iff : a + b ≤ c ↔ a ≤ c ∧ b ≤ c := by simp
lemma add_le (ha : a ≤ c) (hb : b ≤ c) : a + b ≤ c := add_le_iff.2 ⟨ha, hb⟩

@[priority 100] -- See note [lower instance priority]
instance idem_semiring.to_canonically_ordered_add_monoid : canonically_ordered_add_monoid α :=
{ add_le_add_left := λ a b hbc c, by { simp_rw add_eq_sup, exact sup_le_sup_left hbc _ },
  exists_add_of_le := λ a b h, ⟨b, h.add_eq_right.symm⟩,
  le_self_add := λ a b, add_eq_right_iff_le.1 $ by rw [←add_assoc, add_idem],
  ..‹idem_semiring α› }

@[priority 100] -- See note [lower instance priority]
instance idem_semiring.to_covariant_class_mul_le : covariant_class α α (*) (≤) :=
⟨λ a b c hbc, add_eq_left_iff_le.1 $ by rw [←mul_add, hbc.add_eq_left]⟩

@[priority 100] -- See note [lower instance priority]
instance idem_semiring.to_covariant_class_swap_mul_le : covariant_class α α (swap (*)) (≤) :=
⟨λ a b c hbc, add_eq_left_iff_le.1 $ by rw [←add_mul, hbc.add_eq_left]⟩

end idem_semiring

section kleene_algebra
variables [kleene_algebra α] {a b c : α}

@[simp] lemma one_le_kstar : 1 ≤ a∗ := kleene_algebra.one_le_kstar _
lemma mul_kstar_le_kstar : a * a∗ ≤ a∗ := kleene_algebra.mul_kstar_le_kstar _
lemma kstar_mul_le_kstar : a∗ * a ≤ a∗ := kleene_algebra.kstar_mul_le_kstar _
lemma mul_kstar_le_self : b * a ≤ b → b * a∗ ≤ b := kleene_algebra.mul_kstar_le_self _ _
lemma kstar_mul_le_self : a * b ≤ b → a∗ * b ≤ b := kleene_algebra.kstar_mul_le_self _ _

lemma mul_kstar_le (hb : b ≤ c) (ha : c * a ≤ c) : b * a∗ ≤ c :=
(mul_le_mul_right' hb _).trans $ mul_kstar_le_self ha

lemma kstar_mul_le (hb : b ≤ c) (ha : a * c ≤ c) : a∗ * b ≤ c :=
(mul_le_mul_left' hb _).trans $ kstar_mul_le_self ha

lemma kstar_le_of_mul_le_left (hb : 1 ≤ b) : b * a ≤ b → a∗ ≤ b := by simpa using mul_kstar_le hb
lemma kstar_le_of_mul_le_right (hb : 1 ≤ b) : a * b ≤ b → a∗ ≤ b := by simpa using kstar_mul_le hb

@[simp] lemma le_kstar : a ≤ a∗ := le_trans (le_mul_of_one_le_left' one_le_kstar) kstar_mul_le_kstar

@[mono] lemma kstar_mono : monotone (has_kstar.kstar : α → α) :=
λ a b h, kstar_le_of_mul_le_left one_le_kstar $ kstar_mul_le (h.trans le_kstar) $
  mul_kstar_le_kstar

@[simp] lemma kstar_eq_one : a∗ = 1 ↔ a ≤ 1 :=
⟨le_kstar.trans_eq, λ h, one_le_kstar.antisymm' $ kstar_le_of_mul_le_left le_rfl $ by rwa one_mul⟩

@[simp] lemma kstar_zero : (0 : α)∗ = 1 := kstar_eq_one.2 zero_le_one
@[simp] lemma kstar_one : (1 : α)∗ = 1 := kstar_eq_one.2 le_rfl

@[simp] lemma kstar_mul_kstar (a : α) : a∗ * a∗ = a∗ :=
(mul_kstar_le le_rfl $ kstar_mul_le_kstar).antisymm $ le_mul_of_one_le_left' one_le_kstar

@[simp] lemma kstar_eq_self : a∗ = a ↔ a * a = a ∧ 1 ≤ a :=
⟨λ h, ⟨by rw [←h, kstar_mul_kstar], one_le_kstar.trans_eq h⟩, λ h,
  (kstar_le_of_mul_le_left h.2 h.1.le).antisymm le_kstar⟩

@[simp] lemma kstar_idem (a : α) : a∗∗ = a∗ := kstar_eq_self.2 ⟨kstar_mul_kstar _, one_le_kstar⟩

@[simp] lemma pow_le_kstar : ∀ {n : ℕ}, a ^ n ≤ a∗
| 0 := (pow_zero _).trans_le one_le_kstar
| (n + 1) := by {rw pow_succ, exact (mul_le_mul_left' pow_le_kstar _).trans mul_kstar_le_kstar }

end kleene_algebra

namespace prod

instance [idem_semiring α] [idem_semiring β] : idem_semiring (α × β) :=
{ add_eq_sup := λ a b, ext (add_eq_sup _ _) (add_eq_sup _ _),
  ..prod.semiring, ..prod.semilattice_sup _ _, ..prod.order_bot _ _ }

instance [idem_comm_semiring α] [idem_comm_semiring β] : idem_comm_semiring (α × β) :=
{ ..prod.comm_semiring, ..prod.idem_semiring }

variables [kleene_algebra α] [kleene_algebra β]

instance : kleene_algebra (α × β) :=
{ kstar := λ a, (a.1∗, a.2∗),
  one_le_kstar := λ a, ⟨one_le_kstar, one_le_kstar⟩,
  mul_kstar_le_kstar := λ a, ⟨mul_kstar_le_kstar, mul_kstar_le_kstar⟩,
  kstar_mul_le_kstar := λ a, ⟨kstar_mul_le_kstar, kstar_mul_le_kstar⟩,
  mul_kstar_le_self := λ a b, and.imp mul_kstar_le_self mul_kstar_le_self,
  kstar_mul_le_self := λ a b, and.imp kstar_mul_le_self kstar_mul_le_self,
  ..prod.idem_semiring }

lemma kstar_def (a : α × β) : a∗ = (a.1∗, a.2∗) := rfl
@[simp] lemma fst_kstar (a : α × β) : a∗.1 = a.1∗ := rfl
@[simp] lemma snd_kstar (a : α × β) : a∗.2 = a.2∗ := rfl

end prod

namespace pi

instance [Π i, idem_semiring (π i)] : idem_semiring (Π i, π i) :=
{ add_eq_sup := λ a b, funext $ λ i, add_eq_sup _ _,
  ..pi.semiring, ..pi.semilattice_sup, ..pi.order_bot }

instance [Π i, idem_comm_semiring (π i)] : idem_comm_semiring (Π i, π i) :=
{ ..pi.comm_semiring, ..pi.idem_semiring }

variables [Π i, kleene_algebra (π i)]

instance : kleene_algebra (Π i, π i) :=
{ kstar := λ a i, (a i)∗,
  one_le_kstar := λ a i, one_le_kstar,
  mul_kstar_le_kstar := λ a i, mul_kstar_le_kstar,
  kstar_mul_le_kstar := λ a i, kstar_mul_le_kstar,
  mul_kstar_le_self := λ a b h i, mul_kstar_le_self $ h _,
  kstar_mul_le_self := λ a b h i, kstar_mul_le_self $ h _,
  ..pi.idem_semiring }

lemma kstar_def (a : Π i, π i) : a∗ = λ i, (a i)∗ := rfl
@[simp] lemma kstar_apply (a : Π i, π i) (i : ι) : a∗ i = (a i)∗ := rfl

end pi

namespace function.injective

/-- Pullback an `idem_semiring` instance along an injective function. -/
@[reducible] -- See note [reducible non-instances]
protected def idem_semiring [idem_semiring α] [has_zero β] [has_one β] [has_add β] [has_mul β]
  [has_pow β ℕ] [has_smul ℕ β] [has_nat_cast β] [has_sup β] [has_bot β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥) :
  idem_semiring β :=
{ add_eq_sup := λ a b, hf $ by erw [sup, add, add_eq_sup],
  bot := ⊥,
  bot_le := λ a, bot.trans_le $ @bot_le _ _ _ $ f a,
  ..hf.semiring f zero one add mul nsmul npow nat_cast, ..hf.semilattice_sup _ sup, ..‹has_bot β› }

/-- Pullback an `idem_comm_semiring` instance along an injective function. -/
@[reducible] -- See note [reducible non-instances]
protected def idem_comm_semiring [idem_comm_semiring α] [has_zero β] [has_one β] [has_add β]
  [has_mul β] [has_pow β ℕ] [has_smul ℕ β] [has_nat_cast β] [has_sup β] [has_bot β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥) :
  idem_comm_semiring β :=
{ ..hf.comm_semiring f zero one add mul nsmul npow nat_cast,
  ..hf.idem_semiring f zero one add mul nsmul npow nat_cast sup bot }

/-- Pullback an `idem_comm_semiring` instance along an injective function. -/
@[reducible] -- See note [reducible non-instances]
protected def kleene_algebra [kleene_algebra α] [has_zero β] [has_one β] [has_add β]
  [has_mul β] [has_pow β ℕ] [has_smul ℕ β] [has_nat_cast β] [has_sup β] [has_bot β] [has_kstar β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n)
  (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥)
  (kstar : ∀ a, f a∗ = (f a)∗) :
  kleene_algebra β :=
{ one_le_kstar := λ a, one.trans_le $ by { erw kstar, exact one_le_kstar },
  mul_kstar_le_kstar := λ a, by { change f _ ≤ _, erw [mul, kstar], exact mul_kstar_le_kstar },
  kstar_mul_le_kstar := λ a, by { change f _ ≤ _, erw [mul, kstar], exact kstar_mul_le_kstar },
  mul_kstar_le_self := λ a b (h : f _ ≤ _),
    by { change f _ ≤ _, erw [mul, kstar], erw mul at h, exact mul_kstar_le_self h },
  kstar_mul_le_self := λ a b (h : f _ ≤ _),
    by { change f _ ≤ _, erw [mul, kstar], erw mul at h, exact kstar_mul_le_self h },
  ..hf.idem_semiring f zero one add mul nsmul npow nat_cast sup bot, ..‹has_kstar β› }

end function.injective


import data.stream
import util.logic
import util.data.nat
import util.data.stream

open nat function
open stream

def rounds : ℕ → ℕ → stream ℕ := curry $ coinduct rounds.f

lemma rounds_zero (m  : ℕ) :
rounds m 0 = 0 :: rounds (succ m) (succ m) :=
begin
  unfold rounds curry coinduct,
  apply stream.corec_eq
end

lemma rounds_succ (m n : ℕ) :
rounds m (succ n) = succ n :: rounds m n :=
by apply stream.corec_eq

section wf

open well_founded

end wf

def inf_interleave : stream ℕ :=
rounds 0 0

def is_suffix {α} (p q : stream α) : Prop := ∃ i, p = stream.drop i q

infix ` ⊑ `:70 := is_suffix

instance {α} : has_le (stream α) := { le := is_suffix }

section partial_order

variable {α : Type}
variables s s₀ s₁ s₂ : stream α

lemma stream.le_refl : s ⊑ s :=
begin
  unfold is_suffix,
  existsi 0,
  refl
end

lemma stream.le_trans : s₀ ⊑ s₁ → s₁ ⊑ s₂ → s₀ ⊑ s₂ :=
begin
  intros h₀ h₁,
  cases h₀ with i h₀,
  cases h₁ with j h₁,
  unfold is_suffix,
  existsi i+j,
  rw [← stream.drop_drop,← h₁,h₀],
end

end partial_order

theorem head_rounds : ∀ i j, stream.head (rounds i j) = j :=
begin
  intros i j,
  cases j with j
  ; simp [rounds_zero,rounds_succ,stream.head_cons]
end

theorem suffix_cons {α} (s : stream α) (x : α) : s ⊑ (x :: s) :=
begin
  unfold is_suffix,
  existsi 1, refl
end

lemma le_zero_of_eq_zero {n : ℕ} (h : n ≤ 0) : n = 0 :=
le_antisymm h (nat.zero_le _)

theorem suffix_self_of_le (i j k : ℕ) :
  j ≤ k →
  rounds i j ⊑ rounds i k :=
begin
  intro h,
  induction k with k,
  { have h' := le_zero_of_eq_zero h, subst j,
    apply stream.le_refl },
  cases decidable.em (j ≤ k) with h' h',
  { rw rounds_succ,
    apply stream.le_trans,
    { apply k_ih h' },
    { apply suffix_cons } },
  { have h' : j = succ k,
    { apply le_antisymm h,
      apply lt_of_not_le h' },
    rw h', apply stream.le_refl }
end

theorem rounds_succ_succ : ∀ i k, rounds (succ i) (succ i) ⊑ rounds i k :=
begin
  intros i k,
  unfold is_suffix,
  existsi (succ k),
  induction k with k,
  { simp [rounds_zero,stream.drop_succ,stream.tail_cons],refl },
  { rw k_ih, simp [rounds_succ,stream.drop_succ,stream.tail_cons] }
end

theorem is_prefix_add : ∀ (i j : ℕ), rounds (j+i) (j+i) ⊑ rounds j j
  | 0 j  := stream.le_refl _
  | (succ i) j :=
begin
  apply stream.le_trans,
  rw [add_succ],
  apply rounds_succ_succ (j+i) (j+i),
  apply is_prefix_add ,
end

theorem is_prefix_of_le (i j : ℕ) (h : j ≤ i) : rounds i i ⊑ rounds j j :=
begin
  have h' : i = j + (i - j),
  { rw [← nat.add_sub_assoc h, nat.add_sub_cancel_left] },
  rw h',
  apply is_prefix_add
end

section exist

universe variable u
variable {α : Type u}

variables P Q : α → Prop
variables Hq : ∀ x, P x → Q x

end exist

variable {α : Type}
variable i : ℕ
variable s : stream α

theorem rounds_suffix_rounds
  {s : stream ℕ}
  {i j : ℕ}
  (h₀ : j ≤ i)
  (h₁ : s ⊑ rounds i j)
: ∃ i' j', j' ≤ i' ∧ s = rounds i' j' :=
begin
  unfold is_suffix at h₁,
  cases h₁ with k h₁,
  subst s,
  revert i j,
  induction k with k ; intros i j Hij,
  { existsi i, existsi j,
    apply and.intro Hij,
    refl },
  { rw drop_succ,
    cases j with j,
    { rw [rounds_zero,tail_cons] ,
      have h' := @k_ih (succ i) (succ i) (nat.le_refl _),
      apply h',  },
    { have Hij' := nat.le_of_succ_le Hij,
      have h' := @k_ih i j Hij',
      rw [rounds_succ,tail_cons],
      apply h', } },
end

theorem inf_interleave_to_rounds_idx (s : stream ℕ) (h : s ⊑ inf_interleave)
: ∃ i j, j ≤ i ∧ s = rounds i j :=
begin
  apply rounds_suffix_rounds (le_refl _) h
end

theorem search_inf_interleave (s : stream ℕ) (x) (h : s ⊑ inf_interleave)
: ∃ s', s' ⊑ s ∧ head s' = x :=
begin
  cases (inf_interleave_to_rounds_idx s h) with i h₀,
  cases h₀ with j h₀,
  cases h₀ with h₁ h₀,
  existsi rounds (succ $ max i x) x,
  split,
  { rw h₀,
    apply stream.le_trans,
    { apply suffix_self_of_le,
      apply le_succ_of_le,
      apply le_max_right i x },
    apply stream.le_trans,
    { apply is_prefix_of_le _ (succ i),
      apply succ_le_succ,
      apply le_max_left },
    { apply rounds_succ_succ _ j } },
  { apply head_rounds }
end

theorem inf_repeat_inf_inter : ∀ x i, ∃ j, inf_interleave (i+j) = x :=
begin
  intros x i,
  have h' : drop i inf_interleave ⊑ inf_interleave,
  { unfold is_suffix, existsi i, refl },
  have h  := search_inf_interleave (drop i inf_interleave) x h',
  cases h with s' h,
  cases h with h₀ h₁,
  unfold is_suffix at h₀,
  cases h₀ with y h₀,
  existsi y,
  rw [drop_drop,add_comm] at h₀,
  change (nth (i + y) inf_interleave) = _,
  rw [← head_drop,← h₀,h₁]
end


import data.list.basic

variables {α β : Type}

namespace list

def equiv (l1 l2 : list α) := l1 ⊆ l2 ∧ l2 ⊆ l1

notation l1 `≃` l2 := equiv l1 l2

def equiv.refl {l : list α} : l ≃ l :=
and.intro (subset.refl _) (subset.refl _)

def equiv.symm {as1 as2 : list α} : (as1 ≃ as2) → (as2 ≃ as1) :=
begin
  intro h, cases h with h1 h2,
  apply and.intro; assumption
end

lemma equiv.trans {l1 l2 l3 : list α} : (l1 ≃ l2) → (l2 ≃ l3) → (l1 ≃ l3) :=
begin
  intros h1 h2, cases h1 with h1a h1b, cases h2 with h2a h2b,
  apply and.intro (subset.trans h1a h2a) (subset.trans h2b h1b),
end

lemma mem_iff_mem_of_equiv {as1 as2 : list α} :
  (as1 ≃ as2) → ∀ (a : α), a ∈ as1 ↔ a ∈ as2 :=
begin
  intros heqv a, cases heqv with hss1 hss2,
  apply iff.intro; intro hm,
  apply hss1; assumption,
  apply hss2; assumption
end

lemma map_subset_map_of_subset
  {f : α → β} {as1 as2 : list α} :
  (as1 ⊆ as2) → (map f as1 ⊆ map f as2) :=
begin
  intros hss b hb, rewrite mem_map at *, cases hb with a ha,
  cases ha with ha1 ha2, subst ha2, existsi a,
  apply and.intro _ rfl, apply hss ha1
end

lemma map_equiv_map_of_equiv
  {f : α → β} {as1 as2 : list α} :
  (as1 ≃ as2) → (map f as1 ≃ map f as2) :=
begin
  intro heqv, cases heqv with hss1 hss2, apply and.intro;
  apply map_subset_map_of_subset; assumption
end

lemma union_equiv_append [decidable_eq α] {as1 as2 : list α} :
  (as1 ∪ as2) ≃ (as1 ++ as2) :=
begin
  constructor, apply subset_of_sublist,
  apply union_sublist_append, intros a ha,
  rw mem_append at ha, cases ha,
  apply mem_union_left ha,
  apply mem_union_right _ ha,
end

lemma map_union_equiv [decidable_eq α] [decidable_eq β]
  {f : α → β} {as1 as2 : list α} :
  map f (as1 ∪ as2) ≃ (map f as1) ∪ (map f as2) :=
begin
  apply and.intro; intros x hx,
  rewrite mem_map at hx, cases hx with y hy,
  cases hy with hy1 hy2, subst hy2,
  rewrite mem_union at hy1,
  cases hy1 with hym hym,
  apply mem_union_left, rewrite mem_map,
  existsi y, apply and.intro, assumption, refl,
  apply mem_union_right, rewrite mem_map,
  existsi y, apply and.intro, assumption, refl,
  rewrite mem_union at hx, cases hx with hx hx;
  rewrite mem_map at hx; cases hx with y hy;
  rewrite mem_map; existsi y; cases hy with hy1 hy2;
  apply and.intro _ hy2,
  apply mem_union_left hy1,
  apply mem_union_right _ hy1
end

end list


import basicmodal.language basicmodal.semantic basicmodal.syntax
import tactic

universe u

namespace basicmodal

variable {W : Type u}
variable 𝓕 : Kripke_Frame W
local infix ` ≺ `:50 := 𝓕.relation

lemma P1_soundness (φ ψ)
  : 𝓕 ⊧ (φ →' (ψ →' φ)) :=
begin
  intros v w,
  sorry,
end

lemma P2_soundness (φ ψ χ)
  : 𝓕 ⊧ (φ →' (ψ →' χ)) →' ((φ →' ψ) →' (φ →' χ)) :=
begin
  intros v w,

  sorry,
end

lemma P3_soundness (φ ψ)
  : 𝓕 ⊧ (¬'φ →' ¬'ψ) →' (φ →' ψ) :=
begin
  intros v w,
  sorry,
end

lemma K_soundness (φ ψ)
  : 𝓕 ⊧ □(φ →' ψ) →' (□φ →' ψ) :=
begin
  intros v w h h₀,
  sorry,
end

lemma mp_soundness (φ ψ)
  : (𝓕 ⊧ φ →' ψ) → (𝓕 ⊧ φ) → (𝓕 ⊧ ψ) :=
begin
  tauto,
end

lemma nec_soundness (φ)
  : (𝓕 ⊧ φ) → (𝓕 ⊧ □φ) :=
begin
  tauto,
end

theorem soundness  (φ : Formula): (⊢ₖ φ) → (𝓕 ⊧ φ) :=
begin
  assume h,
  induction h,
  case P1: { exact @P1_soundness _ _ _ _},
  case P2: {exact @P2_soundness _ _ _ _ _},
  case P3: {exact @P3_soundness _ _ _ _},
  case K: { exact @K_soundness _ _ _ _,},
  case mp: _ _ _ _ h₀ h₁ { exact mp_soundness _ _ _ h₀ h₁, },
  case nec: _ _ h₀ { exact nec_soundness _ _ h₀, },
end

end basicmodal


import tactic
import order.bounded_lattice

/- Shows that for a in with_top, a+a = 0 is equivalent to a=0. -/

example (a : with_top ℤ) : a + a = 0 ↔ a = 0 :=
begin
  split,
  { -- the hard way
    intro h, -- h is a proof of a+a=0
    -- split into cases
    cases (with_top.cases a) with htop hn,
    { -- a = ⊤
      rw htop at h,
      -- h is false
      cases h,
      -- no cases!
    },
    { -- a = n
      cases hn with n hn,
      rw hn at h ⊢,
      -- now h says n+n=0 and our goal is n=0
      -- but these are equalities in `with_top ℤ
      -- so we need to get them into ℤ
      -- A tactic called `norm_cast` does this
     norm_cast at h ⊢,
      -- we finally have a hypothesis n + n = 0
      -- and a goal n = 0      -- and everything is an integer
      rw add_self_eq_zero at h,
      assumption
    }
  },
  { -- the easy way
    intro ha,
    rw ha,
    simp
  }
end


import data.nat.prime
import data.real.basic
open nat

theorem sqrt_two_irrational_V1 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
-- usually after exists.elim the rest of the proof should be inside
-- parantheses
exists.elim ha (assume c : ℕ, assume aeq : a = 2 * c,
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by simp * at *,
-- therefore the ) below!!!!
show false, from absurd habs dec_trivial )
--#check sqrt_two_irrational_V1

-- tactics mode
theorem sqrt_two_irrational_V2 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
begin
    intro h,
    have h1 : 2 ∣ a^2, by simp [h],
    have h2 : 2 ∣ a, from prime.dvd_of_dvd_pow prime_two h1,
    cases h2 with c aeq,
    have h3 : 2 * (2 * c^2) = 2 * b^2,
        by simp [eq.symm h, aeq];
            simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
    have h4 : 2 * c^2 = b^2,
        from eq_of_mul_eq_mul_left dec_trivial h3,
    have h5 : 2 ∣ b^2,
        by simp [eq.symm h4],
    have hb : 2 ∣ b,
        from prime.dvd_of_dvd_pow prime_two h5,
    have h6 : 2 ∣ gcd a b, from dvd_gcd (exists.intro c aeq) hb,
    have habs : 2 ∣ (1:ℕ), by simp * at *,
    exact absurd habs dec_trivial, done
end

-- using let (it may introduce a bug due to _let_match hypothesis)
theorem sqrt_two_irrational_V3 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
let ⟨c, aeq⟩ := ha in
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by clear_aux_decl; simp * at *, -- replaces simp * at *,
show false, from absurd habs dec_trivial

-- variant with match, needs end to finish
theorem sqrt_two_irrational_V4 {a b : ℕ} (co : gcd a b = 1) : a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
    by simp [h],
have ha : 2 ∣ a,
    from prime.dvd_of_dvd_pow prime_two this,
match ha with | ⟨c, aeq⟩ :=
have 2 * (2 * c^2) = 2 * b^2,
    by simp [eq.symm h, aeq];
       simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
    from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
    by simp [eq.symm this],
have hb : 2 ∣ b,
    from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
    from dvd_gcd ha hb,
have habs : 2 ∣ (1:ℕ),
    by clear_aux_decl; simp * at *, -- replaces simp * at *,
show false, from absurd habs dec_trivial
end

theorem sqrt_two_irrational {a b : ℕ} (co : gcd a b = 1) :
  a^2 ≠ 2 * b^2 :=
assume h : a^2 = 2 * b^2,
have 2 ∣ a^2,
  by simp [h],
have 2 ∣ a,
  from prime.dvd_of_dvd_pow prime_two this,
exists.elim this $
assume (c : nat) (aeq : a = 2 * c),
have 2 * (2 * c^2) = 2 * b^2,
  by simp [eq.symm h, aeq];
    simp [nat.pow_succ, mul_comm, mul_assoc, mul_left_comm],
have 2 * c^2 = b^2,
  from eq_of_mul_eq_mul_left dec_trivial this,
have 2 ∣ b^2,
  by simp [eq.symm this],
have 2 ∣ b,
  from prime.dvd_of_dvd_pow prime_two this,
have 2 ∣ gcd a b,
  from dvd_gcd ‹2 ∣ a› ‹2 ∣ b›,
have 2 ∣ (1 : ℕ),
  by simp * at *,
show false, from absurd ‹2 ∣ 1› dec_trivial
--#check sqrt_two_irrational


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

import algebra.direct_sum.module
import algebra.group.conj_finite
import tactic.fin_cases

/-!
# Not all complementary decompositions of a module over a semiring make up a direct sum

This shows that while `ℤ≤0` and `ℤ≥0` are complementary `ℕ`-submodules of `ℤ`, which in turn
implies as a collection they are `complete_lattice.independent` and that they span all of `ℤ`, they
do not form a decomposition into a direct sum.

This file demonstrates why `direct_sum.is_internal_submodule_of_independent_of_supr_eq_top` must
take `ring R` and not `semiring R`.
-/

lemma units_int.one_ne_neg_one : (1 : ℤˣ) ≠ -1 := dec_trivial

/-- Submodules of positive and negative integers, keyed by sign. -/
def with_sign (i : ℤˣ) : submodule ℕ ℤ :=
add_submonoid.to_nat_submodule $ show add_submonoid ℤ, from
  { carrier := {z | 0 ≤ i • z},
    zero_mem' := show 0 ≤ i • (0 : ℤ), from (smul_zero _).ge,
    add_mem' := λ x y (hx : 0 ≤ i • x) (hy : 0 ≤ i • y), show _ ≤ _, begin
      rw smul_add,
      exact add_nonneg hx hy
    end }

local notation `ℤ≥0` := with_sign 1
local notation `ℤ≤0` := with_sign (-1)

lemma mem_with_sign_one {x : ℤ} : x ∈ ℤ≥0 ↔ 0 ≤ x :=
show _ ≤ _ ↔ _, by rw one_smul

lemma mem_with_sign_neg_one {x : ℤ} : x ∈ ℤ≤0 ↔ x ≤ 0 :=
show _ ≤ _ ↔ _, by rw [units.neg_smul, le_neg, one_smul, neg_zero]

/-- The two submodules are complements. -/
lemma with_sign.is_compl : is_compl (ℤ≥0) (ℤ≤0) :=
begin
  split,
  { apply submodule.disjoint_def.2,
    intros x hx hx',
    exact le_antisymm (mem_with_sign_neg_one.mp hx') (mem_with_sign_one.mp hx), },
  { rw codisjoint_iff_le_sup,
    intros x hx,
    obtain hp | hn := (le_refl (0 : ℤ)).le_or_le x,
    exact submodule.mem_sup_left (mem_with_sign_one.mpr hp),
    exact submodule.mem_sup_right (mem_with_sign_neg_one.mpr hn), }
end

def with_sign.independent : complete_lattice.independent with_sign :=
begin
  refine (complete_lattice.independent_pair units_int.one_ne_neg_one _).mpr
    with_sign.is_compl.disjoint,
  intros i,
  fin_cases i; simp,
end

lemma with_sign.supr : supr with_sign = ⊤ :=
begin
  rw [←finset.sup_univ_eq_supr, units_int.univ, finset.sup_insert, finset.sup_singleton],
  exact with_sign.is_compl.sup_eq_top,
end

/-- But there is no embedding into `ℤ` from the direct sum. -/
lemma with_sign.not_injective :
  ¬function.injective (direct_sum.to_module ℕ ℤˣ ℤ (λ i, (with_sign i).subtype)) :=
begin
  intro hinj,
  let p1 : ℤ≥0 := ⟨1, mem_with_sign_one.2 zero_le_one⟩,
  let n1 : ℤ≤0 := ⟨-1, mem_with_sign_neg_one.2 $ neg_nonpos.2 zero_le_one⟩,
  let z := direct_sum.lof ℕ _ (λ i, with_sign i) 1 p1 +
           direct_sum.lof ℕ _ (λ i, with_sign i) (-1) n1,
  have : z ≠ 0,
  { intro h,
    dsimp [z, direct_sum.lof_eq_of, direct_sum.of] at h,
    replace h := dfinsupp.ext_iff.mp h 1,
    rw [dfinsupp.zero_apply, dfinsupp.add_apply, dfinsupp.single_eq_same,
      dfinsupp.single_eq_of_ne (units_int.one_ne_neg_one.symm), add_zero, subtype.ext_iff,
      submodule.coe_zero] at h,
    apply zero_ne_one h.symm, },
  apply hinj.ne this,
  rw [linear_map.map_zero, linear_map.map_add, direct_sum.to_module_lof, direct_sum.to_module_lof],
  simp,
end

/-- And so they do not represent an internal direct sum. -/
lemma with_sign.not_internal : ¬direct_sum.is_internal with_sign :=
with_sign.not_injective ∘ and.elim_left