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

import algebra.polynomial.big_operators
import field_theory.minpoly
import field_theory.splitting_field
import field_theory.tower
import algebra.squarefree

/-!

# Separable polynomials

We define a polynomial to be separable if it is coprime with its derivative. We prove basic
properties about separable polynomials here.

## Main definitions

* `polynomial.separable f`: a polynomial `f` is separable iff it is coprime with its derivative.
* `polynomial.expand R p f`: expand the polynomial `f` with coefficients in a
  commutative semiring `R` by a factor of p, so `expand R p (∑ aₙ xⁿ)` is `∑ aₙ xⁿᵖ`.
* `polynomial.contract p f`: the opposite of `expand`, so it sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`.

-/

universes u v w
open_locale classical big_operators
open finset

namespace polynomial

section comm_semiring

variables {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S]

/-- A polynomial is separable iff it is coprime with its derivative. -/
def separable (f : polynomial R) : Prop :=
is_coprime f f.derivative

lemma separable_def (f : polynomial R) :
  f.separable ↔ is_coprime f f.derivative :=
iff.rfl

lemma separable_def' (f : polynomial R) :
  f.separable ↔ ∃ a b : polynomial R, a * f + b * f.derivative = 1 :=
iff.rfl

lemma separable_one : (1 : polynomial R).separable :=
is_coprime_one_left

lemma separable_X_add_C (a : R) : (X + C a).separable :=
by { rw [separable_def, derivative_add, derivative_X, derivative_C, add_zero],
  exact is_coprime_one_right }

lemma separable_X : (X : polynomial R).separable :=
by { rw [separable_def, derivative_X], exact is_coprime_one_right }

lemma separable_C (r : R) : (C r).separable ↔ is_unit r :=
by rw [separable_def, derivative_C, is_coprime_zero_right, is_unit_C]

lemma separable.of_mul_left {f g : polynomial R} (h : (f * g).separable) : f.separable :=
begin
  have := h.of_mul_left_left, rw derivative_mul at this,
  exact is_coprime.of_mul_right_left (is_coprime.of_add_mul_left_right this)
end

lemma separable.of_mul_right {f g : polynomial R} (h : (f * g).separable) : g.separable :=
by { rw mul_comm at h, exact h.of_mul_left }

lemma separable.of_dvd {f g : polynomial R} (hf : f.separable) (hfg : g ∣ f) : g.separable :=
by { rcases hfg with ⟨f', rfl⟩, exact separable.of_mul_left hf }

lemma separable_gcd_left {F : Type*} [field F] {f : polynomial F}
  (hf : f.separable) (g : polynomial F) : (euclidean_domain.gcd f g).separable :=
separable.of_dvd hf (euclidean_domain.gcd_dvd_left f g)

lemma separable_gcd_right {F : Type*} [field F] {g : polynomial F}
  (f : polynomial F) (hg : g.separable) : (euclidean_domain.gcd f g).separable :=
separable.of_dvd hg (euclidean_domain.gcd_dvd_right f g)

lemma separable.is_coprime {f g : polynomial R} (h : (f * g).separable) : is_coprime f g :=
begin
  have := h.of_mul_left_left, rw derivative_mul at this,
  exact is_coprime.of_mul_right_right (is_coprime.of_add_mul_left_right this)
end

theorem separable.of_pow' {f : polynomial R} :
  ∀ {n : ℕ} (h : (f ^ n).separable), is_unit f ∨ (f.separable ∧ n = 1) ∨ n = 0
| 0     := λ h, or.inr $ or.inr rfl
| 1     := λ h, or.inr $ or.inl ⟨pow_one f ▸ h, rfl⟩
| (n+2) := λ h, by { rw [pow_succ, pow_succ] at h,
    exact or.inl (is_coprime_self.1 h.is_coprime.of_mul_right_left) }

theorem separable.of_pow {f : polynomial R} (hf : ¬is_unit f) {n : ℕ} (hn : n ≠ 0)
  (hfs : (f ^ n).separable) : f.separable ∧ n = 1 :=
(hfs.of_pow'.resolve_left hf).resolve_right hn

theorem separable.map {p : polynomial R} (h : p.separable) {f : R →+* S} : (p.map f).separable :=
let ⟨a, b, H⟩ := h in ⟨a.map f, b.map f,
by rw [derivative_map, ← map_mul, ← map_mul, ← map_add, H, map_one]⟩

variables (R) (p q : ℕ)

/-- Expand the polynomial by a factor of p, so `∑ aₙ xⁿ` becomes `∑ aₙ xⁿᵖ`. -/
noncomputable def expand : polynomial R →ₐ[R] polynomial R :=
{ commutes' := λ r, eval₂_C _ _,
  .. (eval₂_ring_hom C (X ^ p) : polynomial R →+* polynomial R) }

lemma coe_expand : (expand R p : polynomial R → polynomial R) = eval₂ C (X ^ p) := rfl

variables {R}

lemma expand_eq_sum {f : polynomial R} :
  expand R p f = f.sum (λ e a, C a * (X ^ p) ^ e) :=
by { dsimp [expand, eval₂], refl, }

@[simp] lemma expand_C (r : R) : expand R p (C r) = C r := eval₂_C _ _
@[simp] lemma expand_X : expand R p X = X ^ p := eval₂_X _ _
@[simp] lemma expand_monomial (r : R) : expand R p (monomial q r) = monomial (q * p) r :=
by simp_rw [monomial_eq_smul_X, alg_hom.map_smul, alg_hom.map_pow, expand_X, mul_comm, pow_mul]

theorem expand_expand (f : polynomial R) : expand R p (expand R q f) = expand R (p * q) f :=
polynomial.induction_on f (λ r, by simp_rw expand_C)
  (λ f g ihf ihg, by simp_rw [alg_hom.map_add, ihf, ihg])
  (λ n r ih, by simp_rw [alg_hom.map_mul, expand_C, alg_hom.map_pow, expand_X,
    alg_hom.map_pow, expand_X, pow_mul])

theorem expand_mul (f : polynomial R) : expand R (p * q) f = expand R p (expand R q f) :=
(expand_expand p q f).symm

@[simp] theorem expand_one (f : polynomial R) : expand R 1 f = f :=
polynomial.induction_on f
  (λ r, by rw expand_C)
  (λ f g ihf ihg, by rw [alg_hom.map_add, ihf, ihg])
  (λ n r ih, by rw [alg_hom.map_mul, expand_C, alg_hom.map_pow, expand_X, pow_one])

theorem expand_pow (f : polynomial R) : expand R (p ^ q) f = (expand R p ^[q] f) :=
nat.rec_on q (by rw [pow_zero, expand_one, function.iterate_zero, id]) $ λ n ih,
by rw [function.iterate_succ_apply', pow_succ, expand_mul, ih]

theorem derivative_expand (f : polynomial R) :
  (expand R p f).derivative = expand R p f.derivative * (p * X ^ (p - 1)) :=
by rw [coe_expand, derivative_eval₂_C, derivative_pow, derivative_X, mul_one]

theorem coeff_expand {p : ℕ} (hp : 0 < p) (f : polynomial R) (n : ℕ) :
  (expand R p f).coeff n = if p ∣ n then f.coeff (n / p) else 0 :=
begin
  simp only [expand_eq_sum],
  simp_rw [coeff_sum, ← pow_mul, C_mul_X_pow_eq_monomial, coeff_monomial, finsupp.sum],
  split_ifs with h,
  { rw [finset.sum_eq_single (n/p), nat.mul_div_cancel' h, if_pos rfl], refl,
    { intros b hb1 hb2, rw if_neg, intro hb3, apply hb2, rw [← hb3, nat.mul_div_cancel_left b hp] },
    { intro hn, rw finsupp.not_mem_support_iff.1 hn, split_ifs; refl } },
  { rw finset.sum_eq_zero, intros k hk, rw if_neg, exact λ hkn, h ⟨k, hkn.symm⟩, },
end

@[simp] theorem coeff_expand_mul {p : ℕ} (hp : 0 < p) (f : polynomial R) (n : ℕ) :
  (expand R p f).coeff (n * p) = f.coeff n :=
by rw [coeff_expand hp, if_pos (dvd_mul_left _ _), nat.mul_div_cancel _ hp]

@[simp] theorem coeff_expand_mul' {p : ℕ} (hp : 0 < p) (f : polynomial R) (n : ℕ) :
  (expand R p f).coeff (p * n) = f.coeff n :=
by rw [mul_comm, coeff_expand_mul hp]

theorem expand_eq_map_domain (p : ℕ) (f : polynomial R) :
  expand R p f = f.map_domain (*p) :=
polynomial.induction_on' f (λ p q hp hq, by simp [*, finsupp.map_domain_add]) $
  λ n a, by simp_rw [expand_monomial, monomial_def, finsupp.map_domain_single]

theorem expand_inj {p : ℕ} (hp : 0 < p) {f g : polynomial R} :
  expand R p f = expand R p g ↔ f = g :=
⟨λ H, ext $ λ n, by rw [← coeff_expand_mul hp, H, coeff_expand_mul hp], congr_arg _⟩

theorem expand_eq_zero {p : ℕ} (hp : 0 < p) {f : polynomial R} : expand R p f = 0 ↔ f = 0 :=
by rw [← (expand R p).map_zero, expand_inj hp, alg_hom.map_zero]

theorem expand_eq_C {p : ℕ} (hp : 0 < p) {f : polynomial R} {r : R} :
  expand R p f = C r ↔ f = C r :=
by rw [← expand_C, expand_inj hp, expand_C]

theorem nat_degree_expand (p : ℕ) (f : polynomial R) :
  (expand R p f).nat_degree = f.nat_degree * p :=
begin
  cases p.eq_zero_or_pos with hp hp,
  { rw [hp, coe_expand, pow_zero, mul_zero, ← C_1, eval₂_hom, nat_degree_C] },
  by_cases hf : f = 0,
  { rw [hf, alg_hom.map_zero, nat_degree_zero, zero_mul] },
  have hf1 : expand R p f ≠ 0 := mt (expand_eq_zero hp).1 hf,
  rw [← with_bot.coe_eq_coe, ← degree_eq_nat_degree hf1],
  refine le_antisymm ((degree_le_iff_coeff_zero _ _).2 $ λ n hn, _) _,
  { rw coeff_expand hp, split_ifs with hpn,
    { rw coeff_eq_zero_of_nat_degree_lt, contrapose! hn,
      rw [with_bot.coe_le_coe, ← nat.div_mul_cancel hpn], exact nat.mul_le_mul_right p hn },
    { refl } },
  { refine le_degree_of_ne_zero _,
    rw [coeff_expand_mul hp, ← leading_coeff], exact mt leading_coeff_eq_zero.1 hf }
end

theorem map_expand {p : ℕ} (hp : 0 < p) {f : R →+* S} {q : polynomial R} :
  map f (expand R p q) = expand S p (map f q) :=
by { ext, rw [coeff_map, coeff_expand hp, coeff_expand hp], split_ifs; simp, }

/-- Expansion is injective. -/
lemma expand_injective {n : ℕ} (hn : 0 < n) :
  function.injective (expand R n) :=
λ g g' h, begin
  ext,
  have h' : (expand R n g).coeff (n * n_1) = (expand R n g').coeff (n * n_1) :=
  begin
    apply polynomial.ext_iff.1,
    exact h,
  end,

  rw [polynomial.coeff_expand hn g (n * n_1), polynomial.coeff_expand hn g' (n * n_1)] at h',
  simp only [if_true, dvd_mul_right] at h',
  rw (nat.mul_div_right n_1 hn) at h',
  exact h',
end

end comm_semiring

section comm_ring

variables {R : Type u} [comm_ring R]

lemma separable_X_sub_C {x : R} : separable (X - C x) :=
by simpa only [sub_eq_add_neg, C_neg] using separable_X_add_C (-x)

lemma separable.mul {f g : polynomial R} (hf : f.separable) (hg : g.separable)
  (h : is_coprime f g) : (f * g).separable :=
by { rw [separable_def, derivative_mul], exact ((hf.mul_right h).add_mul_left_right _).mul_left
  ((h.symm.mul_right hg).mul_add_right_right _) }

lemma separable_prod' {ι : Sort*} {f : ι → polynomial R} {s : finset ι} :
  (∀x∈s, ∀y∈s, x ≠ y → is_coprime (f x) (f y)) → (∀x∈s, (f x).separable) →
  (∏ x in s, f x).separable :=
finset.induction_on s (λ _ _, separable_one) $ λ a s has ih h1 h2, begin
  simp_rw [finset.forall_mem_insert, forall_and_distrib] at h1 h2, rw prod_insert has,
  exact h2.1.mul (ih h1.2.2 h2.2) (is_coprime.prod_right $ λ i his, h1.1.2 i his $
    ne.symm $ ne_of_mem_of_not_mem his has)
end

lemma separable_prod {ι : Sort*} [fintype ι] {f : ι → polynomial R}
  (h1 : pairwise (is_coprime on f)) (h2 : ∀ x, (f x).separable) : (∏ x, f x).separable :=
separable_prod' (λ x hx y hy hxy, h1 x y hxy) (λ x hx, h2 x)

lemma separable.inj_of_prod_X_sub_C [nontrivial R] {ι : Sort*} {f : ι → R} {s : finset ι}
  (hfs : (∏ i in s, (X - C (f i))).separable)
  {x y : ι} (hx : x ∈ s) (hy : y ∈ s) (hfxy : f x = f y) : x = y :=
begin
  by_contra hxy,
  rw [← insert_erase hx, prod_insert (not_mem_erase _ _),
      ← insert_erase (mem_erase_of_ne_of_mem (ne.symm hxy) hy),
      prod_insert (not_mem_erase _ _), ← mul_assoc, hfxy, ← sq] at hfs,
  cases (hfs.of_mul_left.of_pow (by exact not_is_unit_X_sub_C) two_ne_zero).2
end

lemma separable.injective_of_prod_X_sub_C [nontrivial R] {ι : Sort*} [fintype ι] {f : ι → R}
  (hfs : (∏ i, (X - C (f i))).separable) : function.injective f :=
λ x y hfxy, hfs.inj_of_prod_X_sub_C (mem_univ _) (mem_univ _) hfxy

lemma is_unit_of_self_mul_dvd_separable {p q : polynomial R}
  (hp : p.separable) (hq : q * q ∣ p) : is_unit q :=
begin
  obtain ⟨p, rfl⟩ := hq,
  apply is_coprime_self.mp,
  have : is_coprime (q * (q * p)) (q * (q.derivative * p + q.derivative * p + q * p.derivative)),
  { simp only [← mul_assoc, mul_add],
    convert hp,
    rw [derivative_mul, derivative_mul],
    ring },
  exact is_coprime.of_mul_right_left (is_coprime.of_mul_left_left this)
end

end comm_ring

section integral_domain

variables (R : Type u) [integral_domain R]

theorem is_local_ring_hom_expand {p : ℕ} (hp : 0 < p) :
  is_local_ring_hom (↑(expand R p) : polynomial R →+* polynomial R) :=
begin
  refine ⟨λ f hf1, _⟩, rw ← coe_fn_coe_base at hf1,
  have hf2 := eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit hf1),
  rw [coeff_expand hp, if_pos (dvd_zero _), p.zero_div] at hf2,
  rw [hf2, is_unit_C] at hf1, rw expand_eq_C hp at hf2, rwa [hf2, is_unit_C]
end

end integral_domain

section field

variables {F : Type u} [field F] {K : Type v} [field K]

theorem separable_iff_derivative_ne_zero {f : polynomial F} (hf : irreducible f) :
  f.separable ↔ f.derivative ≠ 0 :=
⟨λ h1 h2, hf.not_unit $ is_coprime_zero_right.1 $ h2 ▸ h1,
λ h, is_coprime_of_dvd (mt and.right h) $ λ g hg1 hg2 ⟨p, hg3⟩ hg4,
let ⟨u, hu⟩ := (hf.is_unit_or_is_unit hg3).resolve_left hg1 in
have f ∣ f.derivative, by { conv_lhs { rw [hg3, ← hu] }, rwa units.mul_right_dvd },
not_lt_of_le (nat_degree_le_of_dvd this h) $ nat_degree_derivative_lt h⟩

theorem separable_map (f : F →+* K) {p : polynomial F} : (p.map f).separable ↔ p.separable :=
by simp_rw [separable_def, derivative_map, is_coprime_map]

section char_p

variables (p : ℕ) [hp : fact p.prime]
include hp

/-- The opposite of `expand`: sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`. -/
noncomputable def contract (f : polynomial F) : polynomial F :=
⟨f.support.preimage (*p) $ λ _ _ _ _, (nat.mul_left_inj hp.1.pos).1,
λ n, f.coeff (n * p),
λ n, by rw [finset.mem_preimage, mem_support_iff]⟩

theorem coeff_contract (f : polynomial F) (n : ℕ) : (contract p f).coeff n = f.coeff (n * p) := rfl

theorem of_irreducible_expand {f : polynomial F} (hf : irreducible (expand F p f)) :
  irreducible f :=
@@of_irreducible_map _ _ _ (is_local_ring_hom_expand F hp.1.pos) hf

theorem of_irreducible_expand_pow {f : polynomial F} {n : ℕ} :
  irreducible (expand F (p ^ n) f) → irreducible f :=
nat.rec_on n (λ hf, by rwa [pow_zero, expand_one] at hf) $ λ n ih hf,
ih $ of_irreducible_expand p $ by { rw pow_succ at hf, rwa [expand_expand] }

variables [HF : char_p F p]
include HF

theorem expand_char (f : polynomial F) :
  map (frobenius F p) (expand F p f) = f ^ p :=
begin
  refine f.induction_on' (λ a b ha hb, _) (λ n a, _),
  { rw [alg_hom.map_add, map_add, ha, hb, add_pow_char], },
  { rw [expand_monomial, map_monomial, single_eq_C_mul_X, single_eq_C_mul_X,
        mul_pow, ← C.map_pow, frobenius_def],
    ring_exp }
