/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Johan Commelin, Patrick Massot
-/

import algebra.order.with_zero
import ring_theory.ideal.operations

/-!

# The basics of valuation theory.

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

The basic theory of valuations (non-archimedean norms) on a commutative ring,
following T. Wedhorn's unpublished notes “Adic Spaces” ([wedhorn_adic]).

The definition of a valuation we use here is Definition 1.22 of [wedhorn_adic].
A valuation on a ring `R` is a monoid homomorphism `v` to a linearly ordered
commutative monoid with zero, that in addition satisfies the following two axioms:
 * `v 0 = 0`
 * `∀ x y, v (x + y) ≤ max (v x) (v y)`

`valuation R Γ₀`is the type of valuations `R → Γ₀`, with a coercion to the underlying
function. If `v` is a valuation from `R` to `Γ₀` then the induced group
homomorphism `units(R) → Γ₀` is called `unit_map v`.

The equivalence "relation" `is_equiv v₁ v₂ : Prop` defined in 1.27 of [wedhorn_adic] is not strictly
speaking a relation, because `v₁ : valuation R Γ₁` and `v₂ : valuation R Γ₂` might
not have the same type. This corresponds in ZFC to the set-theoretic difficulty
that the class of all valuations (as `Γ₀` varies) on a ring `R` is not a set.
The "relation" is however reflexive, symmetric and transitive in the obvious
sense. Note that we use 1.27(iii) of [wedhorn_adic] as the definition of equivalence.

## Main definitions

* `valuation R Γ₀`, the type of valuations on `R` with values in `Γ₀`
* `valuation.is_equiv`, the heterogeneous equivalence relation on valuations
* `valuation.supp`, the support of a valuation

* `add_valuation R Γ₀`, the type of additive valuations on `R` with values in a
  linearly ordered additive commutative group with a top element, `Γ₀`.

## Implementation Details

`add_valuation R Γ₀` is implemented as `valuation R (multiplicative Γ₀)ᵒᵈ`.

## Notation

In the `discrete_valuation` locale:

 * `ℕₘ₀` is a shorthand for `with_zero (multiplicative ℕ)`
 * `ℤₘ₀` is a shorthand for `with_zero (multiplicative ℤ)`

## TODO

If ever someone extends `valuation`, we should fully comply to the `fun_like` by migrating the
boilerplate lemmas to `valuation_class`.
-/

open_locale classical big_operators
noncomputable theory

open function ideal

variables {K F R : Type*} [division_ring K]

section
variables (F R) (Γ₀ : Type*) [linear_ordered_comm_monoid_with_zero Γ₀] [ring R]

/-- The type of `Γ₀`-valued valuations on `R`.