end

theorem map_expand_pow_char (f : polynomial F) (n : ℕ) :
   map ((frobenius F p) ^ n) (expand F (p ^ n) f) = f ^ (p ^ n) :=
begin
  induction n, {simp [ring_hom.one_def]},
  symmetry,
  rw [pow_succ', pow_mul, ← n_ih, ← expand_char, pow_succ, ring_hom.mul_def, ← map_map, mul_comm,
      expand_mul, ← map_expand (nat.prime.pos hp.1)],
end

theorem expand_contract {f : polynomial F} (hf : f.derivative = 0) :
  expand F p (contract p f) = f :=
begin
  ext n, rw [coeff_expand hp.1.pos, coeff_contract], split_ifs with h,
  { rw nat.div_mul_cancel h },
  { cases n, { exact absurd (dvd_zero p) h },
    have := coeff_derivative f n, rw [hf, coeff_zero, zero_eq_mul] at this, cases this, { rw this },
    rw [← nat.cast_succ, char_p.cast_eq_zero_iff F p] at this,
    exact absurd this h }
end

theorem separable_or {f : polynomial F} (hf : irreducible f) : f.separable ∨
  ¬f.separable ∧ ∃ g : polynomial F, irreducible g ∧ expand F p g = f :=
if H : f.derivative = 0 then or.inr
  ⟨by rw [separable_iff_derivative_ne_zero hf, not_not, H],
  contract p f,
  by haveI := is_local_ring_hom_expand F hp.1.pos; exact
    of_irreducible_map ↑(expand F p) (by rwa ← expand_contract p H at hf),
  expand_contract p H⟩
else or.inl $ (separable_iff_derivative_ne_zero hf).2 H

theorem exists_separable_of_irreducible {f : polynomial F} (hf : irreducible f) (hf0 : f ≠ 0) :
  ∃ (n : ℕ) (g : polynomial F), g.separable ∧ expand F (p ^ n) g = f :=
begin
  generalize hn : f.nat_degree = N, unfreezingI { revert f },
  apply nat.strong_induction_on N, intros N ih f hf hf0 hn,
  rcases separable_or p hf with h | ⟨h1, g, hg, hgf⟩,
  { refine ⟨0, f, h, _⟩, rw [pow_zero, expand_one] },
  { cases N with N,
    { rw [nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff] at hn,
      rw [hn, separable_C, is_unit_iff_ne_zero, not_not] at h1,
      rw [h1, C_0] at hn, exact absurd hn hf0 },
    have hg1 : g.nat_degree * p = N.succ,
    { rwa [← nat_degree_expand, hgf] },
    have hg2 : g.nat_degree ≠ 0,
    { intro this, rw [this, zero_mul] at hg1, cases hg1 },
    have hg3 : g.nat_degree < N.succ,
    { rw [← mul_one g.nat_degree, ← hg1],
      exact nat.mul_lt_mul_of_pos_left hp.1.one_lt (nat.pos_of_ne_zero hg2) },
    have hg4 : g ≠ 0,
    { rintro rfl, exact hg2 nat_degree_zero },
    rcases ih _ hg3 hg hg4 rfl with ⟨n, g, hg5, rfl⟩, refine ⟨n+1, g, hg5, _⟩,
    rw [← hgf, expand_expand, pow_succ] }
end

theorem is_unit_or_eq_zero_of_separable_expand {f : polynomial F} (n : ℕ)
  (hf : (expand F (p ^ n) f).separable) : is_unit f ∨ n = 0 :=
begin
  rw or_iff_not_imp_right, intro hn,
  have hf2 : (expand F (p ^ n) f).derivative = 0,
  { by rw [derivative_expand, nat.cast_pow, char_p.cast_eq_zero,
      zero_pow (nat.pos_of_ne_zero hn), zero_mul, mul_zero] },
  rw [separable_def, hf2, is_coprime_zero_right, is_unit_iff] at hf, rcases hf with ⟨r, hr, hrf⟩,
  rw [eq_comm, expand_eq_C (pow_pos hp.1.pos _)] at hrf,
  rwa [hrf, is_unit_C]
end

theorem unique_separable_of_irreducible {f : polynomial F} (hf : irreducible f) (hf0 : f ≠ 0)
  (n₁ : ℕ) (g₁ : polynomial F) (hg₁ : g₁.separable) (hgf₁ : expand F (p ^ n₁) g₁ = f)
  (n₂ : ℕ) (g₂ : polynomial F) (hg₂ : g₂.separable) (hgf₂ : expand F (p ^ n₂) g₂ = f) :
  n₁ = n₂ ∧ g₁ = g₂ :=
begin
  revert g₁ g₂, wlog hn : n₁ ≤ n₂ := le_total n₁ n₂ using [n₁ n₂, n₂ n₁] tactic.skip,
  unfreezingI { intros, rw le_iff_exists_add at hn, rcases hn with ⟨k, rfl⟩,
    rw [← hgf₁, pow_add, expand_mul, expand_inj (pow_pos hp.1.pos n₁)] at hgf₂, subst hgf₂,
    subst hgf₁,
    rcases is_unit_or_eq_zero_of_separable_expand p k hg₁ with h | rfl,
    { rw is_unit_iff at h, rcases h with ⟨r, hr, rfl⟩,
      simp_rw expand_C at hf, exact absurd (is_unit_C.2 hr) hf.1 },
    { rw [add_zero, pow_zero, expand_one], split; refl } },
  exact λ g₁ g₂ hg₁ hgf₁ hg₂ hgf₂, let ⟨hn, hg⟩ :=
    this g₂ g₁ hg₂ hgf₂ hg₁ hgf₁ in ⟨hn.symm, hg.symm⟩
end

end char_p

lemma separable_prod_X_sub_C_iff' {ι : Sort*} {f : ι → F} {s : finset ι} :
  (∏ i in s, (X - C (f i))).separable ↔ (∀ (x ∈ s) (y ∈ s), f x = f y → x = y) :=
⟨λ hfs x hx y hy hfxy, hfs.inj_of_prod_X_sub_C hx hy hfxy,
λ H, by { rw ← prod_attach, exact separable_prod' (λ x hx y hy hxy,
    @pairwise_coprime_X_sub _ _ { x // x ∈ s } (λ x, f x)
      (λ x y hxy, subtype.eq $ H x.1 x.2 y.1 y.2 hxy) _ _ hxy)
  (λ _ _, separable_X_sub_C) }⟩

lemma separable_prod_X_sub_C_iff {ι : Sort*} [fintype ι] {f : ι → F} :
  (∏ i, (X - C (f i))).separable ↔ function.injective f :=
separable_prod_X_sub_C_iff'.trans $ by simp_rw [mem_univ, true_implies_iff]

section splits

open_locale big_operators

variables {i : F →+* K}

lemma not_unit_X_sub_C (a : F) : ¬ is_unit (X - C a) :=
λ h, have one_eq_zero : (1 : with_bot ℕ) = 0, by simpa using degree_eq_zero_of_is_unit h,
one_ne_zero (option.some_injective _ one_eq_zero)

lemma nodup_of_separable_prod {s : multiset F}
  (hs : separable (multiset.map (λ a, X - C a) s).prod) : s.nodup :=
begin
  rw multiset.nodup_iff_ne_cons_cons,
  rintros a t rfl,
  refine not_unit_X_sub_C a (is_unit_of_self_mul_dvd_separable hs _),
  simpa only [multiset.map_cons, multiset.prod_cons] using mul_dvd_mul_left _ (dvd_mul_right _ _)
end

lemma multiplicity_le_one_of_separable {p q : polynomial F} (hq : ¬ is_unit q)
  (hsep : separable p) : multiplicity q p ≤ 1 :=
begin
  contrapose! hq,
  apply is_unit_of_self_mul_dvd_separable hsep,
  rw ← sq,
  apply multiplicity.pow_dvd_of_le_multiplicity,
  exact_mod_cast (enat.add_one_le_of_lt hq)
end

lemma separable.squarefree {p : polynomial F}  (hsep : separable p) : squarefree p :=
begin
  rw multiplicity.squarefree_iff_multiplicity_le_one p,
  intro f,
  by_cases hunit : is_unit f,
  { exact or.inr hunit },
  exact or.inl (multiplicity_le_one_of_separable hunit hsep)
end

/--If `n ≠ 0` in `F`, then ` X ^ n - a` is separable for any `a ≠ 0`. -/
lemma separable_X_pow_sub_C {n : ℕ} (a : F) (hn : (n : F) ≠ 0) (ha : a ≠ 0) :
  separable (X ^ n - C a) :=
begin
  cases nat.eq_zero_or_pos n with hzero hpos,
  { exfalso,
    rw hzero at hn,
    exact hn (refl 0) },
  apply (separable_def' (X ^ n - C a)).2,
  use [-C (a⁻¹), (C ((a⁻¹) * (↑n)⁻¹) *  X)],
  have mul_pow_sub : X * X ^ (n - 1) = X ^ n,
  { nth_rewrite 0 [←pow_one X],
    rw pow_mul_pow_sub X (nat.succ_le_iff.mpr hpos) },
  rw [derivative_sub, derivative_C, sub_zero, derivative_pow X n, derivative_X, mul_one],
  have hcalc : C (a⁻¹ * (↑n)⁻¹) * (↑n * (X ^ n)) = C a⁻¹ * (X ^ n),
  { calc C (a⁻¹ * (↑n)⁻¹) * (↑n * (X ^ n))
       = C a⁻¹ * C ((↑n)⁻¹) * (C ↑n * (X ^ n)) : by rw [C_mul, C_eq_nat_cast]
   ... = C a⁻¹ * (C ((↑n)⁻¹) * C ↑n) * (X ^ n) : by ring
   ... = C a⁻¹ * C ((↑n)⁻¹ * ↑n) * (X ^ n) : by rw [← C_mul]
   ... = C a⁻¹ * C 1 * (X ^ n) : by field_simp [hn]
   ... = C a⁻¹ * (X ^ n) : by rw [C_1, mul_one] },
  calc -C a⁻¹ * (X ^ n - C a) + C (a⁻¹ * (↑n)⁻¹) * X * (↑n * X ^ (n - 1))
      = -C a⁻¹ * (X ^ n - C a) + C (a⁻¹ * (↑n)⁻¹) * (↑n * (X * X ^ (n - 1))) : by ring
  ... = -C a⁻¹ * (X ^ n - C a) + C a⁻¹ * (X ^ n) : by rw [mul_pow_sub, hcalc]
  ... = C a⁻¹ * C a : by ring
  ... = (1 : polynomial F) : by rw [← C_mul, inv_mul_cancel ha, C_1]
end

/--If `n ≠ 0` in `F`, then ` X ^ n - a` is squarefree for any `a ≠ 0`. -/
lemma squarefree_X_pow_sub_C {n : ℕ} (a : F) (hn : (n : F) ≠ 0) (ha : a ≠ 0) :
  squarefree (X ^ n - C a) :=
(separable_X_pow_sub_C a hn ha).squarefree

lemma root_multiplicity_le_one_of_separable {p : polynomial F} (hp : p ≠ 0)
  (hsep : separable p) (x : F) : root_multiplicity x p ≤ 1 :=
begin
  rw [root_multiplicity_eq_multiplicity, dif_neg hp, ← enat.coe_le_coe, enat.coe_get],
  exact multiplicity_le_one_of_separable (not_unit_X_sub_C _) hsep
end

lemma count_roots_le_one {p : polynomial F} (hsep : separable p) (x : F) :
  p.roots.count x ≤ 1 :=
begin
  by_cases hp : p = 0,
  { simp [hp] },
  rw count_roots hp,
  exact root_multiplicity_le_one_of_separable hp hsep x
end

lemma nodup_roots {p : polynomial F} (hsep : separable p) :
  p.roots.nodup :=
multiset.nodup_iff_count_le_one.mpr (count_roots_le_one hsep)

lemma eq_X_sub_C_of_separable_of_root_eq {x : F} {h : polynomial F} (h_ne_zero : h ≠ 0)
  (h_sep : h.separable) (h_root : h.eval x = 0) (h_splits : splits i h)
  (h_roots : ∀ y ∈ (h.map i).roots, y = i x) : h = (C (leading_coeff h)) * (X - C x) :=
begin
  apply polynomial.eq_X_sub_C_of_splits_of_single_root i h_splits,
  apply finset.mk.inj,
  { change _ = {i x},
    rw finset.eq_singleton_iff_unique_mem,
    split,
    { apply finset.mem_mk.mpr,
      rw mem_roots (show h.map i ≠ 0, by exact map_ne_zero h_ne_zero),
      rw [is_root.def,←eval₂_eq_eval_map,eval₂_hom,h_root],
      exact ring_hom.map_zero i },
    { exact h_roots } },
  { exact nodup_roots (separable.map h_sep) },
end

end splits

end field

end polynomial

open polynomial

theorem irreducible.separable {F : Type u} [field F] [char_zero F] {f : polynomial F}
  (hf : irreducible f) : f.separable :=
begin
  rw [separable_iff_derivative_ne_zero hf, ne, ← degree_eq_bot, degree_derivative_eq], rintro ⟨⟩,
  rw [pos_iff_ne_zero, ne, nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff],
  refine λ hf1, hf.not_unit _, rw [hf1, is_unit_C, is_unit_iff_ne_zero],
  intro hf2, rw [hf2, C_0] at hf1, exact absurd hf1 hf.ne_zero
end

-- TODO: refactor to allow transcendental extensions?
-- See: https://en.wikipedia.org/wiki/Separable_extension#Separability_of_transcendental_extensions

/-- Typeclass for separable field extension: `K` is a separable field extension of `F` iff
the minimal polynomial of every `x : K` is separable. -/
class is_separable (F K : Sort*) [field F] [field K] [algebra F K] : Prop :=
(is_integral' (x : K) : is_integral F x)
(separable' (x : K) : (minpoly F x).separable)

theorem is_separable.is_integral {F K} [field F] [field K] [algebra F K] (h : is_separable F K) :
  ∀ x : K, is_integral F x := is_separable.is_integral'

theorem is_separable.separable {F K} [field F] [field K] [algebra F K] (h : is_separable F K) :
  ∀ x : K, (minpoly F x).separable := is_separable.separable'

theorem is_separable_iff {F K} [field F] [field K] [algebra F K] : is_separable F K ↔
  ∀ x : K, is_integral F x ∧ (minpoly F x).separable :=
⟨λ h x, ⟨h.is_integral x, h.separable x⟩, λ h, ⟨λ x, (h x).1, λ x, (h x).2⟩⟩

instance is_separable_self (F : Type*) [field F] : is_separable F F :=
⟨λ x, is_integral_algebra_map, λ x, by { rw minpoly.eq_X_sub_C', exact separable_X_sub_C }⟩

section is_separable_tower
variables (F K E : Type*) [field F] [field K] [field E] [algebra F K] [algebra F E]
  [algebra K E] [is_scalar_tower F K E]

lemma is_separable_tower_top_of_is_separable [h : is_separable F E] : is_separable K E :=
⟨λ x, is_integral_of_is_scalar_tower x (h.is_integral x),
 λ x, (h.separable x).map.of_dvd (minpoly.dvd_map_of_is_scalar_tower _ _ _)⟩

lemma is_separable_tower_bot_of_is_separable [h : is_separable F E] : is_separable F K :=
is_separable_iff.2 $ λ x, begin
  refine (is_separable_iff.1 h (algebra_map K E x)).imp
    is_integral_tower_bot_of_is_integral_field (λ hs, _),
  obtain ⟨q, hq⟩ := minpoly.dvd F x
    (is_scalar_tower.aeval_eq_zero_of_aeval_algebra_map_eq_zero_field
      (minpoly.aeval F ((algebra_map K E) x))),
  rw hq at hs,
  exact hs.of_mul_left
end

variables {E}

lemma is_separable.of_alg_hom (E' : Type*) [field E'] [algebra F E']
  (f : E →ₐ[F] E') [is_separable F E'] : is_separable F E :=
begin
  letI : algebra E E' := ring_hom.to_algebra f.to_ring_hom,
  haveI : is_scalar_tower F E E' := is_scalar_tower.of_algebra_map_eq (λ x, (f.commutes x).symm),
  exact is_separable_tower_bot_of_is_separable F E E',
end

end is_separable_tower


/-
Copyright stuff
-/
import .base_family
import data.list.sort

/-!
This file defines `supermatroids`; these are nonempty antichains of `bases` in a modular lattice
that satisfy two axioms asserting the existence of bases under various conditions.
-/

universes u v

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

open set order_dual

/-- In a matroid on a finite lattice, bases for sets exist -/
lemma indep.le_basis_of_le_of_finite [base_family α] [finite α] {i x : α} (hi : indep i)
(hix : i ≤ x) :
  ∃ j, j basis_for x ∧ i ≤ j :=
(set.finite.exists_maximal_mem
  (⟨i, ⟨hi,rfl.le,hix⟩⟩ : {i' | indep i' ∧ i ≤ i' ∧ i' ≤ x}.nonempty)).imp
    (λ j ⟨⟨hj, hij,hjx⟩,hj_max⟩,
     ⟨⟨hj,hjx, λ j' hj' hj'x hjj', hj_max j' ⟨hj',hij.trans hjj',hj'x⟩ hjj'⟩, hij⟩)

/-- In a matroid on a finite lattice, canopies for sets exist -/
lemma spanning.super_of_le_of_le_of_finite [base_family α] [finite α] {s x : α} (hs : spanning s)
(hxs : x ≤ s) :
  ∃ t, t canopy_for x ∧ t ≤ s :=
@indep.le_basis_of_le_of_finite αᵒᵈ _ _ _ _ hs hxs

section supermatroid

/-- Class for base families that satisfy an augmentation axiom and in which the base lattice
is modular. Equivalent to independence augmentation in the case of finite set lattices. -/
class supermatroid (α : Type u) extends base_family α, is_modular_lattice α :=
(exists_base_mid_of_indep_le_spanning :
  ∀ (x y : α), indep x → spanning y → x ≤ y → ∃ b, base b ∧ x ≤ b ∧ b ≤ y)
(le_basis_of_indep_le : ∀ (i x : α), indep i → i ≤ x → ∃ j, j basis_for x ∧ i ≤ j)

variables [supermatroid α] {a i j b b' s t x y z x' y' z' : α}

/-- A base_family on a finite lattice that satisfies the middle axiom is a supermatroid. -/
noncomputable lemma supermatroid_of_finite {α : Type u} [base_family α] [finite α]
[is_modular_lattice α]
(h : ∀ (x y : α), indep x → spanning y → x ≤ y → ∃ b, base b ∧ x ≤ b ∧ b ≤ y) :
  supermatroid α :=
⟨h, @indep.le_basis_of_le_of_finite _ _ _⟩

/-- #### Extensions to bases -/

lemma indep.exists_base_mid_of_le_spanning (hi : indep i) (hs : spanning s) (his : i ≤ s) :
  ∃ b, base b ∧ i ≤ b ∧ b ≤ s :=
supermatroid.exists_base_mid_of_indep_le_spanning _ _ hi hs his

lemma indep.exists_base_mid_of_le_sup_base (hi : indep i) (hb : base b) :
   ∃ b', base b' ∧ i ≤ b' ∧ b' ≤ i ⊔ b :=
hi.exists_base_mid_of_le_spanning (hb.sup_left_spanning _) le_sup_left

lemma base.exists_base_of_subset_le_supset_base (hb : base b) (hb' : base b') (hxy : x ≤ y)
  (hxb : x ≤ b) (hb'y : b' ≤ y):
   ∃ b₀, base b₀ ∧ x ≤ b₀ ∧ b₀ ≤ y :=
supermatroid.exists_base_mid_of_indep_le_spanning _ _ ⟨b,hb,hxb⟩ ⟨b',hb',hb'y⟩ hxy

lemma indep.lt_base_le_spanning_of_not_base (hi : indep i) (hi_b : ¬base i) (hs : spanning s)
(his : i ≤ s) :
  ∃ b, base b ∧ i < b ∧ b ≤ s  :=
(hi.exists_base_mid_of_le_spanning hs his).imp
  (λ j, λ ⟨hj,hij,hjs⟩, ⟨hj, hij.lt_of_ne (λ h, hi_b (h.substr hj)), hjs⟩)

lemma indep.lt_base_sup_le_sup_base_of_not_base (hi : indep i) (hi_nb : ¬ base i)
(hb : base b) :
  ∃ b', base b' ∧ i < b' ∧ b' ≤ i ⊔ b :=
(hi.lt_base_le_spanning_of_not_base hi_nb (hb.sup_left_spanning _) le_sup_left)

lemma indep.lt_base_le_spanning_of_lt (hj : indep j) (hs : spanning s) (hi : i < j) (his : i ≤ s) :
  ∃ b, base b ∧ i < b ∧ b ≤ s :=
(hj.indep_of_le hi.le).lt_base_le_spanning_of_not_base (hj.not_base_of_lt hi) hs his

lemma indep.lt_base_le_sup_base_of_lt (hj : indep j) (hi : i < j) (hb : base b) :
  ∃ b', base b' ∧ i < b' ∧ b' ≤ i ⊔ b :=
hj.lt_base_le_spanning_of_lt (hb.sup_left_spanning _) hi le_sup_left

lemma indep.base_of_spanning (hi : indep i) (hs : spanning i) : base i :=
exists.elim (hi.exists_base_mid_of_le_spanning hs rfl.le)
  (λ a ⟨ha,hia,hai⟩, (hai.antisymm hia).subst ha)

lemma indep.le_basis_of_le (hi : indep i) (hix : i ≤ x) : ∃ j, j basis_for x ∧ i ≤ j :=
supermatroid.le_basis_of_indep_le _ _ hi hix

lemma indep.le_basis_sup_right (hi : indep i) (x : α) : ∃ j, j basis_for (i ⊔ x) ∧ i ≤ j :=
hi.le_basis_of_le le_sup_left

lemma indep.le_basis_sup_left (hi : indep i) (x : α) : ∃ j, j basis_for (x ⊔ i) ∧ i ≤ j :=
hi.le_basis_of_le le_sup_right

lemma indep.lt_basis_of_not_basis_of_le (hi : indep i) (hi_n : ¬ i basis_for x)
(hix : i ≤ x) :
  ∃ j, j basis_for x ∧ i < j :=
(hi.le_basis_of_le hix).imp (λ j hj, ⟨hj.1, hj.2.lt_of_ne (λ h, hi_n (h.substr hj.1))⟩)

lemma indep.exists_lt_inf_base_of_not_basis (hi : indep i) (hnb : ¬ i basis_for x)
(hix : i ≤ x) :
  ∃ b, base b ∧ (x ⊓ b) basis_for x ∧ i < x ⊓ b :=
begin
  obtain ⟨j,hj,hjx⟩ := hi.lt_basis_of_not_basis_of_le hnb hix,
  obtain ⟨b,hb,hjb⟩ := hj.indep,
  refine ⟨b, hb, (hb.inf_left_indep _).basis_for inf_le_left _, hjx.trans_le (le_inf hj.le hjb)⟩,
  refine λ j' hj' hj'x hbxj, hbxj.antisymm _,
  rw ←hj.eq_of_le_indep hj' ((le_inf hj.le hjb).trans hbxj) hj'x,
  exact le_inf hj.le hjb,
end

lemma basis_for.base (hb : b basis_for s) (hs : spanning s) : base b :=
exists.elim (hb.indep.exists_base_mid_of_le_spanning hs hb.le)
  (λ b' ⟨hb',hbb',hb's⟩, (hb.eq_of_le_indep hb'.indep hbb' hb's).substr hb')

lemma exists_basis (x : α) : ∃ i, i basis_for x :=
exists.elim (exists_base α)
  (λ b hb, ((hb.inf_right_indep x).le_basis_of_le inf_le_right).imp (λ _ h, h.1))

lemma base.inf_basis (hb : base b) (x : α) :
  ∃ b', base b' ∧ ((b' ⊓ x) basis_for x) ∧ b' ≤ x ⊔ b  :=
begin
  obtain ⟨i,hi⟩ := exists_basis x,
  obtain ⟨b',⟨hb',bib',hb'i⟩⟩ := hi.indep.exists_base_mid_of_le_sup_base hb,
  refine ⟨b',hb',
    (hb'.inf_right_indep _).basis_for inf_le_right (λ j hj hjx hb'j, hb'j.antisymm (le_inf _ hjx)),
    hb'i.trans (sup_le_sup_right hi.le _)⟩,
  rwa ←hi.eq_of_le_indep hj (le_trans (le_inf bib' hi.le) hb'j) hjx,
end

lemma base.lt_base_le_spanning_of_lt (hb : base b) (hs : spanning s) (hib : i < b)
(his : i ≤ s) :
  ∃ b₀, base b₀ ∧ i < b₀ ∧ b₀ ≤ s :=
(hb.indep_of_le hib.le).lt_base_le_spanning_of_not_base (hb.not_base_of_lt hib) hs his

lemma base.lt_base_le_sup_base_of_lt (hb : base b) (hb' : base b') (hib : i < b) :
  ∃ b₀, base b₀ ∧ i < b₀ ∧ b₀ ≤ i ⊔ b' :=
(hb.indep_of_le hib.le).lt_base_sup_le_sup_base_of_not_base (hb.not_base_of_lt hib) hb'

/-- #### Duality -/

private lemma spanning.canopy_le_of_le' (hs : spanning s) (hxs : x ≤ s) :
  ∃ t, t canopy_for x ∧ t ≤ s :=
begin
  obtain ⟨b,hb,hbs⟩ := hs,
  obtain ⟨b₁, hb₁, hb₁x, hb₁b⟩ := hb.inf_basis x,
  refine ⟨x ⊔ b₁, ⟨hb₁.sup_left_spanning _, le_sup_left, _⟩,
    sup_le hxs (hb₁b.trans (sup_le hxs hbs))⟩,
  rintros t ⟨b₂,hb₂,hb₂t⟩ hxt hty,
  refine (sup_le hxt (by_contra (λ hb₁t, _))).antisymm hty,
  set j := b₁ ⊓ (x ⊔ b₂) with hj,

  have hj_lt : j < b₁ := inf_le_left.lt_of_ne
    (λ h_eq, hb₁t (by {rw ← h_eq, exact inf_le_right.trans (sup_le hxt hb₂t)})),

  obtain ⟨b₃, hb₃, hjb₃, hb₃j⟩ := hb₁.lt_base_le_sup_base_of_lt hb₂ hj_lt,

  have h1 := @inf_lt_inf_of_lt_of_sup_le_sup _ _ _ _ _ x hjb₃ (sup_le _ le_sup_right),
  swap,
  { rw [hj, inf_comm, inf_sup_assoc_of_le b₁ le_sup_right, le_inf_iff] at hb₃j,
    rw [hj, inf_comm, inf_sup_assoc_of_le b₁ le_sup_left, le_inf_iff],
    refine ⟨hb₃j.1, hb₃j.2.trans (sup_le le_sup_left (hb₂t.trans _))⟩,
    rwa sup_comm},
  refine (hb₁x.not_indep_of_lt (lt_of_le_of_lt (le_inf _ inf_le_right) h1)
    inf_le_right (hb₃.inf_right_indep x)),
  rw [hj, inf_comm, @inf_comm _ _ _ (x ⊔ b₂)],
  exact le_inf (inf_le_left.trans le_sup_left) inf_le_right,
end

/-- A supermatroid family is also a supermatroid family in the dual  -/
instance : supermatroid αᵒᵈ :=
⟨ λ i s hi hs his,
  (indep.exists_base_mid_of_le_spanning hs hi his).imp (λ b ⟨hb,hsb,hbi⟩, ⟨hb, hbi, hsb⟩),
  λ i x hi hix, (spanning.canopy_le_of_le' hi hix).imp (λ a ⟨ha, hia⟩, ⟨ha, hia⟩)⟩

lemma exists_canopy (x : α) : ∃ s, s canopy_for x := @exists_basis αᵒᵈ _ x

/-- #### Spanning sets -/

-- Need to rename the lemmas in this section to match their indep equivalents

lemma spanning.exists_base_mid_of_indep_le (hs : spanning s) (hi : indep i) (his : i ≤ s) :
  ∃ b, base b ∧ b ≤ s ∧ i ≤ b :=
@indep.exists_base_mid_of_le_spanning αᵒᵈ _ _ _ hs hi his

lemma spanning.base_lt_indep_le_of_not_base (hs : spanning s) (hs_nb : ¬base s) (hi : indep i)
(his : i ≤ s) :
  ∃ b, base b ∧ b < s ∧ i ≤ b :=
@indep.lt_base_le_spanning_of_not_base αᵒᵈ _ _ _ hs hs_nb hi his

lemma spanning.base_lt_inf_base_le_of_not_base (hs : spanning s) (hs_nb : ¬base s)
(hb : base b) :
  ∃ b', base b' ∧ b' < s ∧ s ⊓ b ≤ b' :=
@indep.lt_base_sup_le_sup_base_of_not_base αᵒᵈ _ _ _ hs hs_nb hb

lemma canopy_for.base (hs : s canopy_for x) (hx : indep x) : base s :=
@basis_for.base αᵒᵈ _ _ _ hs hx

lemma spanning.canopy_le_of_le (hs : spanning s) (hxs : x ≤ s) : ∃ t, t canopy_for x ∧ t ≤ s :=
spanning.canopy_le_of_le' hs hxs

lemma spanning.base_le_base_inf_le (hs : spanning s) (hb : base b) :
  ∃ b', base b' ∧ b' ≤ s ∧ s ⊓ b ≤ b' :=
@indep.exists_base_mid_of_le_sup_base αᵒᵈ _ _ _ hs hb

lemma spanning.exists_sup_base_lt_of_not_canopy_for (hs : spanning s) (hnb : ¬ s canopy_for x)
(hix : x ≤ s) :
  ∃ b, base b ∧ (x ⊔ b) canopy_for x ∧ x ⊔ b < s :=
@indep.exists_lt_inf_base_of_not_basis αᵒᵈ _ _ _ hs hnb hix

lemma base.base_lt_inf_le_base_of_lt (hb : base b) (hb' : base b') (hbs : b < s) :
  ∃ b₀, base b₀ ∧ b₀ < s ∧ s ⊓ b' ≤ b₀ :=
@base.lt_base_le_sup_base_of_lt αᵒᵈ _ _ _ _ hb hb' hbs

lemma base.sup_canopy_for (hb : base b) (x : α) :
  ∃ b',base b' ∧ (b' ⊔ x) canopy_for x ∧ x ⊓ b ≤ b'  :=
@base.inf_basis αᵒᵈ _ _ hb x

lemma basis_for.eq_inf_base_of_le_base (hix : i basis_for x) (hb : base b) (hib : i ≤ b) :
  i = x ⊓ b :=
hix.eq_of_le_indep (hb.inf_left_indep x) (le_inf hix.le hib) inf_le_left

lemma basis_for.exists_base (hi : i basis_for x) :
  ∃ b, base b ∧ i = x ⊓ b ∧ ∀ b', base b' → x ⊓ b ≤ b' → x ⊓ b' = x ⊓ b :=
begin
  obtain ⟨b, hb, hib⟩ := hi.indep,
  have := hi.eq_inf_base_of_le_base hb hib, subst this,
  exact ⟨_,hb, rfl, λ b' hb' hxb',
    (hi.eq_of_le_indep (hb'.inf_left_indep x) (le_inf inf_le_left hxb') inf_le_left).symm⟩,
end

lemma exists_base_inf_basis (x : α) : ∃ b, base b ∧ x ⊓ b basis_for x :=
let ⟨i,hi⟩ := exists_basis x in hi.exists_base.imp (λ b ⟨hb,hib,_⟩, ⟨hb, hib ▸ hi⟩)

lemma basis_for.eq_inf_base_both (hix : i basis_for x) (hiy : i basis_for y) :
  ∃ b, base b ∧ i = x ⊓ b ∧ i = y ⊓ b :=
hix.indep.imp (λ b hb, ⟨hb.1, hix.eq_inf_base_of_le_base hb.1 hb.2,
    hiy.eq_inf_base_of_le_base hb.1 hb.2⟩)

lemma canopy_for.eq_sup_super_both (hsx : s canopy_for x) (hsy : s canopy_for y) :
  ∃ b, base b ∧ s = x ⊔ b ∧ s = y ⊔ b :=
@basis_for.eq_inf_base_both αᵒᵈ _ _ _ _ hsx hsy

lemma eq_inf_basis_forall_of_basis_forall {x : κ → α} (h : ∀ k, i basis_for x k) :
  ∃ b, base b ∧ ∀ k, i = (x k) ⊓ b :=
(is_empty_or_nonempty κ).elim (λ he, (exists_base α).imp (λ b hb, ⟨hb, he.elim⟩ ))
  (λ ⟨k⟩, (h k).indep.imp (λ b hb, ⟨hb.1, λ k', (h k').eq_inf_base_of_le_base hb.1 hb.2⟩))

lemma eq_inf_basis_forall_of_basis_forall_mem {S : set α} (hS : ∀ x ∈ S, i basis_for x) :
  ∃ b, base b ∧ ∀ x ∈ S, i = x ⊓ b :=
(@eq_inf_basis_forall_of_basis_forall α S _ i coe (λ ⟨x,hx⟩, hS x hx)).imp
  (λ b hb, ⟨hb.1, λ x hx, (hb.2 ⟨x,hx⟩)⟩)

lemma eq_sup_basis_forall_of_canopy_forall {x : κ → α} (h : ∀ k, s canopy_for x k) :
  ∃ b, base b ∧ ∀ k, s = x k ⊔ b :=
@eq_inf_basis_forall_of_basis_forall αᵒᵈ κ _ _ _ h

lemma eq_sup_basis_forall_of_canopy_forall_mem {S : set α} (hS : ∀ x ∈ S, s canopy_for x) :
  ∃ b, base b ∧ ∀ x ∈ S, s = x ⊔ b :=
@eq_inf_basis_forall_of_basis_forall_mem αᵒᵈ _ _ S hS

lemma canopy_for.eq_sup_base_both (hsx : s canopy_for x) (hsy : s canopy_for y) :
  ∃ b, base b ∧ s = x ⊔ b ∧ s = y ⊔ b :=
@basis_for.eq_inf_base_both αᵒᵈ _ _ _ _ hsx hsy

lemma canopy_for.exists_base (hs : s canopy_for x) :
  ∃ b, base b ∧ s = x ⊔ b ∧ ∀ b', base b' → b' ≤ x ⊔ b → x ⊔ b' = x ⊔ b :=
@basis_for.exists_base αᵒᵈ _ _ _ hs

-- Probably this lemma is the right way to do duality. It might be that only semimodularity is needed...

lemma base.sup_canopy_of_inf_basis (hb : base b) (hbx : (x ⊓ b) basis_for x) :
  (x ⊔ b) canopy_for x :=
begin
  by_contradiction h,
  obtain ⟨b₁,hb₁,-, hb₁x⟩ :=
    (hb.sup_left_spanning x).exists_sup_base_lt_of_not_canopy_for h le_sup_left,

  set i := (x ⊔ b₁) ⊓ b with hi,

  have hlt : i < b := lt_of_le_of_ne inf_le_right
    (λ h, hb₁x.ne (le_antisymm
      (sup_le (le_sup_left.trans hb₁x.le) (le_sup_right.trans hb₁x.le))
      (sup_le (le_sup_left) (by {rw [←h,hi], exact inf_le_left})))),

  obtain ⟨b₂,hb₂,hib₂,hb₂i⟩ := hb.lt_base_le_sup_base_of_lt hb₁ hlt,

  have hlast := @inf_lt_inf_of_lt_of_sup_le_sup _ _ _ _ _ x hib₂ (sup_le _ le_sup_right),
  { refine hbx.not_indep_of_lt (lt_of_le_of_lt _ hlast) inf_le_right (hb₂.inf_right_indep x),
    exact le_inf (le_inf (inf_le_left.trans le_sup_left) inf_le_right) inf_le_left},
  rw [hi, inf_sup_assoc_of_le, le_inf_iff] at hb₂i ⊢,
  { exact ⟨hb₂i.1, hb₂i.1.trans (hb₁x.le.trans_eq sup_comm)⟩},
  exact le_sup_left, exact le_sup_right,
end

lemma base.sup_canopy_iff_inf_basis (hb : base b):
  (x ⊔ b) canopy_for x ↔ (x ⊓ b) basis_for x :=
⟨@base.sup_canopy_of_inf_basis αᵒᵈ _ _ _ hb, hb.sup_canopy_of_inf_basis⟩

lemma indep.le_basis_le_sup (hi : indep i) (hj : j basis_for x) (hix : i ≤ x) :
  ∃ i', i' basis_for x ∧ i ≤ i' ∧ i' ≤ i ⊔ j :=
begin
  obtain ⟨b₁,hb₁,rfl,-⟩ := hj.exists_base,
  obtain ⟨b₂, hb₂,hib₂, hb₂i⟩ := hi.exists_base_mid_of_le_sup_base hb₁,
  rw [←hb₁.sup_canopy_iff_inf_basis] at hj,
  have hb₁b₂ := hj.eq_of_spanning_le (hb₂.sup_left_spanning x) le_sup_left
    (sup_le le_sup_left (hb₂i.trans (sup_le (le_sup_of_le_left hix) le_sup_right))),
  rw [←hb₁b₂, hb₂.sup_canopy_iff_inf_basis] at hj,
  exact ⟨x ⊓ b₂, hj, le_inf hix hib₂, (inf_le_inf_left x hb₂i).trans
    (by rw [inf_comm, sup_inf_assoc_of_le _ hix, inf_comm])⟩,
end

-- This lemma is the independence augmentation axiom in the restriction to `x`
lemma indep.lt_basis_le_sup_of_not_basis (hi : indep i) (hin : ¬ (i basis_for x))
(hj : j basis_for x) (hix : i ≤ x) :
  ∃ i', i' basis_for x ∧ i < i' ∧ i' ≤ i ⊔ j :=
(hi.le_basis_le_sup hj hix).imp (λ b ⟨hb, hib, h⟩,
  ⟨hb, hib.lt_of_ne (λ hib, hin (hib.substr hb)), h⟩)

/-- This lemma is saying that `x ⊔ i` is a canopy for `x` in the restriction to `x ⊔ i` --/
lemma sup_eq_of_basis_basis_basis (hi_inf : x ⊓ i basis_for x) (hi_sup : i basis_for x ⊔ i)
(hj : j basis_for x ⊔ i) :
  x ⊔ j = x ⊔ i :=
begin
  refine (sup_le le_sup_left hj.le).antisymm (sup_le le_sup_left (by_contra (λ h', _))),

  have hnb : ¬ (i ⊓ (x ⊔ j)) basis_for x ⊔ i := hi_sup.not_basis_of_lt (inf_le_left.lt_of_ne
    (λ h_eq, by {rw ←h_eq at h', exact h' inf_le_right} )),

  obtain ⟨i₁, hi₁,hi'i₁,hi₁i'⟩ := (hi_sup.indep.inf_right_indep _).lt_basis_le_sup_of_not_basis
    hnb hj (le_sup_of_le_right inf_le_left),

  have hlt := @inf_lt_inf_of_lt_of_sup_le_sup _ _ _ _ _ x hi'i₁
    (sup_le (hi₁i'.trans (sup_le le_sup_left
      (by {rw [inf_comm, inf_sup_assoc_of_le _ (le_sup_left : x ≤ x ⊔ j), @sup_comm _ _ i],
          exact le_inf le_sup_right hj.le}))) le_sup_right),

  rw [inf_assoc, @inf_comm _ _ _ x, inf_sup_self, inf_comm, @inf_comm _ _ i₁] at hlt,
  exact hi_inf.not_indep_of_lt hlt inf_le_left (hi₁.indep.inf_left_indep _),
end

lemma spanning.ge_canopy_ge_inf (hs : spanning s) (ht : t canopy_for x) (hxs : x ≤ s) :
  ∃ s', s' canopy_for x ∧ s' ≤ s ∧ s ⊓ t ≤ s' :=
@indep.le_basis_le_sup αᵒᵈ _ _ _ _ hs ht hxs

lemma spanning.gt_canopy_ge_inf_of_not_canopy (hs : spanning s) (hsn : ¬ (s canopy_for x))
(ht : t canopy_for x) (hxs : x ≤ s) :
  ∃ s', s' canopy_for x ∧ s' < s ∧ s ⊓ t ≤ s' :=
@indep.lt_basis_le_sup_of_not_basis αᵒᵈ _ _ _ _ hs hsn ht hxs

lemma basis_for.basis_sup_mono (hix : i basis_for x) (hj : indep j) (hij : i ≤ j) :
  j basis_for (x ⊔ j) :=
begin
  obtain ⟨b, hb, hjb⟩ := hj,
  obtain ⟨j',hj',hjj'⟩ := (hb.indep_of_le hjb).le_basis_of_le (le_sup_right : j ≤ x ⊔ j),
  obtain rfl :=
    (hix.eq_of_le_indep (hb.inf_left_indep x) (le_inf hix.le (hij.trans hjb)) inf_le_left),
  by_contra h,
  have hlt  := hjj'.lt_of_ne (by {rintro rfl, exact h hj'}),

  refine hix.not_indep_of_lt _ inf_le_right (hj'.indep.inf_right_indep x),
  refine lt_of_le_of_lt (le_inf hij inf_le_left)
    (inf_lt_inf_of_lt_of_sup_le_sup hlt (sup_le (sup_comm.subst hj'.le) le_sup_right)),
end

lemma canopy_for.canopy_inf_mono (hsx : s canopy_for x) (ht : spanning t) (hts : t ≤ s) :
  t canopy_for (x ⊓ t) :=
@basis_for.basis_sup_mono αᵒᵈ _ _ _ _ hsx ht hts

-- lemma le_basis_nested {n : ℕ} (x : fin n → α) (h : monotone x) :
--   ∃ b, base b ∧ ∀ i, x i ⊓ b basis_for x i :=
-- begin
--   obtain (rfl | n) := n, exact (exists_base α).imp (λ b hb, ⟨hb, fin_zero_elim⟩),
--   suffices hk : ∀ (k : fin n.succ), ∃ b, base b ∧ ∀ (i : fin n.succ), i ≤ k → x i ⊓ b basis_for x i,
--     from (hk (fin.last n)).imp (λ b hb, ⟨hb.1, λ i, hb.2 _ (fin.le_last _)⟩),
--   obtain ⟨b0,⟨hb0,hb0'⟩⟩ := exists_base_inf_basis (x 0),
--   refine λ k, fin.induction_on k ⟨b0, hb0, λ i hi, by rwa hi.antisymm (fin.zero_le _)⟩ _,
--   rintros i ⟨b1,hb1,hib1⟩,
--   --obtain ⟨j,hj⟩ := (hib1 _ rfl.le).indep.le_basis_of_le -,

--   obtain ⟨j,hj,hjb1⟩ := (hib1  _ rfl.le).indep.le_basis_of_le
--     (inf_le_left.trans (h (fin.cast_succ_lt_succ i).le)),

--   obtain ⟨b,hb,hjb⟩ := hj.indep,
--   have := hj.eq_inf_base_of_le_base hb hjb, subst this,
--   refine ⟨b,hb, λ i₀ hi₀i, hi₀i.lt_or_eq.elim (λ hj', _) (by {rintro rfl, assumption })⟩,

--   convert hib1 _ (fin.le_cast_succ_iff.mpr hj') using 1,
--   refine le_antisymm (le_inf inf_le_left _) (le_inf inf_le_left _),
--   { },

--    --indep.le_basis_of_le

  -- exact ((exists_base_inf_basis (x 0)).imp (λ b hb,
  --   ⟨hb.1,λ i hi, by {rw (le_antisymm hi (fin.zero_le i)), exact hb.2}⟩)

  -- refine fin.cases _ (λ i, _),
  -- exact ) ,

--end
  -- obtain (rfl | n) := n,
  -- exact (exists_base α).imp (λ b hb, ⟨hb, fin_zero_elim⟩),

  -- suffices hwin : ∀ (y : ℕ → α), monotone y → (∃ m, ∀ i, m ≤ i → y i = y m) →
  --   ∃ b, base b ∧ ∀ i, y i ⊓ b basis_for y i,
  -- { have h' := hwin (λ i, x ⟨min i n, (min_le_right _ _).trans_lt (lt_add_one _) ⟩)
  --   (λ i j hij, (em (j ≤ n)).elim (λ hjn,
  --     by {have := hij.trans hjn,
  --     refine h (subtype.mk_le_mk.mpr _), convert hij; rwa min_eq_left}) (λ h, by {}))
  --   ⟨n, λ i hni, by simp [min_eq_right hni]⟩,
  --   exact h'.imp (λ b ⟨hb,hbx⟩, ⟨hb, λ ⟨i,hi⟩,
  --     by {rwa nat.lt_succ_iff at hi, convert hbx i; rwa min_eq_left, }⟩) },

  -- induction n with k hk,
  -- exact (exists_base α).imp (λ b hb, ⟨hb, fin_zero_elim⟩),
  -- obtain ⟨b₀,hb₀,hxb₀⟩ := @hk (λ i, x i) (λ i j hij, h (by simpa : (i : fin k.succ) ≤ j)),
  -- dsimp only at hxb₀,

  -- obtain (rfl | k) := k,
  --   exact (exists_base_inf_basis (x 0)).imp (λ b ⟨hb,hxb⟩, ⟨hb, λ i, by rwa fin.eq_zero i⟩),

  -- have := hxb₀ ⟨k, lt_add_one k⟩, dsimp at this,
  -- have := h (sorry : (⟨k,_⟩ : fin (k+1+1)) ≤ ⟨k+1,_⟩),

  -- have := (hxb₀ (fin.last _)).indep.le_basis_of_le (inf_le_left.trans _),

  -- cases n, exact (exists_base α).imp (λ b i, fin_zero_elim),
  -- suffices h₀ : ∀ (k : fin n.succ), ∃ b, ∀ i, i ≤ k → (x i ⊓ b) basis_for x i,
  --   from (h₀ (fin.last n)).imp (λ b hb i, hb _ (fin.le_last i)),
  -- intro k,
  -- refine fin.induction
  --   ((exists_base_inf_basis (x 0)).imp (λ b ⟨hb,hbx⟩ i hi, by rwa hi.antisymm (fin.zero_le _))) _ k,
  -- rintros i ⟨b₀,hb₀⟩,

-- lemma le_basis₂ {x y : α} (hxy : x ≤ y) : ∃ b, x ⊓ b basis_for x ∧ y ⊓ b basis_for y :=
-- begin
--   obtain ⟨i,hi⟩ := exists_basis x,
--   obtain ⟨j,hj,hij⟩ := hi.indep.le_basis_of_le (hi.le.trans hxy),
--   obtain ⟨b, hb, rfl, fa⟩ := hj.exists_base,
--   exact ⟨b, by rwa ←(hi.eq_inf_base_of_le_base hb (hij.trans inf_le_right)), hj⟩,
-- end

end supermatroid


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic

/-

# Constructive bijections

I'm generally quite anti-constructive mathematics; it makes stuff harder
to do in Lean whilst only providing benefits such as computational content
which I am typically not interested in (I never `#eval` stuff, I just
want to prove theorems and I don't care if the proof isn't `refl`).

But one example of where I love constructivism is `X ≃ Y`, the class
of constructive bijections from `X` to `Y`. What is a constructive
bijection? It is a function `f : X → Y` plus some more data, but here
the data is *not* just the propositional claim that `f` is bijective
(i.e. the *existence* of a two-sided inverse) -- it is the actual
data of the two-sided inverse too.

`X ≃ Y` is notation for `equiv X Y`. This is the type of constructive
bijections from `X` to `Y`. To make a term of type `X ≃ Y` you need
to give a 4-tuple consisting of two functions `f : X → Y` and `g : Y → X`,
plus also two proofs: firstly a proof of `∀ y, f (g y) = y`, and secondly
a proof of `∀ x, g (f x) = x`.

Note that `X ≃ Y` has type `Type`, not `Prop`. It does *not* mean "there exists
a bijection from `X` to `Y`", it is the actual data of a bijection
from `X` to `Y`.

Let's build two different bijections from ℚ to ℚ.

The first one is easy; I'll do it for you, to show you the syntax.

-/

def bijection1 : ℚ ≃ ℚ :=
{ to_fun := id, -- use the identity function from ℚ to ℚ
  inv_fun := id, -- its inverse is also the identity function
  left_inv := begin -- we have to prove ∀ q, id (id q) = q
    intro q,
    refl,
  end,
  right_inv := λ q, rfl } -- same proof but in term mode

-- Now see if you can do a harder one.
def bijection2 : ℚ ≃ ℚ :=
{ to_fun := λ q, 3 * q + 4,
  inv_fun := λ r, (r - 4) / 3,
  left_inv := begin -- start with `intro r`, then use `dsimp` to tidy up the mess
    intro r,
    dsimp,
    ring,
  end,
  right_inv := begin
    intro s,
    ring,
  end }


/-
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 order.bounded_order

/-!
# Disjointness and complements

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

This file defines `disjoint`, `codisjoint`, and the `is_compl` predicate.

## Main declarations

* `disjoint x y`: two elements of a lattice are disjoint if their `inf` is the bottom element.
* `codisjoint x y`: two elements of a lattice are codisjoint if their `join` is the top element.
* `is_compl x y`: In a bounded lattice, predicate for "`x` is a complement of `y`". Note that in a
  non distributive lattice, an element can have several complements.
* `complemented_lattice α`: Typeclass stating that any element of a lattice has a complement.

-/

variable {α : Type*}

section disjoint
section partial_order_bot
variables [partial_order α] [order_bot α] {a b c d : α}

/-- Two elements of a lattice are disjoint if their inf is the bottom element.
  (This generalizes disjoint sets, viewed as members of the subset lattice.)

Note that we define this without reference to `⊓`, as this allows us to talk about orders where
the infimum is not unique, or where implementing `has_inf` would require additional `decidable`
arguments. -/
def disjoint (a b : α) : Prop := ∀ ⦃x⦄, x ≤ a → x ≤ b → x ≤ ⊥

lemma disjoint.comm : disjoint a b ↔ disjoint b a := forall_congr $ λ _, forall_swap
@[symm] lemma disjoint.symm ⦃a b : α⦄ : disjoint a b → disjoint b a := disjoint.comm.1
lemma symmetric_disjoint : symmetric (disjoint : α → α → Prop) := disjoint.symm

@[simp] lemma disjoint_bot_left : disjoint ⊥ a := λ x hbot ha, hbot
@[simp] lemma disjoint_bot_right : disjoint a ⊥ := λ x ha hbot, hbot

lemma disjoint.mono (h₁ : a ≤ b) (h₂ : c ≤ d) : disjoint b d → disjoint a c :=
λ h x ha hc, h (ha.trans h₁) (hc.trans h₂)

lemma disjoint.mono_left (h : a ≤ b) : disjoint b c → disjoint a c := disjoint.mono h le_rfl
lemma disjoint.mono_right : b ≤ c → disjoint a c → disjoint a b := disjoint.mono le_rfl

@[simp] lemma disjoint_self : disjoint a a ↔ a = ⊥ :=
⟨λ hd, bot_unique $ hd le_rfl le_rfl, λ h x ha hb, ha.trans_eq h⟩

/- TODO: Rename `disjoint.eq_bot` to `disjoint.inf_eq` and `disjoint.eq_bot_of_self` to
`disjoint.eq_bot` -/
alias disjoint_self ↔ disjoint.eq_bot_of_self _

lemma disjoint.ne (ha : a ≠ ⊥) (hab : disjoint a b) : a ≠ b :=
λ h, ha $ disjoint_self.1 $ by rwa ←h at hab

lemma disjoint.eq_bot_of_le (hab : disjoint a b) (h : a ≤ b) : a = ⊥ :=
eq_bot_iff.2 $ hab le_rfl h

lemma disjoint.eq_bot_of_ge (hab : disjoint a b) : b ≤ a → b = ⊥ := hab.symm.eq_bot_of_le

end partial_order_bot

section partial_bounded_order
variables [partial_order α] [bounded_order α] {a : α}

@[simp] theorem disjoint_top : disjoint a ⊤ ↔ a = ⊥ :=
⟨λ h, bot_unique $ h le_rfl le_top, λ h x ha htop, ha.trans_eq h⟩

@[simp] theorem top_disjoint : disjoint ⊤ a ↔ a = ⊥ :=
⟨λ h, bot_unique $ h le_top le_rfl, λ h x htop ha, ha.trans_eq h⟩

end partial_bounded_order

section semilattice_inf_bot
variables [semilattice_inf α] [order_bot α] {a b c d : α}

lemma disjoint_iff_inf_le : disjoint a b ↔ a ⊓ b ≤ ⊥ :=
⟨λ hd, hd inf_le_left inf_le_right, λ h x ha hb, (le_inf ha hb).trans h⟩
lemma disjoint_iff : disjoint a b ↔ a ⊓ b = ⊥ := disjoint_iff_inf_le.trans le_bot_iff
lemma disjoint.le_bot : disjoint a b → a ⊓ b ≤ ⊥ := disjoint_iff_inf_le.mp
lemma disjoint.eq_bot : disjoint a b → a ⊓ b = ⊥ := bot_unique ∘ disjoint.le_bot
lemma disjoint_assoc : disjoint (a ⊓ b) c ↔ disjoint a (b ⊓ c) :=
by rw [disjoint_iff_inf_le, disjoint_iff_inf_le, inf_assoc]
lemma disjoint_left_comm : disjoint a (b ⊓ c) ↔ disjoint b (a ⊓ c) :=
by simp_rw [disjoint_iff_inf_le, inf_left_comm]
lemma disjoint_right_comm : disjoint (a ⊓ b) c ↔ disjoint (a ⊓ c) b :=
by simp_rw [disjoint_iff_inf_le, inf_right_comm]

variables (c)

lemma disjoint.inf_left (h : disjoint a b) : disjoint (a ⊓ c) b := h.mono_left inf_le_left
lemma disjoint.inf_left' (h : disjoint a b) : disjoint (c ⊓ a) b := h.mono_left inf_le_right
lemma disjoint.inf_right (h : disjoint a b) : disjoint a (b ⊓ c) := h.mono_right inf_le_left
lemma disjoint.inf_right' (h : disjoint a b) : disjoint a (c ⊓ b) := h.mono_right inf_le_right

variables {c}

lemma disjoint.of_disjoint_inf_of_le (h : disjoint (a ⊓ b) c) (hle : a ≤ c) : disjoint a b :=
disjoint_iff.2 $ h.eq_bot_of_le $ inf_le_of_left_le hle

lemma disjoint.of_disjoint_inf_of_le' (h : disjoint (a ⊓ b) c) (hle : b ≤ c) : disjoint a b :=
disjoint_iff.2 $ h.eq_bot_of_le $ inf_le_of_right_le hle

end semilattice_inf_bot

section distrib_lattice_bot
variables [distrib_lattice α] [order_bot α] {a b c : α}

@[simp] lemma disjoint_sup_left : disjoint (a ⊔ b) c ↔ disjoint a c ∧ disjoint b c :=
by simp only [disjoint_iff, inf_sup_right, sup_eq_bot_iff]

@[simp] lemma disjoint_sup_right : disjoint a (b ⊔ c) ↔ disjoint a b ∧ disjoint a c :=
by simp only [disjoint_iff, inf_sup_left, sup_eq_bot_iff]

lemma disjoint.sup_left (ha : disjoint a c) (hb : disjoint b c) : disjoint (a ⊔ b) c :=
disjoint_sup_left.2 ⟨ha, hb⟩

lemma disjoint.sup_right (hb : disjoint a b) (hc : disjoint a c) : disjoint a (b ⊔ c) :=
disjoint_sup_right.2 ⟨hb, hc⟩

lemma disjoint.left_le_of_le_sup_right (h : a ≤ b ⊔ c) (hd : disjoint a c) : a ≤ b :=
le_of_inf_le_sup_le (le_trans hd.le_bot bot_le) $ sup_le h le_sup_right

lemma disjoint.left_le_of_le_sup_left (h : a ≤ c ⊔ b) (hd : disjoint a c) : a ≤ b :=
hd.left_le_of_le_sup_right $ by rwa sup_comm

end distrib_lattice_bot
end disjoint

section codisjoint
section partial_order_top
variables [partial_order α] [order_top α] {a b c d : α}

/-- Two elements of a lattice are codisjoint if their sup is the top element.

Note that we define this without reference to `⊔`, as this allows us to talk about orders where
the supremum is not unique, or where implement `has_sup` would require additional `decidable`
arguments. -/
def codisjoint (a b : α) : Prop := ∀ ⦃x⦄, a ≤ x → b ≤ x → ⊤ ≤ x

lemma codisjoint.comm : codisjoint a b ↔ codisjoint b a := forall_congr $ λ _, forall_swap
@[symm] lemma codisjoint.symm ⦃a b : α⦄ : codisjoint a b → codisjoint b a := codisjoint.comm.1
lemma symmetric_codisjoint : symmetric (codisjoint : α → α → Prop) := codisjoint.symm

@[simp] lemma codisjoint_top_left : codisjoint ⊤ a := λ x htop ha, htop
@[simp] lemma codisjoint_top_right : codisjoint a ⊤ := λ x ha htop, htop

lemma codisjoint.mono (h₁ : a ≤ b) (h₂ : c ≤ d) : codisjoint a c → codisjoint b d :=
λ h x ha hc, h (h₁.trans ha) (h₂.trans hc)

lemma codisjoint.mono_left (h : a ≤ b) : codisjoint a c → codisjoint b c :=
codisjoint.mono h le_rfl
lemma codisjoint.mono_right : b ≤ c → codisjoint a b → codisjoint a c :=
codisjoint.mono le_rfl

@[simp] lemma codisjoint_self : codisjoint a a ↔ a = ⊤ :=
⟨λ hd, top_unique $ hd le_rfl le_rfl, λ h x ha hb, h.symm.trans_le ha⟩

/- TODO: Rename `codisjoint.eq_top` to `codisjoint.sup_eq` and `codisjoint.eq_top_of_self` to
`codisjoint.eq_top` -/
alias codisjoint_self ↔ codisjoint.eq_top_of_self _

lemma codisjoint.ne (ha : a ≠ ⊤) (hab : codisjoint a b) : a ≠ b :=
λ h, ha $ codisjoint_self.1 $ by rwa ←h at hab

lemma codisjoint.eq_top_of_le (hab : codisjoint a b) (h : b ≤ a) : a = ⊤ :=
eq_top_iff.2 $ hab le_rfl h

lemma codisjoint.eq_top_of_ge (hab : codisjoint a b) : a ≤ b → b = ⊤ := hab.symm.eq_top_of_le

end partial_order_top

section partial_bounded_order
variables [partial_order α] [bounded_order α] {a : α}

@[simp] theorem codisjoint_bot : codisjoint a ⊥ ↔ a = ⊤ :=
⟨λ h, top_unique $ h le_rfl bot_le, λ h x ha htop, h.symm.trans_le ha⟩

@[simp] theorem bot_codisjoint : codisjoint ⊥ a ↔ a = ⊤ :=
⟨λ h, top_unique $ h bot_le le_rfl, λ h x htop ha, h.symm.trans_le ha⟩

end partial_bounded_order

section semilattice_sup_top
variables [semilattice_sup α] [order_top α] {a b c d : α}

lemma codisjoint_iff_le_sup : codisjoint a b ↔ ⊤ ≤ a ⊔ b := @disjoint_iff_inf_le αᵒᵈ _ _ _ _
lemma codisjoint_iff : codisjoint a b ↔ a ⊔ b = ⊤ := @disjoint_iff αᵒᵈ _ _ _ _
lemma codisjoint.top_le : codisjoint a b → ⊤ ≤ a ⊔ b := @disjoint.le_bot αᵒᵈ _ _ _ _
lemma codisjoint.eq_top : codisjoint a b → a ⊔ b = ⊤ := @disjoint.eq_bot αᵒᵈ _ _ _ _
lemma codisjoint_assoc : codisjoint (a ⊔ b) c ↔ codisjoint a (b ⊔ c) :=
@disjoint_assoc αᵒᵈ _ _ _ _ _
lemma codisjoint_left_comm : codisjoint a (b ⊔ c) ↔ codisjoint b (a ⊔ c) :=
@disjoint_left_comm αᵒᵈ _ _ _ _ _
lemma codisjoint_right_comm : codisjoint (a ⊔ b) c ↔ codisjoint (a ⊔ c) b :=
@disjoint_right_comm αᵒᵈ _ _ _ _ _

variables (c)

lemma codisjoint.sup_left (h : codisjoint a b) : codisjoint (a ⊔ c) b := h.mono_left le_sup_left
lemma codisjoint.sup_left' (h : codisjoint a b) : codisjoint (c ⊔ a) b := h.mono_left le_sup_right
lemma codisjoint.sup_right (h : codisjoint a b) : codisjoint a (b ⊔ c) := h.mono_right le_sup_left
lemma codisjoint.sup_right' (h : codisjoint a b) : codisjoint a (c ⊔ b) := h.mono_right le_sup_right

variables {c}

lemma codisjoint.of_codisjoint_sup_of_le (h : codisjoint (a ⊔ b) c) (hle : c ≤ a) :
  codisjoint a b :=
@disjoint.of_disjoint_inf_of_le αᵒᵈ _ _ _ _ _ h hle

lemma codisjoint.of_codisjoint_sup_of_le' (h : codisjoint (a ⊔ b) c) (hle : c ≤ b) :
  codisjoint a b :=
@disjoint.of_disjoint_inf_of_le' αᵒᵈ _ _ _ _ _ h hle

end semilattice_sup_top

section distrib_lattice_top
variables [distrib_lattice α] [order_top α] {a b c : α}

@[simp] lemma codisjoint_inf_left : codisjoint (a ⊓ b) c ↔ codisjoint a c ∧ codisjoint b c :=
by simp only [codisjoint_iff, sup_inf_right, inf_eq_top_iff]

@[simp] lemma codisjoint_inf_right : codisjoint a (b ⊓ c) ↔ codisjoint a b ∧ codisjoint a c :=
by simp only [codisjoint_iff, sup_inf_left, inf_eq_top_iff]

lemma codisjoint.inf_left (ha : codisjoint a c) (hb : codisjoint b c) : codisjoint (a ⊓ b) c :=
codisjoint_inf_left.2 ⟨ha, hb⟩

lemma codisjoint.inf_right (hb : codisjoint a b) (hc : codisjoint a c) : codisjoint a (b ⊓ c) :=
codisjoint_inf_right.2 ⟨hb, hc⟩

lemma codisjoint.left_le_of_le_inf_right (h : a ⊓ b ≤ c) (hd : codisjoint b c) : a ≤ c :=
@disjoint.left_le_of_le_sup_right αᵒᵈ _ _ _ _ _ h hd.symm

lemma codisjoint.left_le_of_le_inf_left (h : b ⊓ a ≤ c) (hd : codisjoint b c) : a ≤ c :=
hd.left_le_of_le_inf_right $ by rwa inf_comm

end distrib_lattice_top
end codisjoint

open order_dual

lemma disjoint.dual [semilattice_inf α] [order_bot α] {a b : α} :
  disjoint a b → codisjoint (to_dual a) (to_dual b) := id

lemma codisjoint.dual [semilattice_sup α] [order_top α] {a b : α} :
  codisjoint a b → disjoint (to_dual a) (to_dual b) := id

@[simp] lemma disjoint_to_dual_iff [semilattice_sup α] [order_top α] {a b : α} :
  disjoint (to_dual a) (to_dual b) ↔ codisjoint a b := iff.rfl
@[simp] lemma disjoint_of_dual_iff [semilattice_inf α] [order_bot α] {a b : αᵒᵈ} :
  disjoint (of_dual a) (of_dual b) ↔ codisjoint a b := iff.rfl
@[simp] lemma codisjoint_to_dual_iff [semilattice_inf α] [order_bot α] {a b : α} :
  codisjoint (to_dual a) (to_dual b) ↔ disjoint a b := iff.rfl
@[simp] lemma codisjoint_of_dual_iff [semilattice_sup α] [order_top α] {a b : αᵒᵈ} :
  codisjoint (of_dual a) (of_dual b) ↔ disjoint a b := iff.rfl

section distrib_lattice
variables [distrib_lattice α] [bounded_order α] {a b c : α}

lemma disjoint.le_of_codisjoint (hab : disjoint a b) (hbc : codisjoint b c) : a ≤ c :=
begin
  rw [←@inf_top_eq _ _ _ a, ←@bot_sup_eq _ _ _ c, ←hab.eq_bot, ←hbc.eq_top, sup_inf_right],
  exact inf_le_inf_right _ le_sup_left,
end

end distrib_lattice

section is_compl

/-- Two elements `x` and `y` are complements of each other if `x ⊔ y = ⊤` and `x ⊓ y = ⊥`. -/
@[protect_proj] structure is_compl [partial_order α] [bounded_order α] (x y : α) : Prop :=
(disjoint : disjoint x y)
(codisjoint : codisjoint x y)

lemma is_compl_iff [partial_order α] [bounded_order α] {a b : α} :
  is_compl a b ↔ disjoint a b ∧ codisjoint a b := ⟨λ h, ⟨h.1, h.2⟩, λ h, ⟨h.1, h.2⟩⟩

namespace is_compl

section bounded_partial_order
variables [partial_order α] [bounded_order α] {x y z : α}

@[symm] protected lemma symm (h : is_compl x y) : is_compl y x := ⟨h.1.symm, h.2.symm⟩

lemma dual (h : is_compl x y) : is_compl (to_dual x) (to_dual y) := ⟨h.2, h.1⟩
lemma of_dual {a b : αᵒᵈ} (h : is_compl a b) : is_compl (of_dual a) (of_dual b) := ⟨h.2, h.1⟩

end bounded_partial_order

section bounded_lattice
variables [lattice α] [bounded_order α] {x y z : α}

lemma of_le (h₁ : x ⊓ y ≤ ⊥) (h₂ : ⊤ ≤ x ⊔ y) : is_compl x y :=
⟨disjoint_iff_inf_le.mpr h₁, codisjoint_iff_le_sup.mpr h₂⟩

lemma of_eq (h₁ : x ⊓ y = ⊥) (h₂ : x ⊔ y = ⊤) : is_compl x y :=
⟨disjoint_iff.mpr h₁, codisjoint_iff.mpr h₂⟩

lemma inf_eq_bot (h : is_compl x y) : x ⊓ y = ⊥ := h.disjoint.eq_bot
lemma sup_eq_top (h : is_compl x y) : x ⊔ y = ⊤ := h.codisjoint.eq_top

end bounded_lattice

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

lemma inf_left_le_of_le_sup_right (h : is_compl x y) (hle : a ≤ b ⊔ y) : a ⊓ x ≤ b :=
calc a ⊓ x ≤ (b ⊔ y) ⊓ x : inf_le_inf hle le_rfl
... = (b ⊓ x) ⊔ (y ⊓ x) : inf_sup_right
... = b ⊓ x : by rw [h.symm.inf_eq_bot, sup_bot_eq]
... ≤ b : inf_le_left

lemma le_sup_right_iff_inf_left_le {a b} (h : is_compl x y) : a ≤ b ⊔ y ↔ a ⊓ x ≤ b :=
⟨h.inf_left_le_of_le_sup_right, h.symm.dual.inf_left_le_of_le_sup_right⟩

lemma inf_left_eq_bot_iff (h : is_compl y z) : x ⊓ y = ⊥ ↔ x ≤ z :=
by rw [← le_bot_iff, ← h.le_sup_right_iff_inf_left_le, bot_sup_eq]

lemma inf_right_eq_bot_iff (h : is_compl y z) : x ⊓ z = ⊥ ↔ x ≤ y :=
h.symm.inf_left_eq_bot_iff

lemma disjoint_left_iff (h : is_compl y z) : disjoint x y ↔ x ≤ z :=
by { rw disjoint_iff, exact h.inf_left_eq_bot_iff }

lemma disjoint_right_iff (h : is_compl y z) : disjoint x z ↔ x ≤ y :=
h.symm.disjoint_left_iff

lemma le_left_iff (h : is_compl x y) : z ≤ x ↔ disjoint z y :=
h.disjoint_right_iff.symm

lemma le_right_iff (h : is_compl x y) : z ≤ y ↔ disjoint z x :=
h.symm.le_left_iff

lemma right_le_iff (h : is_compl x y) : y ≤ z ↔ codisjoint z x := h.symm.left_le_iff

protected lemma antitone {x' y'} (h : is_compl x y) (h' : is_compl x' y') (hx : x ≤ x') :
  y' ≤ y :=
h'.right_le_iff.2 $ h.symm.codisjoint.mono_right hx

lemma right_unique (hxy : is_compl x y) (hxz : is_compl x z) :
  y = z :=
le_antisymm (hxz.antitone hxy $ le_refl x) (hxy.antitone hxz $ le_refl x)

lemma left_unique (hxz : is_compl x z) (hyz : is_compl y z) :
  x = y :=
hxz.symm.right_unique hyz.symm

lemma sup_inf {x' y'} (h : is_compl x y) (h' : is_compl x' y') :
  is_compl (x ⊔ x') (y ⊓ y') :=
of_eq
  (by rw [inf_sup_right, ← inf_assoc, h.inf_eq_bot, bot_inf_eq, bot_sup_eq, inf_left_comm,
    h'.inf_eq_bot, inf_bot_eq])
  (by rw [sup_inf_left, @sup_comm _ _ x, sup_assoc, h.sup_eq_top, sup_top_eq, top_inf_eq,
    sup_assoc, sup_left_comm, h'.sup_eq_top, sup_top_eq])

lemma inf_sup {x' y'} (h : is_compl x y) (h' : is_compl x' y') :
  is_compl (x ⊓ x') (y ⊔ y') :=
(h.symm.sup_inf h'.symm).symm

end is_compl

namespace prod
variables {β : Type*} [partial_order α] [partial_order β]

protected lemma disjoint_iff [order_bot α] [order_bot β] {x y : α × β} :
  disjoint x y ↔ disjoint x.1 y.1 ∧ disjoint x.2 y.2 :=
begin
  split,
  { intros h,
    refine ⟨λ a hx hy, (@h (a, ⊥) ⟨hx, _⟩ ⟨hy, _⟩).1, λ b hx hy, (@h (⊥, b) ⟨_, hx⟩ ⟨_, hy⟩).2⟩,
    all_goals { exact bot_le }, },
  { rintros ⟨ha, hb⟩ z hza hzb,
    refine ⟨ha hza.1 hzb.1, hb hza.2 hzb.2⟩ },
end

protected lemma codisjoint_iff [order_top α] [order_top β] {x y : α × β} :
  codisjoint x y ↔ codisjoint x.1 y.1 ∧ codisjoint x.2 y.2 :=
@prod.disjoint_iff αᵒᵈ βᵒᵈ _ _ _ _ _ _

protected lemma is_compl_iff [bounded_order α] [bounded_order β]
  {x y : α × β} :
  is_compl x y ↔ is_compl x.1 y.1 ∧ is_compl x.2 y.2 :=
by simp_rw [is_compl_iff, prod.disjoint_iff, prod.codisjoint_iff, and_and_and_comm]

end prod

section
variables [lattice α] [bounded_order α] {a b x : α}

@[simp] lemma is_compl_to_dual_iff : is_compl (to_dual a) (to_dual b) ↔ is_compl a b :=
⟨is_compl.of_dual, is_compl.dual⟩

@[simp] lemma is_compl_of_dual_iff {a b : αᵒᵈ} : is_compl (of_dual a) (of_dual b) ↔ is_compl a b :=
⟨is_compl.dual, is_compl.of_dual⟩

lemma is_compl_bot_top : is_compl (⊥ : α) ⊤ := is_compl.of_eq bot_inf_eq sup_top_eq
lemma is_compl_top_bot : is_compl (⊤ : α) ⊥ := is_compl.of_eq inf_bot_eq top_sup_eq

lemma eq_top_of_is_compl_bot (h : is_compl x ⊥) : x = ⊤ := sup_bot_eq.symm.trans h.sup_eq_top
lemma eq_top_of_bot_is_compl (h : is_compl ⊥ x) : x = ⊤ := eq_top_of_is_compl_bot h.symm
lemma eq_bot_of_is_compl_top (h : is_compl x ⊤) : x = ⊥ := eq_top_of_is_compl_bot h.dual
lemma eq_bot_of_top_is_compl (h : is_compl ⊤ x) : x = ⊥ := eq_top_of_bot_is_compl h.dual

end

/-- A complemented bounded lattice is one where every element has a (not necessarily unique)
complement. -/
class complemented_lattice (α) [lattice α] [bounded_order α] : Prop :=
(exists_is_compl : ∀ (a : α), ∃ (b : α), is_compl a b)

export complemented_lattice (exists_is_compl)

namespace complemented_lattice
variables [lattice α] [bounded_order α] [complemented_lattice α]

instance : complemented_lattice αᵒᵈ :=
⟨λ a, let ⟨b, hb⟩ := exists_is_compl (show α, from a) in ⟨b, hb.dual⟩⟩

end complemented_lattice

end is_compl


/-
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 algebra.order.absolute_value
import algebra.order.ring.with_top
import algebra.big_operators.basic
import data.fintype.card

/-!
# Results about big operators with values in an ordered algebraic structure.

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

Mostly monotonicity results for the `∏` and `∑` operations.

-/

open function
open_locale big_operators

variables {ι α β M N G k R : Type*}

namespace finset

section ordered_comm_monoid

variables [comm_monoid M] [ordered_comm_monoid N]

/-- Let `{x | p x}` be a subsemigroup of a commutative monoid `M`. Let `f : M → N` be a map
submultiplicative on `{x | p x}`, i.e., `p x → p y → f (x * y) ≤ f x * f y`. Let `g i`, `i ∈ s`, be
a nonempty finite family of elements of `M` such that `∀ i ∈ s, p (g i)`. Then
`f (∏ x in s, g x) ≤ ∏ x in s, f (g x)`. -/
@[to_additive le_sum_nonempty_of_subadditive_on_pred]
lemma le_prod_nonempty_of_submultiplicative_on_pred
  (f : M → N) (p : M → Prop) (h_mul : ∀ x y, p x → p y → f (x * y) ≤ f x * f y)
  (hp_mul : ∀ x y, p x → p y → p (x * y)) (g : ι → M) (s : finset ι) (hs_nonempty : s.nonempty)
  (hs : ∀ i ∈ s, p (g i)) :
  f (∏ i in s, g i) ≤ ∏ i in s, f (g i) :=
begin
  refine le_trans (multiset.le_prod_nonempty_of_submultiplicative_on_pred f p h_mul hp_mul _ _ _) _,
  { simp [hs_nonempty.ne_empty], },
  { exact multiset.forall_mem_map_iff.mpr hs, },
  rw multiset.map_map,
  refl,
end

/-- Let `{x | p x}` be an additive subsemigroup of an additive commutative monoid `M`. Let
`f : M → N` be a map subadditive on `{x | p x}`, i.e., `p x → p y → f (x + y) ≤ f x + f y`. Let
`g i`, `i ∈ s`, be a nonempty finite family of elements of `M` such that `∀ i ∈ s, p (g i)`. Then
`f (∑ i in s, g i) ≤ ∑ i in s, f (g i)`. -/
add_decl_doc le_sum_nonempty_of_subadditive_on_pred

/-- If `f : M → N` is a submultiplicative function, `f (x * y) ≤ f x * f y` and `g i`, `i ∈ s`, is a
nonempty finite family of elements of `M`, then `f (∏ i in s, g i) ≤ ∏ i in s, f (g i)`. -/
@[to_additive le_sum_nonempty_of_subadditive]
lemma le_prod_nonempty_of_submultiplicative
  (f : M → N) (h_mul : ∀ x y, f (x * y) ≤ f x * f y) {s : finset ι} (hs : s.nonempty) (g : ι → M) :
  f (∏ i in s, g i) ≤ ∏ i in s, f (g i) :=
le_prod_nonempty_of_submultiplicative_on_pred f (λ i, true) (λ x y _ _, h_mul x y)
  (λ _ _ _ _, trivial) g s hs (λ _ _, trivial)

/-- If `f : M → N` is a subadditive function, `f (x + y) ≤ f x + f y` and `g i`, `i ∈ s`, is a
nonempty finite family of elements of `M`, then `f (∑ i in s, g i) ≤ ∑ i in s, f (g i)`. -/
add_decl_doc le_sum_nonempty_of_subadditive

/-- Let `{x | p x}` be a subsemigroup of a commutative monoid `M`. Let `f : M → N` be a map
such that `f 1 = 1` and `f` is submultiplicative on `{x | p x}`, i.e.,
`p x → p y → f (x * y) ≤ f x * f y`. Let `g i`, `i ∈ s`, be a finite family of elements of `M` such
that `∀ i ∈ s, p (g i)`. Then `f (∏ i in s, g i) ≤ ∏ i in s, f (g i)`. -/
@[to_additive le_sum_of_subadditive_on_pred]
lemma le_prod_of_submultiplicative_on_pred (f : M → N) (p : M → Prop) (h_one : f 1 = 1)
  (h_mul : ∀ x y, p x → p y → f (x * y) ≤ f x * f y)
  (hp_mul : ∀ x y, p x → p y → p (x * y)) (g : ι → M) {s : finset ι} (hs : ∀ i ∈ s, p (g i)) :
  f (∏ i in s, g i) ≤ ∏ i in s, f (g i) :=
begin
  rcases eq_empty_or_nonempty s with rfl|hs_nonempty,
  { simp [h_one] },
  { exact le_prod_nonempty_of_submultiplicative_on_pred f p h_mul hp_mul g s hs_nonempty hs, },
end

/-- Let `{x | p x}` be a subsemigroup of a commutative additive monoid `M`. Let `f : M → N` be a map
such that `f 0 = 0` and `f` is subadditive on `{x | p x}`, i.e. `p x → p y → f (x + y) ≤ f x + f y`.
Let `g i`, `i ∈ s`, be a finite family of elements of `M` such that `∀ i ∈ s, p (g i)`. Then
`f (∑ x in s, g x) ≤ ∑ x in s, f (g x)`. -/
add_decl_doc le_sum_of_subadditive_on_pred

/-- If `f : M → N` is a submultiplicative function, `f (x * y) ≤ f x * f y`, `f 1 = 1`, and `g i`,
`i ∈ s`, is a finite family of elements of `M`, then `f (∏ i in s, g i) ≤ ∏ i in s, f (g i)`. -/
@[to_additive le_sum_of_subadditive]
lemma le_prod_of_submultiplicative (f : M → N) (h_one : f 1 = 1)
  (h_mul : ∀ x y, f (x * y) ≤ f x * f y) (s : finset ι) (g : ι → M) :
  f (∏ i in s, g i) ≤ ∏ i in s, f (g i) :=
begin
  refine le_trans (multiset.le_prod_of_submultiplicative f h_one h_mul _) _,
  rw multiset.map_map,
  refl,
end

/-- If `f : M → N` is a subadditive function, `f (x + y) ≤ f x + f y`, `f 0 = 0`, and `g i`,
`i ∈ s`, is a finite family of elements of `M`, then `f (∑ i in s, g i) ≤ ∑ i in s, f (g i)`. -/
add_decl_doc le_sum_of_subadditive

variables {f g : ι → N} {s t : finset ι}

/-- In an ordered commutative monoid, if each factor `f i` of one finite product is less than or
equal to the corresponding factor `g i` of another finite product, then
`∏ i in s, f i ≤ ∏ i in s, g i`. -/
@[to_additive sum_le_sum]
lemma prod_le_prod' (h : ∀ i ∈ s, f i ≤ g i) : ∏ i in s, f i ≤ ∏ i in s, g i :=
multiset.prod_map_le_prod_map f g h

/-- In an ordered additive commutative monoid, if each summand `f i` of one finite sum is less than
or equal to the corresponding summand `g i` of another finite sum, then
`∑ i in s, f i ≤ ∑ i in s, g i`. -/
add_decl_doc sum_le_sum

@[to_additive sum_nonneg] lemma one_le_prod' (h : ∀i ∈ s, 1 ≤ f i) : 1 ≤ (∏ i in s, f i) :=
le_trans (by rw prod_const_one) (prod_le_prod' h)

@[to_additive finset.sum_nonneg']
lemma one_le_prod'' (h : ∀ (i : ι), 1 ≤ f i) : 1 ≤ ∏ (i : ι) in s, f i :=
finset.one_le_prod' (λ i hi, h i)

@[to_additive sum_nonpos] lemma prod_le_one' (h : ∀i ∈ s, f i ≤ 1) : (∏ i in s, f i) ≤ 1 :=
(prod_le_prod' h).trans_eq (by rw prod_const_one)

@[to_additive sum_le_sum_of_subset_of_nonneg]
lemma prod_le_prod_of_subset_of_one_le' (h : s ⊆ t) (hf : ∀ i ∈ t, i ∉ s → 1 ≤ f i) :
  ∏ i in s, f i ≤ ∏ i in t, f i :=
by classical;
calc (∏ i in s, f i) ≤ (∏ i in t \ s, f i) * (∏ i in s, f i) :
    le_mul_of_one_le_left' $ one_le_prod' $ by simpa only [mem_sdiff, and_imp]
  ... = ∏ i in t \ s ∪ s, f i : (prod_union sdiff_disjoint).symm
  ... = ∏ i in t, f i         : by rw [sdiff_union_of_subset h]

@[to_additive sum_mono_set_of_nonneg]
lemma prod_mono_set_of_one_le' (hf : ∀ x, 1 ≤ f x) : monotone (λ s, ∏ x in s, f x) :=
λ s t hst, prod_le_prod_of_subset_of_one_le' hst $ λ x _ _, hf x

@[to_additive sum_le_univ_sum_of_nonneg]
lemma prod_le_univ_prod_of_one_le' [fintype ι] {s : finset ι} (w : ∀ x, 1 ≤ f x) :
  ∏ x in s, f x ≤ ∏ x, f x :=
prod_le_prod_of_subset_of_one_le' (subset_univ s) (λ a _ _, w a)

@[to_additive sum_eq_zero_iff_of_nonneg]
lemma prod_eq_one_iff_of_one_le' : (∀ i ∈ s, 1 ≤ f i) → (∏ i in s, f i = 1 ↔ ∀ i ∈ s, f i = 1) :=
begin
  classical,
  apply finset.induction_on s,
  exact λ _, ⟨λ _ _, false.elim, λ _, rfl⟩,
  assume a s ha ih H,
  have : ∀ i ∈ s, 1 ≤ f i, from λ _, H _ ∘ mem_insert_of_mem,
  rw [prod_insert ha, mul_eq_one_iff' (H _ $ mem_insert_self _ _) (one_le_prod' this),
    forall_mem_insert, ih this]
end

@[to_additive sum_eq_zero_iff_of_nonneg]
lemma prod_eq_one_iff_of_le_one' : (∀ i ∈ s, f i ≤ 1) → (∏ i in s, f i = 1 ↔ ∀ i ∈ s, f i = 1) :=
@prod_eq_one_iff_of_one_le' _ Nᵒᵈ _ _ _

@[to_additive single_le_sum]
lemma single_le_prod' (hf : ∀ i ∈ s, 1 ≤ f i) {a} (h : a ∈ s) : f a ≤ (∏ x in s, f x) :=
calc f a = ∏ i in {a}, f i : prod_singleton.symm
     ... ≤ ∏ i in s, f i   :
  prod_le_prod_of_subset_of_one_le' (singleton_subset_iff.2 h) $ λ i hi _, hf i hi

@[to_additive sum_le_card_nsmul]
lemma prod_le_pow_card (s : finset ι) (f : ι → N) (n : N) (h : ∀ x ∈ s, f x ≤ n) :
  s.prod f ≤ n ^ s.card :=
begin
  refine (multiset.prod_le_pow_card (s.val.map f) n _).trans _,
  { simpa using h },
  { simpa }
end

@[to_additive card_nsmul_le_sum]
lemma pow_card_le_prod (s : finset ι) (f : ι → N) (n : N) (h : ∀ x ∈ s, n ≤ f x) :
  n ^ s.card ≤ s.prod f :=
@finset.prod_le_pow_card _ Nᵒᵈ _ _ _ _ h

lemma card_bUnion_le_card_mul [decidable_eq β] (s : finset ι) (f : ι → finset β) (n : ℕ)
  (h : ∀ a ∈ s, (f a).card ≤ n) :
  (s.bUnion f).card ≤ s.card * n :=
card_bUnion_le.trans $ sum_le_card_nsmul _ _ _ h

variables {ι' : Type*} [decidable_eq ι']

@[to_additive sum_fiberwise_le_sum_of_sum_fiber_nonneg]
lemma prod_fiberwise_le_prod_of_one_le_prod_fiber' {t : finset ι'}
  {g : ι → ι'} {f : ι → N} (h : ∀ y ∉ t, (1 : N) ≤ ∏ x in s.filter (λ x, g x = y), f x) :
  ∏ y in t, ∏ x in s.filter (λ x, g x = y), f x ≤ ∏ x in s, f x :=
calc (∏ y in t, ∏ x in s.filter (λ x, g x = y), f x) ≤
  (∏ y in t ∪ s.image g, ∏ x in s.filter (λ x, g x = y), f x) :
  prod_le_prod_of_subset_of_one_le' (subset_union_left _ _) $ λ y hyts, h y
... = ∏ x in s, f x :
  prod_fiberwise_of_maps_to (λ x hx, mem_union.2 $ or.inr $ mem_image_of_mem _ hx) _

@[to_additive sum_le_sum_fiberwise_of_sum_fiber_nonpos]
lemma prod_le_prod_fiberwise_of_prod_fiber_le_one' {t : finset ι'}
  {g : ι → ι'} {f : ι → N} (h : ∀ y ∉ t, (∏ x in s.filter (λ x, g x = y), f x) ≤ 1) :
  (∏ x in s, f x) ≤ ∏ y in t, ∏ x in s.filter (λ x, g x = y), f x :=
@prod_fiberwise_le_prod_of_one_le_prod_fiber' _ Nᵒᵈ _ _ _ _ _ _ _ h

end ordered_comm_monoid

lemma abs_sum_le_sum_abs {G : Type*} [linear_ordered_add_comm_group G] (f : ι → G) (s : finset ι) :
  |∑ i in s, f i| ≤ ∑ i in s, |f i| :=
le_sum_of_subadditive _ abs_zero abs_add s f

lemma abs_sum_of_nonneg {G : Type*} [linear_ordered_add_comm_group G] {f : ι → G} {s : finset ι}
  (hf : ∀ i ∈ s, 0 ≤ f i) :
  |∑ (i : ι) in s, f i| = ∑ (i : ι) in s, f i :=
by rw abs_of_nonneg (finset.sum_nonneg hf)

lemma abs_sum_of_nonneg' {G : Type*} [linear_ordered_add_comm_group G] {f : ι → G} {s : finset ι}
  (hf : ∀ i, 0 ≤ f i) :
  |∑ (i : ι) in s, f i| = ∑ (i : ι) in s, f i :=
by rw abs_of_nonneg (finset.sum_nonneg' hf)

lemma abs_prod {R : Type*} [linear_ordered_comm_ring R] {f : ι → R} {s : finset ι} :
  |∏ x in s, f x| = ∏ x in s, |f x| :=
(abs_hom.to_monoid_hom : R →* R).map_prod _ _

section pigeonhole

variable [decidable_eq β]

theorem card_le_mul_card_image_of_maps_to {f : α → β} {s : finset α} {t : finset β}
  (Hf : ∀ a ∈ s, f a ∈ t) (n : ℕ) (hn : ∀ a ∈ t, (s.filter (λ x, f x = a)).card ≤ n) :
  s.card ≤ n * t.card :=
calc s.card = (∑ a in t, (s.filter (λ x, f x = a)).card) : card_eq_sum_card_fiberwise Hf
        ... ≤ (∑ _ in t, n)                              : sum_le_sum hn
        ... = _                                          : by simp [mul_comm]

theorem card_le_mul_card_image {f : α → β} (s : finset α)
  (n : ℕ) (hn : ∀ a ∈ s.image f, (s.filter (λ x, f x = a)).card ≤ n) :
  s.card ≤ n * (s.image f).card :=
card_le_mul_card_image_of_maps_to (λ x, mem_image_of_mem _) n hn

theorem mul_card_image_le_card_of_maps_to {f : α → β} {s : finset α} {t : finset β}
  (Hf : ∀ a ∈ s, f a ∈ t) (n : ℕ) (hn : ∀ a ∈ t, n ≤ (s.filter (λ x, f x = a)).card) :
  n * t.card ≤ s.card :=
calc n * t.card = (∑ _ in t, n) : by simp [mul_comm]
            ... ≤ (∑ a in t, (s.filter (λ x, f x = a)).card) : sum_le_sum hn
            ... = s.card : by rw ← card_eq_sum_card_fiberwise Hf

theorem mul_card_image_le_card {f : α → β} (s : finset α)
  (n : ℕ) (hn : ∀ a ∈ s.image f, n ≤ (s.filter (λ x, f x = a)).card) :
  n * (s.image f).card ≤ s.card :=
mul_card_image_le_card_of_maps_to (λ x, mem_image_of_mem _) n hn

end pigeonhole

section double_counting
variables [decidable_eq α] {s : finset α} {B : finset (finset α)} {n : ℕ}

/-- If every element belongs to at most `n` finsets, then the sum of their sizes is at most `n`
times how many they are. -/
lemma sum_card_inter_le (h : ∀ a ∈ s, (B.filter $ (∈) a).card ≤ n) :
  ∑ t in B, (s ∩ t).card ≤ s.card * n :=
begin
  refine le_trans _ (s.sum_le_card_nsmul _ _ h),
  simp_rw [←filter_mem_eq_inter, card_eq_sum_ones, sum_filter],
  exact sum_comm.le,
end

/-- If every element belongs to at most `n` finsets, then the sum of their sizes is at most `n`
times how many they are. -/
lemma sum_card_le [fintype α] (h : ∀ a, (B.filter $ (∈) a).card ≤ n) :
  ∑ s in B, s.card ≤ fintype.card α * n :=
calc ∑ s in B, s.card = ∑ s in B, (univ ∩ s).card : by simp_rw univ_inter
                  ... ≤ fintype.card α * n        : sum_card_inter_le (λ a _, h a)

/-- If every element belongs to at least `n` finsets, then the sum of their sizes is at least `n`
times how many they are. -/
lemma le_sum_card_inter (h : ∀ a ∈ s, n ≤ (B.filter $ (∈) a).card) :
  s.card * n ≤ ∑ t in B, (s ∩ t).card :=
begin
  apply (s.card_nsmul_le_sum _ _ h).trans,
  simp_rw [←filter_mem_eq_inter, card_eq_sum_ones, sum_filter],
  exact sum_comm.le,
end

/-- If every element belongs to at least `n` finsets, then the sum of their sizes is at least `n`
times how many they are. -/
lemma le_sum_card [fintype α] (h : ∀ a, n ≤ (B.filter $ (∈) a).card) :
  fintype.card α * n ≤ ∑ s in B, s.card :=
calc fintype.card α * n ≤ ∑ s in B, (univ ∩ s).card : le_sum_card_inter (λ a _, h a)
                    ... = ∑ s in B, s.card          : by simp_rw univ_inter

/-- If every element belongs to exactly `n` finsets, then the sum of their sizes is `n` times how
many they are. -/
lemma sum_card_inter (h : ∀ a ∈ s, (B.filter $ (∈) a).card = n) :
  ∑ t in B, (s ∩ t).card = s.card * n :=
(sum_card_inter_le $ λ a ha, (h a ha).le).antisymm (le_sum_card_inter $ λ a ha, (h a ha).ge)

/-- If every element belongs to exactly `n` finsets, then the sum of their sizes is `n` times how
many they are. -/
lemma sum_card [fintype α] (h : ∀ a, (B.filter $ (∈) a).card = n) :
  ∑ s in B, s.card = fintype.card α * n :=
by simp_rw [fintype.card, ←sum_card_inter (λ a _, h a), univ_inter]

lemma card_le_card_bUnion {s : finset ι} {f : ι → finset α} (hs : (s : set ι).pairwise_disjoint f)
  (hf : ∀ i ∈ s, (f i).nonempty) :
  s.card ≤ (s.bUnion f).card :=
by { rw [card_bUnion hs, card_eq_sum_ones], exact sum_le_sum (λ i hi, (hf i hi).card_pos) }

lemma card_le_card_bUnion_add_card_fiber {s : finset ι} {f : ι → finset α}
  (hs : (s : set ι).pairwise_disjoint f) :
  s.card ≤ (s.bUnion f).card + (s.filter $ λ i, f i = ∅).card :=
begin
  rw [←finset.filter_card_add_filter_neg_card_eq_card (λ i, f i = ∅), add_comm],
  exact add_le_add_right ((card_le_card_bUnion (hs.subset $ filter_subset _ _) $ λ i hi,
    nonempty_of_ne_empty $ (mem_filter.1 hi).2).trans $ card_le_of_subset $
    bUnion_subset_bUnion_of_subset_left _ $ filter_subset _ _) _,
end

lemma card_le_card_bUnion_add_one {s : finset ι} {f : ι → finset α} (hf : injective f)
  (hs : (s : set ι).pairwise_disjoint f) :
  s.card ≤ (s.bUnion f).card + 1 :=
(card_le_card_bUnion_add_card_fiber hs).trans $ add_le_add_left (card_le_one.2 $ λ i hi j hj, hf $
  (mem_filter.1 hi).2.trans (mem_filter.1 hj).2.symm) _

end double_counting

section canonically_ordered_monoid

variables [canonically_ordered_monoid M] {f : ι → M} {s t : finset ι}

@[simp, to_additive sum_eq_zero_iff]
lemma prod_eq_one_iff' : ∏ x in s, f x = 1 ↔ ∀ x ∈ s, f x = 1 :=
prod_eq_one_iff_of_one_le' $ λ x hx, one_le (f x)

@[to_additive sum_le_sum_of_subset]
lemma prod_le_prod_of_subset' (h : s ⊆ t) : ∏ x in s, f x ≤ ∏ x in t, f x :=
prod_le_prod_of_subset_of_one_le' h $ assume x h₁ h₂, one_le _

@[to_additive sum_mono_set]
lemma prod_mono_set' (f : ι → M) : monotone (λ s, ∏ x in s, f x) :=
λ s₁ s₂ hs, prod_le_prod_of_subset' hs

@[to_additive sum_le_sum_of_ne_zero]
lemma prod_le_prod_of_ne_one' (h : ∀ x ∈ s, f x ≠ 1 → x ∈ t) :
  ∏ x in s, f x ≤ ∏ x in t, f x :=
by classical;
calc ∏ x in s, f x = (∏ x in s.filter (λ x, f x = 1), f x) * ∏ x in s.filter (λ x, f x ≠ 1), f x :
    by rw [← prod_union, filter_union_filter_neg_eq];
       exact disjoint_filter.2 (assume _ _ h n_h, n_h h)
  ... ≤ (∏ x in t, f x) : mul_le_of_le_one_of_le
      (prod_le_one' $ by simp only [mem_filter, and_imp]; exact λ _ _, le_of_eq)
      (prod_le_prod_of_subset' $ by simpa only [subset_iff, mem_filter, and_imp])

end canonically_ordered_monoid

section ordered_cancel_comm_monoid

variables [ordered_cancel_comm_monoid M] {f g : ι → M} {s t : finset ι}

@[to_additive sum_lt_sum]
theorem prod_lt_prod' (Hle : ∀ i ∈ s, f i ≤ g i) (Hlt : ∃ i ∈ s, f i < g i) :
  ∏ i in s, f i < ∏ i in s, g i :=
begin
  classical,
  rcases Hlt with ⟨i, hi, hlt⟩,
  rw [← insert_erase hi, prod_insert (not_mem_erase _ _), prod_insert (not_mem_erase _ _)],
  exact mul_lt_mul_of_lt_of_le hlt (prod_le_prod' $ λ j hj, Hle j  $ mem_of_mem_erase hj)
end

@[to_additive sum_lt_sum_of_nonempty]
lemma prod_lt_prod_of_nonempty' (hs : s.nonempty) (Hlt : ∀ i ∈ s, f i < g i) :
  ∏ i in s, f i < ∏ i in s, g i :=
begin
  apply prod_lt_prod',
  { intros i hi, apply le_of_lt (Hlt i hi) },
  cases hs with i hi,
  exact ⟨i, hi, Hlt i hi⟩,
end

@[to_additive sum_lt_sum_of_subset]
lemma prod_lt_prod_of_subset' (h : s ⊆ t) {i : ι} (ht : i ∈ t) (hs : i ∉ s) (hlt : 1 < f i)
  (hle : ∀ j ∈ t, j ∉ s → 1 ≤ f j) :
  ∏ j in s, f j < ∏ j in t, f j :=
by classical;
calc ∏ j in s, f j < ∏ j in insert i s, f j :
begin
  rw prod_insert hs,
  exact lt_mul_of_one_lt_left' (∏ j in s, f j) hlt,
end
... ≤ ∏ j in t, f j :
begin
  apply prod_le_prod_of_subset_of_one_le',
  { simp [finset.insert_subset, h, ht] },
  { assume x hx h'x,
    simp only [mem_insert, not_or_distrib] at h'x,
    exact hle x hx h'x.2 }
end

@[to_additive single_lt_sum]
lemma single_lt_prod' {i j : ι} (hij : j ≠ i) (hi : i ∈ s) (hj : j ∈ s) (hlt : 1 < f j)
  (hle : ∀ k ∈ s, k ≠ i → 1 ≤ f k) :
  f i < ∏ k in s, f k :=
calc f i = ∏ k in {i}, f k : prod_singleton.symm
     ... < ∏ k in s, f k   :
  prod_lt_prod_of_subset' (singleton_subset_iff.2 hi) hj (mt mem_singleton.1 hij) hlt $
    λ k hks hki, hle k hks (mt mem_singleton.2 hki)

@[to_additive sum_pos] lemma one_lt_prod (h : ∀i ∈ s, 1 < f i) (hs : s.nonempty) :
  1 < (∏ i in s, f i) :=
lt_of_le_of_lt (by rw prod_const_one) $ prod_lt_prod_of_nonempty' hs h

@[to_additive] lemma prod_lt_one (h : ∀i ∈ s, f i < 1) (hs : s.nonempty) :
  (∏ i in s, f i) < 1 :=
(prod_lt_prod_of_nonempty' hs h).trans_le (by rw prod_const_one)

@[to_additive sum_pos'] lemma one_lt_prod' (h : ∀ i ∈ s, 1 ≤ f i) (hs : ∃ i ∈ s, 1 < f i) :
  1 < (∏ i in s, f i) :=
prod_const_one.symm.trans_lt $ prod_lt_prod' h hs

@[to_additive] lemma prod_lt_one' (h : ∀ i ∈ s, f i ≤ 1) (hs : ∃ i ∈ s, f i < 1)  :
  ∏ i in s, f i < 1 :=
prod_const_one.le.trans_lt' $ prod_lt_prod' h hs

@[to_additive] lemma prod_eq_prod_iff_of_le {f g : ι → M} (h : ∀ i ∈ s, f i ≤ g i) :
  ∏ i in s, f i = ∏ i in s, g i ↔ ∀ i ∈ s, f i = g i :=
begin
  classical,
  revert h,
  refine finset.induction_on s (λ _, ⟨λ _ _, false.elim, λ _, rfl⟩) (λ a s ha ih H, _),
  specialize ih (λ i, H i ∘ finset.mem_insert_of_mem),
  rw [finset.prod_insert ha, finset.prod_insert ha, finset.forall_mem_insert, ←ih],
  exact mul_eq_mul_iff_eq_and_eq (H a (s.mem_insert_self a)) (finset.prod_le_prod'
    (λ i, H i ∘ finset.mem_insert_of_mem)),
end

end ordered_cancel_comm_monoid

section linear_ordered_cancel_comm_monoid

variables [linear_ordered_cancel_comm_monoid M] {f g : ι → M} {s t : finset ι}

@[to_additive exists_lt_of_sum_lt]
theorem exists_lt_of_prod_lt' (Hlt : ∏ i in s, f i < ∏ i in s, g i) :
  ∃ i ∈ s, f i < g i :=
begin
  contrapose! Hlt with Hle,
  exact prod_le_prod' Hle
end

@[to_additive exists_le_of_sum_le]
theorem exists_le_of_prod_le' (hs : s.nonempty) (Hle : ∏ i in s, f i ≤ ∏ i in s, g i) :
  ∃ i ∈ s, f i ≤ g i :=
begin
  contrapose! Hle with Hlt,
  exact prod_lt_prod_of_nonempty' hs Hlt
end

@[to_additive exists_pos_of_sum_zero_of_exists_nonzero]
lemma exists_one_lt_of_prod_one_of_exists_ne_one' (f : ι → M)
  (h₁ : ∏ i in s, f i = 1) (h₂ : ∃ i ∈ s, f i ≠ 1) :
  ∃ i ∈ s, 1 < f i :=
begin
  contrapose! h₁,
  obtain ⟨i, m, i_ne⟩ : ∃ i ∈ s, f i ≠ 1 := h₂,
  apply ne_of_lt,
  calc ∏ j in s, f j < ∏ j in s, 1 : prod_lt_prod' h₁ ⟨i, m, (h₁ i m).lt_of_ne i_ne⟩
                 ... = 1           : prod_const_one
end

end linear_ordered_cancel_comm_monoid

section ordered_comm_semiring

variables [ordered_comm_semiring R] {f g : ι → R} {s t : finset ι}
open_locale classical

/- this is also true for a ordered commutative multiplicative monoid with zero -/
lemma prod_nonneg (h0 : ∀ i ∈ s, 0 ≤ f i) : 0 ≤ ∏ i in s, f i :=
prod_induction f (λ i, 0 ≤ i) (λ _ _ ha hb, mul_nonneg ha hb) zero_le_one h0

/-- If all `f i`, `i ∈ s`, are nonnegative and each `f i` is less than or equal to `g i`, then the
product of `f i` is less than or equal to the product of `g i`. See also `finset.prod_le_prod'` for
the case of an ordered commutative multiplicative monoid. -/
lemma prod_le_prod (h0 : ∀ i ∈ s, 0 ≤ f i) (h1 : ∀ i ∈ s, f i ≤ g i) :
  ∏ i in s, f i ≤ ∏ i in s, g i :=
begin
  induction s using finset.induction with a s has ih h,
  { simp },
  { simp only [prod_insert has], apply mul_le_mul,
    { exact h1 a (mem_insert_self a s) },
    { apply ih (λ x H, h0 _ _) (λ x H, h1 _ _); exact (mem_insert_of_mem H) },
    { apply prod_nonneg (λ x H, h0 x (mem_insert_of_mem H)) },
    { apply le_trans (h0 a (mem_insert_self a s)) (h1 a (mem_insert_self a s)) } }
end

/-- If each `f i`, `i ∈ s` belongs to `[0, 1]`, then their product is less than or equal to one.
See also `finset.prod_le_one'` for the case of an ordered commutative multiplicative monoid. -/
lemma prod_le_one (h0 : ∀ i ∈ s, 0 ≤ f i) (h1 : ∀ i ∈ s, f i ≤ 1) :
  ∏ i in s, f i ≤ 1 :=
begin
  convert ← prod_le_prod h0 h1,
  exact finset.prod_const_one
end

/-- If `g, h ≤ f` and `g i + h i ≤ f i`, then the product of `f` over `s` is at least the
  sum of the products of `g` and `h`. This is the version for `ordered_comm_semiring`. -/
lemma prod_add_prod_le {i : ι} {f g h : ι → R}
  (hi : i ∈ s) (h2i : g i + h i ≤ f i) (hgf : ∀ j ∈ s, j ≠ i → g j ≤ f j)
  (hhf : ∀ j ∈ s, j ≠ i → h j ≤ f j) (hg : ∀ i ∈ s, 0 ≤ g i) (hh : ∀ i ∈ s, 0 ≤ h i) :
  ∏ i in s, g i + ∏ i in s, h i ≤ ∏ i in s, f i :=
begin
  simp_rw [prod_eq_mul_prod_diff_singleton hi],
  refine le_trans _ (mul_le_mul_of_nonneg_right h2i _),
  { rw [right_distrib],
    apply add_le_add; apply mul_le_mul_of_nonneg_left; try { apply_assumption; assumption };
      apply prod_le_prod; simp * { contextual := tt } },
  { apply prod_nonneg, simp only [and_imp, mem_sdiff, mem_singleton],
    intros j h1j h2j, exact le_trans (hg j h1j) (hgf j h1j h2j) }
end

end ordered_comm_semiring

section strict_ordered_comm_semiring
variables [strict_ordered_comm_semiring R] [nontrivial R] {f : ι → R} {s : finset ι}

/- This is also true for a ordered commutative multiplicative monoid with zero -/
lemma prod_pos (h0 : ∀ i ∈ s, 0 < f i) : 0 < ∏ i in s, f i :=
prod_induction f (λ x, 0 < x) (λ _ _ ha hb, mul_pos ha hb) zero_lt_one h0

end strict_ordered_comm_semiring

section canonically_ordered_comm_semiring

variables [canonically_ordered_comm_semiring R] {f g h : ι → R} {s : finset ι} {i : ι}

@[simp]
lemma _root_.canonically_ordered_comm_semiring.multiset_prod_pos [nontrivial R] {m : multiset R} :
  0 < m.prod ↔ (∀ x ∈ m, (0 : R) < x) :=
begin
  induction m using quotient.induction_on,
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact canonically_ordered_comm_semiring.list_prod_pos,
end

/-- Note that the name is to match `canonically_ordered_comm_semiring.mul_pos`. -/
@[simp]
lemma _root_.canonically_ordered_comm_semiring.prod_pos [nontrivial R] :
  0 < ∏ i in s, f i ↔ (∀ i ∈ s, (0 : R) < f i) :=
canonically_ordered_comm_semiring.multiset_prod_pos.trans $ by simp

/-- If `g, h ≤ f` and `g i + h i ≤ f i`, then the product of `f` over `s` is at least the
  sum of the products of `g` and `h`. This is the version for `canonically_ordered_comm_semiring`.
-/
lemma prod_add_prod_le' (hi : i ∈ s) (h2i : g i + h i ≤ f i)
  (hgf : ∀ j ∈ s, j ≠ i → g j ≤ f j) (hhf : ∀ j ∈ s, j ≠ i → h j ≤ f j) :
  ∏ i in s, g i + ∏ i in s, h i ≤ ∏ i in s, f i :=
begin
  classical, simp_rw [prod_eq_mul_prod_diff_singleton hi],
  refine le_trans _ (mul_le_mul_right' h2i _),
  rw [right_distrib],
  apply add_le_add; apply mul_le_mul_left'; apply prod_le_prod';
  simp only [and_imp, mem_sdiff, mem_singleton]; intros; apply_assumption; assumption
end

end canonically_ordered_comm_semiring

end finset

namespace fintype

variables [fintype ι]

@[to_additive sum_mono, mono]
lemma prod_mono' [ordered_comm_monoid M] : monotone (λ f : ι → M, ∏ i, f i) :=
λ f g hfg, finset.prod_le_prod' $ λ x _, hfg x

attribute [mono] sum_mono

@[to_additive sum_strict_mono]
lemma prod_strict_mono' [ordered_cancel_comm_monoid M] : strict_mono (λ f : ι → M, ∏ x, f x) :=
λ f g hfg, let ⟨hle, i, hlt⟩ := pi.lt_def.mp hfg in
  finset.prod_lt_prod' (λ i _, hle i) ⟨i, finset.mem_univ i, hlt⟩

end fintype

namespace with_top
open finset

/-- A product of finite numbers is still finite -/
lemma prod_lt_top [comm_monoid_with_zero R] [no_zero_divisors R] [nontrivial R] [decidable_eq R]
  [has_lt R] {s : finset ι} {f : ι → with_top R} (h : ∀ i ∈ s, f i ≠ ⊤) :
  ∏ i in s, f i < ⊤ :=
prod_induction f (λ a, a < ⊤) (λ a b h₁ h₂, mul_lt_top' h₁ h₂) (coe_lt_top 1) $
  λ a ha, with_top.lt_top_iff_ne_top.2 (h a ha)

/-- A sum of numbers is infinite iff one of them is infinite -/
lemma sum_eq_top_iff [add_comm_monoid M] {s : finset ι} {f : ι → with_top M} :
  ∑ i in s, f i = ⊤ ↔ ∃ i ∈ s, f i = ⊤ :=
by induction s using finset.cons_induction; simp [*, or_and_distrib_right, exists_or_distrib]

/-- A sum of finite numbers is still finite -/
lemma sum_lt_top_iff [add_comm_monoid M] [has_lt M] {s : finset ι} {f : ι → with_top M} :
  ∑ i in s, f i < ⊤ ↔ ∀ i ∈ s, f i < ⊤ :=
by simp only [with_top.lt_top_iff_ne_top, ne.def, sum_eq_top_iff, not_exists]

/-- A sum of finite numbers is still finite -/
lemma sum_lt_top [add_comm_monoid M] [has_lt M] {s : finset ι} {f : ι → with_top M}
  (h : ∀ i ∈ s, f i ≠ ⊤) : (∑ i in s, f i) < ⊤ :=
sum_lt_top_iff.2 $ λ i hi, with_top.lt_top_iff_ne_top.2 (h i hi)

end with_top

section absolute_value

variables {S : Type*}

lemma absolute_value.sum_le [semiring R] [ordered_semiring S]
  (abv : absolute_value R S) (s : finset ι) (f : ι → R) :
  abv (∑ i in s, f i) ≤ ∑ i in s, abv (f i) :=
finset.le_sum_of_subadditive abv (map_zero _) abv.add_le _ _

lemma is_absolute_value.abv_sum [semiring R] [ordered_semiring S] (abv : R → S)
  [is_absolute_value abv] (f : ι → R) (s : finset ι) :
  abv (∑ i in s, f i) ≤ ∑ i in s, abv (f i) :=
(is_absolute_value.to_absolute_value abv).sum_le _ _

lemma absolute_value.map_prod [comm_semiring R] [nontrivial R] [linear_ordered_comm_ring S]
  (abv : absolute_value R S) (f : ι → R) (s : finset ι) :
  abv (∏ i in s, f i) = ∏ i in s, abv (f i) :=
abv.to_monoid_hom.map_prod f s

lemma is_absolute_value.map_prod [comm_semiring R] [nontrivial R] [linear_ordered_comm_ring S]
  (abv : R → S) [is_absolute_value abv] (f : ι → R) (s : finset ι) :
  abv (∏ i in s, f i) = ∏ i in s, abv (f i) :=
(is_absolute_value.to_absolute_value abv).map_prod _ _

end absolute_value


-- Simple theorems

import algebra.group_power.ring
import analysis.special_functions.pow
import data.real.basic
import data.complex.basic
import measure_theory.integral.circle_integral
import tactic.linarith.frontend
open tactic.interactive (nlinarith)
open complex (abs has_zero)
open_locale nnreal

namespace simple

lemma abs_sub_ge (a b : ℂ) : abs (a + b) ≥ abs a - abs b := begin
  let h := complex.abs_add (a + b) (-b),
  simp at h,
  linarith,
end

lemma abs_sub_ge' {a b : ℂ} : abs (a + b) ≥ abs a - abs b := abs_sub_ge _ _

lemma le_to_ge {X : Type} [linear_order X] {a b : X} (h : a ≤ b) : b ≥ a := h
lemma ge_to_le {X : Type} [linear_order X] {a b : X} (h : a ≥ b) : b ≤ a := h
lemma lt_to_gt {X : Type} [linear_order X] {a b : X} (h : a < b) : b > a := h
lemma gt_to_lt {X : Type} [linear_order X] {a b : X} (h : a > b) : b < a := h

lemma sq_bound (x : ℝ) : (1 + x)^2 ≥ 1 + 2*x := begin
  have h : (1 + x)^2 = 1 + 2*x + x^2 := by ring,
  nlinarith
end

lemma sq_increasing {x y : ℝ} (p : 0 ≤ x) (h : x ≤ y) : x^2 ≤ y^2 := by nlinarith
lemma mul_increasing {x y z : ℝ} (p : 0 ≤ x) (h : y ≤ z) : x * y ≤ x * z := mul_le_mul_of_nonneg_left h p
lemma nat_nonneg (n : ℕ) : 0 ≤ (↑n : ℝ) := by simp

lemma large_div_nat (a b : ℝ) (h : a > 0) : ∃ n : ℕ, a * n ≥ b := begin
  existsi (nat.ceil (b / a)),
  have e : a * (b / a) = b := calc a * (b / a) = b / a * a : by ring
                            ... = b : div_mul_cancel b (ne_of_gt h),
  nth_rewrite 1 ←e,
  refine mul_le_mul_of_nonneg_left _ _,
  exact nat.le_ceil _,
  apply le_of_lt,
  assumption
end

lemma gap {x y : ℝ} (h : x < y) : ∃ s : ℝ, s > 0 ∧ x + s ≤ y := begin
  have sp := sub_lt_sub_right h x,
  set s := y - x with q,
  have xx : x - x = 0 := by ring,
  rw [←q, xx] at sp,
  existsi s,
  constructor,
  assumption,
  linarith
end

lemma not_all {A : Type} {p : A → Prop} (_ : ¬∀ x : A, p x) : ∃ x : A, ¬(p x) := by finish

lemma not_false (p : Prop) : ¬p ↔ (p → false) := by finish
lemma not_lt {x y : ℝ} : (x < y → false) ↔ (x ≥ y) := begin
  rw (not_false (x < y)).symm,
  finish
end

lemma coe_increasing {a b : ℕ} (h : a ≤ b) : (a : ℝ) ≤ (b : ℝ) := nat.cast_le.mpr h
lemma coe_pow_ge_one {n : ℕ} : 1 ≤ (2^n : ℝ) := begin
  induction n with n,
  norm_num,
  transitivity (2^n : ℝ),
  assumption,
  have h : 2^n.succ = 2*2^n := pow_succ _ _,
  have he : (2^n.succ : ℝ) = (2*2^n : ℝ) := rfl,
  rw he, linarith
end

lemma real_nnreal_ennreal (r : ℝ) : ennreal.of_real r = ↑r.to_nnreal := rfl
lemma nnreal_ennreal_coe_lt {a : ennreal} {b : nnreal} (h : a < b) : a.to_nnreal < b := begin
  rw ←with_top.coe_lt_coe,
  calc ↑(a.to_nnreal) ≤ a : ennreal.coe_to_nnreal_le_self
  ... < ↑b : h
end
lemma to_nnreal_pos {a b c : ennreal} (ab : a < b) (bc : b < c) : 0 < b.to_nnreal := begin
  apply ennreal.to_nnreal_pos,
  refine ne_of_gt _,
  calc 0 ≤ a : by simp
  ... < b : ab,
  refine ne_of_lt _,
  calc b < c : bc
  ... ≤ ⊤ : by simp
end

lemma inv_nonneg {x : ℝ} (h : x ≥ 0) : x⁻¹ ≥ 0 := inv_nonneg.mpr h

lemma pow_inv (x : ℝ) (n : ℕ) : (x^n)⁻¹ = x⁻¹^n := begin by_cases x = 0, simp, field_simp end

lemma div_pow_inv (x y : ℝ) (n : ℕ) : x / y^n = x * y⁻¹^n := begin
  calc x / y^n = (y^n)⁻¹ * x : (inv_mul_eq_div (y^n) x).symm
  ... = y⁻¹^n * x : by rw (pow_inv y n)
  ... = x * y⁻¹^n : by ring
end

lemma abs_sub (z w : ℂ) : abs (z - w) ≤ abs z + abs w := begin
  set n := -w,
  have h0 : z - w = z + n := rfl,
  have h1 : abs w = abs n := (complex.abs_neg w).symm,
  rw [h0, h1], exact complex.abs_add z n
end

lemma abs_sub' {z w : ℂ} : abs (z - w) ≤ abs z + abs w := abs_sub z w

lemma abs_le_zero {z : ℂ} (h : abs z ≤ 0) : z = 0 :=
  complex.abs_eq_zero.mp (le_antisymm (complex.abs_nonneg z) h).symm

lemma sqr_pos {x : ℝ} (h : x > 0) : x^2 > 0 := pow_pos h 2

lemma zero_lt_bit1 {A : Type} [linear_ordered_semiring A] {a : A} : 0 < a → 0 < bit1 a := begin
  rw [bit1, bit0], intro, apply add_pos, apply add_pos, assumption, assumption, norm_num
end

lemma zero_le_bit1 {A : Type} [linear_ordered_semiring A] {a : A} : 0 ≤ a → 0 ≤ bit1 a := begin
  rw [bit1, bit0], intro, apply add_nonneg, apply add_nonneg, assumption, assumption, norm_num
end

lemma ring_sub_pos {A : Type} [linear_ordered_ring A] {a b : A} (h : a < b) : 0 < b - a := begin
  simp, assumption
end

lemma ring_sub_le_sub {A : Type} [linear_ordered_ring A] {a b c d : A}
    (ac : a ≤ c) (db : d ≤ b): a - b ≤ c - d := sub_le_sub ac db

lemma ring_add_le_add {A : Type} [linear_ordered_ring A] {a b c d : A}
    (ac : a ≤ c) (bd : b ≤ d) : a + b ≤ c + d := add_le_add ac bd

lemma ring_add_nonneg {A : Type} [linear_ordered_ring A] {a b : A}
    (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a + b := add_nonneg ha hb

lemma ring_sub_nonneg {A : Type} [linear_ordered_ring A] {a b : A} (h : b ≤ a) : 0 ≤ a - b := sub_nonneg.mpr h

lemma ring_add_lt_add_left {A : Type} [linear_ordered_ring A] {a b c : A}
    (h : b < c) : a + b < a + c := add_lt_add_left h a

lemma ring_add_lt_add_right {A : Type} [linear_ordered_ring A] {a b c : A}
    (h : b < c) : b + a < c + a := add_lt_add_right h a

theorem pow_pos' {A : Type} [ordered_semiring A] {a : A} {n : ℕ} (h : 0 < a) : 0 < a^n := pow_pos h _
theorem pow_nonneg' {A : Type} [ordered_semiring A] {a : A} {n : ℕ} (h : 0 ≤ a) : 0 ≤ a^n := pow_nonneg h _

lemma finset_complex_abs_sum_le (N : finset ℕ) (f : ℕ → ℂ)
    : abs (N.sum (λ n, f n)) ≤ N.sum (λ n, abs (f n)) :=
begin
  induction N using finset.induction with n N Nn h, {
    simp
  }, {
    rw finset.sum_insert Nn,
    rw finset.sum_insert Nn,
    transitivity abs (f n) + abs (N.sum (λ n, f n)), {
      exact complex.abs_add _ _
    }, {
      apply add_le_add_left, assumption
    }
  }
end

lemma div_self {K : Type} [division_ring K] {a : K} (h : a ≠ 0) : a / a = 1 :=
  by rw [div_eq_mul_inv, mul_inv_cancel h]

lemma div_cancel_le {x : ℝ} : x * x⁻¹ ≤ 1 := begin
  rw ←div_eq_mul_inv,
  exact div_self_le_one x,
end

lemma ne_iff_not_eq {T : Type} {a b : T} : ¬(a = b) ↔ a ≠ b := begin
  have q := eq_or_ne a b,
  finish
end

lemma div_le_div_right {a b c : ℝ} : c ≥ 0 → a ≤ b → a / c ≤ b / c := begin
  intros c0 ab,
  by_cases cnz : c = 0, { rw cnz, simp },
  rw ne_iff_not_eq at cnz,
  refine (div_le_div_right _).mpr ab,
  exact lt_of_le_of_ne c0 cnz.symm
end

lemma subset_union_sdiff (A B : finset ℕ) : B ⊆ A ∪ B \ A := begin
  rw finset.subset_iff, intros x Bx,
  rw [finset.mem_union, finset.mem_sdiff],
  finish
end

lemma le_add_nonneg_right {a b : ℝ} : 0 ≤ b → a ≤ a + b := le_add_of_le_of_nonneg (le_refl a)
lemma le_add_nonneg_left {a b : ℝ} : 0 ≤ b → a ≤ b + a := begin
  rw add_comm, exact le_add_nonneg_right
end

lemma div_le_one {a b : ℝ} : 0 ≤ b → a ≤ b → a / b ≤ 1 := begin
  intros b0 ab,
  by_cases z : b = 0, {
    rw z, simp
  }, {
    refine (div_le_one _).mpr _,
    have z : b ≠ 0 := z,
    exact lt_of_le_of_ne b0 z.symm,
    assumption
  }
end

lemma real_abs_nonneg {a : ℝ} : |a| ≥ 0 := abs_nonneg _

lemma nat_real_coe_le_coe {n m : ℕ} : n ≤ m → (n : ℝ) ≤ (m : ℝ) := begin
  exact nat.cast_le.mpr
end

lemma pow_div {z : ℂ} {n : ℕ} (z0 : z ≠ 0) : z ^ (n+1) / z = z ^ n := begin
  rw pow_succ,
  calc z * z^n / z = z / z * z^n : (div_mul_eq_mul_div _ _ _).symm
  ... = 1 * z^n : by rw div_self z0
  ... = z^n : by ring
end

-- (z ^ a) ^ n = z ^ (a * n)
lemma pow_mul_nat {z w : ℂ} {n : ℕ} : (z ^ w) ^ n = z ^ (w * n) := begin
  by_cases z0 : z = 0, {
    rw z0,
    by_cases w0 : w = 0, { rw w0, simp },
    by_cases n0 : n = 0, { rw n0, simp },
    have wn0 : w * n ≠ 0 := mul_ne_zero w0 (nat.cast_ne_zero.mpr n0),
    rw complex.zero_cpow w0,
    rw complex.zero_cpow wn0,
    exact zero_pow' n n0
  },
  rw complex.cpow_def_of_ne_zero z0,
  rw complex.cpow_def_of_ne_zero z0,
  rw ←complex.exp_nat_mul,
  ring_nf
end

lemma continuous_on.circle_map (c : ℂ) (r : ℝ) (s : set ℝ) : continuous_on (circle_map c r) s :=
  continuous.continuous_on (continuous_circle_map _ _)

-- Version of continuous_on.comp for f ∘ g that puts everything about g after :,
-- to behave well under apply_rules.
lemma continuous_on.comp_left {B C : Type} [topological_space B] [topological_space C]
    {s : set B} {f : B → C} (fc : continuous_on f s)
    : ∀ (A : Type) [tA : topological_space A] (t : set A) (g : A → B),
      @continuous_on A B tA _ g t → set.maps_to g t s → @continuous_on A C tA _ (λ a, f (g a)) t :=
  λ A tA t g gc m, @continuous_on.comp _ _ _ tA _ _ _ _ _ _ fc gc m

lemma continuous_complex_abs : continuous complex.abs := begin
  rw metric.continuous_iff, intros z e ep,
  existsi [e, ep], intros w wz,
  rw real.dist_eq,
  rw complex.dist_eq at wz,
  have h := abs_norm_sub_norm_le w z,
  simp at h,
  exact lt_of_le_of_lt h wz,
end

end simple