When you extend this structure, make sure to extend `valuation_class`. -/
@[nolint has_nonempty_instance]
structure valuation extends R →*₀ Γ₀ :=
(map_add_le_max' : ∀ x y, to_fun (x + y) ≤ max (to_fun x) (to_fun y))

/-- `valuation_class F α β` states that `F` is a type of valuations.

You should also extend this typeclass when you extend `valuation`. -/
class valuation_class extends monoid_with_zero_hom_class F R Γ₀ :=
(map_add_le_max (f : F) (x y : R) : f (x + y) ≤ max (f x) (f y))

export valuation_class (map_add_le_max)

instance [valuation_class F R Γ₀] : has_coe_t F (valuation R Γ₀) :=
⟨λ f, { to_fun := f, map_one' := map_one f, map_zero' := map_zero f, map_mul' := map_mul f,
  map_add_le_max' := map_add_le_max f }⟩

end

namespace valuation

variables {Γ₀   : Type*}
variables {Γ'₀  : Type*}
variables {Γ''₀ : Type*} [linear_ordered_comm_monoid_with_zero Γ''₀]

section basic
variables [ring R]

section monoid
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]

instance : valuation_class (valuation R Γ₀) R Γ₀ :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_mul := λ f, f.map_mul',
  map_one := λ f, f.map_one',
  map_zero := λ f, f.map_zero',
  map_add_le_max := λ f, f.map_add_le_max' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (valuation R Γ₀) (λ _, R → Γ₀) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe (v : valuation R Γ₀) : v.to_fun = v := rfl
@[ext] lemma ext {v₁ v₂ : valuation R Γ₀} (h : ∀ r, v₁ r = v₂ r) : v₁ = v₂ := fun_like.ext _ _ h

variables (v : valuation R Γ₀) {x y z : R}

@[simp, norm_cast] lemma coe_coe : ⇑(v : R →*₀ Γ₀) = v := rfl

@[simp] lemma map_zero : v 0 = 0 := v.map_zero'
@[simp] lemma map_one  : v 1 = 1 := v.map_one'
@[simp] lemma map_mul  : ∀ x y, v (x * y) = v x * v y := v.map_mul'
@[simp] lemma map_add  : ∀ x y, v (x + y) ≤ max (v x) (v y) := v.map_add_le_max'

lemma map_add_le {x y g} (hx : v x ≤ g) (hy : v y ≤ g) : v (x + y) ≤ g :=
le_trans (v.map_add x y) $ max_le hx hy

lemma map_add_lt {x y g} (hx : v x < g) (hy : v y < g) : v (x + y) < g :=
lt_of_le_of_lt (v.map_add x y) $ max_lt hx hy

lemma map_sum_le {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hf : ∀ i ∈ s, v (f i) ≤ g) :
  v (∑ i in s, f i) ≤ g :=
begin
  refine finset.induction_on s
    (λ _, trans_rel_right (≤) v.map_zero zero_le') (λ a s has ih hf, _) hf,
  rw finset.forall_mem_insert at hf, rw finset.sum_insert has,
  exact v.map_add_le hf.1 (ih hf.2)
end

lemma map_sum_lt {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g ≠ 0)
  (hf : ∀ i ∈ s, v (f i) < g) : v (∑ i in s, f i) < g :=
begin
  refine finset.induction_on s
    (λ _, trans_rel_right (<) v.map_zero (zero_lt_iff.2 hg)) (λ a s has ih hf, _) hf,
  rw finset.forall_mem_insert at hf, rw finset.sum_insert has,
  exact v.map_add_lt hf.1 (ih hf.2)
end

lemma map_sum_lt' {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : 0 < g)
  (hf : ∀ i ∈ s, v (f i) < g) : v (∑ i in s, f i) < g :=
v.map_sum_lt (ne_of_gt hg) hf

@[simp] lemma map_pow  : ∀ x (n:ℕ), v (x^n) = (v x)^n :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_pow

/-- Deprecated. Use `fun_like.ext_iff`. -/
lemma ext_iff {v₁ v₂ : valuation R Γ₀} : v₁ = v₂ ↔ ∀ r, v₁ r = v₂ r := fun_like.ext_iff

-- The following definition is not an instance, because we have more than one `v` on a given `R`.
-- In addition, type class inference would not be able to infer `v`.

/-- A valuation gives a preorder on the underlying ring. -/
def to_preorder : preorder R := preorder.lift v

/-- If `v` is a valuation on a division ring then `v(x) = 0` iff `x = 0`. -/
@[simp] lemma zero_iff [nontrivial Γ₀] (v : valuation K Γ₀) {x : K} :
  v x = 0 ↔ x = 0 :=
map_eq_zero v

lemma ne_zero_iff [nontrivial Γ₀] (v : valuation K Γ₀) {x : K} :
  v x ≠ 0 ↔ x ≠ 0 :=
map_ne_zero v

theorem unit_map_eq (u : Rˣ) :
  (units.map (v : R →* Γ₀) u : Γ₀) = v u := rfl

/-- A ring homomorphism `S → R` induces a map `valuation R Γ₀ → valuation S Γ₀`. -/
def comap {S : Type*} [ring S] (f : S →+* R) (v : valuation R Γ₀) :
  valuation S Γ₀ :=
{ to_fun := v ∘ f,
  map_add_le_max' := λ x y, by simp only [comp_app, map_add, f.map_add],
  .. v.to_monoid_with_zero_hom.comp f.to_monoid_with_zero_hom, }

@[simp]
lemma comap_apply {S : Type*} [ring S] (f : S →+* R) (v : valuation R Γ₀) (s : S) :
  v.comap f s = v (f s) := rfl

@[simp] lemma comap_id : v.comap (ring_hom.id R) = v := ext $ λ r, rfl

lemma comap_comp {S₁ : Type*} {S₂ : Type*} [ring S₁] [ring S₂] (f : S₁ →+* S₂) (g : S₂ →+* R) :
  v.comap (g.comp f) = (v.comap g).comap f :=
ext $ λ r, rfl

/-- A `≤`-preserving group homomorphism `Γ₀ → Γ'₀` induces a map `valuation R Γ₀ → valuation R Γ'₀`.
-/
def map (f : Γ₀ →*₀ Γ'₀) (hf : monotone f) (v : valuation R Γ₀) :
  valuation R Γ'₀ :=
{ to_fun := f ∘ v,
  map_add_le_max' := λ r s,
    calc f (v (r + s)) ≤ f (max (v r) (v s))     : hf (v.map_add r s)
                   ... = max (f (v r)) (f (v s)) : hf.map_max,
  .. monoid_with_zero_hom.comp f v.to_monoid_with_zero_hom }

/-- Two valuations on `R` are defined to be equivalent if they induce the same preorder on `R`. -/
def is_equiv (v₁ : valuation R Γ₀) (v₂ : valuation R Γ'₀) : Prop :=
∀ r s, v₁ r ≤ v₁ s ↔ v₂ r ≤ v₂ s

end monoid

section group
variables [linear_ordered_comm_group_with_zero Γ₀] {R} {Γ₀} (v : valuation R Γ₀) {x y z : R}

@[simp] lemma map_neg (x : R) : v (-x) = v x :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_neg x

lemma map_sub_swap (x y : R) : v (x - y) = v (y - x) :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_sub_swap x y

lemma map_sub (x y : R) : v (x - y) ≤ max (v x) (v y) :=
calc v (x - y) = v (x + -y)         : by rw [sub_eq_add_neg]
           ... ≤ max (v x) (v $ -y) : v.map_add _ _
           ... = max (v x) (v y)    : by rw map_neg

lemma map_sub_le {x y g} (hx : v x ≤ g) (hy : v y ≤ g) : v (x - y) ≤ g :=
begin
  rw sub_eq_add_neg,
  exact v.map_add_le hx (le_trans (le_of_eq (v.map_neg y)) hy)
end

lemma map_add_of_distinct_val (h : v x ≠ v y) : v (x + y) = max (v x) (v y) :=
begin
  suffices : ¬v (x + y) < max (v x) (v y),
    from or_iff_not_imp_right.1 (le_iff_eq_or_lt.1 (v.map_add x y)) this,
  intro h',
  wlog vyx : v y < v x,
  { refine this v h.symm _ (h.lt_or_lt.resolve_right vyx), rwa [add_comm, max_comm] },
  rw max_eq_left_of_lt vyx at h',
  apply lt_irrefl (v x),
  calc v x = v ((x+y) - y)         : by simp
        ... ≤ max (v $ x + y) (v y) : map_sub _ _ _
        ... < v x                   : max_lt h' vyx
end

lemma map_add_eq_of_lt_right (h : v x < v y) : v (x + y) = v y :=
begin
  convert v.map_add_of_distinct_val _,
  { symmetry, rw max_eq_right_iff, exact le_of_lt h },
  { exact ne_of_lt h }
end

lemma map_add_eq_of_lt_left (h : v y < v x) : v (x + y) = v x :=
begin
  rw add_comm, exact map_add_eq_of_lt_right _ h,
end

lemma map_eq_of_sub_lt (h : v (y - x) < v x) : v y = v x :=
begin
  have := valuation.map_add_of_distinct_val v (ne_of_gt h).symm,
  rw max_eq_right (le_of_lt h) at this,
  simpa using this
end

lemma map_one_add_of_lt (h : v x < 1) : v (1 + x) = 1 :=
begin
  rw ← v.map_one at h,
  simpa only [v.map_one] using v.map_add_eq_of_lt_left h
end

lemma map_one_sub_of_lt (h : v x < 1) : v (1 - x) = 1 :=
begin
  rw [← v.map_one, ← v.map_neg] at h,
  rw sub_eq_add_neg 1 x,
  simpa only [v.map_one, v.map_neg] using v.map_add_eq_of_lt_left h
end

lemma one_lt_val_iff (v : valuation K Γ₀) {x : K} (h : x ≠ 0) :
  1 < v x ↔ v x⁻¹ < 1 :=
by simpa using (inv_lt_inv₀ (v.ne_zero_iff.2 h) one_ne_zero).symm

/-- The subgroup of elements whose valuation is less than a certain unit.-/
def lt_add_subgroup (v : valuation R Γ₀) (γ : Γ₀ˣ) : add_subgroup R :=
{ carrier   := {x | v x < γ},
  zero_mem' := by { have h := units.ne_zero γ, contrapose! h, simpa using h },
  add_mem'  := λ x y x_in y_in, lt_of_le_of_lt (v.map_add x y) (max_lt x_in y_in),
  neg_mem'  := λ x x_in, by rwa [set.mem_set_of_eq, map_neg] }

end group
end basic -- end of section

namespace is_equiv
variables [ring R]
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]
variables {v : valuation R Γ₀}
variables {v₁ : valuation R Γ₀} {v₂ : valuation R Γ'₀} {v₃ : valuation R Γ''₀}

@[refl] lemma refl : v.is_equiv v :=
λ _ _, iff.refl _

@[symm] lemma symm (h : v₁.is_equiv v₂) : v₂.is_equiv v₁ :=
λ _ _, iff.symm (h _ _)

@[trans] lemma trans (h₁₂ : v₁.is_equiv v₂) (h₂₃ : v₂.is_equiv v₃) : v₁.is_equiv v₃ :=
λ _ _, iff.trans (h₁₂ _ _) (h₂₃ _ _)

lemma of_eq {v' : valuation R Γ₀} (h : v = v') : v.is_equiv v' :=
by { subst h }

lemma map {v' : valuation R Γ₀} (f : Γ₀ →*₀ Γ'₀) (hf : monotone f)
  (inf : injective f) (h : v.is_equiv v') :
  (v.map f hf).is_equiv (v'.map f hf) :=
let H : strict_mono f := hf.strict_mono_of_injective inf in
λ r s,
calc f (v r) ≤ f (v s) ↔ v r ≤ v s   : by rw H.le_iff_le
                   ... ↔ v' r ≤ v' s : h r s
                   ... ↔ f (v' r) ≤ f (v' s) : by rw H.le_iff_le

/-- `comap` preserves equivalence. -/
lemma comap {S : Type*} [ring S] (f : S →+* R) (h : v₁.is_equiv v₂) :
  (v₁.comap f).is_equiv (v₂.comap f) :=
λ r s, h (f r) (f s)

lemma val_eq (h : v₁.is_equiv v₂) {r s : R} :
  v₁ r = v₁ s ↔ v₂ r = v₂ s :=
by simpa only [le_antisymm_iff] using and_congr (h r s) (h s r)

lemma ne_zero (h : v₁.is_equiv v₂) {r : R} :
  v₁ r ≠ 0 ↔ v₂ r ≠ 0 :=
begin
  have : v₁ r ≠ v₁ 0 ↔ v₂ r ≠ v₂ 0 := not_iff_not_of_iff h.val_eq,
  rwa [v₁.map_zero, v₂.map_zero] at this,
end

end is_equiv -- end of namespace

section

lemma is_equiv_of_map_strict_mono [linear_ordered_comm_monoid_with_zero Γ₀]
  [linear_ordered_comm_monoid_with_zero Γ'₀] [ring R] {v : valuation R Γ₀} (f : Γ₀ →*₀ Γ'₀)
  (H : strict_mono f) :
  is_equiv (v.map f (H.monotone)) v :=
λ x y, ⟨H.le_iff_le.mp, λ h, H.monotone h⟩

lemma is_equiv_of_val_le_one [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) (h : ∀ {x:K}, v x ≤ 1 ↔ v' x ≤ 1) :
  v.is_equiv v' :=
begin
  intros x y,
  by_cases hy : y = 0, { simp [hy, zero_iff], },
  rw show y = 1 * y, by rw one_mul,
  rw [← (inv_mul_cancel_right₀ hy x)],
  iterate 2 {rw [v.map_mul _ y, v'.map_mul _ y]},
  rw [v.map_one, v'.map_one],
  split; intro H,
  { apply mul_le_mul_right',
    replace hy := v.ne_zero_iff.mpr hy,
    replace H := le_of_le_mul_right hy H,
    rwa h at H, },
  { apply mul_le_mul_right',
    replace hy := v'.ne_zero_iff.mpr hy,
    replace H := le_of_le_mul_right hy H,
    rwa h, },
end

lemma is_equiv_iff_val_le_one
  [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) :
  v.is_equiv v' ↔ ∀ {x : K}, v x ≤ 1 ↔ v' x ≤ 1 :=
⟨λ h x, by  simpa using h x 1, is_equiv_of_val_le_one _ _⟩

lemma is_equiv_iff_val_eq_one
  [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) :
  v.is_equiv v' ↔ ∀ {x : K}, v x = 1 ↔ v' x = 1 :=
begin
  split,
  { intros h x,
    simpa using @is_equiv.val_eq _ _ _ _ _ _ v v' h x 1 },
  { intros h, apply is_equiv_of_val_le_one, intros x,
    split,
    { intros hx,
      cases lt_or_eq_of_le hx with hx' hx',
      { have : v (1 + x) = 1,
        { rw ← v.map_one, apply map_add_eq_of_lt_left, simpa },
        rw h at this,
        rw (show x = (-1) + (1 + x), by simp),
        refine le_trans (v'.map_add _ _) _,
        simp [this] },
      { rw h at hx', exact le_of_eq hx' } },
    { intros hx,
      cases lt_or_eq_of_le hx with hx' hx',
      { have : v' (1 + x) = 1,
        { rw ← v'.map_one, apply map_add_eq_of_lt_left, simpa },
        rw ← h at this,
        rw (show x = (-1) + (1 + x), by simp),
        refine le_trans (v.map_add _ _) _,
        simp [this] },
      { rw ← h at hx', exact le_of_eq hx' } } }
end

lemma is_equiv_iff_val_lt_one
  [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) :
  v.is_equiv v' ↔ ∀ {x : K}, v x < 1 ↔ v' x < 1 :=
begin
  split,
  { intros h x,
    simp only [lt_iff_le_and_ne, and_congr ((is_equiv_iff_val_le_one _ _).1 h)
      ((is_equiv_iff_val_eq_one _ _).1 h).not] },
  { rw is_equiv_iff_val_eq_one,
    intros h x,
    by_cases hx : x = 0, { simp only [(zero_iff _).2 hx, zero_ne_one] },
    split,
    { intro hh,
      by_contra h_1,
      cases ne_iff_lt_or_gt.1 h_1,
      { simpa [hh, lt_self_iff_false] using h.2 h_2 },
      { rw [← inv_one, ← inv_eq_iff_eq_inv, ← map_inv₀] at hh,
        exact hh.not_lt (h.2 ((one_lt_val_iff v' hx).1 h_2)) } },
    { intro hh,
      by_contra h_1,
      cases ne_iff_lt_or_gt.1 h_1,
      { simpa [hh, lt_self_iff_false] using h.1 h_2 },
      { rw [← inv_one, ← inv_eq_iff_eq_inv, ← map_inv₀] at hh,
        exact hh.not_lt (h.1 ((one_lt_val_iff v hx).1 h_2)) } } }
end

lemma is_equiv_iff_val_sub_one_lt_one
  [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) :
  v.is_equiv v' ↔ ∀ {x : K}, v (x - 1) < 1 ↔ v' (x - 1) < 1 :=
begin
  rw is_equiv_iff_val_lt_one,
  exact (equiv.sub_right 1).surjective.forall
end

lemma is_equiv_tfae
  [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) :
  [v.is_equiv v',
   ∀ {x}, v x ≤ 1 ↔ v' x ≤ 1,
   ∀ {x}, v x = 1 ↔ v' x = 1,
   ∀ {x}, v x < 1 ↔ v' x < 1,
   ∀ {x}, v (x-1) < 1 ↔ v' (x-1) < 1].tfae :=
begin
  tfae_have : 1 ↔ 2, { apply is_equiv_iff_val_le_one },
  tfae_have : 1 ↔ 3, { apply is_equiv_iff_val_eq_one },
  tfae_have : 1 ↔ 4, { apply is_equiv_iff_val_lt_one },
  tfae_have : 1 ↔ 5, { apply is_equiv_iff_val_sub_one_lt_one },
  tfae_finish
end

end

section supp
variables [comm_ring R]
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]
variables (v : valuation R Γ₀)

/-- The support of a valuation `v : R → Γ₀` is the ideal of `R` where `v` vanishes. -/
def supp : ideal R :=
{ carrier   := {x | v x = 0},
  zero_mem' := map_zero v,
  add_mem'  := λ x y hx hy, le_zero_iff.mp $
    calc v (x + y) ≤ max (v x) (v y) : v.map_add x y
               ... ≤ 0               : max_le (le_zero_iff.mpr hx) (le_zero_iff.mpr hy),
  smul_mem' := λ c x hx, calc v (c * x)
                        = v c * v x : map_mul v c x
                    ... = v c * 0 : congr_arg _ hx
                    ... = 0 : mul_zero _ }

@[simp] lemma mem_supp_iff (x : R) : x ∈ supp v ↔ v x = 0 := iff.rfl
-- @[simp] lemma mem_supp_iff' (x : R) : x ∈ (supp v : set R) ↔ v x = 0 := iff.rfl

/-- The support of a valuation is a prime ideal. -/
instance [nontrivial Γ₀] [no_zero_divisors Γ₀] : ideal.is_prime (supp v) :=
⟨λ (h : v.supp = ⊤), one_ne_zero $ show (1 : Γ₀) = 0,
from calc 1 = v 1 : v.map_one.symm
        ... = 0   : show (1:R) ∈ supp v, by { rw h, trivial },
 λ x y hxy, begin
    show v x = 0 ∨ v y = 0,
    change v (x * y) = 0 at hxy,
    rw [v.map_mul x y] at hxy,
    exact eq_zero_or_eq_zero_of_mul_eq_zero hxy
  end⟩

lemma map_add_supp (a : R) {s : R} (h : s ∈ supp v) : v (a + s) = v a :=
begin
  have aux : ∀ a s, v s = 0 → v (a + s) ≤ v a,
  { intros a' s' h', refine le_trans (v.map_add a' s') (max_le le_rfl _), simp [h'], },
  apply le_antisymm (aux a s h),
  calc v a = v (a + s + -s) : by simp
       ... ≤ v (a + s)      : aux (a + s) (-s) (by rwa ←ideal.neg_mem_iff at h)
end

lemma comap_supp {S : Type*} [comm_ring S] (f : S →+* R) :
  supp (v.comap f) = ideal.comap f v.supp :=
ideal.ext $ λ x,
begin
  rw [mem_supp_iff, ideal.mem_comap, mem_supp_iff],
  refl,
end

end supp -- end of section

end valuation

section add_monoid

variables (R) [ring R] (Γ₀ : Type*) [linear_ordered_add_comm_monoid_with_top Γ₀]

/-- The type of `Γ₀`-valued additive valuations on `R`. -/
@[nolint has_nonempty_instance]
def add_valuation := valuation R (multiplicative Γ₀ᵒᵈ)

end add_monoid

namespace add_valuation
variables {Γ₀ : Type*} {Γ'₀ : Type*}

section basic

section monoid

variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables (R) (Γ₀) [ring R]

/-- A valuation is coerced to the underlying function `R → Γ₀`. -/
instance : has_coe_to_fun (add_valuation R Γ₀) (λ _, R → Γ₀) :=
{ coe := λ v, v.to_monoid_with_zero_hom.to_fun }

variables {R} {Γ₀} (v : add_valuation R Γ₀) {x y z : R}

section

variables (f : R → Γ₀) (h0 : f 0 = ⊤) (h1 : f 1 = 0)
variables (hadd : ∀ x y, min (f x) (f y) ≤ f (x + y)) (hmul : ∀ x y, f (x * y) = f x + f y)

/-- An alternate constructor of `add_valuation`, that doesn't reference `multiplicative Γ₀ᵒᵈ` -/
def of : add_valuation R Γ₀ :=
{ to_fun := f,
  map_one' := h1,
  map_zero' := h0,
  map_add_le_max' := hadd,
  map_mul' := hmul }

variables {h0} {h1} {hadd} {hmul} {r : R}

@[simp]
theorem of_apply : (of f h0 h1 hadd hmul) r = f r := rfl

/-- The `valuation` associated to an `add_valuation` (useful if the latter is constructed using
`add_valuation.of`). -/
def valuation : valuation R (multiplicative Γ₀ᵒᵈ) := v

@[simp] lemma valuation_apply (r : R) :
  v.valuation r = multiplicative.of_add (order_dual.to_dual (v r)) := rfl

end

@[simp] lemma map_zero : v 0 = ⊤ := v.map_zero
@[simp] lemma map_one  : v 1 = 0 := v.map_one
@[simp] lemma map_mul  : ∀ x y, v (x * y) = v x + v y := v.map_mul
@[simp] lemma map_add  : ∀ x y, min (v x) (v y) ≤ v (x + y) := v.map_add

lemma map_le_add {x y g} (hx : g ≤ v x) (hy : g ≤ v y) : g ≤ v (x + y) := v.map_add_le hx hy

lemma map_lt_add {x y g} (hx : g < v x) (hy : g < v y) : g < v (x + y) := v.map_add_lt hx hy

lemma map_le_sum {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hf : ∀ i ∈ s, g ≤ v (f i)) :
  g ≤ v (∑ i in s, f i) := v.map_sum_le hf

lemma map_lt_sum {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g ≠ ⊤)
  (hf : ∀ i ∈ s, g < v (f i)) : g < v (∑ i in s, f i) := v.map_sum_lt hg hf

lemma map_lt_sum' {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g < ⊤)
  (hf : ∀ i ∈ s, g < v (f i)) : g < v (∑ i in s, f i) := v.map_sum_lt' hg hf

@[simp] lemma map_pow  : ∀ x (n:ℕ), v (x^n) = n • (v x) := v.map_pow

@[ext] lemma ext {v₁ v₂ : add_valuation R Γ₀} (h : ∀ r, v₁ r = v₂ r) : v₁ = v₂ :=
valuation.ext h

lemma ext_iff {v₁ v₂ : add_valuation R Γ₀} : v₁ = v₂ ↔ ∀ r, v₁ r = v₂ r :=
valuation.ext_iff

-- The following definition is not an instance, because we have more than one `v` on a given `R`.
-- In addition, type class inference would not be able to infer `v`.

/-- A valuation gives a preorder on the underlying ring. -/
def to_preorder : preorder R := preorder.lift v

/-- If `v` is an additive valuation on a division ring then `v(x) = ⊤` iff `x = 0`. -/
@[simp] lemma top_iff [nontrivial Γ₀] (v : add_valuation K Γ₀) {x : K} :
  v x = ⊤ ↔ x = 0 :=
v.zero_iff

lemma ne_top_iff [nontrivial Γ₀] (v : add_valuation K Γ₀) {x : K} :
  v x ≠ ⊤ ↔ x ≠ 0 :=
v.ne_zero_iff

/-- A ring homomorphism `S → R` induces a map `add_valuation R Γ₀ → add_valuation S Γ₀`. -/
def comap {S : Type*} [ring S] (f : S →+* R) (v : add_valuation R Γ₀) :
  add_valuation S Γ₀ :=
v.comap f

@[simp] lemma comap_id : v.comap (ring_hom.id R) = v := v.comap_id

lemma comap_comp {S₁ : Type*} {S₂ : Type*} [ring S₁] [ring S₂] (f : S₁ →+* S₂) (g : S₂ →+* R) :
  v.comap (g.comp f) = (v.comap g).comap f :=
v.comap_comp f g

/-- A `≤`-preserving, `⊤`-preserving group homomorphism `Γ₀ → Γ'₀` induces a map
  `add_valuation R Γ₀ → add_valuation R Γ'₀`.
-/
def map (f : Γ₀ →+ Γ'₀) (ht : f ⊤ = ⊤) (hf : monotone f) (v : add_valuation R Γ₀) :
  add_valuation R Γ'₀ :=
v.map
{ to_fun := f,
  map_mul' := f.map_add,
  map_one' := f.map_zero,
  map_zero' := ht } (λ x y h, hf h)

/-- Two additive valuations on `R` are defined to be equivalent if they induce the same
  preorder on `R`. -/
def is_equiv (v₁ : add_valuation R Γ₀) (v₂ : add_valuation R Γ'₀) : Prop :=
v₁.is_equiv v₂

end monoid

section group
variables [linear_ordered_add_comm_group_with_top Γ₀] [ring R] (v : add_valuation R Γ₀) {x y z : R}

@[simp] lemma map_inv (v : add_valuation K Γ₀) {x : K} :
  v x⁻¹ = - (v x) :=
map_inv₀ v.valuation x

@[simp] lemma map_neg (x : R) : v (-x) = v x :=
v.map_neg x

lemma map_sub_swap (x y : R) : v (x - y) = v (y - x) :=
v.map_sub_swap x y

lemma map_sub (x y : R) : min (v x) (v y) ≤ v (x - y) :=
v.map_sub x y

lemma map_le_sub {x y g} (hx : g ≤ v x) (hy : g ≤ v y) : g ≤ v (x - y) := v.map_sub_le hx hy

lemma map_add_of_distinct_val (h : v x ≠ v y) : v (x + y) = min (v x) (v y) :=
v.map_add_of_distinct_val h

lemma map_eq_of_lt_sub (h : v x < v (y - x)) : v y = v x :=
v.map_eq_of_sub_lt h

end group

end basic

namespace is_equiv
variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables [ring R]
variables {Γ''₀ : Type*} [linear_ordered_add_comm_monoid_with_top Γ''₀]
variables {v : add_valuation R Γ₀}
variables {v₁ : add_valuation R Γ₀} {v₂ : add_valuation R Γ'₀} {v₃ : add_valuation R Γ''₀}

@[refl] lemma refl : v.is_equiv v := valuation.is_equiv.refl

@[symm] lemma symm (h : v₁.is_equiv v₂) : v₂.is_equiv v₁ := h.symm

@[trans] lemma trans (h₁₂ : v₁.is_equiv v₂) (h₂₃ : v₂.is_equiv v₃) : v₁.is_equiv v₃ :=
h₁₂.trans h₂₃

lemma of_eq {v' : add_valuation R Γ₀} (h : v = v') : v.is_equiv v' :=
valuation.is_equiv.of_eq h

lemma map {v' : add_valuation R Γ₀} (f : Γ₀ →+ Γ'₀) (ht : f ⊤ = ⊤) (hf : monotone f)
  (inf : injective f) (h : v.is_equiv v') :
  (v.map f ht hf).is_equiv (v'.map f ht hf) :=
h.map
{ to_fun := f,
  map_mul' := f.map_add,
  map_one' := f.map_zero,
  map_zero' := ht } (λ x y h, hf h) inf

/-- `comap` preserves equivalence. -/
lemma comap {S : Type*} [ring S] (f : S →+* R) (h : v₁.is_equiv v₂) :
  (v₁.comap f).is_equiv (v₂.comap f) :=
h.comap f

lemma val_eq (h : v₁.is_equiv v₂) {r s : R} :
  v₁ r = v₁ s ↔ v₂ r = v₂ s :=
h.val_eq

end is_equiv

section supp
variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables [comm_ring R]
variables (v : add_valuation R Γ₀)

/-- The support of an additive valuation `v : R → Γ₀` is the ideal of `R` where `v x = ⊤` -/
def supp : ideal R := v.supp

@[simp] lemma mem_supp_iff (x : R) : x ∈ supp v ↔ v x = ⊤ := v.mem_supp_iff x

lemma map_add_supp (a : R) {s : R} (h : s ∈ supp v) : v (a + s) = v a :=
v.map_add_supp a h

end supp -- end of section

attribute [irreducible] add_valuation

end add_valuation

section valuation_notation

localized "notation (name := nat.multiplicative_zero)
  `ℕₘ₀` := with_zero (multiplicative ℕ)" in discrete_valuation
localized "notation (name := int.multiplicative_zero)
  `ℤₘ₀` := with_zero (multiplicative ℤ)" in discrete_valuation

end valuation_notation


import lib.m154

/-
# Quantificateur universel

Ce fichier est consacré au quantificateur universel, symbolisé par `∀`.

On rappelle qu'un *prédicat* est un énoncé dépendant d'un objet `x` d'un type `X` fixé.
Le plus souvent pour nous `X = ℝ`, le type des nombres réels. Un prédicat n'est donc
pas un énoncé mathématique autonome.

À partir d'un prédicat `P`, on peut former l'énoncé autonome :
« Pour tout x, P x », qu'on note `∀ x, P x`. La définition suivante
construit un énoncé, portant sur une fonction `f` fixée, à partir du prédicat
qui associe à tout nombre réel `x` l'énoncé `f (-x) = f x`
(notons que Lean est économe en parenthèses ici).
-/

def paire (f : ℝ → ℝ) := ∀ x, f (-x) = f x

/-
Dans l'énoncé `∀ x, f(-x) = f x`, le type `ℝ` de `x` n'apparait pas explicitement
car on peut le déduire de l'information que `f` est une fonction de `ℝ` dans `ℝ`
qui est visiblement appliquée à `x`.

Cependant il peut être plus clair de l'indiquer explicitement comme dans la
définition suivante, et ce serait indispensable sans l'indication fournie par `f x`.
-/

def impaire (f : ℝ → ℝ) := ∀ x : ℝ, f (-x) = -f x

/-
Sur papier on écrit « ∀ x ∈ ℝ, » plutôt que « ∀ x : ℝ, ».

Pour *démontrer* un énoncé de la forme `∀ x, P x` où `P` est un prédicat,
il faut se donner un élément `x` arbitraire et démontrer l'énoncé `P x`.
Dans Lean on utilisera la commande `Soit x`, pour se donner un élément `x`.
Pour plus de clarté, on peut indiquer le type d'objet `x` considéré en écrivant
`Soit x : ℝ,`. Sur paper on écrirait plutôt : « Soit x un nombre réel »,
ou bien « Soit x ∈ ℝ ».
-/

-- La fonction qui envoie `x` sur `x²` est paire.
example : paire (fct x ↦ x^2) :=
begin
  Soit x : ℝ,
  On calcule,
end

-- La fonction qui envoie `x` sur `x³` est impaire.
example : impaire (fct x ↦ x^3) :=
begin
  sorry
end

/-
Pour *utiliser*  un énoncé de la forme `∀ x, P x` où `P` est un prédicat,
on peut le spécialiser à n'importe quel objet `x` de type `X`.
Voyons d'abord un exemple où on peut conclure immédiatement.
-/

example (f : ℝ → ℝ) (hf : paire f) : f (-5) = f 5 :=
begin
  On conclut par hf appliqué à 5,
end

/- On peut aussi spécialiser une hypothèse de la forme `∀ x, P x` à un
`x` donné et l'utiliser un peu plus tard. -/

example (f g : ℝ → ℝ) (hf : paire f) : g (f (-5)) = g (f 5) :=
begin
  On applique hf à 5,
  On réécrit via hf,
end

example (f : ℝ → ℝ) (hf : impaire f) : f (-3) = - f 3 :=
begin
  sorry
end

/-
Voyons maintenant un exemple qui démontre un énoncé quantifié en utilisant
deux hypothèses quantifiées.
Dans cet exemple, on nomme `x₀` le nombre réel introduit par la
commande `Soit` pour insister sur le fait qu'il est fixé et bien voir
qu'après la ligne `On applique hf à x₀`, l'hypothèse `hf` ne porte plus que
sur ce seul nombre.
-/

-- Si f et g sont paires alors leur somme l'est aussi.
example (f g : ℝ → ℝ) : paire f → paire g →  paire (f + g) :=
begin
  Supposons (hf : ∀ x, f (-x) = f x) (hg : ∀ x, g (-x) = g x),
  Montrons que ∀ x, (f+g) (-x) = (f+g) x,
  Soit x₀ : ℝ,
  On applique hf à x₀,
  On applique hg à x₀,
  calc (f + g) (-x₀) = f (-x₀) + g (-x₀) : by On calcule
  ... = f x₀ + g (-x₀) : by On réécrit via hf
  ... = f x₀ + g x₀ : by On réécrit via hg
  ... = (f + g) x₀ : by On calcule,
end

/-
Dans la démonstration précédente, la ligne commençant par "Montrons que"
est purement psychologique, Lean n'en a pas besoin du tout.

De plus on n'est pas obligé d'expliciter la définition de "paire"
dans la première ligne.

Enfin Lean n'a pas vraiment besoin qu'on lui dise à quel réel appliquer
les hypothèses de parité, il lui suffit de chercher dans le but en cours
donc les lignes de spécialisation `On applique` sont inutiles.

On peut donc aussi utiliser la version ci-dessous.
-/

-- Si f et g sont paires alors leur somme l'est aussi,
-- avec une démonstration moins bavarde.
example (f g : ℝ → ℝ) : paire f → paire g →  paire (f + g) :=
begin
  Supposons (hf : paire f) (hg : paire g),
  Soit x,
  calc (f + g) (-x) = f (-x) + g (-x) : by On calcule
  ... = f x + g (-x) : by On réécrit via hf
  ... = f x + g x : by On réécrit via hg
  ... = (f + g) x : by On calcule,
end

example (f g : ℝ → ℝ) : paire f → paire (g ∘ f) :=
begin
  sorry
end

example (f g : ℝ → ℝ) : impaire f → impaire g →  impaire (g ∘ f) :=
begin
  sorry
end

/-
Voyons maintenant comment manipuler des prédicats plus complexes.
On se donne une fonction `f : ℝ → ℝ` et on forme le prédicat
portant sur deux nombres `x₁̀` et `x₂` auxquels on associe
l'énoncé `x₁ ≤ x₂ → f x₁ ≤ f x₂` (Si x₁ ≤ x₂ alors f(x₁) ≤ f(x₂)).

On peut emboîter deux quantificateurs universels pour obtenir la définition
de fonction croissante.
-/

def croissante (f : ℝ → ℝ) := ∀ x₁, (∀ x₂, x₁ ≤ x₂ → f x₁ ≤ f x₂)

/-
Un tel emboîtement est un peu lourd à lire, on peut l'abréger comme
dans la définition suivante.
-/

def decroissante (f : ℝ → ℝ) := ∀ x₁ x₂, x₁ ≤ x₂ → f x₁ ≥ f x₂

/-
Dans l'exemple suivant, la commande
`On conclut par (hf : croissante f) appliqué à [x₁, x₂, h],`
spécialise en vol l'énoncé `hf` en lui fournissant deux nombres réels
et une hypothèse d'inégalité.
Le rappel du contenu de `hf` n'est là que pour faciliter la lecture, on
aurait pu écrire
`On conclut par hf appliqué à [x₁, x₂, h],`
-/

example (f g : ℝ → ℝ) (hf : croissante f) (hg : croissante g) : croissante (g ∘ f) :=
begin
  Soit x₁ x₂,
  Supposons h : x₁ ≤ x₂,
  Montrons que g (f x₁) ≤ g (f x₂), -- Cette ligne est facultative mais facilite la lecture
  Fait F1 : f x₁ ≤ f x₂,
    On conclut par (hf : croissante f) appliqué à [x₁, x₂, h],
  On conclut par (hg : croissante g) appliqué à [f x₁, f x₂, F1],
end

/-
On peut aussi utiliser la commande `Par ... appliqué à ... on obtient ...`
pour spécialiser un énoncé quantifié universellement, comme dans
la variante suivante.
-/

example (f g : ℝ → ℝ) (hf : croissante f) (hg : croissante g) : croissante (g ∘ f) :=
begin
  Soit x₁ x₂,
  Supposons h : x₁ ≤ x₂,
  Montrons que g (f x₁) ≤ g (f x₂),
  Par hf appliqué à [x₁, x₂, h] on obtient hf' : f x₁ ≤ f x₂,
  On conclut par hg appliqué à [f x₁, f x₂, hf'],
end

/-
Dans le morceau de commande `on obtient hf' : f x₁ ≤ f x₂`,
la partie `: f x₁ ≤ f x₂` est facultative, car Lean sait bien
ce qu'on obtient en appliquant `hf`, mais elle aide à passer à
la rédaction sur papier. On peut donc commencer par ne pas
l'utiliser lors de la recherche de démonstration puis la rajouter
avant de passer sur papier.

Voici encore une autre variante, avec `On applique` :
-/
example (f g : ℝ → ℝ) (hf : croissante f) (hg : croissante g) : croissante (g ∘ f) :=
begin
  Soit x₁ x₂,
  Supposons h : x₁ ≤ x₂,
  Montrons que g (f x₁) ≤ g (f x₂),
  On applique hf à [x₁, x₂, h],
  On conclut par hg appliqué à [f x₁, f x₂, hf],
end

/- Le même en raisonnant vers l'arrière. On remarquera que Lean se débrouille pour comprendre à
quels nombres réels appliquer les hypothèses de croissance. -/
example (f g : ℝ → ℝ) (hf : croissante f) (hg : croissante g) : croissante (g ∘ f) :=
begin
  Soit x₁ x₂,
  Supposons h : x₁ ≤ x₂,
  Montrons que (g ∘ f) x₁ ≤ (g ∘ f) x₂,
  Par hg il suffit de montrer que f x₁ ≤ f x₂,
  Par hf il suffit de montrer que x₁ ≤ x₂,
  On conclut par h,
end

example (f g : ℝ → ℝ) (hf : croissante f) (hg : decroissante g) : decroissante (g ∘ f) :=
begin
  sorry
end


-- Teorema_del_emparedado.lean
-- Teorema del emparedado
-- José A. Alonso Jiménez
-- Sevilla, 18 de julio de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- En Lean, una sucesión u₀, u₁, u₂, ... se puede representar mediante
-- una función (u : ℕ → ℝ) de forma que u(n) es uₙ.
--
-- Se define que a es el límite de la sucesión u, por
--    def limite : (ℕ → ℝ) → ℝ → Prop :=
--    λ u a, ∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - a| < ε
-- donde se usa la notación |x| para el valor absoluto de x
--    notation `|`x`|` := abs x
--
-- Demostrar que si para todo n, u(n) ≤ v(n) ≤ w(n) y u(n) tiene el
-- mismo límite que w(n), entonces v(n) también tiene dicho límite.
-- ---------------------------------------------------------------------

import data.real.basic

variables (u v w : ℕ → ℝ)
variable  (a : ℝ)

notation `|`x`|` := abs x

def limite : (ℕ → ℝ) → ℝ → Prop :=
λ u c, ∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - c| ≤ ε

-- Nota. En la demostración se usará el siguiente lema:
lemma max_ge_iff
  {p q r : ℕ}
  : r ≥ max p q ↔ r ≥ p ∧ r ≥ q :=
max_le_iff

-- 1ª demostración
-- ===============

example
  (hu : limite u a)
  (hw : limite w a)
  (h : ∀ n, u n ≤ v n)
  (h' : ∀ n, v n ≤ w n) :
  limite v a :=
begin
  intros ε hε,
  cases hu ε hε with N hN, clear hu,
  cases hw ε hε with N' hN', clear hw hε,
  use max N N',
  intros n hn,
  rw max_ge_iff at hn,
  specialize hN n hn.1,
  specialize hN' n hn.2,
  specialize h n,
  specialize h' n,
  clear hn,
  rw abs_le at *,
  split,
  { calc -ε
         ≤ u n - a : hN.1
     ... ≤ v n - a : by linarith, },
  { calc v n - a
         ≤ w n - a : by linarith
     ... ≤ ε       : hN'.2, },
end

-- 2ª demostración
example
  (hu : limite u a)
  (hw : limite w a)
  (h : ∀ n, u n ≤ v n)
  (h' : ∀ n, v n ≤ w n) :
  limite v a :=
begin
  intros ε hε,
  cases hu ε hε with N hN, clear hu,
  cases hw ε hε with N' hN', clear hw hε,
  use max N N',
  intros n hn,
  rw max_ge_iff at hn,
  specialize hN n (by linarith),
  specialize hN' n (by linarith),
  specialize h n,
  specialize h' n,
  rw abs_le at *,
  split,
  { linarith, },
  { linarith, },
end

-- 3ª demostración
example
  (hu : limite u a)
  (hw : limite w a)
  (h : ∀ n, u n ≤ v n)
  (h' : ∀ n, v n ≤ w n) :
  limite v a :=
begin
  intros ε hε,
  cases hu ε hε with N hN, clear hu,
  cases hw ε hε with N' hN', clear hw hε,
  use max N N',
  intros n hn,
  rw max_ge_iff at hn,
  specialize hN n (by linarith),
  specialize hN' n (by linarith),
  specialize h n,
  specialize h' n,
  rw abs_le at *,
  split ; linarith,
end

-- 4ª demostración
example
  (hu : limite u a)
  (hw : limite w a)
  (h : ∀ n, u n ≤ v n)
  (h' : ∀ n, v n ≤ w n) :
  limite v a :=
assume ε,
assume hε : ε > 0,
exists.elim (hu ε hε)
  ( assume N,
    assume hN : ∀ (n : ℕ), n ≥ N → |u n - a| ≤ ε,
    exists.elim (hw ε hε)
      ( assume N',
        assume hN' : ∀ (n : ℕ), n ≥ N' → |w n - a| ≤ ε,
        show ∃ N, ∀ n, n ≥ N → |v n - a| ≤ ε, from
          exists.intro (max N N')
            ( assume n,
              assume hn : n ≥ max N N',
              have h1 : n ≥ N ∧ n ≥ N',
                from max_ge_iff.mp hn,
              have h2 : -ε ≤ v n - a,
                { have h2a : |u n - a| ≤ ε,
                    from hN n h1.1,
                  calc -ε
                       ≤ u n - a : and.left (abs_le.mp h2a)
                   ... ≤ v n - a : by linarith [h n], },
              have h3 : v n - a ≤ ε,
                { have h3a : |w n - a| ≤ ε,
                    from hN' n h1.2,
                  calc v n - a
                       ≤ w n - a : by linarith [h' n]
                   ... ≤ ε       : and.right (abs_le.mp h3a), },
              show |v n - a| ≤ ε,
                from abs_le.mpr (and.intro h2 h3))))


-- La_equipotencia_es_una_relacion_reflexiva.lean
-- La equipotencia es una relación reflexiva
-- José A. Alonso Jiménez
-- Sevilla, 11 de agosto de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Dos conjuntos A y B son equipotentes (y se denota por A ≃ B) si
-- existe una aplicación biyectiva entre ellos. La equipotencia se puede
-- definir en Lean por
--    def es_equipotente (A B : Type*) :=
--      ∃ g : A → B, bijective g
--
--    infix ` ⋍ `: 50 := es_equipotente
--
-- Demostrar que la relación de equipotencia es reflexiva.
-- ---------------------------------------------------------------------

import tactic
open function

def es_equipotente (A B : Type*) :=
  ∃ g : A → B, bijective g

infix ` ⋍ `: 50 := es_equipotente

-- 1ª demostración
example : reflexive (⋍) :=
begin
  intro X,
  use id,
  exact bijective_id,
end

-- 2ª demostración
example : reflexive (⋍) :=
begin
  intro X,
  use [id, bijective_id],
end

-- 3ª demostración
example : reflexive (⋍) :=
λ X, ⟨id, bijective_id⟩

-- 4ª demostración
example : reflexive (⋍) :=
by tidy


import data.nat.basic

namespace hidden

axiom propext {a b : Prop} : (a ↔ b) → a = b

section
  variables a b c d e : Prop
  variable p : Prop → Prop

  theorem thm₁ (h : a ↔ b) : (c ∧ a ∧ d → e) ↔ (c ∧ b ∧ d → e) :=
  propext h ▸ iff.refl _

  theorem thm₂ (h : a ↔ b) (h₁ : p a) : p b :=
  propext h ▸ h₁

  #print axioms thm₁
end

universes u₁ u₂

#check (@funext : ∀ {α : Type u₁} {β : α → Type u₂}
           {f₁ f₂ : Π (x : α), β x},
         (∀ (x : α), f₁ x = f₂ x) → f₁ = f₂)

universe u

def set (α : Type u) := α → Prop

namespace set

variable {α : Type u}

definition mem (x : α) (a : set α) := a x
notation e ∈ a := mem e a

theorem setext {a b : set α} (h : ∀ x, x ∈ a ↔ x ∈ b) : a = b :=
funext (assume x, propext (h x))

definition empty : set α := λ x, false
local notation `∅` := empty

definition inter (a b : set α) : set α := λ x, x ∈ a ∧ x ∈ b
notation a ∩ b := inter a b

theorem inter_self (a : set α) : a ∩ a = a :=
setext (assume x, and_self _)

theorem inter_empty (a : set α) : a ∩ ∅ = ∅ :=
setext (assume x, and_false _)

theorem empty_inter (a : set α) : ∅ ∩ a = ∅ :=
setext (assume x, false_and _)

theorem inter.comm (a b : set α) : a ∩ b = b ∩ a :=
setext (assume x, and_comm _ _)

end set

def f₁ (x : ℕ) := x
def f₂ (x : ℕ) := 0 + x

theorem feq : f₁ = f₂ := funext (assume x, (zero_add x).symm)

def val : ℕ := eq.rec_on feq (0 : ℕ)

-- complicated!
#reduce val

-- evaluates to 0
#eval val

namespace quotient

private definition eqv {α : Type u} (p₁ p₂ : α × α) : Prop :=
(p₁.1 = p₂.1 ∧ p₁.2 = p₂.2) ∨ (p₁.1 = p₂.2 ∧ p₁.2 = p₂.1)

infix `~` := eqv

open or

private theorem eqv.refl {α : Type u} :
  ∀ p : α × α, p ~ p :=
assume p, inl ⟨rfl, rfl⟩

private theorem eqv.symm {α : Type u} :
  ∀ p₁ p₂ : α × α, p₁ ~ p₂ → p₂ ~ p₁
| (a₁, a₂) (b₁, b₂) (inl ⟨a₁b₁, a₂b₂⟩) :=
    inl ⟨symm a₁b₁, symm a₂b₂⟩
| (a₁, a₂) (b₁, b₂) (inr ⟨a₁b₂, a₂b₁⟩) :=
    inr ⟨symm a₂b₁, symm a₁b₂⟩

private theorem eqv.trans {α : Type u} :
  ∀ p₁ p₂ p₃ : α × α, p₁ ~ p₂ → p₂ ~ p₃ → p₁ ~ p₃
| (a₁, a₂) (b₁, b₂) (c₁, c₂)
    (inl ⟨a₁b₁, a₂b₂⟩) (inl ⟨b₁c₁, b₂c₂⟩) :=
  inl ⟨trans a₁b₁ b₁c₁, trans a₂b₂ b₂c₂⟩
| (a₁, a₂) (b₁, b₂) (c₁, c₂)
    (inl ⟨a₁b₁, a₂b₂⟩) (inr ⟨b₁c₂, b₂c₁⟩) :=
  inr ⟨trans a₁b₁ b₁c₂, trans a₂b₂ b₂c₁⟩
| (a₁, a₂) (b₁, b₂) (c₁, c₂)
    (inr ⟨a₁b₂, a₂b₁⟩) (inl ⟨b₁c₁, b₂c₂⟩) :=
  inr ⟨trans a₁b₂ b₂c₂, trans a₂b₁ b₁c₁⟩
| (a₁, a₂) (b₁, b₂) (c₁, c₂)
    (inr ⟨a₁b₂, a₂b₁⟩) (inr ⟨b₁c₂, b₂c₁⟩) :=
  inl ⟨trans a₁b₂ b₂c₁, trans a₂b₁ b₁c₂⟩

private theorem is_equivalence (α : Type u) :
  equivalence (@eqv α) :=
mk_equivalence (@eqv α) (@eqv.refl α) (@eqv.symm α)
  (@eqv.trans α)

instance uprod.setoid (α : Type u) : setoid (α × α) :=
setoid.mk (@eqv α) (is_equivalence α)

definition uprod (α : Type u) : Type u :=
quotient (uprod.setoid α)

namespace uprod
  definition mk {α : Type u} (a₁ a₂ : α) : uprod α :=
  ⟦(a₁, a₂)⟧

  local notation `{` a₁ `,` a₂ `}` := mk a₁ a₂

theorem mk_eq_mk {α : Type} (a₁ a₂ : α) :
    {a₁, a₂} = {a₂, a₁} :=
  quot.sound (inr ⟨rfl, rfl⟩)

private definition mem_fn {α : Type} (a : α) :
    α × α → Prop
  | (a₁, a₂) := a = a₁ ∨ a = a₂

  -- auxiliary lemma for proving mem_respects
  private lemma mem_swap {α : Type} {a : α} :
    ∀ {p : α × α}, mem_fn a p = mem_fn a (⟨p.2, p.1⟩)
  | (a₁, a₂) := propext (iff.intro
      (λ l : a = a₁ ∨ a = a₂,
        or.elim l (λ h₁, inr h₁) (λ h₂, inl h₂))
      (λ r : a = a₂ ∨ a = a₁,
        or.elim r (λ h₁, inr h₁) (λ h₂, inl h₂)))

  private lemma mem_respects {α : Type} :
    ∀ {p₁ p₂ : α × α} (a : α),
      p₁ ~ p₂ → mem_fn a p₁ = mem_fn a p₂
  | (a₁, a₂) (b₁, b₂) a (inl ⟨a₁b₁, a₂b₂⟩) :=
    by { dsimp at a₁b₁, dsimp at a₂b₂, rw [a₁b₁, a₂b₂] }
  | (a₁, a₂) (b₁, b₂) a (inr ⟨a₁b₂, a₂b₁⟩) :=
    by { dsimp at a₁b₂, dsimp at a₂b₁, rw [a₁b₂, a₂b₁],
          apply mem_swap }

  def mem {α : Type} (a : α) (u : uprod α) : Prop :=
  quot.lift_on u (λ p, mem_fn a p) (λ p₁ p₂ e, mem_respects a e)

  local infix `∈` := mem

  theorem mem_mk_left {α : Type} (a b : α) : a ∈ {a, b} :=
  inl rfl

  theorem mem_mk_right {α : Type} (a b : α) : b ∈ {a, b} :=
  inr rfl

  theorem mem_or_mem_of_mem_mk {α : Type} {a b c : α} :
    c ∈ {a, b} → c = a ∨ c = b :=
  λ h, h

end uprod

end quotient

namespace choice

class inductive nonempty (α : Sort u) : Prop
| intro : α → nonempty

example (α : Type u) : nonempty α ↔ ∃ x : α, true :=
iff.intro (λ ⟨a⟩, ⟨a, trivial⟩) (λ ⟨a, h⟩, ⟨a⟩)

axiom choice {α : Sort u} : nonempty α → α

noncomputable theorem indefinite_description
    {α : Sort u} (p : α → Prop) :
  (∃ x, p x) → {x // p x} :=
λ h, choice (let ⟨x, px⟩ := h in ⟨⟨x, px⟩⟩)

noncomputable def some {a : Sort u} {p : a → Prop}
  (h : ∃ x, p x) : a :=
subtype.val (indefinite_description p h)

theorem some_spec {a : Sort u} {p : a → Prop}
  (h : ∃ x, p x) : p (some h) :=
subtype.property (indefinite_description p h)

noncomputable theorem inhabited_of_nonempty {α : Type u} :
  nonempty α → inhabited α :=
λ h, choice (let ⟨a⟩ := h in ⟨⟨a⟩⟩)

end choice

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
-/
import data.bool.set
import data.nat.basic
import order.bounds

/-!
# Theory of complete lattices

## Main definitions

* `Sup` and `Inf` are the supremum and the infimum of a set;
* `supr (f : ι → α)` and `infi (f : ι → α)` are indexed supremum and infimum of a function,
  defined as `Sup` and `Inf` of the range of this function;
* `class complete_lattice`: a bounded lattice such that `Sup s` is always the least upper boundary
  of `s` and `Inf s` is always the greatest lower boundary of `s`;
* `class complete_linear_order`: a linear ordered complete lattice.

## Naming conventions

We use `Sup`/`Inf`/`supr`/`infi` for the corresponding functions in the statement. Sometimes we
also use `bsupr`/`binfi` for "bounded" supremum or infimum, i.e. one of `⨆ i ∈ s, f i`,
`⨆ i (hi : p i), f i`, or more generally `⨆ i (hi : p i), f i hi`.

## Notation

* `⨆ i, f i` : `supr f`, the supremum of the range of `f`;
* `⨅ i, f i` : `infi f`, the infimum of the range of `f`.
-/

set_option old_structure_cmd true
open set function

variables {α β β₂ : Type*} {ι ι₂ : Sort*}

/-- class for the `Sup` operator -/
class has_Sup (α : Type*) := (Sup : set α → α)
/-- class for the `Inf` operator -/
class has_Inf (α : Type*) := (Inf : set α → α)

export has_Sup (Sup) has_Inf (Inf)

/-- Supremum of a set -/
add_decl_doc has_Sup.Sup
/-- Infimum of a set -/
add_decl_doc has_Inf.Inf

/-- Indexed supremum -/
def supr [has_Sup α] {ι} (s : ι → α) : α := Sup (range s)
/-- Indexed infimum -/
def infi [has_Inf α] {ι} (s : ι → α) : α := Inf (range s)

@[priority 50] instance has_Inf_to_nonempty (α) [has_Inf α] : nonempty α := ⟨Inf ∅⟩
@[priority 50] instance has_Sup_to_nonempty (α) [has_Sup α] : nonempty α := ⟨Sup ∅⟩

notation `⨆` binders `, ` r:(scoped f, supr f) := r
notation `⨅` binders `, ` r:(scoped f, infi f) := r

instance (α) [has_Inf α] : has_Sup (order_dual α) := ⟨(Inf : set α → α)⟩
instance (α) [has_Sup α] : has_Inf (order_dual α) := ⟨(Sup : set α → α)⟩

/--
Note that we rarely use `complete_semilattice_Sup`
(in fact, any such object is always a `complete_lattice`, so it's usually best to start there).

Nevertheless it is sometimes a useful intermediate step in constructions.
-/
@[ancestor partial_order has_Sup]
class complete_semilattice_Sup (α : Type*) extends partial_order α, has_Sup α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)

section
variables [complete_semilattice_Sup α] {s t : set α} {a b : α}

@[ematch] theorem le_Sup : a ∈ s → a ≤ Sup s := complete_semilattice_Sup.le_Sup s a

theorem Sup_le : (∀b∈s, b ≤ a) → Sup s ≤ a := complete_semilattice_Sup.Sup_le s a

lemma is_lub_Sup (s : set α) : is_lub s (Sup s) := ⟨assume x, le_Sup, assume x, Sup_le⟩

lemma is_lub.Sup_eq (h : is_lub s a) : Sup s = a := (is_lub_Sup s).unique h

theorem le_Sup_of_le (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_Sup hb)

theorem Sup_le_Sup (h : s ⊆ t) : Sup s ≤ Sup t :=
(is_lub_Sup s).mono (is_lub_Sup t) h

@[simp] theorem Sup_le_iff : Sup s ≤ a ↔ (∀b ∈ s, b ≤ a) :=
is_lub_le_iff (is_lub_Sup s)

lemma le_Sup_iff : a ≤ Sup s ↔ (∀ b ∈ upper_bounds s, a ≤ b) :=
⟨λ h b hb, le_trans h (Sup_le hb), λ hb, hb _ (λ x, le_Sup)⟩

theorem Sup_le_Sup_of_forall_exists_le (h : ∀ x ∈ s, ∃ y ∈ t, x ≤ y) : Sup s ≤ Sup t :=
le_Sup_iff.2 $ λ b hb, Sup_le $ λ a ha, let ⟨c, hct, hac⟩ := h a ha in hac.trans (hb hct)

-- We will generalize this to conditionally complete lattices in `cSup_singleton`.
theorem Sup_singleton {a : α} : Sup {a} = a :=
is_lub_singleton.Sup_eq

end

/--
Note that we rarely use `complete_semilattice_Inf`
(in fact, any such object is always a `complete_lattice`, so it's usually best to start there).

Nevertheless it is sometimes a useful intermediate step in constructions.
-/
@[ancestor partial_order has_Inf]
class complete_semilattice_Inf (α : Type*) extends partial_order α, has_Inf α :=
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)

section
variables [complete_semilattice_Inf α] {s t : set α} {a b : α}

@[ematch] theorem Inf_le : a ∈ s → Inf s ≤ a := complete_semilattice_Inf.Inf_le s a

theorem le_Inf : (∀b∈s, a ≤ b) → a ≤ Inf s := complete_semilattice_Inf.le_Inf s a

lemma is_glb_Inf (s : set α) : is_glb s (Inf s) := ⟨assume a, Inf_le, assume a, le_Inf⟩

lemma is_glb.Inf_eq (h : is_glb s a) : Inf s = a := (is_glb_Inf s).unique h

theorem Inf_le_of_le (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (Inf_le hb) h

theorem Inf_le_Inf (h : s ⊆ t) : Inf t ≤ Inf s :=
(is_glb_Inf s).mono (is_glb_Inf t) h

@[simp] theorem le_Inf_iff : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
le_is_glb_iff (is_glb_Inf s)

lemma Inf_le_iff :
  Inf s ≤ a ↔ (∀ b, (∀ x ∈ s, b ≤ x) → b ≤ a) :=
⟨λ h b hb, le_trans (le_Inf hb) h, λ hb, hb _ (λ x, Inf_le)⟩

theorem Inf_le_Inf_of_forall_exists_le (h : ∀ x ∈ s, ∃ y ∈ t, y ≤ x) : Inf t ≤ Inf s :=
le_of_forall_le begin
  simp only [le_Inf_iff],
  introv h₀ h₁,
  rcases h _ h₁ with ⟨y,hy,hy'⟩,
  solve_by_elim [le_trans _ hy']
end

-- We will generalize this to conditionally complete lattices in `cInf_singleton`.
theorem Inf_singleton {a : α} : Inf {a} = a :=
is_glb_singleton.Inf_eq

end

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
@[protect_proj, ancestor lattice complete_semilattice_Sup complete_semilattice_Inf has_top has_bot]
class complete_lattice (α : Type*) extends
  lattice α, complete_semilattice_Sup α, complete_semilattice_Inf α, has_top α, has_bot α :=
(le_top : ∀ x : α, x ≤ ⊤)
(bot_le : ∀ x : α, ⊥ ≤ x)

@[priority 100]  -- see Note [lower instance priority]
instance complete_lattice.to_bounded_order [h : complete_lattice α] : bounded_order α :=
{ ..h }

/-- Create a `complete_lattice` from a `partial_order` and `Inf` function
that returns the greatest lower bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Sup, bot, top
  ..complete_lattice_of_Inf my_T _ }
```
-/
def complete_lattice_of_Inf (α : Type*) [H1 : partial_order α]
  [H2 : has_Inf α] (is_glb_Inf : ∀ s : set α, is_glb s (Inf s)) :
  complete_lattice α :=
{ bot := Inf univ,
  bot_le := λ x, (is_glb_Inf univ).1 trivial,
  top := Inf ∅,
  le_top := λ a, (is_glb_Inf ∅).2 $ by simp,
  sup := λ a b, Inf {x | a ≤ x ∧ b ≤ x},
  inf := λ a b, Inf {a, b},
  le_inf := λ a b c hab hac, by { apply (is_glb_Inf _).2, simp [*] },
  inf_le_right := λ a b, (is_glb_Inf _).1 $ mem_insert_of_mem _ $ mem_singleton _,
  inf_le_left := λ a b, (is_glb_Inf _).1 $ mem_insert _ _,
  sup_le := λ a b c hac hbc, (is_glb_Inf _).1 $ by simp [*],
  le_sup_left := λ a b, (is_glb_Inf _).2 $ λ x, and.left,
  le_sup_right := λ a b, (is_glb_Inf _).2 $ λ x, and.right,
  le_Inf := λ s a ha, (is_glb_Inf s).2 ha,
  Inf_le := λ s a ha, (is_glb_Inf s).1 ha,
  Sup := λ s, Inf (upper_bounds s),
  le_Sup := λ s a ha, (is_glb_Inf (upper_bounds s)).2 $ λ b hb, hb ha,
  Sup_le := λ s a ha, (is_glb_Inf (upper_bounds s)).1 ha,
  .. H1, .. H2 }

/--
Any `complete_semilattice_Inf` is in fact a `complete_lattice`.

Note that this construction has bad definitional properties:
see the doc-string on `complete_lattice_of_Inf`.
-/
def complete_lattice_of_complete_semilattice_Inf (α : Type*) [complete_semilattice_Inf α] :
  complete_lattice α :=
complete_lattice_of_Inf α (λ s, is_glb_Inf s)

/-- Create a `complete_lattice` from a `partial_order` and `Sup` function
that returns the least upper bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Inf, bot, top
  ..complete_lattice_of_Sup my_T _ }
```
-/
def complete_lattice_of_Sup (α : Type*) [H1 : partial_order α]
  [H2 : has_Sup α] (is_lub_Sup : ∀ s : set α, is_lub s (Sup s)) :
  complete_lattice α :=
{ top := Sup univ,
  le_top := λ x, (is_lub_Sup univ).1 trivial,
  bot := Sup ∅,
  bot_le := λ x, (is_lub_Sup ∅).2 $ by simp,
  sup := λ a b, Sup {a, b},
  sup_le := λ a b c hac hbc, (is_lub_Sup _).2 (by simp [*]),
  le_sup_left := λ a b, (is_lub_Sup _).1 $ mem_insert _ _,
  le_sup_right := λ a b, (is_lub_Sup _).1 $ mem_insert_of_mem _ $ mem_singleton _,
  inf := λ a b, Sup {x | x ≤ a ∧ x ≤ b},
  le_inf := λ a b c hab hac, (is_lub_Sup _).1 $ by simp [*],
  inf_le_left := λ a b, (is_lub_Sup _).2 (λ x, and.left),
  inf_le_right := λ a b, (is_lub_Sup _).2 (λ x, and.right),
  Inf := λ s, Sup (lower_bounds s),
  Sup_le := λ s a ha, (is_lub_Sup s).2 ha,
  le_Sup := λ s a ha, (is_lub_Sup s).1 ha,
  Inf_le := λ s a ha, (is_lub_Sup (lower_bounds s)).2 (λ b hb, hb ha),
  le_Inf := λ s a ha, (is_lub_Sup (lower_bounds s)).1 ha,
  .. H1, .. H2 }

/--
Any `complete_semilattice_Sup` is in fact a `complete_lattice`.

Note that this construction has bad definitional properties:
see the doc-string on `complete_lattice_of_Sup`.
-/
def complete_lattice_of_complete_semilattice_Sup (α : Type*) [complete_semilattice_Sup α] :
  complete_lattice α :=
complete_lattice_of_Sup α (λ s, is_lub_Sup s)

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type*) extends complete_lattice α,
  linear_order α renaming max → sup min → inf

namespace order_dual
variable (α)

instance [complete_lattice α] : complete_lattice (order_dual α) :=
{ le_Sup := @complete_lattice.Inf_le α _,
  Sup_le := @complete_lattice.le_Inf α _,
  Inf_le := @complete_lattice.le_Sup α _,
  le_Inf := @complete_lattice.Sup_le α _,
  .. order_dual.lattice α, ..order_dual.has_Sup α, ..order_dual.has_Inf α,
  .. order_dual.bounded_order α }

instance [complete_linear_order α] : complete_linear_order (order_dual α) :=
{ .. order_dual.complete_lattice α, .. order_dual.linear_order α }

end order_dual

section
variables [complete_lattice α] {s t : set α} {a b : α}

theorem Inf_le_Sup (hs : s.nonempty) : Inf s ≤ Sup s :=
is_glb_le_is_lub (is_glb_Inf s) (is_lub_Sup s) hs

theorem Sup_union {s t : set α} : Sup (s ∪ t) = Sup s ⊔ Sup t :=
((is_lub_Sup s).union (is_lub_Sup t)).Sup_eq

theorem Sup_inter_le {s t : set α} : Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
Sup_le $ λ b hb, le_inf (le_Sup hb.1) (le_Sup hb.2)
/-
  Sup_le (assume a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {s t : set α} : Inf (s ∪ t) = Inf s ⊓ Inf t :=
((is_glb_Inf s).union (is_glb_Inf t)).Inf_eq

theorem le_Inf_inter {s t : set α} : Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
@Sup_inter_le (order_dual α) _ _ _

@[simp] theorem Sup_empty : Sup ∅ = (⊥ : α) :=
(@is_lub_empty α _ _).Sup_eq

@[simp] theorem Inf_empty : Inf ∅ = (⊤ : α) :=
(@is_glb_empty α _ _).Inf_eq

@[simp] theorem Sup_univ : Sup univ = (⊤ : α) :=
(@is_lub_univ α _ _).Sup_eq

@[simp] theorem Inf_univ : Inf univ = (⊥ : α) :=
(@is_glb_univ α _ _).Inf_eq

-- TODO(Jeremy): get this automatically
@[simp] theorem Sup_insert {a : α} {s : set α} : Sup (insert a s) = a ⊔ Sup s :=
((is_lub_Sup s).insert a).Sup_eq

@[simp] theorem Inf_insert {a : α} {s : set α} : Inf (insert a s) = a ⊓ Inf s :=
((is_glb_Inf s).insert a).Inf_eq

theorem Sup_le_Sup_of_subset_insert_bot (h : s ⊆ insert ⊥ t) : Sup s ≤ Sup t :=
le_trans (Sup_le_Sup h) (le_of_eq (trans Sup_insert bot_sup_eq))

theorem Inf_le_Inf_of_subset_insert_top (h : s ⊆ insert ⊤ t) : Inf t ≤ Inf s :=
le_trans (le_of_eq (trans top_inf_eq.symm Inf_insert.symm)) (Inf_le_Inf h)

theorem Sup_pair {a b : α} : Sup {a, b} = a ⊔ b :=
(@is_lub_pair α _ a b).Sup_eq

theorem Inf_pair {a b : α} : Inf {a, b} = a ⊓ b :=
(@is_glb_pair α _ a b).Inf_eq

@[simp] theorem Inf_eq_top : Inf s = ⊤ ↔ (∀a∈s, a = ⊤) :=
iff.intro
  (assume h a ha, top_unique $ h ▸ Inf_le ha)
  (assume h, top_unique $ le_Inf $ assume a ha, top_le_iff.2 $ h a ha)

lemma eq_singleton_top_of_Inf_eq_top_of_nonempty {s : set α}
  (h_inf : Inf s = ⊤) (hne : s.nonempty) : s = {⊤} :=
by { rw set.eq_singleton_iff_nonempty_unique_mem, rw Inf_eq_top at h_inf, exact ⟨hne, h_inf⟩, }

@[simp] theorem Sup_eq_bot : Sup s = ⊥ ↔ (∀a∈s, a = ⊥) :=
@Inf_eq_top (order_dual α) _ _

lemma eq_singleton_bot_of_Sup_eq_bot_of_nonempty {s : set α}
  (h_sup : Sup s = ⊥) (hne : s.nonempty) : s = {⊥} :=
by { rw set.eq_singleton_iff_nonempty_unique_mem, rw Sup_eq_bot at h_sup, exact ⟨hne, h_sup⟩, }

/--Introduction rule to prove that `b` is the supremum of `s`: it suffices to check that `b`
is larger than all elements of `s`, and that this is not the case of any `w < b`.
See `cSup_eq_of_forall_le_of_forall_lt_exists_gt` for a version in conditionally complete
lattices. -/
theorem Sup_eq_of_forall_le_of_forall_lt_exists_gt (_ : ∀a∈s, a ≤ b)
  (H : ∀w, w < b → (∃a∈s, w < a)) : Sup s = b :=
have h : (Sup s < b) ∨ (Sup s = b) := lt_or_eq_of_le (Sup_le ‹∀a∈s, a ≤ b›),
have ¬(Sup s < b) :=
  assume: Sup s < b,
  let ⟨a, _, _⟩ := (H (Sup s) ‹Sup s < b›) in  /- a ∈ s, Sup s < a-/
  have Sup s < Sup s := lt_of_lt_of_le ‹Sup s < a› (le_Sup ‹a ∈ s›),
  show false, from lt_irrefl _ this,
show Sup s = b, from or.resolve_left h this

/--Introduction rule to prove that `b` is the infimum of `s`: it suffices to check that `b`
is smaller than all elements of `s`, and that this is not the case of any `w > b`.
See `cInf_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in conditionally complete
lattices. -/
theorem Inf_eq_of_forall_ge_of_forall_gt_exists_lt (_ : ∀a∈s, b ≤ a)
  (H : ∀w, b < w → (∃a∈s, a < w)) : Inf s = b :=
@Sup_eq_of_forall_le_of_forall_lt_exists_gt (order_dual α) _ _ ‹_› ‹_› ‹_›

end

section complete_linear_order
variables [complete_linear_order α] {s t : set α} {a b : α}

lemma Inf_lt_iff : Inf s < b ↔ (∃a∈s, a < b) :=
is_glb_lt_iff (is_glb_Inf s)

lemma lt_Sup_iff : b < Sup s ↔ (∃a∈s, b < a) :=
lt_is_lub_iff (is_lub_Sup s)

lemma Sup_eq_top : Sup s = ⊤ ↔ (∀b<⊤, ∃a∈s, b < a) :=
iff.intro
  (assume (h : Sup s = ⊤) b hb, by rwa [←h, lt_Sup_iff] at hb)
  (assume h, top_unique $ le_of_not_gt $ assume h',
    let ⟨a, ha, h⟩ := h _ h' in
    lt_irrefl a $ lt_of_le_of_lt (le_Sup ha) h)

lemma Inf_eq_bot : Inf s = ⊥ ↔ (∀b>⊥, ∃a∈s, a < b) :=
@Sup_eq_top (order_dual α) _ _

lemma lt_supr_iff {f : ι → α} : a < supr f ↔ (∃i, a < f i) :=
lt_Sup_iff.trans exists_range_iff

lemma infi_lt_iff {f : ι → α} : infi f < a ↔ (∃i, f i < a) :=
Inf_lt_iff.trans exists_range_iff

end complete_linear_order

/-
### supr & infi
-/

section
variables [complete_lattice α] {s t : ι → α} {a b : α}

-- TODO: this declaration gives error when starting smt state
--@[ematch]
theorem le_supr (s : ι → α) (i : ι) : s i ≤ supr s :=
le_Sup ⟨i, rfl⟩

@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i ≤ supr s :) :=
le_Sup ⟨i, rfl⟩

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i :) ≤ (: supr s :) :=
le_Sup ⟨i, rfl⟩
-/

lemma is_lub_supr : is_lub (range s) (⨆j, s j) := is_lub_Sup _

lemma is_lub.supr_eq (h : is_lub (range s) a) : (⨆j, s j) = a := h.Sup_eq

lemma is_glb_infi : is_glb (range s) (⨅j, s j) := is_glb_Inf _

lemma is_glb.infi_eq (h : is_glb (range s) a) : (⨅j, s j) = a := h.Inf_eq

theorem le_supr_of_le (i : ι) (h : a ≤ s i) : a ≤ supr s :=
le_trans h (le_supr _ i)

theorem le_bsupr {p : ι → Prop} {f : Π i (h : p i), α} (i : ι) (hi : p i) :
  f i hi ≤ ⨆ i hi, f i hi :=
le_supr_of_le i $ le_supr (f i) hi

theorem le_bsupr_of_le {p : ι → Prop} {f : Π i (h : p i), α} (i : ι) (hi : p i) (h : a ≤ f i hi) :
  a ≤ ⨆ i hi, f i hi :=
le_trans h (le_bsupr i hi)

theorem supr_le (h : ∀i, s i ≤ a) : supr s ≤ a :=
Sup_le $ assume b ⟨i, eq⟩, eq ▸ h i

theorem bsupr_le {p : ι → Prop} {f : Π i (h : p i), α} (h : ∀ i hi, f i hi ≤ a) :
  (⨆ i (hi : p i), f i hi) ≤ a :=
supr_le $ λ i, supr_le $ h i

theorem bsupr_le_supr (p : ι → Prop) (f : ι → α) : (⨆ i (H : p i), f i) ≤ ⨆ i, f i :=
bsupr_le (λ i hi, le_supr f i)

theorem supr_le_supr (h : ∀i, s i ≤ t i) : supr s ≤ supr t :=
supr_le $ assume i, le_supr_of_le i (h i)

theorem supr_le_supr2 {t : ι₂ → α} (h : ∀i, ∃j, s i ≤ t j) : supr s ≤ supr t :=
supr_le $ assume j, exists.elim (h j) le_supr_of_le

theorem bsupr_le_bsupr {p : ι → Prop} {f g : Π i (hi : p i), α} (h : ∀ i hi, f i hi ≤ g i hi) :
  (⨆ i hi, f i hi) ≤ ⨆ i hi, g i hi :=
bsupr_le $ λ i hi, le_trans (h i hi) (le_bsupr i hi)

theorem supr_le_supr_const (h : ι → ι₂) : (⨆ i:ι, a) ≤ (⨆ j:ι₂, a) :=
supr_le $ le_supr _ ∘ h

theorem bsupr_le_bsupr' {p q : ι → Prop} (hpq : ∀ i, p i → q i) {f : ι → α} :
  (⨆ i (hpi : p i), f i) ≤ ⨆ i (hqi : q i), f i :=
supr_le_supr $ λ i, supr_le_supr_const (hpq i)

@[simp] theorem supr_le_iff : supr s ≤ a ↔ (∀i, s i ≤ a) :=
(is_lub_le_iff is_lub_supr).trans forall_range_iff

theorem supr_lt_iff : supr s < a ↔ ∃ b < a, ∀ i, s i ≤ b :=
⟨λ h, ⟨supr s, h, λ i, le_supr s i⟩, λ ⟨b, hba, hsb⟩, (supr_le hsb).trans_lt hba⟩

theorem Sup_eq_supr {s : set α} : Sup s = (⨆a ∈ s, a) :=
le_antisymm
  (Sup_le $ assume b h, le_supr_of_le b $ le_supr _ h)
  (supr_le $ assume b, supr_le $ assume h, le_Sup h)

lemma Sup_eq_supr' {α} [has_Sup α] (s : set α) : Sup s = ⨆ x : s, (x : α) :=
by rw [supr, subtype.range_coe]

lemma Sup_sUnion {s : set (set α)} :
  Sup (⋃₀ s) = ⨆ (t ∈ s), Sup t :=
begin
  apply le_antisymm,
  { apply Sup_le (λ b hb, _),
    rcases hb with ⟨t, ts, bt⟩,
    apply le_trans _ (le_supr _ t),
    exact le_trans (le_Sup bt) (le_supr _ ts), },
  { apply supr_le (λ t, _),
    exact supr_le (λ ts, Sup_le_Sup (λ x xt, ⟨t, ts, xt⟩)) }
end

lemma le_supr_iff : (a ≤ supr s) ↔ (∀ b, (∀ i, s i ≤ b) → a ≤ b) :=
⟨λ h b hb, le_trans h (supr_le hb), λ h, h _ $ λ i, le_supr s i⟩

lemma monotone.le_map_supr [complete_lattice β] {f : α → β} (hf : monotone f) :
  (⨆ i, f (s i)) ≤ f (supr s) :=
supr_le $ λ i, hf $ le_supr _ _

lemma monotone.le_map_supr2 [complete_lattice β] {f : α → β} (hf : monotone f)
  {ι' : ι → Sort*} (s : Π i, ι' i → α) :
  (⨆ i (h : ι' i), f (s i h)) ≤ f (⨆ i (h : ι' i), s i h) :=
calc (⨆ i h, f (s i h)) ≤ (⨆ i, f (⨆ h, s i h)) :
  supr_le_supr $ λ i, hf.le_map_supr
... ≤ f (⨆ i (h : ι' i), s i h) : hf.le_map_supr

lemma monotone.le_map_Sup [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) :
  (⨆a∈s, f a) ≤ f (Sup s) :=
by rw [Sup_eq_supr]; exact hf.le_map_supr2 _

lemma order_iso.map_supr [complete_lattice β] (f : α ≃o β) (x : ι → α) :
  f (⨆ i, x i) = ⨆ i, f (x i) :=
eq_of_forall_ge_iff $ f.surjective.forall.2 $ λ x,
  by simp only [f.le_iff_le, supr_le_iff]

lemma order_iso.map_Sup [complete_lattice β] (f : α ≃o β) (s : set α) :
  f (Sup s) = ⨆ a ∈ s, f a :=
by simp only [Sup_eq_supr, order_iso.map_supr]

lemma supr_comp_le {ι' : Sort*} (f : ι' → α) (g : ι → ι') :
  (⨆ x, f (g x)) ≤ ⨆ y, f y :=
supr_le_supr2 $ λ x, ⟨_, le_rfl⟩

lemma monotone.supr_comp_eq [preorder β] {f : β → α} (hf : monotone f)
  {s : ι → β} (hs : ∀ x, ∃ i, x ≤ s i) :
  (⨆ x, f (s x)) = ⨆ y, f y :=
le_antisymm (supr_comp_le _ _) (supr_le_supr2 $ λ x, (hs x).imp $ λ i hi, hf hi)

lemma function.surjective.supr_comp {α : Type*} [has_Sup α] {f : ι → ι₂}
  (hf : surjective f) (g : ι₂ → α) :
  (⨆ x, g (f x)) = ⨆ y, g y :=
by simp only [supr, hf.range_comp]

lemma supr_congr {α : Type*} [has_Sup α] {f : ι → α} {g : ι₂ → α} (h : ι → ι₂)
  (h1 : surjective h) (h2 : ∀ x, g (h x) = f x) : (⨆ x, f x) = ⨆ y, g y :=
by { convert h1.supr_comp g, exact (funext h2).symm }

-- TODO: finish doesn't do well here.
@[congr] theorem supr_congr_Prop {α : Type*} [has_Sup α] {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : supr f₁ = supr f₂ :=
begin
  have := propext pq, subst this,
  congr' with x,
  apply f
end

theorem infi_le (s : ι → α) (i : ι) : infi s ≤ s i :=
Inf_le ⟨i, rfl⟩

@[ematch] theorem infi_le' (s : ι → α) (i : ι) : (: infi s ≤ s i :) :=
Inf_le ⟨i, rfl⟩

theorem infi_le_of_le (i : ι) (h : s i ≤ a) : infi s ≤ a :=
le_trans (infi_le _ i) h

theorem binfi_le {p : ι → Prop} {f : Π i (hi : p i), α} (i : ι) (hi : p i) :
  (⨅ i hi, f i hi) ≤ f i hi :=
infi_le_of_le i $ infi_le (f i) hi

theorem binfi_le_of_le {p : ι → Prop} {f : Π i (hi : p i), α} (i : ι) (hi : p i) (h : f i hi ≤ a) :
  (⨅ i hi, f i hi) ≤ a :=
le_trans (binfi_le i hi) h

theorem le_infi (h : ∀i, a ≤ s i) : a ≤ infi s :=
le_Inf $ assume b ⟨i, eq⟩, eq ▸ h i

theorem le_binfi {p : ι → Prop} {f : Π i (h : p i), α} (h : ∀ i hi, a ≤ f i hi) :
  a ≤ ⨅ i hi, f i hi :=
le_infi $ λ i, le_infi $ h i

theorem infi_le_binfi (p : ι → Prop) (f : ι → α) : (⨅ i, f i) ≤ ⨅ i (H : p i), f i :=
le_binfi (λ i hi, infi_le f i)

theorem infi_le_infi (h : ∀i, s i ≤ t i) : infi s ≤ infi t :=
le_infi $ assume i, infi_le_of_le i (h i)

theorem infi_le_infi2 {t : ι₂ → α} (h : ∀j, ∃i, s i ≤ t j) : infi s ≤ infi t :=
le_infi $ assume j, exists.elim (h j) infi_le_of_le

theorem binfi_le_binfi {p : ι → Prop} {f g : Π i (h : p i), α} (h : ∀ i hi, f i hi ≤ g i hi) :
  (⨅ i hi, f i hi) ≤ ⨅ i hi, g i hi :=
le_binfi $ λ i hi, le_trans (binfi_le i hi) (h i hi)

theorem infi_le_infi_const (h : ι₂ → ι) : (⨅ i:ι, a) ≤ (⨅ j:ι₂, a) :=
le_infi $ infi_le _ ∘ h

@[simp] theorem le_infi_iff : a ≤ infi s ↔ (∀i, a ≤ s i) :=
⟨assume : a ≤ infi s, assume i, le_trans this (infi_le _ _), le_infi⟩

theorem Inf_eq_infi {s : set α} : Inf s = (⨅a ∈ s, a) :=
@Sup_eq_supr (order_dual α) _ _

theorem Inf_eq_infi' {α} [has_Inf α] (s : set α) : Inf s = ⨅ a : s, a :=
@Sup_eq_supr' (order_dual α) _ _

lemma monotone.map_infi_le [complete_lattice β] {f : α → β} (hf : monotone f) :
  f (infi s) ≤ (⨅ i, f (s i)) :=
le_infi $ λ i, hf $ infi_le _ _

lemma monotone.map_infi2_le [complete_lattice β] {f : α → β} (hf : monotone f)
  {ι' : ι → Sort*} (s : Π i, ι' i → α) :
  f (⨅ i (h : ι' i), s i h) ≤ (⨅ i (h : ι' i), f (s i h)) :=
@monotone.le_map_supr2 (order_dual α) (order_dual β) _ _ _ f hf.dual _ _

lemma monotone.map_Inf_le [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) :
  f (Inf s) ≤ ⨅ a∈s, f a :=
by rw [Inf_eq_infi]; exact hf.map_infi2_le _

lemma order_iso.map_infi [complete_lattice β] (f : α ≃o β) (x : ι → α) :
  f (⨅ i, x i) = ⨅ i, f (x i) :=
order_iso.map_supr f.dual _

lemma order_iso.map_Inf [complete_lattice β] (f : α ≃o β) (s : set α) :
  f (Inf s) = ⨅ a ∈ s, f a :=
order_iso.map_Sup f.dual _

lemma le_infi_comp {ι' : Sort*} (f : ι' → α) (g : ι → ι') :
  (⨅ y, f y) ≤ ⨅ x, f (g x) :=
infi_le_infi2 $ λ x, ⟨_, le_rfl⟩

lemma monotone.infi_comp_eq [preorder β] {f : β → α} (hf : monotone f)
  {s : ι → β} (hs : ∀ x, ∃ i, s i ≤ x) :
  (⨅ x, f (s x)) = ⨅ y, f y :=
le_antisymm (infi_le_infi2 $ λ x, (hs x).imp $ λ i hi, hf hi) (le_infi_comp _ _)

lemma function.surjective.infi_comp {α : Type*} [has_Inf α] {f : ι → ι₂}
  (hf : surjective f) (g : ι₂ → α) :
  (⨅ x, g (f x)) = ⨅ y, g y :=
@function.surjective.supr_comp _ _ (order_dual α) _ f hf g

lemma infi_congr {α : Type*} [has_Inf α] {f : ι → α} {g : ι₂ → α} (h : ι → ι₂)
  (h1 : surjective h) (h2 : ∀ x, g (h x) = f x) : (⨅ x, f x) = ⨅ y, g y :=
@supr_congr _ _ (order_dual α) _ _ _ h h1 h2

@[congr] theorem infi_congr_Prop {α : Type*} [has_Inf α] {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : infi f₁ = infi f₂ :=
@supr_congr_Prop (order_dual α) _ p q f₁ f₂ pq f

lemma supr_const_le {x : α} : (⨆ (h : ι), x) ≤ x :=
supr_le (λ _, le_rfl)

lemma le_infi_const {x : α} : x ≤ (⨅ (h : ι), x) :=
le_infi (λ _, le_rfl)

-- We will generalize this to conditionally complete lattices in `cinfi_const`.
theorem infi_const [nonempty ι] {a : α} : (⨅ b:ι, a) = a :=
by rw [infi, range_const, Inf_singleton]

-- We will generalize this to conditionally complete lattices in `csupr_const`.
theorem supr_const [nonempty ι] {a : α} : (⨆ b:ι, a) = a :=
@infi_const (order_dual α) _ _ _ _

@[simp] lemma infi_top : (⨅i:ι, ⊤ : α) = ⊤ :=
top_unique $ le_infi $ assume i, le_rfl

@[simp] lemma supr_bot : (⨆i:ι, ⊥ : α) = ⊥ :=
@infi_top (order_dual α) _ _

@[simp] lemma infi_eq_top : infi s = ⊤ ↔ (∀i, s i = ⊤) :=
Inf_eq_top.trans forall_range_iff

@[simp] lemma supr_eq_bot : supr s = ⊥ ↔ (∀i, s i = ⊥) :=
Sup_eq_bot.trans forall_range_iff

@[simp] lemma infi_pos {p : Prop} {f : p → α} (hp : p) : (⨅ h : p, f h) = f hp :=
le_antisymm (infi_le _ _) (le_infi $ assume h, le_rfl)

@[simp] lemma infi_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨅ h : p, f h) = ⊤ :=
le_antisymm le_top $ le_infi $ assume h, (hp h).elim

@[simp] lemma supr_pos {p : Prop} {f : p → α} (hp : p) : (⨆ h : p, f h) = f hp :=
le_antisymm (supr_le $ assume h, le_rfl) (le_supr _ _)

@[simp] lemma supr_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨆ h : p, f h) = ⊥ :=
le_antisymm (supr_le $ assume h, (hp h).elim) bot_le

/--Introduction rule to prove that `b` is the supremum of `f`: it suffices to check that `b`
is larger than `f i` for all `i`, and that this is not the case of any `w<b`.
See `csupr_eq_of_forall_le_of_forall_lt_exists_gt` for a version in conditionally complete
lattices. -/
theorem supr_eq_of_forall_le_of_forall_lt_exists_gt {f : ι → α} (h₁ : ∀ i, f i ≤ b)
  (h₂ : ∀ w, w < b → (∃ i, w < f i)) : (⨆ (i : ι), f i) = b :=
Sup_eq_of_forall_le_of_forall_lt_exists_gt (forall_range_iff.mpr h₁)
  (λ w hw, exists_range_iff.mpr $ h₂ w hw)

/--Introduction rule to prove that `b` is the infimum of `f`: it suffices to check that `b`
is smaller than `f i` for all `i`, and that this is not the case of any `w>b`.
See `cinfi_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in conditionally complete
lattices. -/
theorem infi_eq_of_forall_ge_of_forall_gt_exists_lt {f : ι → α} (h₁ : ∀ i, b ≤ f i)
(h₂ : ∀ w, b < w → (∃ i, f i < w)) : (⨅ (i : ι), f i) = b :=
@supr_eq_of_forall_le_of_forall_lt_exists_gt (order_dual α) _ _ _ ‹_› ‹_› ‹_›

lemma supr_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨆h:p, a h) = (if h : p then a h else ⊥) :=
by by_cases p; simp [h]

lemma supr_eq_if {p : Prop} [decidable p] (a : α) :
  (⨆h:p, a) = (if p then a else ⊥) :=
supr_eq_dif (λ _, a)

lemma infi_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨅h:p, a h) = (if h : p then a h else ⊤) :=
@supr_eq_dif (order_dual α) _ _ _ _

lemma infi_eq_if {p : Prop} [decidable p] (a : α) :
  (⨅h:p, a) = (if p then a else ⊤) :=
infi_eq_dif (λ _, a)

-- TODO: should this be @[simp]?
theorem infi_comm {f : ι → ι₂ → α} : (⨅i, ⨅j, f i j) = (⨅j, ⨅i, f i j) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le_of_le j $ infi_le _ i)
  (le_infi $ assume j, le_infi $ assume i, infi_le_of_le i $ infi_le _ j)

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

-- TODO: should this be @[simp]?
theorem supr_comm {f : ι → ι₂ → α} : (⨆i, ⨆j, f i j) = (⨆j, ⨆i, f i j) :=
@infi_comm (order_dual α) _ _ _ _

@[simp] theorem infi_infi_eq_left {b : β} {f : Πx:β, x = b → α} :
  (⨅x, ⨅h:x = b, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_rfl end)

@[simp] theorem infi_infi_eq_right {b : β} {f : Πx:β, b = x → α} :
  (⨅x, ⨅h:b = x, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_rfl end)

@[simp] theorem supr_supr_eq_left {b : β} {f : Πx:β, x = b → α} :
  (⨆x, ⨆h : x = b, f x h) = f b rfl :=
@infi_infi_eq_left (order_dual α) _ _ _ _

@[simp] theorem supr_supr_eq_right {b : β} {f : Πx:β, b = x → α} :
  (⨆x, ⨆h : b = x, f x h) = f b rfl :=
@infi_infi_eq_right (order_dual α) _ _ _ _

attribute [ematch] le_refl

theorem infi_subtype {p : ι → Prop} {f : subtype p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

lemma infi_subtype' {p : ι → Prop} {f : ∀ i, p i → α} :
  (⨅ i (h : p i), f i h) = (⨅ x : subtype p, f x x.property) :=
(@infi_subtype _ _ _ p (λ x, f x.val x.property)).symm

lemma infi_subtype'' {ι} (s : set ι) (f : ι → α) :
  (⨅ i : s, f i) = ⨅ (t : ι) (H : t ∈ s), f t :=
infi_subtype

theorem infi_inf_eq {f g : ι → α} : (⨅ x, f x ⊓ g x) = (⨅ x, f x) ⊓ (⨅ x, g x) :=
le_antisymm
  (le_inf
    (le_infi $ assume i, infi_le_of_le i inf_le_left)
    (le_infi $ assume i, infi_le_of_le i inf_le_right))
  (le_infi $ assume i, le_inf
    (inf_le_of_left_le $ infi_le _ _)
    (inf_le_of_right_le $ infi_le _ _))

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

lemma infi_inf [h : nonempty ι] {f : ι → α} {a : α} : (⨅x, f x) ⊓ a = (⨅ x, f x ⊓ a) :=
by rw [infi_inf_eq, infi_const]

lemma inf_infi [nonempty ι] {f : ι → α} {a : α} : a ⊓ (⨅x, f x) = (⨅ x, a ⊓ f x) :=
by rw [inf_comm, infi_inf]; simp [inf_comm]

lemma binfi_inf {p : ι → Prop} {f : Π i (hi : p i), α} {a : α} (h : ∃ i, p i) :
  (⨅i (h : p i), f i h) ⊓ a = (⨅ i (h : p i), f i h ⊓ a) :=
by haveI : nonempty {i // p i} := (let ⟨i, hi⟩ := h in ⟨⟨i, hi⟩⟩);
  rw [infi_subtype', infi_subtype', infi_inf]

lemma inf_binfi {p : ι → Prop} {f : Π i (hi : p i), α} {a : α} (h : ∃ i, p i) :
  a ⊓ (⨅i (h : p i), f i h) = (⨅ i (h : p i), a ⊓ f i h) :=
by simpa only [inf_comm] using binfi_inf h

theorem supr_sup_eq {f g : ι → α} : (⨆ x, f x ⊔ g x) = (⨆ x, f x) ⊔ (⨆ x, g x) :=
@infi_inf_eq (order_dual α) ι _ _ _

lemma supr_sup [h : nonempty ι] {f : ι → α} {a : α} : (⨆ x, f x) ⊔ a = (⨆ x, f x ⊔ a) :=
@infi_inf (order_dual α) _ _ _ _ _

lemma sup_supr [nonempty ι] {f : ι → α} {a : α} : a ⊔ (⨆ x, f x) = (⨆ x, a ⊔ f x) :=
@inf_infi (order_dual α) _ _ _ _ _

/-! ### `supr` and `infi` under `Prop` -/

@[simp] theorem infi_false {s : false → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ assume i, false.elim i)

@[simp] theorem supr_false {s : false → α} : supr s = ⊥ :=
le_antisymm (supr_le $ assume i, false.elim i) bot_le

theorem infi_true {s : true → α} : infi s = s trivial :=
infi_pos trivial

theorem supr_true {s : true → α} : supr s = s trivial :=
supr_pos trivial

@[simp] theorem infi_exists {p : ι → Prop} {f : Exists p → α} :
  (⨅ x, f x) = (⨅ i, ⨅ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

@[simp] theorem supr_exists {p : ι → Prop} {f : Exists p → α} :
  (⨆ x, f x) = (⨆ i, ⨆ h:p i, f ⟨i, h⟩) :=
@infi_exists (order_dual α) _ _ _ _

theorem infi_and {p q : Prop} {s : p ∧ q → α} : infi s = (⨅ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

/-- The symmetric case of `infi_and`, useful for rewriting into a infimum over a conjunction -/
lemma infi_and' {p q : Prop} {s : p → q → α} :
  (⨅ (h₁ : p) (h₂ : q), s h₁ h₂) = ⨅ (h : p ∧ q), s h.1 h.2 :=
by { symmetry, exact infi_and }

theorem supr_and {p q : Prop} {s : p ∧ q → α} : supr s = (⨆ h₁ h₂, s ⟨h₁, h₂⟩) :=
@infi_and (order_dual α) _ _ _ _

/-- The symmetric case of `supr_and`, useful for rewriting into a supremum over a conjunction -/
lemma supr_and' {p q : Prop} {s : p → q → α} :
  (⨆ (h₁ : p) (h₂ : q), s h₁ h₂) = ⨆ (h : p ∧ q), s h.1 h.2 :=
by { symmetry, exact supr_and }

theorem infi_or {p q : Prop} {s : p ∨ q → α} :
  infi s = (⨅ h : p, s (or.inl h)) ⊓ (⨅ h : q, s (or.inr h)) :=
le_antisymm
  (le_inf
    (infi_le_infi2 $ assume j, ⟨_, le_rfl⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_rfl⟩))
  (le_infi $ assume i, match i with
  | or.inl i := inf_le_of_left_le $ infi_le _ _
  | or.inr j := inf_le_of_right_le $ infi_le _ _
  end)

theorem supr_or {p q : Prop} {s : p ∨ q → α} :
  (⨆ x, s x) = (⨆ i, s (or.inl i)) ⊔ (⨆ j, s (or.inr j)) :=
@infi_or (order_dual α) _ _ _ _

section

variables (p : ι → Prop) [decidable_pred p]

lemma supr_dite (f : Π i, p i → α) (g : Π i, ¬p i → α) :
  (⨆ i, if h : p i then f i h else g i h) = (⨆ i (h : p i), f i h) ⊔ (⨆ i (h : ¬ p i), g i h) :=
begin
  rw ←supr_sup_eq,
  congr' 1 with i,
  split_ifs with h;
  simp [h],
end

lemma supr_ite (f g : ι → α) :
  (⨆ i, if p i then f i else g i) = (⨆ i (h : p i), f i) ⊔ (⨆ i (h : ¬ p i), g i) :=
supr_dite _ _ _

lemma infi_dite (f : Π i, p i → α) (g : Π i, ¬p i → α) :
  (⨅ i, if h : p i then f i h else g i h) = (⨅ i (h : p i), f i h) ⊓ (⨅ i (h : ¬ p i), g i h) :=
supr_dite p (show Π i, p i → order_dual α, from f) g

lemma infi_ite (f g : ι → α) :
  (⨅ i, if p i then f i else g i) = (⨅ i (h : p i), f i) ⊓ (⨅ i (h : ¬ p i), g i) :=
infi_dite _ _ _

end

lemma Sup_range {α : Type*} [has_Sup α] {f : ι → α} : Sup (range f) = supr f := rfl

lemma Inf_range {α : Type*} [has_Inf α] {f : ι → α} : Inf (range f) = infi f := rfl

lemma supr_range' {α} [has_Sup α] (g : β → α) (f : ι → β) :
  (⨆ b : range f, g b) = ⨆ i, g (f i) :=
by rw [supr, supr, ← image_eq_range, ← range_comp]

lemma infi_range' {α} [has_Inf α] (g : β → α) (f : ι → β) :
  (⨅ b : range f, g b) = ⨅ i, g (f i) :=
@supr_range' _ _ (order_dual α) _ _ _

lemma infi_range {g : β → α} {f : ι → β} : (⨅b∈range f, g b) = (⨅i, g (f i)) :=
by rw [← infi_subtype'', infi_range']

lemma supr_range {g : β → α} {f : ι → β} : (⨆b∈range f, g b) = (⨆i, g (f i)) :=
@infi_range (order_dual α) _ _ _ _ _

theorem Inf_image' {α} [has_Inf α] {s : set β} {f : β → α} :
  Inf (f '' s) = (⨅ a : s, f a) :=
by rw [infi, image_eq_range]

theorem Sup_image' {α} [has_Sup α] {s : set β} {f : β → α} :
  Sup (f '' s) = (⨆ a : s, f a) :=
@Inf_image' _ (order_dual α) _ _ _

theorem Inf_image {s : set β} {f : β → α} : Inf (f '' s) = (⨅ a ∈ s, f a) :=
by rw [← infi_subtype'', Inf_image']

theorem Sup_image {s : set β} {f : β → α} : Sup (f '' s) = (⨆ a ∈ s, f a) :=
@Inf_image (order_dual α) _ _ _ _

/-
### supr and infi under set constructions
-/

theorem infi_emptyset {f : β → α} : (⨅ x ∈ (∅ : set β), f x) = ⊤ :=
by simp

theorem supr_emptyset {f : β → α} : (⨆ x ∈ (∅ : set β), f x) = ⊥ :=
by simp

theorem infi_univ {f : β → α} : (⨅ x ∈ (univ : set β), f x) = (⨅ x, f x) :=
by simp

theorem supr_univ {f : β → α} : (⨆ x ∈ (univ : set β), f x) = (⨆ x, f x) :=
by simp

theorem infi_union {f : β → α} {s t : set β} : (⨅ x ∈ s ∪ t, f x) = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) :=
by simp only [← infi_inf_eq, infi_or]

lemma infi_split (f : β → α) (p : β → Prop) :
  (⨅ i, f i) = (⨅ i (h : p i), f i) ⊓ (⨅ i (h : ¬ p i), f i) :=
by simpa [classical.em] using @infi_union _ _ _ f {i | p i} {i | ¬ p i}

lemma infi_split_single (f : β → α) (i₀ : β) :
  (⨅ i, f i) = f i₀ ⊓ (⨅ i (h : i ≠ i₀), f i) :=
by convert infi_split _ _; simp

theorem infi_le_infi_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨅ x ∈ t, f x) ≤ (⨅ x ∈ s, f x) :=
by rw [(union_eq_self_of_subset_left h).symm, infi_union]; exact inf_le_left

theorem supr_union {f : β → α} {s t : set β} : (⨆ x ∈ s ∪ t, f x) = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) :=
@infi_union (order_dual α) _ _ _ _ _

lemma supr_split (f : β → α) (p : β → Prop) :
  (⨆ i, f i) = (⨆ i (h : p i), f i) ⊔ (⨆ i (h : ¬ p i), f i) :=
@infi_split (order_dual α) _ _ _ _

lemma supr_split_single (f : β → α) (i₀ : β) :
  (⨆ i, f i) = f i₀ ⊔ (⨆ i (h : i ≠ i₀), f i) :=
@infi_split_single (order_dual α) _ _ _ _

theorem supr_le_supr_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨆ x ∈ s, f x) ≤ (⨆ x ∈ t, f x) :=
@infi_le_infi_of_subset (order_dual α) _ _ _ _ _ h

theorem infi_insert {f : β → α} {s : set β} {b : β} :
  (⨅ x ∈ insert b s, f x) = f b ⊓ (⨅x∈s, f x) :=
eq.trans infi_union $ congr_arg (λx:α, x ⊓ (⨅x∈s, f x)) infi_infi_eq_left

theorem supr_insert {f : β → α} {s : set β} {b : β} :
  (⨆ x ∈ insert b s, f x) = f b ⊔ (⨆x∈s, f x) :=
eq.trans supr_union $ congr_arg (λx:α, x ⊔ (⨆x∈s, f x)) supr_supr_eq_left

theorem infi_singleton {f : β → α} {b : β} : (⨅ x ∈ (singleton b : set β), f x) = f b :=
by simp

theorem infi_pair {f : β → α} {a b : β} : (⨅ x ∈ ({a, b} : set β), f x) = f a ⊓ f b :=
by rw [infi_insert, infi_singleton]

theorem supr_singleton {f : β → α} {b : β} : (⨆ x ∈ (singleton b : set β), f x) = f b :=
@infi_singleton (order_dual α) _ _ _ _

theorem supr_pair {f : β → α} {a b : β} : (⨆ x ∈ ({a, b} : set β), f x) = f a ⊔ f b :=
by rw [supr_insert, supr_singleton]

lemma infi_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨅ c ∈ f '' t, g c) = (⨅ b ∈ t, g (f b)) :=
by rw [← Inf_image, ← Inf_image, ← image_comp]

lemma supr_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨆ c ∈ f '' t, g c) = (⨆ b ∈ t, g (f b)) :=
@infi_image (order_dual α) _ _ _ _ _ _

theorem supr_extend_bot {e : ι → β} (he : injective e) (f : ι → α) :
  (⨆ j, extend e f ⊥ j) = ⨆ i, f i :=
begin
  rw supr_split _ (λ j, ∃ i, e i = j),
  simp [extend_apply he, extend_apply', @supr_comm _ β ι] { contextual := tt }
end

/-!
### `supr` and `infi` under `Type`
-/

theorem supr_of_empty' {α ι} [has_Sup α] [is_empty ι] (f : ι → α) :
  supr f = Sup (∅ : set α) :=
congr_arg Sup (range_eq_empty f)

theorem supr_of_empty [is_empty ι] (f : ι → α) : supr f = ⊥ :=
(supr_of_empty' f).trans Sup_empty

theorem infi_of_empty' {α ι} [has_Inf α] [is_empty ι] (f : ι → α) :
  infi f = Inf (∅ : set α) :=
congr_arg Inf (range_eq_empty f)

theorem infi_of_empty [is_empty ι] (f : ι → α) : infi f = ⊤ :=
@supr_of_empty (order_dual α) _ _ _ f

lemma supr_bool_eq {f : bool → α} : (⨆b:bool, f b) = f tt ⊔ f ff :=
by rw [supr, bool.range_eq, Sup_pair, sup_comm]

lemma infi_bool_eq {f : bool → α} : (⨅b:bool, f b) = f tt ⊓ f ff :=
@supr_bool_eq (order_dual α) _ _

lemma sup_eq_supr (x y : α) : x ⊔ y = ⨆ b : bool, cond b x y :=
by rw [supr_bool_eq, bool.cond_tt, bool.cond_ff]

lemma inf_eq_infi (x y : α) : x ⊓ y = ⨅ b : bool, cond b x y :=
@sup_eq_supr (order_dual α) _ _ _

lemma is_glb_binfi {s : set β} {f : β → α} : is_glb (f '' s) (⨅ x ∈ s, f x) :=
by simpa only [range_comp, subtype.range_coe, infi_subtype'] using @is_glb_infi α s _ (f ∘ coe)

theorem supr_subtype {p : ι → Prop} {f : subtype p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
@infi_subtype (order_dual α) _ _ _ _

lemma supr_subtype' {p : ι → Prop} {f : ∀ i, p i → α} :
  (⨆ i (h : p i), f i h) = (⨆ x : subtype p, f x x.property) :=
(@supr_subtype _ _ _ p (λ x, f x.val x.property)).symm

lemma supr_subtype'' {ι} (s : set ι) (f : ι → α) :
  (⨆ i : s, f i) = ⨆ (t : ι) (H : t ∈ s), f t :=
supr_subtype

lemma is_lub_bsupr {s : set β} {f : β → α} : is_lub (f '' s) (⨆ x ∈ s, f x) :=
by simpa only [range_comp, subtype.range_coe, supr_subtype'] using @is_lub_supr α s _ (f ∘ coe)

theorem infi_sigma {p : β → Type*} {f : sigma p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
eq_of_forall_le_iff $ λ c, by simp only [le_infi_iff, sigma.forall]

theorem supr_sigma {p : β → Type*} {f : sigma p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
@infi_sigma (order_dual α) _ _ _ _

theorem infi_prod {γ : Type*} {f : β × γ → α} : (⨅ x, f x) = (⨅ i j, f (i, j)) :=
eq_of_forall_le_iff $ λ c, by simp only [le_infi_iff, prod.forall]

theorem supr_prod {γ : Type*} {f : β × γ → α} : (⨆ x, f x) = (⨆ i j, f (i, j)) :=
@infi_prod (order_dual α) _ _ _ _

theorem infi_sum {γ : Type*} {f : β ⊕ γ → α} :
  (⨅ x, f x) = (⨅ i, f (sum.inl i)) ⊓ (⨅ j, f (sum.inr j)) :=
eq_of_forall_le_iff $ λ c, by simp only [le_inf_iff, le_infi_iff, sum.forall]

theorem supr_sum {γ : Type*} {f : β ⊕ γ → α} :
  (⨆ x, f x) = (⨆ i, f (sum.inl i)) ⊔ (⨆ j, f (sum.inr j)) :=
@infi_sum (order_dual α) _ _ _ _

theorem supr_option (f : option β → α) :
  (⨆ o, f o) = f none ⊔ ⨆ b, f (option.some b) :=
eq_of_forall_ge_iff $ λ c, by simp only [supr_le_iff, sup_le_iff, option.forall]

theorem infi_option (f : option β → α) :
  (⨅ o, f o) = f none ⊓ ⨅ b, f (option.some b) :=
@supr_option (order_dual α) _ _ _

/-- A version of `supr_option` useful for rewriting right-to-left. -/
lemma supr_option_elim (a : α) (f : β → α) : (⨆ o : option β, o.elim a f) = a ⊔ ⨆ b, f b :=
by simp [supr_option]

/-- A version of `infi_option` useful for rewriting right-to-left. -/
lemma infi_option_elim (a : α) (f : β → α) : (⨅ o : option β, o.elim a f) = a ⊓ ⨅ b, f b :=
@supr_option_elim (order_dual α) _ _ _ _

/-- When taking the supremum of `f : ι → α`, the elements of `ι` on which `f` gives `⊥` can be
dropped, without changing the result. -/
lemma supr_ne_bot_subtype (f : ι → α) : (⨆ i : {i // f i ≠ ⊥}, f i) = ⨆ i, f i :=
begin
  by_cases htriv : ∀ i, f i = ⊥,
  { simp only [htriv, supr_bot] },
  refine le_antisymm (supr_comp_le f _) (supr_le_supr2 _),
  intros i,
  by_cases hi : f i = ⊥,
  { rw hi,
    obtain ⟨i₀, hi₀⟩ := not_forall.mp htriv,
    exact ⟨⟨i₀, hi₀⟩, bot_le⟩ },
  { exact ⟨⟨i, hi⟩, rfl.le⟩ },
end

/-- When taking the infimum of `f : ι → α`, the elements of `ι` on which `f` gives `⊤` can be
dropped, without changing the result. -/
lemma infi_ne_top_subtype (f : ι → α) : (⨅ i : {i // f i ≠ ⊤}, f i) = ⨅ i, f i :=
@supr_ne_bot_subtype (order_dual α) ι _ f

/-!
### `supr` and `infi` under `ℕ`
-/

lemma supr_ge_eq_supr_nat_add {u : ℕ → α} (n : ℕ) : (⨆ i ≥ n, u i) = ⨆ i, u (i + n) :=
begin
  apply le_antisymm;
  simp only [supr_le_iff],
  { exact λ i hi, le_Sup ⟨i - n, by { dsimp only, rw tsub_add_cancel_of_le hi }⟩ },
  { exact λ i, le_Sup ⟨i + n, supr_pos (nat.le_add_left _ _)⟩ }
end

lemma infi_ge_eq_infi_nat_add {u : ℕ → α} (n : ℕ) : (⨅ i ≥ n, u i) = ⨅ i, u (i + n) :=
@supr_ge_eq_supr_nat_add (order_dual α) _ _ _

lemma monotone.supr_nat_add {f : ℕ → α} (hf : monotone f) (k : ℕ) :
  (⨆ n, f (n + k)) = ⨆ n, f n :=
le_antisymm (supr_le (λ i, le_rfl.trans (le_supr _ (i + k))))
    (supr_le_supr (λ i, hf (nat.le_add_right i k)))

@[simp] lemma supr_infi_ge_nat_add (f : ℕ → α) (k : ℕ) :
  (⨆ n, ⨅ i ≥ n, f (i + k)) = ⨆ n, ⨅ i ≥ n, f i :=
begin
  have hf : monotone (λ n, ⨅ i ≥ n, f i),
    from λ n m hnm, le_infi (λ i, (infi_le _ i).trans (le_infi (λ h, infi_le _ (hnm.trans h)))),
  rw ←monotone.supr_nat_add hf k,
  { simp_rw [infi_ge_eq_infi_nat_add, ←nat.add_assoc], },
end

lemma sup_supr_nat_succ (u : ℕ → α) : u 0 ⊔ (⨆ i, u (i + 1)) = ⨆ i, u i :=
begin
  refine eq_of_forall_ge_iff (λ c, _),
  simp only [sup_le_iff, supr_le_iff],
  refine ⟨λ h, _, λ h, ⟨h _, λ i, h _⟩⟩,
  rintro (_|i),
  exacts [h.1, h.2 i]
end

lemma inf_infi_nat_succ (u : ℕ → α) : u 0 ⊓ (⨅ i, u (i + 1)) = ⨅ i, u i :=
@sup_supr_nat_succ (order_dual α) _ u

end

section complete_linear_order
variables [complete_linear_order α]

lemma supr_eq_top (f : ι → α) : supr f = ⊤ ↔ (∀b<⊤, ∃i, b < f i) :=
by simp only [← Sup_range, Sup_eq_top, set.exists_range_iff]

lemma infi_eq_bot (f : ι → α) : infi f = ⊥ ↔ (∀b>⊥, ∃i, f i < b) :=
by simp only [← Inf_range, Inf_eq_bot, set.exists_range_iff]

end complete_linear_order

/-!
### Instances
-/

instance Prop.complete_lattice : complete_lattice Prop :=
{ Sup    := λs, ∃a∈s, a,
  le_Sup := assume s a h p, ⟨a, h, p⟩,
  Sup_le := assume s a h ⟨b, h', p⟩, h b h' p,
  Inf    := λs, ∀a:Prop, a∈s → a,
  Inf_le := assume s a h p, p a h,
  le_Inf := assume s a h p b hb, h b hb p,
  .. Prop.bounded_order,
  .. Prop.distrib_lattice }

@[simp] lemma Inf_Prop_eq {s : set Prop} : Inf s = (∀p ∈ s, p) := rfl

@[simp] lemma Sup_Prop_eq {s : set Prop} : Sup s = (∃p ∈ s, p) := rfl

@[simp] lemma infi_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨅i, p i) = (∀i, p i) :=
le_antisymm (assume h i, h _ ⟨i, rfl⟩ ) (assume h p ⟨i, eq⟩, eq ▸ h i)

@[simp] lemma supr_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨆i, p i) = (∃i, p i) :=
le_antisymm (λ ⟨q, ⟨i, (eq : p i = q)⟩, hq⟩, ⟨i, eq.symm ▸ hq⟩) (λ ⟨i, hi⟩, ⟨p i, ⟨i, rfl⟩, hi⟩)

instance pi.has_Sup {α : Type*} {β : α → Type*} [Π i, has_Sup (β i)] : has_Sup (Π i, β i) :=
⟨λ s i, ⨆ f : s, (f : Π i, β i) i⟩

instance pi.has_Inf {α : Type*} {β : α → Type*} [Π i, has_Inf (β i)] : has_Inf (Π i, β i) :=
⟨λ s i, ⨅ f : s, (f : Π i, β i) i⟩

instance pi.complete_lattice {α : Type*} {β : α → Type*} [∀ i, complete_lattice (β i)] :
  complete_lattice (Π i, β i) :=
{ Sup := Sup,
  Inf := Inf,
  le_Sup := λ s f hf i, le_supr (λ f : s, (f : Π i, β i) i) ⟨f, hf⟩,
  Inf_le := λ s f hf i, infi_le (λ f : s, (f : Π i, β i) i) ⟨f, hf⟩,
  Sup_le := λ s f hf i, supr_le $ λ g, hf g g.2 i,
  le_Inf := λ s f hf i, le_infi $ λ g, hf g g.2 i,
  .. pi.bounded_order,
  .. pi.lattice }

lemma Inf_apply {α : Type*} {β : α → Type*} [Π i, has_Inf (β i)]
  {s : set (Πa, β a)} {a : α} :
  (Inf s) a = (⨅ f : s, (f : Πa, β a) a) :=
rfl

@[simp] lemma infi_apply {α : Type*} {β : α → Type*} {ι : Sort*} [Π i, has_Inf (β i)]
  {f : ι → Πa, β a} {a : α} :
  (⨅i, f i) a = (⨅i, f i a) :=
by rw [infi, Inf_apply, infi, infi, ← image_eq_range (λ f : Π i, β i, f a) (range f), ← range_comp]

lemma Sup_apply {α : Type*} {β : α → Type*} [Π i, has_Sup (β i)] {s : set (Πa, β a)} {a : α} :
  (Sup s) a = (⨆f:s, (f : Πa, β a) a) :=
rfl

lemma unary_relation_Sup_iff {α : Type*} (s : set (α → Prop)) {a : α} :
  Sup s a ↔ ∃ (r : α → Prop), r ∈ s ∧ r a :=
by { change (∃ _, _) ↔ _, simp [-eq_iff_iff] }

lemma binary_relation_Sup_iff {α β : Type*} (s : set (α → β → Prop)) {a : α} {b : β} :
  Sup s a b ↔ ∃ (r : α → β → Prop), r ∈ s ∧ r a b :=
by { change (∃ _, _) ↔ _, simp [-eq_iff_iff] }

@[simp] lemma supr_apply {α : Type*} {β : α → Type*} {ι : Sort*} [Π i, has_Sup (β i)]
  {f : ι → Πa, β a} {a : α} :
  (⨆i, f i) a = (⨆i, f i a) :=
@infi_apply α (λ i, order_dual (β i)) _ _ f a

section complete_lattice
variables [preorder α] [complete_lattice β]

theorem monotone_Sup_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Sup s) :=
assume x y h, supr_le $ λ f, le_supr_of_le f $ m_s f f.2 h

theorem monotone_Inf_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Inf s) :=
assume x y h, le_infi $ λ f, infi_le_of_le f $ m_s f f.2 h

end complete_lattice

namespace prod
variables (α β)

instance [has_Inf α] [has_Inf β] : has_Inf (α × β) :=
⟨λs, (Inf (prod.fst '' s), Inf (prod.snd '' s))⟩

instance [has_Sup α] [has_Sup β] : has_Sup (α × β) :=
⟨λs, (Sup (prod.fst '' s), Sup (prod.snd '' s))⟩

instance [complete_lattice α] [complete_lattice β] : complete_lattice (α × β) :=
{ le_Sup := assume s p hab, ⟨le_Sup $ mem_image_of_mem _ hab, le_Sup $ mem_image_of_mem _ hab⟩,
  Sup_le := assume s p h,
    ⟨ Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).1,
      Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).2⟩,
  Inf_le := assume s p hab, ⟨Inf_le $ mem_image_of_mem _ hab, Inf_le $ mem_image_of_mem _ hab⟩,
  le_Inf := assume s p h,
    ⟨ le_Inf $ ball_image_of_ball $ assume p hp, (h p hp).1,
      le_Inf $ ball_image_of_ball $ assume p hp, (h p hp).2⟩,
  .. prod.lattice α β,
  .. prod.bounded_order α β,
  .. prod.has_Sup α β,
  .. prod.has_Inf α β }

end prod

section complete_lattice
variables [complete_lattice α] {a : α} {s : set α}

/-- This is a weaker version of `sup_Inf_eq` -/
lemma sup_Inf_le_infi_sup :
  a ⊔ Inf s ≤ (⨅ b ∈ s, a ⊔ b) :=
le_infi $ assume i, le_infi $ assume h, sup_le_sup_left (Inf_le h) _

/-- This is a weaker version of `Inf_sup_eq` -/
lemma Inf_sup_le_infi_sup :
  Inf s ⊔ a ≤ (⨅ b ∈ s, b ⊔ a) :=
le_infi $ assume i, le_infi $ assume h, sup_le_sup_right (Inf_le h) _

/-- This is a weaker version of `inf_Sup_eq` -/
lemma supr_inf_le_inf_Sup :
  (⨆ b ∈ s, a ⊓ b) ≤ a ⊓ Sup s :=
supr_le $ assume i, supr_le $ assume h, inf_le_inf_left _ (le_Sup h)

/-- This is a weaker version of `Sup_inf_eq` -/
lemma supr_inf_le_Sup_inf :
  (⨆ b ∈ s, b ⊓ a) ≤ Sup s ⊓ a :=
supr_le $ assume i, supr_le $ assume h, inf_le_inf_right _ (le_Sup h)

lemma disjoint_Sup_left {a : set α} {b : α} (d : disjoint (Sup a) b) {i} (hi : i ∈ a) :
  disjoint i b :=
(supr_le_iff.mp (supr_le_iff.mp (supr_inf_le_Sup_inf.trans (d : _)) i : _) hi : _)

lemma disjoint_Sup_right {a : set α} {b : α} (d : disjoint b (Sup a)) {i} (hi : i ∈ a) :
  disjoint b i :=
(supr_le_iff.mp (supr_le_iff.mp (supr_inf_le_inf_Sup.trans (d : _)) i : _) hi : _)

end complete_lattice

namespace complete_lattice
variables [complete_lattice α]

/-- An independent set of elements in a complete lattice is one in which every element is disjoint
  from the `Sup` of the rest. -/
def set_independent (s : set α) : Prop := ∀ ⦃a⦄, a ∈ s → disjoint a (Sup (s \ {a}))

variables {s : set α} (hs : set_independent s)

@[simp]
lemma set_independent_empty : set_independent (∅ : set α) :=
λ x hx, (set.not_mem_empty x hx).elim

theorem set_independent.mono {t : set α} (hst : t ⊆ s) :
  set_independent t :=
λ a ha, (hs (hst ha)).mono_right (Sup_le_Sup (diff_subset_diff_left hst))

/-- If the elements of a set are independent, then any pair within that set is disjoint. -/
lemma set_independent.disjoint {x y : α} (hx : x ∈ s) (hy : y ∈ s) (h : x ≠ y) : disjoint x y :=
disjoint_Sup_right (hs hx) ((mem_diff y).mpr ⟨hy, by simp [h.symm]⟩)

include hs

/-- If the elements of a set are independent, then any element is disjoint from the `Sup` of some
subset of the rest. -/
lemma set_independent.disjoint_Sup {x : α} {y : set α} (hx : x ∈ s) (hy : y ⊆ s) (hxy : x ∉ y) :
  disjoint x (Sup y) :=
begin
  have := (hs.mono $ insert_subset.mpr ⟨hx, hy⟩) (mem_insert x _),
  rw [insert_diff_of_mem _ (mem_singleton _), diff_singleton_eq_self hxy] at this,
  exact this,
end

omit hs

/-- An independent indexed family of elements in a complete lattice is one in which every element
  is disjoint from the `supr` of the rest.

  Example: an indexed family of non-zero elements in a
  vector space is linearly independent iff the indexed family of subspaces they generate is
  independent in this sense.

  Example: an indexed family of submodules of a module is independent in this sense if
  and only the natural map from the direct sum of the submodules to the module is injective. -/
def independent {ι : Sort*} {α : Type*} [complete_lattice α] (t : ι → α) : Prop :=
∀ i : ι, disjoint (t i) (⨆ (j ≠ i), t j)

lemma set_independent_iff {α : Type*} [complete_lattice α] (s : set α) :
  set_independent s ↔ independent (coe : s → α) :=
begin
  simp_rw [independent, set_independent, set_coe.forall, Sup_eq_supr],
  refine forall₂_congr (λ a ha, _),
  congr' 2,
  convert supr_subtype.symm,
  simp [supr_and],
end

variables {t : ι → α} (ht : independent t)

theorem independent_def : independent t ↔ ∀ i : ι, disjoint (t i) (⨆ (j ≠ i), t j) :=
iff.rfl

theorem independent_def' {ι : Type*} {t : ι → α} :
  independent t ↔ ∀ i, disjoint (t i) (Sup (t '' {j | j ≠ i})) :=
by {simp_rw Sup_image, refl}

theorem independent_def'' {ι : Type*} {t : ι → α} :
  independent t ↔ ∀ i, disjoint (t i) (Sup {a | ∃ j ≠ i, t j = a}) :=
by {rw independent_def', tidy}

@[simp]
lemma independent_empty (t : empty → α) : independent t.

@[simp]
lemma independent_pempty (t : pempty → α) : independent t.

/-- If the elements of a set are independent, then any pair within that set is disjoint. -/
lemma independent.disjoint {x y : ι} (h : x ≠ y) : disjoint (t x) (t y) :=
disjoint_Sup_right (ht x) ⟨y, by simp [h.symm]⟩

lemma independent.mono {ι : Type*} {α : Type*} [complete_lattice α]
  {s t : ι → α} (hs : independent s) (hst : t ≤ s) :
  independent t :=
λ i, (hs i).mono (hst i) (supr_le_supr $ λ j, supr_le_supr $ λ _, hst j)

/-- Composing an independent indexed family with an injective function on the index results in
another indepedendent indexed family. -/
lemma independent.comp {ι ι' : Sort*} {α : Type*} [complete_lattice α]
  {s : ι → α} (hs : independent s) (f : ι' → ι) (hf : function.injective f) :
  independent (s ∘ f) :=
λ i, (hs (f i)).mono_right begin
  refine (supr_le_supr $ λ i, _).trans (supr_comp_le _ f),
  exact supr_le_supr_const hf.ne,
end

/-- Composing an indepedent indexed family with an order isomorphism on the elements results in
another indepedendent indexed family. -/
lemma independent.map_order_iso {ι : Sort*} {α β : Type*}
  [complete_lattice α] [complete_lattice β] (f : α ≃o β) {a : ι → α} (ha : independent a) :
  independent (f ∘ a) :=
λ i, ((ha i).map_order_iso f).mono_right (f.monotone.le_map_supr2 _)

@[simp] lemma independent_map_order_iso_iff {ι : Sort*} {α β : Type*}
  [complete_lattice α] [complete_lattice β] (f : α ≃o β) {a : ι → α} :
  independent (f ∘ a) ↔ independent a :=
⟨ λ h, have hf : f.symm ∘ f ∘ a = a := congr_arg (∘ a) f.left_inv.comp_eq_id,
      hf ▸ h.map_order_iso f.symm,
  λ h, h.map_order_iso f⟩

/-- If the elements of a set are independent, then any element is disjoint from the `supr` of some
subset of the rest. -/
lemma independent.disjoint_bsupr {ι : Type*} {α : Type*} [complete_lattice α]
  {t : ι → α} (ht : independent t) {x : ι} {y : set ι} (hx : x ∉ y) :
  disjoint (t x) (⨆ i ∈ y, t i) :=
disjoint.mono_right (bsupr_le_bsupr' $ λ i hi, (ne_of_mem_of_not_mem hi hx : _)) (ht x)

end complete_lattice


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.free
import algebra.monoid_algebra.basic

/-!
# Free algebras

Given a semiring `R` and a type `X`, we construct the free non-unital, non-associative algebra on
`X` with coefficients in `R`, together with its universal property. The construction is valuable
because it can be used to build free algebras with more structure, e.g., free Lie algebras.

Note that elsewhere we have a construction of the free unital, associative algebra. This is called
`free_algebra`.

## Main definitions

  * `free_non_unital_non_assoc_algebra`
  * `free_non_unital_non_assoc_algebra.lift`
  * `free_non_unital_non_assoc_algebra.of`

## Implementation details

We construct the free algebra as the magma algebra, with coefficients in `R`, of the free magma on
`X`. However we regard this as an implementation detail and thus deliberately omit the lemmas
`of_apply` and `lift_apply`, and we mark `free_non_unital_non_assoc_algebra` and `lift` as
irreducible once we have established the universal property.

## Tags

free algebra, non-unital, non-associative, free magma, magma algebra, universal property,
forgetful functor, adjoint functor
-/

universes u v w

noncomputable theory

variables (R : Type u) (X : Type v) [semiring R]

/-- The free non-unital, non-associative algebra on the type `X` with coefficients in `R`. -/
abbreviation free_non_unital_non_assoc_algebra := monoid_algebra R (free_magma X)

namespace free_non_unital_non_assoc_algebra

variables {X}

/-- The embedding of `X` into the free algebra with coefficients in `R`. -/
def of : X → free_non_unital_non_assoc_algebra R X :=
(monoid_algebra.of_magma R _) ∘ free_magma.of

variables {A : Type w} [non_unital_non_assoc_semiring A]
variables [module R A] [is_scalar_tower R A A] [smul_comm_class R A A]

/-- The functor `X ↦ free_non_unital_non_assoc_algebra R X` from the category of types to the
category of non-unital, non-associative algebras over `R` is adjoint to the forgetful functor in the
other direction. -/
def lift : (X → A) ≃ non_unital_alg_hom R (free_non_unital_non_assoc_algebra R X) A :=
free_magma.lift.trans (monoid_algebra.lift_magma R)

@[simp] lemma lift_symm_apply (F : non_unital_alg_hom R (free_non_unital_non_assoc_algebra R X) A) :
  (lift R).symm F = F ∘ (of R) :=
rfl

@[simp] lemma of_comp_lift (f : X → A) : (lift R f) ∘ (of R) = f :=
(lift R).left_inv f

@[simp] lemma lift_unique
  (f : X → A) (F : non_unital_alg_hom R (free_non_unital_non_assoc_algebra R X) A) :
  F ∘ (of R) = f ↔ F = lift R f :=
(lift R).symm_apply_eq

@[simp] lemma lift_of_apply (f : X → A) (x) : lift R f (of R x) = f x :=
congr_fun (of_comp_lift _ f) x

@[simp] lemma lift_comp_of (F : non_unital_alg_hom R (free_non_unital_non_assoc_algebra R X) A) :
  lift R (F ∘ (of R)) = F :=
(lift R).apply_symm_apply F

@[ext] lemma hom_ext {F₁ F₂ : non_unital_alg_hom R (free_non_unital_non_assoc_algebra R X) A}
  (h : ∀ x, F₁ (of R x) = F₂ (of R x)) : F₁ = F₂ :=
(lift R).symm.injective $ funext h

end free_non_unital_non_assoc_algebra