/-
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.big_operators.basic
import data.finset.pi
import data.finset.powerset

/-!
# Results about big operators with values in a (semi)ring

We prove results about big operators that involve some interaction between
multiplicative and additive structures on the values being combined.
-/

universes u v w

open_locale big_operators

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

namespace finset
variables {s s₁ s₂ : finset α} {a : α} {b : β}  {f g : α → β}

section comm_monoid
variables [comm_monoid β]

open_locale classical

lemma prod_pow_eq_pow_sum {x : β} {f : α → ℕ} :
  ∀ {s : finset α}, (∏ i in s, x ^ (f i)) = x ^ (∑ x in s, f x) :=
begin
  apply finset.induction,
  { simp },
  { assume a s has H,
    rw [finset.prod_insert has, finset.sum_insert has, pow_add, H] }
end

end comm_monoid

section semiring
variables [non_unital_non_assoc_semiring β]

lemma sum_mul : (∑ x in s, f x) * b = ∑ x in s, f x * b :=
add_monoid_hom.map_sum (add_monoid_hom.mul_right b) _ s

lemma mul_sum : b * (∑ x in s, f x) = ∑ x in s, b * f x :=
add_monoid_hom.map_sum (add_monoid_hom.mul_left b) _ s

lemma sum_mul_sum {ι₁ : Type*} {ι₂ : Type*} (s₁ : finset ι₁) (s₂ : finset ι₂)
  (f₁ : ι₁ → β) (f₂ : ι₂ → β) :
  (∑ x₁ in s₁, f₁ x₁) * (∑ x₂ in s₂, f₂ x₂) = ∑ p in s₁.product s₂, f₁ p.1 * f₂ p.2 :=
by { rw [sum_product, sum_mul, sum_congr rfl], intros, rw mul_sum }

end semiring

section semiring
variables [non_assoc_semiring β]

lemma sum_mul_boole [decidable_eq α] (s : finset α) (f : α → β) (a : α) :
  (∑ x in s, (f x * ite (a = x) 1 0)) = ite (a ∈ s) (f a) 0 :=
by simp

lemma sum_boole_mul [decidable_eq α] (s : finset α) (f : α → β) (a : α) :
  (∑ x in s, (ite (a = x) 1 0) * f x) = ite (a ∈ s) (f a) 0 :=
by simp

end semiring

lemma sum_div [division_ring β] {s : finset α} {f : α → β} {b : β} :
  (∑ x in s, f x) / b = ∑ x in s, f x / b :=
by simp only [div_eq_mul_inv, sum_mul]

section comm_semiring
variables [comm_semiring β]

/-- The product over a sum can be written as a sum over the product of sets, `finset.pi`.
  `finset.prod_univ_sum` is an alternative statement when the product is over `univ`. -/
lemma prod_sum {δ : α → Type*} [decidable_eq α] [∀a, decidable_eq (δ a)]
  {s : finset α} {t : Πa, finset (δ a)} {f : Πa, δ a → β} :
  (∏ a in s, ∑ b in (t a), f a b) =
    ∑ p in (s.pi t), ∏ x in s.attach, f x.1 (p x.1 x.2) :=
begin
  induction s using finset.induction with a s ha ih,
  { rw [pi_empty, sum_singleton], refl },
  { have h₁ : ∀x ∈ t a, ∀y ∈ t a, ∀h : x ≠ y,
        disjoint (image (pi.cons s a x) (pi s t)) (image (pi.cons s a y) (pi s t)),
    { assume x hx y hy h,
      simp only [disjoint_iff_ne, mem_image],
      rintros _ ⟨p₂, hp, eq₂⟩ _ ⟨p₃, hp₃, eq₃⟩ eq,
      have : pi.cons s a x p₂ a (mem_insert_self _ _) = pi.cons s a y p₃ a (mem_insert_self _ _),
      { rw [eq₂, eq₃, eq] },
      rw [pi.cons_same, pi.cons_same] at this,
      exact h this },
    rw [prod_insert ha, pi_insert ha, ih, sum_mul, sum_bUnion h₁],
    refine sum_congr rfl (λ b _, _),
    have h₂ : ∀p₁∈pi s t, ∀p₂∈pi s t, pi.cons s a b p₁ = pi.cons s a b p₂ → p₁ = p₂, from
      assume p₁ h₁ p₂ h₂ eq, pi_cons_injective ha eq,
    rw [sum_image h₂, mul_sum],
    refine sum_congr rfl (λ g _, _),
    rw [attach_insert, prod_insert, prod_image],
    { simp only [pi.cons_same],
      congr' with ⟨v, hv⟩, congr',
      exact (pi.cons_ne (by rintro rfl; exact ha hv)).symm },
    { exact λ _ _ _ _, subtype.eq ∘ subtype.mk.inj },
    { simp only [mem_image], rintro ⟨⟨_, hm⟩, _, rfl⟩, exact ha hm } }
end

open_locale classical

/-- The product of `f a + g a` over all of `s` is the sum
  over the powerset of `s` of the product of `f` over a subset `t` times
  the product of `g` over the complement of `t`  -/
lemma prod_add (f g : α → β) (s : finset α) :
  ∏ a in s, (f a + g a) = ∑ t in s.powerset, ((∏ a in t, f a) * (∏ a in (s \ t), g a)) :=
calc ∏ a in s, (f a + g a)
    = ∏ a in s, ∑ p in ({true, false} : finset Prop), if p then f a else g a : by simp
... = ∑ p in (s.pi (λ _, {true, false}) : finset (Π a ∈ s, Prop)),
        ∏ a in s.attach, if p a.1 a.2 then f a.1 else g a.1 : prod_sum
... = ∑ t in s.powerset, (∏ a in t, f a) * (∏ a in (s \ t), g a) : begin
  refine eq.symm (sum_bij (λ t _ a _, a ∈ t) _ _ _ _),
  { simp [subset_iff]; tauto },
  { intros t ht,
    erw [prod_ite (λ a : {a // a ∈ s}, f a.1) (λ a : {a // a ∈ s}, g a.1)],
    refine congr_arg2 _
      (prod_bij (λ (a : α) (ha : a ∈ t), ⟨a, mem_powerset.1 ht ha⟩)
         _ _ _
        (λ b hb, ⟨b, by cases b;
          simpa only [true_and, exists_prop, mem_filter, and_true, mem_attach, eq_self_iff_true,
            subtype.coe_mk] using hb⟩))
      (prod_bij (λ (a : α) (ha : a ∈ s \ t), ⟨a, by simp * at *⟩)
        _ _ _
        (λ b hb, ⟨b, by cases b; begin
          simp only [true_and, mem_filter, mem_attach, subtype.coe_mk] at hb,
          simpa only [true_and, exists_prop, and_true, mem_sdiff, eq_self_iff_true, subtype.coe_mk,
            b_property],
        end⟩));
    intros; simp * at *; simp * at * },
  { assume a₁ a₂ h₁ h₂ H,
    ext x,
    simp only [function.funext_iff, subset_iff, mem_powerset, eq_iff_iff] at h₁ h₂ H,
    exact ⟨λ hx, (H x (h₁ hx)).1 hx, λ hx, (H x (h₂ hx)).2 hx⟩ },
  { assume f hf,
    exact ⟨s.filter (λ a : α, ∃ h : a ∈ s, f a h),
      by simp, by funext; intros; simp *⟩ }
end

/-- `∏ i, (f i + g i) = (∏ i, f i) + ∑ i, g i * (∏ j < i, f j + g j) * (∏ j > i, f j)`. -/
lemma prod_add_ordered {ι R : Type*} [comm_semiring R] [linear_order ι] (s : finset ι)
  (f g : ι → R) :
  (∏ i in s, (f i + g i)) = (∏ i in s, f i) +
    ∑ i in s, g i * (∏ j in s.filter (< i), (f j + g j)) * ∏ j in s.filter (λ j, i < j), f j :=
begin
  refine finset.induction_on_max s (by simp) _,
  clear s, intros a s ha ihs,
  have ha' : a ∉ s, from λ ha', (ha a ha').false,
  rw [prod_insert ha', prod_insert ha', sum_insert ha', filter_insert, if_neg (lt_irrefl a),
    filter_true_of_mem ha, ihs, add_mul, mul_add, mul_add, add_assoc],
  congr' 1, rw add_comm, congr' 1,
  { rw [filter_false_of_mem, prod_empty, mul_one],
    exact (forall_mem_insert _ _ _).2 ⟨lt_irrefl a, λ i hi, (ha i hi).not_lt⟩ },
  { rw mul_sum,
    refine sum_congr rfl (λ i hi, _),
    rw [filter_insert, if_neg (ha i hi).not_lt, filter_insert, if_pos (ha i hi), prod_insert,
      mul_left_comm],
    exact mt (λ ha, (mem_filter.1 ha).1) ha' }
end

/-- `∏ i, (f i - g i) = (∏ i, f i) - ∑ i, g i * (∏ j < i, f j - g j) * (∏ j > i, f j)`. -/

/-- `∏ i, (1 - f i) = 1 - ∑ i, f i * (∏ j < i, 1 - f j)`. This formula is useful in construction of
a partition of unity from a collection of “bump” functions.  -/
lemma prod_one_sub_ordered {ι R : Type*} [comm_ring R] [linear_order ι] (s : finset ι) (f : ι → R) :
  (∏ i in s, (1 - f i)) = 1 - ∑ i in s, f i * ∏ j in s.filter (< i), (1 - f j) :=
by { rw prod_sub_ordered, simp }

/--  Summing `a^s.card * b^(n-s.card)` over all finite subsets `s` of a `finset`
gives `(a + b)^s.card`.-/
lemma sum_pow_mul_eq_add_pow
  {α R : Type*} [comm_semiring R] (a b : R) (s : finset α) :
  (∑ t in s.powerset, a ^ t.card * b ^ (s.card - t.card)) = (a + b) ^ s.card :=
begin
  rw [← prod_const, prod_add],
  refine finset.sum_congr rfl (λ t ht, _),
  rw [prod_const, prod_const, ← card_sdiff (mem_powerset.1 ht)]
end

theorem dvd_sum {b : β} {s : finset α} {f : α → β}
  (h : ∀ x ∈ s, b ∣ f x) : b ∣ ∑ x in s, f x :=
multiset.dvd_sum (λ y hy, by rcases multiset.mem_map.1 hy with ⟨x, hx, rfl⟩; exact h x hx)

@[norm_cast]
lemma prod_nat_cast (s : finset α) (f : α → ℕ) :
  ↑(∏ x in s, f x : ℕ) = (∏ x in s, (f x : β)) :=
(nat.cast_ring_hom β).map_prod f s

end comm_semiring

section comm_ring

variables {R : Type*} [comm_ring R]

lemma prod_range_cast_nat_sub (n k : ℕ) :
  ∏ i in range k, (n - i : R) = (∏ i in range k, (n - i) : ℕ) :=
begin
  rw prod_nat_cast,
  cases le_or_lt k n with hkn hnk,
  { exact prod_congr rfl (λ i hi, (nat.cast_sub $ (mem_range.1 hi).le.trans hkn).symm) },
  { rw ← mem_range at hnk,
    rw [prod_eq_zero hnk, prod_eq_zero hnk]; simp }
end

end comm_ring

/-- A product over all subsets of `s ∪ {x}` is obtained by multiplying the product over all subsets
of `s`, and over all subsets of `s` to which one adds `x`. -/
@[to_additive "A sum over all subsets of `s ∪ {x}` is obtained by summing the sum over all subsets
of `s`, and over all subsets of `s` to which one adds `x`."]
lemma prod_powerset_insert [decidable_eq α] [comm_monoid β] {s : finset α} {x : α} (h : x ∉ s)
  (f : finset α → β) :
  (∏ a in (insert x s).powerset, f a) =
    (∏ a in s.powerset, f a) * (∏ t in s.powerset, f (insert x t)) :=
begin
  rw [powerset_insert, finset.prod_union, finset.prod_image],
  { assume t₁ h₁ t₂ h₂ heq,
    rw [← finset.erase_insert (not_mem_of_mem_powerset_of_not_mem h₁ h),
        ← finset.erase_insert (not_mem_of_mem_powerset_of_not_mem h₂ h), heq] },
  { rw finset.disjoint_iff_ne,
    assume t₁ h₁ t₂ h₂,
    rcases finset.mem_image.1 h₂ with ⟨t₃, h₃, H₃₂⟩,
    rw ← H₃₂,
    exact ne_insert_of_not_mem _ _ (not_mem_of_mem_powerset_of_not_mem h₁ h) }
end

/-- A product over `powerset s` is equal to the double product over sets of subsets of `s` with
`card s = k`, for `k = 1, ..., card s`. -/
@[to_additive "A sum over `powerset s` is equal to the double sum over sets of subsets of `s` with
`card s = k`, for `k = 1, ..., card s`"]
lemma prod_powerset [comm_monoid β] (s : finset α) (f : finset α → β) :
  ∏ t in powerset s, f t = ∏ j in range (card s + 1), ∏ t in powerset_len j s, f t :=
begin
  classical,
  rw [powerset_card_bUnion, prod_bUnion],
  intros i hi j hj hij,
  rw [function.on_fun, powerset_len_eq_filter, powerset_len_eq_filter, disjoint_filter],
  intros x hx hc hnc,
  apply hij,
  rwa ← hc,
end

lemma sum_range_succ_mul_sum_range_succ [non_unital_non_assoc_semiring β] (n k : ℕ) (f g : ℕ → β) :
  (∑ i in range (n+1), f i) * (∑ i in range (k+1), g i) =
    (∑ i in range n, f i) * (∑ i in range k, g i) +
    f n * (∑ i in range k, g i) +
    (∑ i in range n, f i) * g k +
    f n * g k :=
by simp only [add_mul, mul_add, add_assoc, sum_range_succ]

end finset


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import topology.separation

/-!
# Sober spaces

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

A quasi-sober space is a topological space where every
irreducible closed subset has a generic point.
A sober space is a quasi-sober space where every irreducible closed subset
has a *unique* generic point. This is if and only if the space is T0, and thus sober spaces can be
stated via `[quasi_sober α] [t0_space α]`.

## Main definition

* `is_generic_point` : `x` is the generic point of `S` if `S` is the closure of `x`.
* `quasi_sober` : A space is quasi-sober if every irreducible closed subset has a generic point.

-/

open set

variables {α β : Type*} [topological_space α] [topological_space β]

section generic_point

/-- `x` is a generic point of `S` if `S` is the closure of `x`. -/
def is_generic_point (x : α) (S : set α) : Prop := closure ({x} : set α) = S

lemma is_generic_point_def {x : α} {S : set α} : is_generic_point x S ↔ closure ({x} : set α) = S :=
iff.rfl

lemma is_generic_point.def {x : α} {S : set α} (h : is_generic_point x S) :
  closure ({x} : set α) = S := h

lemma is_generic_point_closure {x : α} : is_generic_point x (closure ({x} : set α)) := refl _

variables {x y : α} {S U Z : set α}

lemma is_generic_point_iff_specializes :
  is_generic_point x S ↔ ∀ y, x ⤳ y ↔ y ∈ S :=
by simp only [specializes_iff_mem_closure, is_generic_point, set.ext_iff]

namespace is_generic_point

lemma specializes_iff_mem (h : is_generic_point x S) : x ⤳ y ↔ y ∈ S :=
is_generic_point_iff_specializes.1 h y

lemma specializes (h : is_generic_point x S) (h' : y ∈ S) : x ⤳ y :=
h.specializes_iff_mem.2 h'

lemma mem (h : is_generic_point x S) : x ∈ S :=
h.specializes_iff_mem.1 specializes_rfl

protected lemma is_closed (h : is_generic_point x S) : is_closed S :=
h.def ▸ is_closed_closure

protected

/-- In a T₀ space, each set has at most one generic point. -/
protected lemma eq [t0_space α] (h : is_generic_point x S) (h' : is_generic_point y S) : x = y :=
((h.specializes h'.mem).antisymm (h'.specializes h.mem)).eq

lemma mem_open_set_iff (h : is_generic_point x S) (hU : is_open U) :
  x ∈ U ↔ (S ∩ U).nonempty :=
⟨λ h', ⟨x, h.mem, h'⟩, λ ⟨y, hyS, hyU⟩, (h.specializes hyS).mem_open hU hyU⟩

lemma disjoint_iff (h : is_generic_point x S) (hU : is_open U) : disjoint S U ↔ x ∉ U :=
by rw [h.mem_open_set_iff hU, ← not_disjoint_iff_nonempty_inter, not_not]

lemma mem_closed_set_iff (h : is_generic_point x S) (hZ : is_closed Z) :
  x ∈ Z ↔ S ⊆ Z :=
by rw [← h.def, hZ.closure_subset_iff, singleton_subset_iff]

protected lemma image (h : is_generic_point x S) {f : α → β} (hf : continuous f) :
  is_generic_point (f x) (closure (f '' S)) :=
begin
  rw [is_generic_point_def, ← h.def, ← image_singleton],
  exact subset.antisymm (closure_mono (image_subset _ subset_closure))
    (closure_minimal (image_closure_subset_closure_image hf) is_closed_closure)
end

end is_generic_point

lemma is_generic_point_iff_forall_closed (hS : is_closed S) (hxS : x ∈ S) :
  is_generic_point x S ↔ ∀ Z : set α, is_closed Z → x ∈ Z → S ⊆ Z :=
have closure {x} ⊆ S, from closure_minimal (singleton_subset_iff.2 hxS) hS,
by simp_rw [is_generic_point, subset_antisymm_iff, this, true_and, closure, subset_sInter_iff,
  mem_set_of_eq, and_imp, singleton_subset_iff]

end generic_point

section sober

/-- A space is sober if every irreducible closed subset has a generic point. -/
@[mk_iff]
class quasi_sober (α : Type*) [topological_space α] : Prop :=
(sober : ∀ {S : set α} (hS₁ : is_irreducible S) (hS₂ : is_closed S), ∃ x, is_generic_point x S)

/-- A generic point of the closure of an irreducible space. -/
noncomputable
def is_irreducible.generic_point [quasi_sober α] {S : set α} (hS : is_irreducible S) : α :=
(quasi_sober.sober hS.closure is_closed_closure).some

lemma is_irreducible.generic_point_spec [quasi_sober α] {S : set α} (hS : is_irreducible S) :
  is_generic_point hS.generic_point (closure S) :=
(quasi_sober.sober hS.closure is_closed_closure).some_spec

@[simp] lemma is_irreducible.generic_point_closure_eq [quasi_sober α] {S : set α}
  (hS : is_irreducible S) : closure ({hS.generic_point} : set α) = closure S :=
hS.generic_point_spec

variable (α)

/-- A generic point of a sober irreducible space. -/
noncomputable
def generic_point [quasi_sober α] [irreducible_space α] : α :=
(irreducible_space.is_irreducible_univ α).generic_point

lemma generic_point_spec [quasi_sober α] [irreducible_space α] :
  is_generic_point (generic_point α) ⊤ :=
by simpa using (irreducible_space.is_irreducible_univ α).generic_point_spec

@[simp]
lemma generic_point_closure [quasi_sober α] [irreducible_space α] :
  closure ({generic_point α} : set α) = ⊤ := generic_point_spec α

variable {α}

lemma generic_point_specializes [quasi_sober α] [irreducible_space α] (x : α) :
  generic_point α ⤳ x := (is_irreducible.generic_point_spec _).specializes (by simp)

local attribute [instance, priority 10] specialization_order

/-- The closed irreducible subsets of a sober space bijects with the points of the space. -/
noncomputable
def irreducible_set_equiv_points [quasi_sober α] [t0_space α] :
  { s : set α | is_irreducible s ∧ is_closed s } ≃o α :=
{ to_fun := λ s, s.prop.1.generic_point,
  inv_fun := λ x, ⟨closure ({x} : set α), is_irreducible_singleton.closure, is_closed_closure⟩,
  left_inv := λ s,
    subtype.eq $ eq.trans (s.prop.1.generic_point_spec) $ closure_eq_iff_is_closed.mpr s.2.2,
  right_inv := λ x, is_irreducible_singleton.closure.generic_point_spec.eq
      (by { convert is_generic_point_closure using 1, rw closure_closure }),
  map_rel_iff' := λ s t, by { change _ ⤳ _ ↔ _, rw specializes_iff_closure_subset,
    simp [s.prop.2.closure_eq, t.prop.2.closure_eq, ← subtype.coe_le_coe] } }

lemma closed_embedding.quasi_sober {f : α → β} (hf : closed_embedding f) [quasi_sober β] :
  quasi_sober α :=
begin
  constructor,
  intros S hS hS',
  have hS'' := hS.image f hf.continuous.continuous_on,
  obtain ⟨x, hx⟩ := quasi_sober.sober hS'' (hf.is_closed_map _ hS'),
  obtain ⟨y, hy, rfl⟩ := hx.mem,
  use y,
  change _ = _ at hx,
  apply set.image_injective.mpr hf.inj,
  rw [← hx, ← hf.closure_image_eq, set.image_singleton]
end

lemma open_embedding.quasi_sober {f : α → β} (hf : open_embedding f) [quasi_sober β] :
  quasi_sober α :=
begin
  constructor,
  intros S hS hS',
  have hS'' := hS.image f hf.continuous.continuous_on,
  obtain ⟨x, hx⟩ := quasi_sober.sober hS''.closure is_closed_closure,
  obtain ⟨T, hT, rfl⟩ := hf.to_inducing.is_closed_iff.mp hS',
  rw set.image_preimage_eq_inter_range at hx hS'',
  have hxT : x ∈ T,
  { rw ← hT.closure_eq, exact closure_mono (set.inter_subset_left _ _) hx.mem },
  have hxU : x ∈ set.range f,
  { rw hx.mem_open_set_iff hf.open_range,
    refine set.nonempty.mono _ hS''.1,
    simpa using subset_closure },
  rcases hxU with ⟨y, rfl⟩,
  use y,
  change _ = _,
  rw [hf.to_embedding.closure_eq_preimage_closure_image,
    set.image_singleton, (show _ = _, from hx)],
  apply set.image_injective.mpr hf.inj,
  ext z,
  simp only [set.image_preimage_eq_inter_range, set.mem_inter_iff, and.congr_left_iff],
  exact λ hy, ⟨λ h, hT.closure_eq ▸ closure_mono (set.inter_subset_left _ _) h,
    λ h, subset_closure ⟨h, hy⟩⟩
end

/-- A space is quasi sober if it can be covered by open quasi sober subsets. -/
lemma quasi_sober_of_open_cover (S : set (set α)) (hS : ∀ s : S, is_open (s : set α))
  [hS' : ∀ s : S, quasi_sober s] (hS'' : ⋃₀ S = ⊤) : quasi_sober α :=
begin
  rw quasi_sober_iff,
  intros t h h',
  obtain ⟨x, hx⟩ := h.1,
  obtain ⟨U, hU, hU'⟩ : x ∈ ⋃₀S := by { rw hS'', trivial },
  haveI : quasi_sober U := hS' ⟨U, hU⟩,
  have H : is_preirreducible (coe ⁻¹' t : set U) :=
    h.2.preimage (hS ⟨U, hU⟩).open_embedding_subtype_coe,
  replace H : is_irreducible (coe ⁻¹' t : set U) := ⟨⟨⟨x, hU'⟩, by simpa using hx⟩, H⟩,
  use H.generic_point,
  have := continuous_subtype_coe.closure_preimage_subset _ H.generic_point_spec.mem,
  rw h'.closure_eq at this,
  apply le_antisymm,
  { apply h'.closure_subset_iff.mpr, simpa using this },
  rw [← set.image_singleton, ← closure_closure],
  have := closure_mono (image_closure_subset_closure_image (@continuous_subtype_coe α _ U)),
  refine set.subset.trans _ this,
  rw H.generic_point_spec.def,
  refine (subset_closure_inter_of_is_preirreducible_of_is_open
    h.2 (hS ⟨U, hU⟩) ⟨x, hx, hU'⟩).trans (closure_mono _),
  rw ← subtype.image_preimage_coe,
  exact set.image_subset _ subset_closure,
end

@[priority 100]
instance t2_space.quasi_sober [t2_space α] : quasi_sober α :=
begin
  constructor,
  rintro S h -,
  obtain ⟨x, rfl⟩ := is_irreducible_iff_singleton.mp h,
  exact ⟨x, closure_singleton⟩
end

end sober


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

import algebra.big_operators.fin
import algebra.geom_sum
import group_theory.perm.fin
import linear_algebra.matrix.determinant
import tactic.ring_exp

/-!
# Vandermonde matrix

This file defines the `vandermonde` matrix and gives its determinant.

## Main definitions

 - `vandermonde v`: a square matrix with the `i, j`th entry equal to `v i ^ j`.

## Main results

 - `det_vandermonde`: `det (vandermonde v)` is the product of `v i - v j`, where
   `(i, j)` ranges over the unordered pairs.
-/

variables {R : Type*} [comm_ring R]

open_locale big_operators
open_locale matrix

open equiv

namespace matrix

/-- `vandermonde v` is the square matrix with `i`th row equal to `1, v i, v i ^ 2, v i ^ 3, ...`.
-/
def vandermonde {n : ℕ} (v : fin n → R) : matrix (fin n) (fin n) R :=
λ i j, v i ^ (j : ℕ)

@[simp] lemma vandermonde_apply {n : ℕ} (v : fin n → R) (i j) :
  vandermonde v i j = v i ^ (j : ℕ) :=
rfl

@[simp] lemma vandermonde_cons {n : ℕ} (v0 : R) (v : fin n → R) :
  vandermonde (fin.cons v0 v : fin n.succ → R) =
    fin.cons (λ j, v0 ^ (j : ℕ)) (λ i, fin.cons 1 (λ j, v i * vandermonde v i j)) :=
begin
  ext i j,
  refine fin.cases (by simp) (λ i, _) i,
  refine fin.cases (by simp) (λ j, _) j,
  simp [pow_succ]
end

lemma vandermonde_succ {n : ℕ} (v : fin n.succ → R) :
  vandermonde v =
    fin.cons (λ j, v 0 ^ (j : ℕ))
      (λ i, fin.cons 1 (λ j, v i.succ * vandermonde (fin.tail v) i j)) :=
begin
  conv_lhs { rw [← fin.cons_self_tail v, vandermonde_cons] },
  simp only [fin.tail]
end

lemma vandermonde_mul_vandermonde_transpose {n : ℕ} (v w : fin n → R) (i j) :
  (vandermonde v ⬝ (vandermonde w)ᵀ) i j = ∑ (k : fin n), (v i * w j) ^ (k : ℕ) :=
by simp only [vandermonde_apply, matrix.mul_apply, matrix.transpose_apply, mul_pow]

lemma vandermonde_transpose_mul_vandermonde {n : ℕ} (v : fin n → R) (i j) :
  ((vandermonde v)ᵀ ⬝ vandermonde v) i j = ∑ (k : fin n), v k ^ (i + j : ℕ) :=
by simp only [vandermonde_apply, matrix.mul_apply, matrix.transpose_apply, pow_add]

lemma det_vandermonde {n : ℕ} (v : fin n → R) :
  det (vandermonde v) = ∏ i : fin n, ∏ j in finset.univ.filter (λ j, i < j), (v j - v i) :=
begin
  unfold vandermonde,

  induction n with n ih,
  { exact det_eq_one_of_card_eq_zero (fintype.card_fin 0) },

  calc det (λ (i j : fin n.succ), v i ^ (j : ℕ))
      = det (λ (i j : fin n.succ), @fin.cons _ (λ _, R)
               (v 0 ^ (j : ℕ))
               (λ i, v (fin.succ i) ^ (j : ℕ) - v 0 ^ (j : ℕ)) i) :
    det_eq_of_forall_row_eq_smul_add_const (fin.cons 0 1) 0 (fin.cons_zero _ _) _
  ... = det (λ (i j : fin n), @fin.cons _ (λ _, R)
              (v 0 ^ (j.succ : ℕ))
              (λ (i : fin n), v (fin.succ i) ^ (j.succ : ℕ) - v 0 ^ (j.succ : ℕ))
              (fin.succ_above 0 i)) :
    by simp_rw [det_succ_column_zero, fin.sum_univ_succ, fin.cons_zero, minor, fin.cons_succ,
                fin.coe_zero, pow_zero, one_mul, sub_self, mul_zero, zero_mul,
                finset.sum_const_zero, add_zero]
  ... = det (λ (i j : fin n), (v (fin.succ i) - v 0) *
              (∑ k in finset.range (j + 1 : ℕ), v i.succ ^ k * v 0 ^ (j - k : ℕ))) :
    by { congr, ext i j, rw [fin.succ_above_zero, fin.cons_succ, fin.coe_succ, mul_comm],
         exact (geom_sum₂_mul (v i.succ) (v 0) (j + 1 : ℕ)).symm }
  ... = (∏ (i : fin n), (v (fin.succ i) - v 0)) * det (λ (i j : fin n),
    (∑ k in finset.range (j + 1 : ℕ), v i.succ ^ k * v 0 ^ (j - k : ℕ))) :
    det_mul_column (λ i, v (fin.succ i) - v 0) _
  ... = (∏ (i : fin n), (v (fin.succ i) - v 0)) * det (λ (i j : fin n), v (fin.succ i) ^ (j : ℕ)) :
    congr_arg ((*) _) _
  ... = ∏ i : fin n.succ, ∏ j in finset.univ.filter (λ j, i < j), (v j - v i) :
    by { simp_rw [ih (v ∘ fin.succ), fin.prod_univ_succ, fin.prod_filter_zero_lt,
                  fin.prod_filter_succ_lt] },
  { intros i j,
    rw fin.cons_zero,
    refine fin.cases _ (λ i, _) i,
    { simp },
    rw [fin.cons_succ, fin.cons_succ, pi.one_apply],
    ring },
  { cases n,
    { simp only [det_eq_one_of_card_eq_zero (fintype.card_fin 0)] },
    apply det_eq_of_forall_col_eq_smul_add_pred (λ i, v 0),
    { intro j,
      simp },
    { intros i j,
      simp only [smul_eq_mul, pi.add_apply, fin.coe_succ, fin.coe_cast_succ, pi.smul_apply],
      rw [finset.sum_range_succ, add_comm, tsub_self, pow_zero, mul_one, finset.mul_sum],
      congr' 1,
      refine finset.sum_congr rfl (λ i' hi', _),
      rw [mul_left_comm (v 0), nat.succ_sub, pow_succ],
      exact nat.lt_succ_iff.mp (finset.mem_range.mp hi') } }
end

end matrix


import tactic

/-
# Level 3 : Deeper conjunctions
-/

namespace math3345 -- hide

/-
P and Q and R are propositions.
-/

variable P : Prop
variable Q : Prop
variable R : Prop

/- Lemma : no-side-bar

`h` is evidence that `(P ∧ Q) ∧ R`, and we can extract evidence for `P ∧ Q` by
using `h.left` and extract evidence for `R` with `h.right`.

Finish the proof with `exact` followed by something.

-/
lemma and_more_elim (h : ((P ∧ Q) ∧ R)) : Q :=
begin

  sorry,

end

end math3345 -- hide


import .misc

open function

--- A structure that carries a map together with a specified inverse.
structure bijection (α β : Sort _) :=
  (to_fun : α → β) (inv : β → α) (left_inverse : left_inverse inv to_fun) (right_inverse : right_inverse inv to_fun)

@[reducible,inline]
instance bijection_to_fun (α β : Sort _) : has_coe_to_fun (bijection α β) :=
{
  F := _,
  coe := bijection.to_fun
}

namespace bijection

--- The underlying map of `bijection α β` has an inverse.
protected
lemma has_inverse {α β : Sort _} (f : bijection α β) : has_inverse f.to_fun :=
  ⟨f.inv, ⟨f.left_inverse, f.right_inverse⟩⟩

--- The inverse part of `bijection α β` has an inverse.
protected
lemma inv_has_inverse {α β : Sort _} (f : bijection α β) : has_inverse f.inv :=
  ⟨f.to_fun, ⟨f.right_inverse, f.left_inverse⟩⟩

--- Bijections are injective.
protected
lemma is_injective {α β : Sort _} (f : bijection α β) : injective f.to_fun :=
  has_left_inverse.injective ⟨f.inv, f.left_inverse⟩

--- Bijections are surjective.
protected
lemma is_surjective {α β : Sort _} (f : bijection α β) : surjective f.to_fun :=
  has_right_inverse.surjective ⟨f.inv, f.right_inverse⟩

--- Bijections are bijective.
protected
lemma is_bijective {α β : Sort _} (f : bijection α β) : bijective f.to_fun :=
  ⟨f.is_injective, f.is_surjective⟩

--- The inverses of bijections are injective.
protected
lemma inv_is_injective {α β : Sort _} (f : bijection α β) : injective f.inv :=
  has_left_inverse.injective ⟨f.to_fun, f.right_inverse⟩

--- The inverses of bijections are surjective.
protected
lemma inv_is_surjective {α β : Sort _} (f : bijection α β) : surjective f.inv :=
  has_right_inverse.surjective ⟨f.to_fun, f.left_inverse⟩

--- The inverses of bijections are bijective
protected
lemma inv_is_bijective {α β : Sort _} (f : bijection α β) : bijective f.inv :=
  ⟨f.inv_is_injective, f.inv_is_surjective⟩

--- The identity if a bijection
protected
definition id {α : Sort _} : bijection α α :=
{
  to_fun := @id α,
  inv := @id α,
  left_inverse := λ _, rfl,
  right_inverse := λ _, rfl
}

--- The composition of bijections is a bijection.
protected
definition comp {α β γ : Sort _} (g : bijection β γ) (f : bijection α β) : bijection α γ :=
{
  to_fun := g.to_fun ∘ f.to_fun,
  inv := f.inv ∘ g.inv,
  left_inverse := left_inverse_comp g.left_inverse f.left_inverse,
  right_inverse := right_inverse_comp g.right_inverse f.right_inverse
}

--- Bijections are invertible.
protected
definition inverse {α β : Sort _} (f : bijection α β) : bijection β α :=
{
  to_fun := f.inv,
  inv := f.to_fun,
  left_inverse := f.right_inverse,
  right_inverse := f.left_inverse
}

--- The subtype `{a : α // true}` is isomorphic to `α` itself.
definition subtype_true (α : Sort _) : bijection {x : α // true} α :=
{
  to_fun := subtype.val,
  inv := λ x, ⟨x, true.intro⟩,
  left_inverse := λ x, by cases x; refl,
  right_inverse := @rfl α
}

--- The subtypes classified by equivalent propositions are isomorphic.
definition subtype_equiv {α : Sort _} {p q : α → Prop} (hpq: ∀ x, p x ↔ q x) : bijection (subtype p) (subtype q) :=
{
  to_fun := λ x, subtype.rec_on x (λ a h, ⟨a, iff.mp (hpq a) h⟩),
  inv := λ x, subtype.rec_on x (λ a h, ⟨a, iff.mpr (hpq a) h⟩),
  left_inverse := λ x, by cases x; refl,
  right_inverse := λ x, by cases x; refl
}

--- Subtypes of a subtype is just a subtype of the root type.
definition subtype_uncurry {α : Sort _} {p q : α → Prop} : bijection {x : subtype p // q x.val} {x : α // p x ∧ q x} :=
{
  to_fun := λ x, ⟨x.val.val, ⟨x.val.property, x.property⟩⟩,
  inv := λ x, ⟨⟨x.val,x.property.left⟩,x.property.right⟩,
  left_inverse := λ x, by cases x; cases x_val; refl,
  right_inverse := λ x, by cases x; refl
}

--- Subtypes of a subtype is just a subtype of the root type.
definition subtype_curry {α : Sort _} {p q : α → Prop} : bijection {x : α // p x ∧ q x} {x : subtype p // q x.val} :=
{
  to_fun := λ x, ⟨⟨x.val,x.property.left⟩,x.property.right⟩,
  inv := λ x, ⟨x.val.val, ⟨x.val.property, x.property⟩⟩,
  left_inverse := λ x, by cases x; refl,
  right_inverse := λ x, by cases x; cases x_val; refl
}

/- In the following, we use `funext` and `definite_description`. -/
namespace unsafe

--- Construct an term of `bijection α β` from a bijective map by choosing its inverse.
noncomputable definition to_bijection {α β : Sort _} (f : α → β) (hbij : bijective f) : bijection α β :=
{
  to_fun := f,
  inv := funrel.unsafe.reify (funrel.inverse_of_bijective hbij),
  left_inverse :=
    begin
      intros a,
      rw [←funrel.unsafe.reify_fun_id f],
      exact (funrel.unsafe.reify_inverse (funrel.bijective_fun_isom hbij)).left a,
    end,
  right_inverse :=
    begin
      intros b,
      rw [←funrel.unsafe.reify_fun_id f],
      exact (funrel.unsafe.reify_inverse (funrel.bijective_fun_isom hbij)).right b
    end
}

--- `subsingleton` type is isomorphic to a `nonempty` proposition
noncomputable definition subsingleton_is_proposition (α : Sort _) [subsingleton α] : bijection α (nonempty α) :=
  to_bijection (@nonempty.intro α) $
    begin
      split,
      show injective _,
        by intros a b _; exact subsingleton.elim a b,
      show surjective _,
        by intros h; exact h.elim (λ a, exists.intro a rfl)
    end

end unsafe

end bijection


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

import .basic
import .le
import .lt
import ..logic

namespace hidden

namespace mynat

variables {m n k: mynat}

-- Subtraction

def sub: mynat → mynat → mynat
| m 0               := m
| 0 n               := 0
| (succ m) (succ n) := sub m n

instance: has_sub mynat := ⟨sub⟩

@[simp]
theorem sub_succ_succ : succ m - succ n = m - n := rfl

-- Reverse implication does NOT hold
-- Is there any point having this as a theorem
theorem sub_congr: m = n → m - k = n - k :=
begin
  assume h,
  congr,
  assumption,
end

-- °_° why doesn't this work the normal way
@[simp]
theorem sub_zero: m - 0 = m :=
begin
  cases m,
    refl,
  refl,
end

@[simp]
theorem zero_sub: 0 - m = 0 :=
begin
  cases m,
    refl,
  refl,
end

@[simp]
theorem sub_self_eq_zero: n - n = 0 :=
begin
  induction n with n hn,
    refl,
  rwa sub_succ_succ,
end

@[simp]
theorem succ_sub_self: (succ m) - m = 1 :=
begin
  induction m with m hm,
    simp,
  rwa sub_succ_succ,
end

-- Watch out, similar things do not hold, e.g. (5 - 6) + 6 ≠ 5
-- see also sub_add_condition
@[simp]
theorem add_sub: (m + n) - n = m :=
begin
  induction n with n hn,
    rw [zz, add_zero, sub_zero],
  rwa [add_succ, sub_succ_succ],
end
-- Simple corollaries of the above
@[simp] theorem add_sub_one: (m + 1) - 1 = m := add_sub

@[simp]
theorem succ_sub_one:
(succ m) - 1 = m := by rwa [←add_one_succ, add_sub]

-- the exact condition for cancellation to occur in subtraction-addition.
-- Mechanically, this proof is not so interesting, but this formulation
-- can be quite fruitful to keep in mind, and this theorem can save some
-- time
theorem sub_add_condition:
(m - n) + n = m ↔ n ≤ m :=
begin
  split, {
    assume h,
    existsi m - n,
    rw add_comm,
    symmetry,
    assumption,
  }, {
    assume h,
    cases h with d hd,
    rw [hd, add_comm n d, add_sub],
  },
end

theorem sub_zero_iff_le: m - n = 0 ↔ m ≤ n :=
begin
  cases le_total_order m n with hmn hnm, {
    split, {
      cc,
    }, {
      assume hmn2,
      cases hmn with d hd,
      rw hd,
      induction m with m_n m_ih generalizing n, {
        simp,
      }, {
        rw [succ_add, sub_succ_succ],
        cases n, {
          exfalso,
          from succ_ne_zero (add_integral hd.symm),
        }, {
          apply m_ih (le_succ_cancel hmn2),
          apply succ_inj,
          rwa succ_add at hd,
        },
      },
    },
  }, {
    split, {
      assume hmn,
      cases hnm with d hd,
      rw [hd, add_comm, add_sub] at hmn,
      rw hmn at hd,
      rw [hd, add_zero],
    }, {
      assume hmn,
      have hmeqn := le_antisymm hnm hmn,
      rw hmeqn,
      from sub_self_eq_zero,
    }
  }
end

-- just the contrapositive. Useful later
theorem sub_nzero_iff_gt: m - n ≠ 0 ↔ n < m :=
iff_to_contrapositive sub_zero_iff_le

theorem sub_succ_impl_le: m - n = succ k → n < m :=
begin
  assume hmnsk,
  rw ←sub_nzero_iff_gt,
  rw hmnsk,
  from succ_ne_zero,
end

theorem sub_succ_rearrange: m - n = succ k ↔ m = succ k + n :=
begin
  split, {
    assume hmnsk,
    have hnlm := sub_succ_impl_le hmnsk,
    rw lt_iff_succ_le at hnlm,
    cases hnlm with d hd,
    rw [hd, add_comm, add_succ, ←succ_add, add_sub] at hmnsk,
    rw [hd, ←hmnsk, succ_add, succ_add, add_comm],
  }, {
    assume hmskn,
    rw [hmskn, add_sub],
  },
end

theorem sub_succ_converse: n < m → ∃ k, m - n = succ k :=
begin
  assume hnm,
  cases lt_iff_succ_le.mp hnm with d hd,
  existsi d,
  rw [hd, succ_add, ←add_succ, add_comm, add_sub],
end

theorem sub_succ_cancel: succ m - n = succ k → m - n = k :=
begin
  rw [sub_succ_rearrange, succ_add],
  assume hmkn,
  rw [succ_inj hmkn, add_sub],
end

theorem sub_overkill: m - (m + k) = 0 :=
begin
  rw sub_zero_iff_le,
  from le_to_add,
end

theorem sub_le: m - n ≤ m :=
begin
  cases hmn: m - n, {
    from zero_le,
  }, {
    rw sub_succ_rearrange at hmn,
    existsi n,
    assumption,
  }
end

theorem sub_succ_lt: m ≠ 0 → m - succ n < m :=
begin
  assume h,
  rw nzero_iff_succ at h,
  cases h with k h,
  rw [h, sub_succ_succ, ←le_iff_lt_succ],
  from sub_le,
end

theorem sub_from_le: m ≤ n → m - k ≤ n :=
begin
  assume hmn,
  cases (sub_le: m - k ≤ m) with d1 hd1,
  cases hmn with d2 hd2,
  existsi d1 + d2,
  rw hd2,
  conv {
    to_lhs,
    rw hd1,
  },
  rwa add_assoc,
end

@[simp]
theorem sub_switch_one: (m - n) - 1 = (m - 1) - n :=
begin
  cases h: (m - n) - 1, {
    symmetry,
    rw [zz, sub_zero_iff_le],
    rw [zz, sub_zero_iff_le] at h,
    cases h with d hd,
    cases d, {
      simp at hd,
      have hr := sub_succ_rearrange.mp hd.symm,
      have : succ 0 = 1 := rfl,
      rw [hr, add_comm, zz, this, add_sub],
    }, {
      have hmn0 := add_integral (succ_inj hd.symm),
      rw sub_zero_iff_le at hmn0,
      from sub_from_le hmn0,
    },
  }, {
    symmetry,
    rw [sub_succ_rearrange, succ_add, sub_succ_rearrange],
    rw [sub_succ_rearrange, succ_add, sub_succ_rearrange] at h,
    rw h,
    simp,
  },
end

@[simp]
theorem sub_succ: m - (succ n) = m - n - 1 :=
begin
  induction m with m hm,
    repeat { rw zz <|> rw zero_sub },
  rw [sub_succ_succ, ←add_one_succ, sub_switch_one, add_sub_one],
end

@[simp]
theorem sub_distr: m - (n + k) = m - n - k :=
begin
  induction k with k hk,
    rw [zz, add_zero, sub_zero],
  rw [sub_succ, ←hk, ←sub_succ, add_succ],
end

@[simp]
theorem sub_switch: (m - n) - k = (m - k) - n :=
begin
  induction k with k hk,
    repeat { rw zz <|> rw sub_zero },
  repeat { rw sub_succ },
  rw [←sub_switch_one, hk],
end

@[simp] theorem mul_sub: m * (n - k) = m * n - m * k :=
begin
  induction m with m hm, {
    simp,
  }, {
    cases hmnk: succ m * (n - k), {
      symmetry,
      rw [zz, sub_zero_iff_le],
      apply le_mul,
      rw ←sub_zero_iff_le,
      from mul_integral succ_ne_zero hmnk,
    }, {
      cases hnk: n - k, {
        rw hnk at hmnk,
        simp at hmnk,
        exfalso, from succ_ne_zero hmnk.symm,
      },
      symmetry,
      rw sub_succ_rearrange,
      rw sub_succ_rearrange at hnk,
      rw [hnk, add_sub] at hmnk,
      rw [←hmnk, hnk],
      rw mul_add,
    },
  },
end

@[simp] theorem sub_mul: (m - n) * k = m * k - n * k :=
by rw [mul_comm, mul_comm m, mul_comm n k, mul_sub]
-- Cute corollary
@[simp]
theorem difference_two_squares: m * m - n * n = (m - n) * (m + n) :=
by rw [sub_mul, mul_add, mul_add, sub_distr, mul_comm m n, add_sub]

end mynat

end hidden


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/

import data.list.rotate
import group_theory.perm.support

/-!
# Permutations from a list

A list `l : list α` can be interpreted as a `equiv.perm α` where each element in the list
is permuted to the next one, defined as `form_perm`. When we have that `nodup l`,
we prove that `equiv.perm.support (form_perm l) = l.to_finset`, and that
`form_perm l` is rotationally invariant, in `form_perm_rotate`.

When there are duplicate elements in `l`, how and in what arrangement with respect to the other
elements they appear in the list determines the formed permutation.
This is because `list.form_perm` is implemented as a product of `equiv.swap`s.
That means that presence of a sublist of two adjacent duplicates like `[..., x, x, ...]`
will produce the same permutation as if the adjacent duplicates were not present.

The `list.form_perm` definition is meant to primarily be used with `nodup l`, so that
the resulting permutation is cyclic (if `l` has at least two elements).
The presence of duplicates in a particular placement can lead `list.form_perm` to produce a
nontrivial permutation that is noncyclic.
-/

namespace list

variables {α β : Type*}

section form_perm

variables [decidable_eq α] (l : list α)

open equiv equiv.perm

/--
A list `l : list α` can be interpreted as a `equiv.perm α` where each element in the list
is permuted to the next one, defined as `form_perm`. When we have that `nodup l`,
we prove that `equiv.perm.support (form_perm l) = l.to_finset`, and that
`form_perm l` is rotationally invariant, in `form_perm_rotate`.
-/
def form_perm : equiv.perm α :=
(zip_with equiv.swap l l.tail).prod

@[simp] lemma form_perm_nil : form_perm ([] : list α) = 1 := rfl

@[simp] lemma form_perm_singleton (x : α) : form_perm [x] = 1 := rfl

@[simp] lemma form_perm_cons_cons (x y : α) (l : list α) :
  form_perm (x :: y :: l) = swap x y * form_perm (y :: l) :=
prod_cons

lemma form_perm_pair (x y : α) : form_perm [x, y] = swap x y := rfl

lemma form_perm_apply_of_not_mem (x : α) (l : list α) (h : x ∉ l) :
  form_perm l x = x :=
begin
  cases l with y l,
  { simp },
  induction l with z l IH generalizing x y,
  { simp },
  { specialize IH x z (mt (mem_cons_of_mem y) h),
    simp only [not_or_distrib, mem_cons_iff] at h,
    simp [IH, swap_apply_of_ne_of_ne, h] }
end

lemma form_perm_apply_mem_of_mem (x : α) (l : list α) (h : x ∈ l) :
  form_perm l x ∈ l :=
begin
  cases l with y l,
  { simpa },
  induction l with z l IH generalizing x y,
  { simpa using h },
  { by_cases hx : x ∈ z :: l,
    { rw [form_perm_cons_cons, mul_apply, swap_apply_def],
      split_ifs;
      simp [IH _ _ hx] },
    { replace h : x = y := or.resolve_right h hx,
      simp [form_perm_apply_of_not_mem _ _ hx, ←h] } }
end

@[simp] lemma form_perm_cons_concat_apply_last (x y : α) (xs : list α) :
  form_perm (x :: (xs ++ [y])) y = x :=
begin
  induction xs with z xs IH generalizing x y,
  { simp },
  { simp [IH] }
end

@[simp] lemma form_perm_apply_last (x : α) (xs : list α) :
  form_perm (x :: xs) ((x :: xs).last (cons_ne_nil x xs)) = x :=
begin
  induction xs using list.reverse_rec_on with xs y IH generalizing x;
  simp
end

@[simp] lemma form_perm_apply_nth_le_length (x : α) (xs : list α) :
  form_perm (x :: xs) ((x :: xs).nth_le xs.length (by simp)) = x :=
by rw [nth_le_cons_length, form_perm_apply_last]

lemma form_perm_apply_head (x y : α) (xs : list α) (h : nodup (x :: y :: xs)) :
  form_perm (x :: y :: xs) x = y :=
by simp [form_perm_apply_of_not_mem _ _ (not_mem_of_nodup_cons h)]

lemma form_perm_apply_nth_le_zero (l : list α) (h : nodup l) (hl : 1 < l.length) :
  form_perm l (l.nth_le 0 (zero_lt_one.trans hl)) = l.nth_le 1 hl :=
begin
  rcases l with (_|⟨x, _|⟨y, tl⟩⟩),
  { simp },
  { simp },
  { simpa using form_perm_apply_head _ _ _ h }
end

lemma form_perm_eq_head_iff_eq_last (x y : α) :
  form_perm (y :: l) x = y ↔ x = last (y :: l) (cons_ne_nil _ _) :=
iff.trans (by rw form_perm_apply_last) (form_perm (y :: l)).injective.eq_iff

lemma zip_with_swap_prod_support' (l l' : list α) :
  {x | (zip_with swap l l').prod x ≠ x} ≤ l.to_finset ⊔ l'.to_finset :=
begin
  simp only [set.sup_eq_union, set.le_eq_subset],
  induction l with y l hl generalizing l',
  { simp },
  { cases l' with z l',
    { simp },
    { intro x,
      simp only [set.union_subset_iff, mem_cons_iff, zip_with_cons_cons, foldr, prod_cons,
                 mul_apply],
      intro hx,
      by_cases h : x ∈ {x | (zip_with swap l l').prod x ≠ x},
      { specialize hl l' h,
        refine set.mem_union.elim hl (λ hm, _) (λ hm, _);
        { simp only [finset.coe_insert, set.mem_insert_iff, finset.mem_coe, to_finset_cons,
                     mem_to_finset] at hm ⊢,
          simp [hm] } },
      { simp only [not_not, set.mem_set_of_eq] at h,
        simp only [h, set.mem_set_of_eq] at hx,
        rw swap_apply_ne_self_iff at hx,
        rcases hx with ⟨hyz, rfl|rfl⟩;
        simp } } }
end

lemma zip_with_swap_prod_support [fintype α] (l l' : list α) :
  (zip_with swap l l').prod.support ≤ l.to_finset ⊔ l'.to_finset :=
begin
  intros x hx,
  have hx' : x ∈ {x | (zip_with swap l l').prod x ≠ x} := by simpa using hx,
  simpa using zip_with_swap_prod_support' _ _ hx'
end

lemma support_form_perm_le' : {x | form_perm l x ≠ x} ≤ l.to_finset :=
begin
  refine (zip_with_swap_prod_support' l l.tail).trans _,
  simpa [finset.subset_iff] using tail_subset l
end

lemma support_form_perm_le [fintype α] : support (form_perm l) ≤ l.to_finset :=
begin
  intros x hx,
  have hx' : x ∈ {x | form_perm l x ≠ x} := by simpa using hx,
  simpa using support_form_perm_le' _ hx'
end

lemma form_perm_apply_lt (xs : list α) (h : nodup xs) (n : ℕ) (hn : n + 1 < xs.length) :
  form_perm xs (xs.nth_le n ((nat.lt_succ_self n).trans hn)) = xs.nth_le (n + 1) hn :=
begin
  induction n with n IH generalizing xs,
  { simpa using form_perm_apply_nth_le_zero _ h _ },
  { rcases xs with (_|⟨x, _|⟨y, l⟩⟩),
    { simp },
    { simp },
    { specialize IH (y :: l) (nodup_of_nodup_cons h) _,
      { simpa [nat.succ_lt_succ_iff] using hn },
      simp only [swap_apply_eq_iff, coe_mul, form_perm_cons_cons, nth_le],
      generalize_proofs at IH,
      rw [IH, swap_apply_of_ne_of_ne, nth_le];
      { rintro rfl,
        simpa [nth_le_mem _ _ _] using h } } }
end

lemma form_perm_apply_nth_le (xs : list α) (h : nodup xs) (n : ℕ) (hn : n < xs.length) :
  form_perm xs (xs.nth_le n hn) = xs.nth_le ((n + 1) % xs.length)
    (nat.mod_lt _ (n.zero_le.trans_lt hn)) :=
begin
  cases xs with x xs,
  { simp },
  { have : n ≤ xs.length,
    { refine nat.le_of_lt_succ _,
      simpa using hn },
    rcases this.eq_or_lt with rfl|hn',
    { simp },
    { simp [form_perm_apply_lt, h, nat.mod_eq_of_lt, nat.succ_lt_succ hn'] } }
end

lemma support_form_perm_of_nodup' (l : list α) (h : nodup l) (h' : ∀ (x : α), l ≠ [x]) :
  {x | form_perm l x ≠ x} = l.to_finset :=
begin
  apply le_antisymm,
  { exact support_form_perm_le' l },
  { intros x hx,
    simp only [finset.mem_coe, mem_to_finset] at hx,
    obtain ⟨n, hn, rfl⟩ := nth_le_of_mem hx,
    rw [set.mem_set_of_eq, form_perm_apply_nth_le _ h],
    intro H,
    rw nodup_iff_nth_le_inj at h,
    specialize h _ _ _ _ H,
    cases (nat.succ_le_of_lt hn).eq_or_lt with hn' hn',
    { simp only [←hn', nat.mod_self] at h,
      refine not_exists.mpr h' _,
      simpa [←h, eq_comm, length_eq_one] using hn' },
    { simpa [nat.mod_eq_of_lt hn'] using h } }
end

lemma support_form_perm_of_nodup [fintype α] (l : list α) (h : nodup l) (h' : ∀ (x : α), l ≠ [x]) :
  support (form_perm l) = l.to_finset :=
begin
  rw ←finset.coe_inj,
  convert support_form_perm_of_nodup' _ h h',
  simp [set.ext_iff]
end

lemma form_perm_rotate_one (l : list α) (h : nodup l) :
  form_perm (l.rotate 1) = form_perm l :=
begin
  have h' : nodup (l.rotate 1),
  { simpa using h },
  ext x,
  by_cases hx : x ∈ l.rotate 1,
  { obtain ⟨k, hk, rfl⟩ := nth_le_of_mem hx,
    rw [form_perm_apply_nth_le _ h', nth_le_rotate l, nth_le_rotate l,
      form_perm_apply_nth_le _ h],
    simp },
  { rw [form_perm_apply_of_not_mem _ _ hx, form_perm_apply_of_not_mem],
    simpa using hx }
end

lemma form_perm_rotate (l : list α) (h : nodup l) (n : ℕ) :
  form_perm (l.rotate n) = form_perm l :=
begin
  induction n with n hn,
  { simp },
  { rw [nat.succ_eq_add_one, ←rotate_rotate, form_perm_rotate_one, hn],
    rwa is_rotated.nodup_iff,
    exact is_rotated.forall l n }
end

lemma form_perm_eq_of_is_rotated {l l' : list α} (hd : nodup l) (h : l ~r l') :
  form_perm l = form_perm l' :=
begin
  obtain ⟨n, rfl⟩ := h,
  exact (form_perm_rotate l hd n).symm
end

lemma form_perm_reverse (l : list α) (h : nodup l) :
  form_perm l.reverse = (form_perm l)⁻¹ :=
begin
  -- Let's show `form_perm l` is an inverse to `form_perm l.reverse`.
  rw [eq_comm, inv_eq_iff_mul_eq_one],
  ext x,
  -- We only have to check for `x ∈ l` that `form_perm l (form_perm l.reverse x)`
  rw [mul_apply, one_apply],
  by_cases hx : x ∈ l,
  swap,
  { rw [form_perm_apply_of_not_mem x l.reverse, form_perm_apply_of_not_mem _ _ hx],
    simpa using hx },
  { obtain ⟨k, hk, rfl⟩ := nth_le_of_mem (mem_reverse.mpr hx),
    rw [form_perm_apply_nth_le l.reverse (nodup_reverse.mpr h),
        nth_le_reverse', form_perm_apply_nth_le _ h, nth_le_reverse'],
    { congr,
      rw [length_reverse, ←nat.succ_le_iff, nat.succ_eq_add_one] at hk,
      cases hk.eq_or_lt with hk' hk',
      { simp [←hk'] },
      { rw [length_reverse, nat.mod_eq_of_lt hk', tsub_add_eq_add_tsub (nat.le_pred_of_lt hk'),
            nat.mod_eq_of_lt],
        { simp },
        { rw tsub_add_cancel_of_le,
          refine tsub_lt_self _ (nat.zero_lt_succ _),
          all_goals { simpa using (nat.zero_le _).trans_lt hk' } } } },
    all_goals { rw [← tsub_add_eq_tsub_tsub, ←length_reverse],
      refine tsub_lt_self _ (zero_lt_one.trans_le (le_add_right le_rfl)),
      exact k.zero_le.trans_lt hk } },
end

lemma form_perm_pow_apply_nth_le (l : list α) (h : nodup l) (n k : ℕ) (hk : k < l.length) :
  (form_perm l ^ n) (l.nth_le k hk) = l.nth_le ((k + n) % l.length)
    (nat.mod_lt _ (k.zero_le.trans_lt hk)) :=
begin
  induction n with n hn,
  { simp [nat.mod_eq_of_lt hk] },
  { simp [pow_succ, mul_apply, hn, form_perm_apply_nth_le _ h, nat.succ_eq_add_one,
          ←nat.add_assoc] }
end

lemma form_perm_ext_iff {x y x' y' : α} {l l' : list α}
  (hd : nodup (x :: y :: l)) (hd' : nodup (x' :: y' :: l')) :
  form_perm (x :: y :: l) = form_perm (x' :: y' :: l') ↔ (x :: y :: l) ~r (x' :: y' :: l') :=
begin
  refine ⟨λ h, _, λ hr, form_perm_eq_of_is_rotated hd hr⟩,
  rw equiv.perm.ext_iff at h,
  have hx : x' ∈ (x :: y :: l),
  { have : x' ∈ {z | form_perm (x :: y :: l) z ≠ z},
    { rw [set.mem_set_of_eq, h x', form_perm_apply_head _ _ _ hd'],
      simp only [mem_cons_iff, nodup_cons] at hd',
      push_neg at hd',
      exact hd'.left.left.symm },
    simpa using support_form_perm_le' _ this },
  obtain ⟨n, hn, hx'⟩ := nth_le_of_mem hx,
  have hl : (x :: y :: l).length = (x' :: y' :: l').length,
  { rw [←erase_dup_eq_self.mpr hd, ←erase_dup_eq_self.mpr hd',
        ←card_to_finset, ←card_to_finset],
    refine congr_arg finset.card _,
    rw [←finset.coe_inj, ←support_form_perm_of_nodup' _ hd (by simp),
        ←support_form_perm_of_nodup' _ hd' (by simp)],
    simp only [h] },
  use n,
  apply list.ext_le,
  { rw [length_rotate, hl] },
  { intros k hk hk',
    rw nth_le_rotate,
    induction k with k IH,
    { simp_rw [nat.zero_add, nat.mod_eq_of_lt hn],
      simpa },
    { have : k.succ = (k + 1) % (x' :: y' :: l').length,
      { rw [←nat.succ_eq_add_one, nat.mod_eq_of_lt hk'] },
      simp_rw this,
      rw [←form_perm_apply_nth_le _ hd' k (k.lt_succ_self.trans hk'),
          ←IH (k.lt_succ_self.trans hk), ←h, form_perm_apply_nth_le _ hd],
      congr' 1,
      have h1 : 1 = 1 % (x' :: y' :: l').length := by simp,
      rw [hl, nat.mod_eq_of_lt hk', h1, ←nat.add_mod, nat.succ_add] } }
end

lemma form_perm_apply_mem_eq_self_iff (hl : nodup l) (x : α) (hx : x ∈ l) :
  form_perm l x = x ↔ length l ≤ 1 :=
begin
  obtain ⟨k, hk, rfl⟩ := nth_le_of_mem hx,
  rw [form_perm_apply_nth_le _ hl, hl.nth_le_inj_iff],
  cases hn : l.length,
  { exact absurd k.zero_le (hk.trans_le hn.le).not_le },
  { rw hn at hk,
    cases (nat.le_of_lt_succ hk).eq_or_lt with hk' hk',
    { simp [←hk', nat.succ_le_succ_iff, eq_comm] },
    { simpa [nat.mod_eq_of_lt (nat.succ_lt_succ hk'), nat.succ_lt_succ_iff]
        using k.zero_le.trans_lt hk' } }
end

lemma form_perm_apply_mem_ne_self_iff (hl : nodup l) (x : α) (hx : x ∈ l) :
  form_perm l x ≠ x ↔ 2 ≤ l.length :=
begin
  rw [ne.def, form_perm_apply_mem_eq_self_iff _ hl x hx, not_le],
  exact ⟨nat.succ_le_of_lt, nat.lt_of_succ_le⟩
end

lemma mem_of_form_perm_ne_self (l : list α) (x : α) (h : form_perm l x ≠ x) :
  x ∈ l :=
begin
  suffices : x ∈ {y | form_perm l y ≠ y},
  { rw ←mem_to_finset,
    exact support_form_perm_le' _ this },
  simpa using h
end

lemma form_perm_eq_self_of_not_mem (l : list α) (x : α) (h : x ∉ l) :
  form_perm l x = x :=
by_contra (λ H, h $ mem_of_form_perm_ne_self _ _ H)

lemma form_perm_eq_one_iff (hl : nodup l) :
  form_perm l = 1 ↔ l.length ≤ 1 :=
begin
  cases l with hd tl,
  { simp },
  { rw ←form_perm_apply_mem_eq_self_iff _ hl hd (mem_cons_self _ _),
    split,
    { simp {contextual := tt} },
    { intro h,
      simp only [(hd :: tl).form_perm_apply_mem_eq_self_iff hl hd (mem_cons_self hd tl),
                 add_le_iff_nonpos_left, length, nonpos_iff_eq_zero, length_eq_zero] at h,
      simp [h] } }
end

lemma form_perm_eq_form_perm_iff {l l' : list α} (hl : l.nodup) (hl' : l'.nodup) :
  l.form_perm = l'.form_perm ↔ l ~r l' ∨ l.length ≤ 1 ∧ l'.length ≤ 1 :=
begin
  rcases l with (_ | ⟨x, _ | ⟨y, l⟩⟩),
  { suffices : l'.length ≤ 1 ↔ l' = nil ∨ l'.length ≤ 1,
    { simpa [eq_comm, form_perm_eq_one_iff, hl, hl', length_eq_zero] },
    refine ⟨λ h, or.inr h, _⟩,
    rintro (rfl | h),
    { simp },
    { exact h } },
  { suffices : l'.length ≤ 1 ↔ [x] ~r l' ∨ l'.length ≤ 1,
    { simpa [eq_comm, form_perm_eq_one_iff, hl, hl', length_eq_zero, le_rfl] },
    refine ⟨λ h, or.inr h, _⟩,
    rintro (h | h),
    { simp [←h.perm.length_eq] },
    { exact h } },
  { rcases l' with (_ | ⟨x', _ | ⟨y', l'⟩⟩),
    { simp [form_perm_eq_one_iff, hl, -form_perm_cons_cons] },
    { suffices : ¬ (x :: y :: l) ~r [x'],
      { simp [form_perm_eq_one_iff, hl, -form_perm_cons_cons] },
      intro h,
      simpa using h.perm.length_eq },
    { simp [-form_perm_cons_cons, form_perm_ext_iff hl hl'] } }
end

lemma form_perm_zpow_apply_mem_imp_mem (l : list α) (x : α) (hx : x ∈ l) (n : ℤ) :
  ((form_perm l) ^ n) x ∈ l :=
begin
  by_cases h : (l.form_perm ^ n) x = x,
  { simpa [h] using hx },
  { have : x ∈ {x | (l.form_perm ^ n) x ≠ x} := h,
    rw ←set_support_apply_mem at this,
    replace this := set_support_zpow_subset _ _ this,
    simpa using support_form_perm_le' _ this }
end

lemma form_perm_pow_length_eq_one_of_nodup (hl : nodup l) :
  (form_perm l) ^ (length l) = 1 :=
begin
  ext x,
  by_cases hx : x ∈ l,
  { obtain ⟨k, hk, rfl⟩ := nth_le_of_mem hx,
    simp [form_perm_pow_apply_nth_le _ hl, nat.mod_eq_of_lt hk] },
  { have : x ∉ {x | (l.form_perm ^ l.length) x ≠ x},
    { intros H,
      refine hx _,
      replace H := set_support_zpow_subset l.form_perm l.length H,
      simpa using support_form_perm_le' _ H },
    simpa }
end

end form_perm

end list


-- Límite de subsucesiones
-- =======================

import data.real.basic

variable  {u : ℕ → ℝ}
variables {a : ℝ}
variable  {φ : ℕ → ℕ}

-- ----------------------------------------------------
-- Nota. Usaremos los siguientes conceptos estudiados
-- anteriormente.
-- ----------------------------------------------------

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

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

def extraccion : (ℕ → ℕ) → Prop
| φ := ∀ n m, n < m → φ n < φ m

lemma id_mne_extraccion
  (h : extraccion φ)
  : ∀ n, n ≤ φ n :=
begin
  intros n,
  induction n with m HI,
  { linarith },
  { exact nat.succ_le_of_lt (by linarith [h m (m+1) (by linarith)]) },
end

lemma extraccion_mye
  (h : extraccion φ)
  : ∀ N N', ∃ n ≥ N', φ n ≥ N :=
λ N N',
  ⟨max N N', le_max_right N N',
             le_trans (le_max_left N N')
             (id_mne_extraccion h (max N N'))⟩

-- ----------------------------------------------------
-- Ejercicio. Demostrar que las subsucesiones de las
-- sucesiones convergentes tienen el mismo límite que
-- la sucesión.
-- ----------------------------------------------------

-- 1ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  -- unfold limite,
  intros ε hε,
  -- unfold limite at h,
  cases h ε hε with N hN,
  use N,
  intros n hn,
  apply hN,
  apply le_trans hn,
  exact id_mne_extraccion hφ n,
end

-- 2ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  cases h ε hε with N hN,
  use N,
  intros n hn,
  apply hN,
  exact le_trans hn (id_mne_extraccion hφ n),
end

-- 3ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  cases h ε hε with N hN,
  use N,
  intros n hn,
  exact hN (φ n) (le_trans hn (id_mne_extraccion hφ n)),
end

-- 4ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  cases h ε hε with N hN,
  use N,
  exact λ n hn, hN (φ n) (le_trans hn (id_mne_extraccion hφ n)),
end

-- 5ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  -- unfold limite at h,
  cases h ε hε with N hN,
  exact ⟨N, λ n hn, hN (φ n) (le_trans hn (id_mne_extraccion hφ n))⟩,
end

-- 6ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  exact (exists.elim (h ε hε)
          (λ N hN,
            ⟨N, λ n hn,
                  hN (φ n) (le_trans hn (id_mne_extraccion hφ n))⟩)),
end

-- 7ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
λ ε hε,
  (exists.elim (h ε hε)
    (λ N hN,
       ⟨N, λ n hn,
             hN (φ n) (le_trans hn (id_mne_extraccion hφ n))⟩))

-- 8ª demostración
example
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
begin
  intros ε hε,
  cases h ε hε with N hN,
  use N,
  intros n hn,
  apply hN,
  calc N ≤ n   : hn
     ... ≤ φ n : id_mne_extraccion hφ n,
end

-- 9ª demostración
lemma limite_subsucesion
  (h : limite u a)
  (hφ : extraccion φ)
  : limite (u ∘ φ) a :=
assume ε,
assume hε : ε > 0,
exists.elim (h ε hε)
 ( assume N,
   assume hN : ∀ n, n ≥ N → |u n - a| ≤ ε,
   have h1 : ∀n, n ≥ N → |(u ∘ φ) n - a| ≤ ε,
     { assume n,
       assume hn : n ≥ N,
       have h2 : N ≤ φ n, from
         calc N ≤ n   : hn
           ... ≤ φ n : id_mne_extraccion hφ n,
       show |(u ∘ φ) n - a| ≤ ε,
         from hN (φ n) h2,
     },
   show ∃ N, ∀n, n ≥ N → |(u ∘ φ) n - a| ≤ ε,
     from exists.intro N h1)


/-
Copyright (c) 2021 Eric Weiser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.algebra.operations
import algebra.algebra.subalgebra.basic
import ring_theory.subring.pointwise
import ring_theory.adjoin.basic

/-!
# Pointwise actions on subalgebras.

If `R'` acts on an `R`-algebra `A` (so that `R'` and `R` actions commute)
then we get an `R'` action on the collection of `R`-subalgebras.
-/

namespace subalgebra

section pointwise
variables {R : Type*} {A : Type*} [comm_semiring R] [semiring A] [algebra R A]

theorem mul_to_submodule_le (S T : subalgebra R A) :
  S.to_submodule * T.to_submodule ≤ (S ⊔ T).to_submodule :=
begin
  rw submodule.mul_le,
  intros y hy z hz,
  show y * z ∈ (S ⊔ T),
  exact mul_mem (algebra.mem_sup_left hy) (algebra.mem_sup_right hz),
end

/-- As submodules, subalgebras are idempotent. -/
@[simp] theorem mul_self  (S : subalgebra R A) : S.to_submodule * S.to_submodule = S.to_submodule :=
begin
  apply le_antisymm,
  { refine (mul_to_submodule_le _ _).trans_eq _,
    rw sup_idem },
  { intros x hx1,
    rw ← mul_one x,
    exact submodule.mul_mem_mul hx1 (show (1 : A) ∈ S, from one_mem S) }
end

/-- When `A` is commutative, `subalgebra.mul_to_submodule_le` is strict. -/
theorem mul_to_submodule {R : Type*} {A : Type*} [comm_semiring R] [comm_semiring A] [algebra R A]
  (S T : subalgebra R A) :
  S.to_submodule * T.to_submodule = (S ⊔ T).to_submodule :=
begin
  refine le_antisymm (mul_to_submodule_le _ _) _,
  rintros x (hx : x ∈ algebra.adjoin R (S ∪ T : set A)),
  refine algebra.adjoin_induction hx (λ x hx, _) (λ r, _) (λ _ _, submodule.add_mem _)
    (λ x y hx hy, _),
  { cases hx with hxS hxT,
    { rw ← mul_one x,
      exact submodule.mul_mem_mul hxS (show (1 : A) ∈ T, from one_mem T) },
    { rw ← one_mul x,
      exact submodule.mul_mem_mul (show (1 : A) ∈ S, from one_mem S) hxT } },
  { rw ← one_mul (algebra_map _ _ _),
    exact submodule.mul_mem_mul (show (1 : A) ∈ S, from one_mem S) (algebra_map_mem _ _) },
  have := submodule.mul_mem_mul hx hy,
  rwa [mul_assoc, mul_comm _ T.to_submodule, ←mul_assoc _ _ S.to_submodule, mul_self,
    mul_comm T.to_submodule, ←mul_assoc, mul_self] at this,
end

variables {R' : Type*} [semiring R'] [mul_semiring_action R' A] [smul_comm_class R' R A]

/-- The action on a subalgebra corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action R' (subalgebra R A) :=
{ smul := λ a S, S.map (mul_semiring_action.to_alg_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (alg_hom.ext $ by exact one_smul R')).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (alg_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subalgebra.pointwise_mul_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (m : R') (S : subalgebra R A) : ↑(m • S) = m • (S : set A) := rfl

@[simp] lemma pointwise_smul_to_subsemiring (m : R') (S : subalgebra R A) :
  (m • S).to_subsemiring = m • S.to_subsemiring := rfl

@[simp] lemma pointwise_smul_to_submodule (m : R') (S : subalgebra R A) :
  (m • S).to_submodule = m • S.to_submodule := rfl

@[simp] lemma pointwise_smul_to_subring {R' R A : Type*} [semiring R'] [comm_ring R] [ring A]
  [mul_semiring_action R' A] [algebra R A] [smul_comm_class R' R A] (m : R') (S : subalgebra R A) :
  (m • S).to_subring = m • S.to_subring := rfl

lemma smul_mem_pointwise_smul (m : R') (r : A) (S : subalgebra R A) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set A))

end pointwise

end subalgebra


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Floris van Doorn
-/
import analysis.calculus.iterated_deriv
import analysis.inner_product_space.euclidean_dist
import measure_theory.function.locally_integrable
import measure_theory.integral.set_integral

/-!
# Infinitely smooth bump function

In this file we construct several infinitely smooth functions with properties that an analytic
function cannot have:

* `exp_neg_inv_glue` is equal to zero for `x ≤ 0` and is strictly positive otherwise; it is given by
  `x ↦ exp (-1/x)` for `x > 0`;

* `real.smooth_transition` is equal to zero for `x ≤ 0` and is equal to one for `x ≥ 1`; it is given
  by `exp_neg_inv_glue x / (exp_neg_inv_glue x + exp_neg_inv_glue (1 - x))`;

* `f : cont_diff_bump_of_inner c`, where `c` is a point in an inner product space, is
  a bundled smooth function such that

  - `f` is equal to `1` in `metric.closed_ball c f.r`;
  - `support f = metric.ball c f.R`;
  - `0 ≤ f x ≤ 1` for all `x`.

  The structure `cont_diff_bump_of_inner` contains the data required to construct the
  function: real numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available
  through `coe_fn`.

* If `f : cont_diff_bump_of_inner c` and `μ` is a measure on the domain of `f`, then `f.normed μ`
  is a smooth bump function with integral `1` w.r.t. `μ`.

* `f : cont_diff_bump c`, where `c` is a point in a finite dimensional real vector space, is a
  bundled smooth function such that

  - `f` is equal to `1` in `euclidean.closed_ball c f.r`;
  - `support f = euclidean.ball c f.R`;
  - `0 ≤ f x ≤ 1` for all `x`.

  The structure `cont_diff_bump` contains the data required to construct the function: real
  numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available through `coe_fn`.
-/

noncomputable theory
open_locale classical topological_space

open polynomial real filter set function

/-- `exp_neg_inv_glue` is the real function given by `x ↦ exp (-1/x)` for `x > 0` and `0`
for `x ≤ 0`. It is a basic building block to construct smooth partitions of unity. Its main property
is that it vanishes for `x ≤ 0`, it is positive for `x > 0`, and the junction between the two
behaviors is flat enough to retain smoothness. The fact that this function is `C^∞` is proved in
`exp_neg_inv_glue.smooth`. -/
def exp_neg_inv_glue (x : ℝ) : ℝ := if x ≤ 0 then 0 else exp (-x⁻¹)

namespace exp_neg_inv_glue

/-- Our goal is to prove that `exp_neg_inv_glue` is `C^∞`. For this, we compute its successive
derivatives for `x > 0`. The `n`-th derivative is of the form `P_aux n (x) exp(-1/x) / x^(2 n)`,
where `P_aux n` is computed inductively. -/
noncomputable def P_aux : ℕ → polynomial ℝ
| 0 := 1
| (n+1) := X^2 * (P_aux n).derivative  + (1 - C ↑(2 * n) * X) * (P_aux n)

/-- Formula for the `n`-th derivative of `exp_neg_inv_glue`, as an auxiliary function `f_aux`. -/
def f_aux (n : ℕ) (x : ℝ) : ℝ :=
if x ≤ 0 then 0 else (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n)

/-- The `0`-th auxiliary function `f_aux 0` coincides with `exp_neg_inv_glue`, by definition. -/
lemma f_aux_zero_eq : f_aux 0 = exp_neg_inv_glue :=
begin
  ext x,
  by_cases h : x ≤ 0,
  { simp [exp_neg_inv_glue, f_aux, h] },
  { simp [h, exp_neg_inv_glue, f_aux, ne_of_gt (not_le.1 h), P_aux] }
end

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
(given in this statement in unfolded form) is the `n+1`-th auxiliary function, since
the polynomial `P_aux (n+1)` was chosen precisely to ensure this. -/
lemma f_aux_deriv (n : ℕ) (x : ℝ) (hx : x ≠ 0) :
  has_deriv_at (λx, (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n))
    ((P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n + 1))) x :=
begin
  have A : ∀ k : ℕ, 2 * (k + 1) - 1 = 2 * k + 1 := λ k, rfl,
  convert (((P_aux n).has_deriv_at x).mul
               (((has_deriv_at_exp _).comp x (has_deriv_at_inv hx).neg))).div
            (has_deriv_at_pow (2 * n) x) (pow_ne_zero _ hx) using 1,
  field_simp [hx, P_aux],
  -- `ring_exp` can't solve `p ∨ q` goal generated by `mul_eq_mul_right_iff`
  cases n; simp [nat.succ_eq_add_one, A, -mul_eq_mul_right_iff]; ring_exp
end

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
is the `n+1`-th auxiliary function. -/
lemma f_aux_deriv_pos (n : ℕ) (x : ℝ) (hx : 0 < x) :
  has_deriv_at (f_aux n) ((P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n + 1))) x :=
begin
  apply (f_aux_deriv n x (ne_of_gt hx)).congr_of_eventually_eq,
  filter_upwards [lt_mem_nhds hx] with _ hy,
  simp [f_aux, hy.not_le]
end

/-- To get differentiability at `0` of the auxiliary functions, we need to know that their limit
is `0`, to be able to apply general differentiability extension theorems. This limit is checked in
this lemma. -/
lemma f_aux_limit (n : ℕ) :
  tendsto (λx, (P_aux n).eval x * exp (-x⁻¹) / x^(2 * n)) (𝓝[>] 0) (𝓝 0) :=
begin
  have A : tendsto (λx, (P_aux n).eval x) (𝓝[>] 0) (𝓝 ((P_aux n).eval 0)) :=
  (P_aux n).continuous_within_at,
  have B : tendsto (λx, exp (-x⁻¹) / x^(2 * n)) (𝓝[>] 0) (𝓝 0),
  { convert (tendsto_pow_mul_exp_neg_at_top_nhds_0 (2 * n)).comp tendsto_inv_zero_at_top,
    ext x,
    field_simp },
  convert A.mul B;
  simp [mul_div_assoc]
end

/-- Deduce from the limiting behavior at `0` of its derivative and general differentiability
extension theorems that the auxiliary function `f_aux n` is differentiable at `0`,
with derivative `0`. -/
lemma f_aux_deriv_zero (n : ℕ) : has_deriv_at (f_aux n) 0 0 :=
begin
  -- we check separately differentiability on the left and on the right
  have A : has_deriv_within_at (f_aux n) (0 : ℝ) (Iic 0) 0,
  { apply (has_deriv_at_const (0 : ℝ) (0 : ℝ)).has_deriv_within_at.congr,
    { assume y hy,
      simp at hy,
      simp [f_aux, hy] },
    { simp [f_aux, le_refl] } },
  have B : has_deriv_within_at (f_aux n) (0 : ℝ) (Ici 0) 0,
  { have diff : differentiable_on ℝ (f_aux n) (Ioi 0) :=
      λx hx, (f_aux_deriv_pos n x hx).differentiable_at.differentiable_within_at,
    -- next line is the nontrivial bit of this proof, appealing to differentiability
    -- extension results.
    apply has_deriv_at_interval_left_endpoint_of_tendsto_deriv diff _ self_mem_nhds_within,
    { refine (f_aux_limit (n+1)).congr' _,
      apply mem_of_superset self_mem_nhds_within (λx hx, _),
      simp [(f_aux_deriv_pos n x hx).deriv] },
    { have : f_aux n 0 = 0, by simp [f_aux, le_refl],
      simp only [continuous_within_at, this],
      refine (f_aux_limit n).congr' _,
      apply mem_of_superset self_mem_nhds_within (λx hx, _),
      have : ¬(x ≤ 0), by simpa using hx,
      simp [f_aux, this] } },
  simpa using A.union B,
end

/-- At every point, the auxiliary function `f_aux n` has a derivative which is
equal to `f_aux (n+1)`. -/
lemma f_aux_has_deriv_at (n : ℕ) (x : ℝ) : has_deriv_at (f_aux n) (f_aux (n+1) x) x :=
begin
  -- check separately the result for `x < 0`, where it is trivial, for `x > 0`, where it is done
  -- in `f_aux_deriv_pos`, and for `x = 0`, done in
  -- `f_aux_deriv_zero`.
  rcases lt_trichotomy x 0 with hx|hx|hx,
  { have : f_aux (n+1) x = 0, by simp [f_aux, le_of_lt hx],
    rw this,
    apply (has_deriv_at_const x (0 : ℝ)).congr_of_eventually_eq,
    filter_upwards [gt_mem_nhds hx] with _ hy,
    simp [f_aux, hy.le] },
  { have : f_aux (n + 1) 0 = 0, by simp [f_aux, le_refl],
    rw [hx, this],
    exact f_aux_deriv_zero n },
  { have : f_aux (n+1) x = (P_aux (n+1)).eval x * exp (-x⁻¹) / x^(2 * (n+1)),
      by simp [f_aux, not_le_of_gt hx],
    rw this,
    exact f_aux_deriv_pos n x hx },
end

/-- The successive derivatives of the auxiliary function `f_aux 0` are the
functions `f_aux n`, by induction. -/
lemma f_aux_iterated_deriv (n : ℕ) : iterated_deriv n (f_aux 0) = f_aux n :=
begin
  induction n with n IH,
  { simp },
  { simp [iterated_deriv_succ, IH],
    ext x,
    exact (f_aux_has_deriv_at n x).deriv }
end

/-- The function `exp_neg_inv_glue` is smooth. -/
protected theorem cont_diff {n} : cont_diff ℝ n exp_neg_inv_glue :=
begin
  rw ← f_aux_zero_eq,
  apply cont_diff_of_differentiable_iterated_deriv (λ m hm, _),
  rw f_aux_iterated_deriv m,
  exact λ x, (f_aux_has_deriv_at m x).differentiable_at
end

/-- The function `exp_neg_inv_glue` vanishes on `(-∞, 0]`. -/
lemma zero_of_nonpos {x : ℝ} (hx : x ≤ 0) : exp_neg_inv_glue x = 0 :=
by simp [exp_neg_inv_glue, hx]

/-- The function `exp_neg_inv_glue` is positive on `(0, +∞)`. -/
lemma pos_of_pos {x : ℝ} (hx : 0 < x) : 0 < exp_neg_inv_glue x :=
by simp [exp_neg_inv_glue, not_le.2 hx, exp_pos]

/-- The function exp_neg_inv_glue` is nonnegative. -/
lemma nonneg (x : ℝ) : 0 ≤ exp_neg_inv_glue x :=
begin
  cases le_or_gt x 0,
  { exact ge_of_eq (zero_of_nonpos h) },
  { exact le_of_lt (pos_of_pos h) }
end

end exp_neg_inv_glue

/-- An infinitely smooth function `f : ℝ → ℝ` such that `f x = 0` for `x ≤ 0`,
`f x = 1` for `1 ≤ x`, and `0 < f x < 1` for `0 < x < 1`. -/
def real.smooth_transition (x : ℝ) : ℝ :=
exp_neg_inv_glue x / (exp_neg_inv_glue x + exp_neg_inv_glue (1 - x))

namespace real

namespace smooth_transition

variables {x : ℝ}

open exp_neg_inv_glue

lemma pos_denom (x) : 0 < exp_neg_inv_glue x + exp_neg_inv_glue (1 - x) :=
((@zero_lt_one ℝ _ _).lt_or_lt x).elim
  (λ hx, add_pos_of_pos_of_nonneg (pos_of_pos hx) (nonneg _))
  (λ hx, add_pos_of_nonneg_of_pos (nonneg _) (pos_of_pos $ sub_pos.2 hx))

lemma one_of_one_le (h : 1 ≤ x) : smooth_transition x = 1 :=
(div_eq_one_iff_eq $ (pos_denom x).ne').2 $ by rw [zero_of_nonpos (sub_nonpos.2 h), add_zero]

lemma zero_of_nonpos (h : x ≤ 0) : smooth_transition x = 0 :=
by rw [smooth_transition, zero_of_nonpos h, zero_div]

@[simp] protected lemma zero : smooth_transition 0 = 0 :=
zero_of_nonpos le_rfl

@[simp] protected lemma one : smooth_transition 1 = 1 :=
one_of_one_le le_rfl

lemma le_one (x : ℝ) : smooth_transition x ≤ 1 :=
(div_le_one (pos_denom x)).2 $ le_add_of_nonneg_right (nonneg _)

lemma nonneg (x : ℝ) : 0 ≤ smooth_transition x :=
div_nonneg (exp_neg_inv_glue.nonneg _) (pos_denom x).le

lemma lt_one_of_lt_one (h : x < 1) : smooth_transition x < 1 :=
(div_lt_one $ pos_denom x).2 $ lt_add_of_pos_right _ $ pos_of_pos $ sub_pos.2 h

lemma pos_of_pos (h : 0 < x) : 0 < smooth_transition x :=
div_pos (exp_neg_inv_glue.pos_of_pos h) (pos_denom x)

protected lemma cont_diff {n} : cont_diff ℝ n smooth_transition :=
exp_neg_inv_glue.cont_diff.div
  (exp_neg_inv_glue.cont_diff.add $ exp_neg_inv_glue.cont_diff.comp $
    cont_diff_const.sub cont_diff_id) $
  λ x, (pos_denom x).ne'

protected lemma cont_diff_at {x n} : cont_diff_at ℝ n smooth_transition x :=
smooth_transition.cont_diff.cont_diff_at

protected lemma continuous : continuous smooth_transition :=
(@smooth_transition.cont_diff 0).continuous

end smooth_transition

end real

variables {E X : Type*}

/-- `f : cont_diff_bump_of_inner c`, where `c` is a point in an inner product space, is a
bundled smooth function such that

- `f` is equal to `1` in `metric.closed_ball c f.r`;
- `support f = metric.ball c f.R`;
- `0 ≤ f x ≤ 1` for all `x`.

The structure `cont_diff_bump_of_inner` contains the data required to construct the function:
real numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available through
`coe_fn`. -/
structure cont_diff_bump_of_inner (c : E) :=
(r R : ℝ)
(r_pos : 0 < r)
(r_lt_R : r < R)

namespace cont_diff_bump_of_inner

lemma R_pos {c : E} (f : cont_diff_bump_of_inner c) : 0 < f.R := f.r_pos.trans f.r_lt_R

instance (c : E) : inhabited (cont_diff_bump_of_inner c) := ⟨⟨1, 2, zero_lt_one, one_lt_two⟩⟩

variables [inner_product_space ℝ E] [normed_group X] [normed_space ℝ X]
variables {c : E} (f : cont_diff_bump_of_inner c) {x : E} {n : with_top ℕ}

/-- The function defined by `f : cont_diff_bump_of_inner c`. Use automatic coercion to
function instead. -/
def to_fun (f : cont_diff_bump_of_inner c) : E → ℝ :=
λ x, real.smooth_transition ((f.R - dist x c) / (f.R - f.r))

instance : has_coe_to_fun (cont_diff_bump_of_inner c) (λ _, E → ℝ) := ⟨to_fun⟩

protected lemma «def» (x : E) : f x = real.smooth_transition ((f.R - dist x c) / (f.R - f.r)) :=
rfl

protected lemma sub (x : E) : f (c - x) = f (c + x) :=
by simp_rw [f.def, dist_self_sub_left, dist_self_add_left]

protected lemma neg (f : cont_diff_bump_of_inner (0 : E)) (x : E) : f (- x) = f x :=
by simp_rw [← zero_sub, f.sub, zero_add]

open real (smooth_transition) real.smooth_transition metric

lemma one_of_mem_closed_ball (hx : x ∈ closed_ball c f.r) :
  f x = 1 :=
one_of_one_le $ (one_le_div (sub_pos.2 f.r_lt_R)).2 $ sub_le_sub_left hx _

lemma nonneg : 0 ≤ f x := nonneg _

/-- A version of `cont_diff_bump_of_inner.nonneg` with `x` explicit -/
lemma nonneg' (x : E) : 0 ≤ f x :=
f.nonneg

lemma le_one : f x ≤ 1 := le_one _

lemma pos_of_mem_ball (hx : x ∈ ball c f.R) : 0 < f x :=
pos_of_pos $ div_pos (sub_pos.2 hx) (sub_pos.2 f.r_lt_R)

lemma lt_one_of_lt_dist (h : f.r < dist x c) : f x < 1 :=
lt_one_of_lt_one $ (div_lt_one (sub_pos.2 f.r_lt_R)).2 $ sub_lt_sub_left h _

lemma zero_of_le_dist (hx : f.R ≤ dist x c) : f x = 0 :=
zero_of_nonpos $ div_nonpos_of_nonpos_of_nonneg (sub_nonpos.2 hx) (sub_nonneg.2 f.r_lt_R.le)

lemma support_eq : support (f : E → ℝ) = metric.ball c f.R :=
begin
  ext x,
  suffices : f x ≠ 0 ↔ dist x c < f.R, by simpa [mem_support],
  cases lt_or_le (dist x c) f.R with hx hx,
  { simp [hx, (f.pos_of_mem_ball hx).ne'] },
  { simp [hx.not_lt, f.zero_of_le_dist hx] }
end

lemma tsupport_eq : tsupport f = closed_ball c f.R :=
by simp_rw [tsupport, f.support_eq, closure_ball _ f.R_pos.ne']

protected lemma has_compact_support [finite_dimensional ℝ E] : has_compact_support f :=
by simp_rw [has_compact_support, f.tsupport_eq, is_compact_closed_ball]

lemma eventually_eq_one_of_mem_ball (h : x ∈ ball c f.r) :
  f =ᶠ[𝓝 x] 1 :=
((is_open_lt (continuous_id.dist continuous_const) continuous_const).eventually_mem h).mono $
  λ z hz, f.one_of_mem_closed_ball (le_of_lt hz)

lemma eventually_eq_one : f =ᶠ[𝓝 c] 1 :=
f.eventually_eq_one_of_mem_ball (mem_ball_self f.r_pos)

/-- `cont_diff_bump` is `𝒞ⁿ` in all its arguments. -/
protected lemma _root_.cont_diff_at.cont_diff_bump {c g : X → E}
  {f : ∀ x, cont_diff_bump_of_inner (c x)} {x : X}
  (hc : cont_diff_at ℝ n c x) (hr : cont_diff_at ℝ n (λ x, (f x).r) x)
  (hR : cont_diff_at ℝ n (λ x, (f x).R) x)
  (hg : cont_diff_at ℝ n g x) : cont_diff_at ℝ n (λ x, f x (g x)) x :=
begin
  rcases eq_or_ne (g x) (c x) with hx|hx,
  { have : (λ x, f x (g x)) =ᶠ[𝓝 x] (λ x, 1),
    { have : dist (g x) (c x) < (f x).r, { simp_rw [hx, dist_self, (f x).r_pos] },
      have := continuous_at.eventually_lt (hg.continuous_at.dist hc.continuous_at) hr.continuous_at
        this,
      exact eventually_of_mem this
        (λ x hx, (f x).one_of_mem_closed_ball (mem_set_of_eq.mp hx).le) },
    exact cont_diff_at_const.congr_of_eventually_eq this },
  { refine real.smooth_transition.cont_diff_at.comp x _,
    refine ((hR.sub $ hg.dist hc hx).div (hR.sub hr) (sub_pos.mpr (f x).r_lt_R).ne') }
end

lemma _root_.cont_diff.cont_diff_bump {c g : X → E} {f : ∀ x, cont_diff_bump_of_inner (c x)}
  (hc : cont_diff ℝ n c) (hr : cont_diff ℝ n (λ x, (f x).r)) (hR : cont_diff ℝ n (λ x, (f x).R))
  (hg : cont_diff ℝ n g) : cont_diff ℝ n (λ x, f x (g x)) :=
by { rw [cont_diff_iff_cont_diff_at] at *, exact λ x, (hc x).cont_diff_bump (hr x) (hR x) (hg x) }

protected lemma cont_diff : cont_diff ℝ n f :=
cont_diff_const.cont_diff_bump cont_diff_const cont_diff_const cont_diff_id

protected lemma cont_diff_at : cont_diff_at ℝ n f x :=
f.cont_diff.cont_diff_at

protected lemma cont_diff_within_at {s : set E} : cont_diff_within_at ℝ n f s x :=
f.cont_diff_at.cont_diff_within_at

protected lemma continuous : continuous f :=
cont_diff_zero.mp f.cont_diff

open measure_theory
variables [measurable_space E] {μ : measure E}

/-- A bump function normed so that `∫ x, f.normed μ x ∂μ = 1`. -/
protected def normed (μ : measure E) : E → ℝ :=
λ x, f x / ∫ x, f x ∂μ

lemma normed_def {μ : measure E} (x : E) : f.normed μ x = f x / ∫ x, f x ∂μ :=
rfl

lemma nonneg_normed (x : E) : 0 ≤ f.normed μ x :=
div_nonneg f.nonneg $ integral_nonneg f.nonneg'

lemma cont_diff_normed {n : with_top ℕ} : cont_diff ℝ n (f.normed μ) :=
f.cont_diff.div_const

lemma continuous_normed : continuous (f.normed μ) :=
f.continuous.div_const

lemma normed_sub (x : E) : f.normed μ (c - x) = f.normed μ (c + x) :=
by simp_rw [f.normed_def, f.sub]

lemma normed_neg (f : cont_diff_bump_of_inner (0 : E)) (x : E) : f.normed μ (- x) = f.normed μ x :=
by simp_rw [f.normed_def, f.neg]

variables [borel_space E] [finite_dimensional ℝ E] [is_locally_finite_measure μ]

protected lemma integrable : integrable f μ :=
f.continuous.integrable_of_has_compact_support f.has_compact_support

protected lemma integrable_normed : integrable (f.normed μ) μ :=
f.integrable.div_const _

variables [μ .is_open_pos_measure]

lemma integral_pos : 0 < ∫ x, f x ∂μ :=
begin
  refine (integral_pos_iff_support_of_nonneg f.nonneg' f.integrable).mpr _,
  rw [f.support_eq],
  refine is_open_ball.measure_pos _ (nonempty_ball.mpr f.R_pos)
end

lemma integral_normed : ∫ x, f.normed μ x ∂μ = 1 :=
begin
  simp_rw [cont_diff_bump_of_inner.normed, div_eq_mul_inv, mul_comm (f _), ← smul_eq_mul,
    integral_smul],
  exact inv_mul_cancel (f.integral_pos.ne')
end

lemma support_normed_eq : support (f.normed μ) = metric.ball c f.R :=
by simp_rw [cont_diff_bump_of_inner.normed, support_div, f.support_eq,
  support_const f.integral_pos.ne', inter_univ]

lemma tsupport_normed_eq : tsupport (f.normed μ) = metric.closed_ball c f.R :=
by simp_rw [tsupport, f.support_normed_eq, closure_ball _ f.R_pos.ne']

lemma has_compact_support_normed : has_compact_support (f.normed μ) :=
by simp_rw [has_compact_support, f.tsupport_normed_eq, is_compact_closed_ball]

variable (μ)
lemma integral_normed_smul (z : X) [complete_space X] : ∫ x, f.normed μ x • z ∂μ = z :=
by simp_rw [integral_smul_const, f.integral_normed, one_smul]

end cont_diff_bump_of_inner

/-- `f : cont_diff_bump c`, where `c` is a point in a finite dimensional real vector space, is
a bundled smooth function such that

  - `f` is equal to `1` in `euclidean.closed_ball c f.r`;
  - `support f = euclidean.ball c f.R`;
  - `0 ≤ f x ≤ 1` for all `x`.

The structure `cont_diff_bump` contains the data required to construct the function: real
numbers `r`, `R`, and proofs of `0 < r < R`. The function itself is available through `coe_fn`.-/
structure cont_diff_bump [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E] (c : E)
  extends cont_diff_bump_of_inner (to_euclidean c)

namespace cont_diff_bump

variables [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E] {c x : E}
  (f : cont_diff_bump c)

/-- The function defined by `f : cont_diff_bump c`. Use automatic coercion to function
instead. -/
def to_fun (f : cont_diff_bump c) : E → ℝ := f.to_cont_diff_bump_of_inner ∘ to_euclidean

instance : has_coe_to_fun (cont_diff_bump c) (λ _, E → ℝ) := ⟨to_fun⟩

instance (c : E) : inhabited (cont_diff_bump c) := ⟨⟨default⟩⟩

lemma R_pos : 0 < f.R := f.to_cont_diff_bump_of_inner.R_pos

lemma coe_eq_comp : ⇑f = f.to_cont_diff_bump_of_inner ∘ to_euclidean := rfl

lemma one_of_mem_closed_ball (hx : x ∈ euclidean.closed_ball c f.r) :
  f x = 1 :=
f.to_cont_diff_bump_of_inner.one_of_mem_closed_ball hx

lemma nonneg : 0 ≤ f x := f.to_cont_diff_bump_of_inner.nonneg

lemma le_one : f x ≤ 1 := f.to_cont_diff_bump_of_inner.le_one

lemma pos_of_mem_ball (hx : x ∈ euclidean.ball c f.R) : 0 < f x :=
f.to_cont_diff_bump_of_inner.pos_of_mem_ball hx

lemma lt_one_of_lt_dist (h : f.r < euclidean.dist x c) : f x < 1 :=
f.to_cont_diff_bump_of_inner.lt_one_of_lt_dist h

lemma zero_of_le_dist (hx : f.R ≤ euclidean.dist x c) : f x = 0 :=
f.to_cont_diff_bump_of_inner.zero_of_le_dist hx

lemma support_eq : support (f : E → ℝ) = euclidean.ball c f.R :=
by rw [euclidean.ball_eq_preimage, ← f.to_cont_diff_bump_of_inner.support_eq,
  ← support_comp_eq_preimage, coe_eq_comp]

lemma tsupport_eq : tsupport f = euclidean.closed_ball c f.R :=
by rw [tsupport, f.support_eq, euclidean.closure_ball _ f.R_pos.ne']

protected lemma has_compact_support : has_compact_support f :=
by simp_rw [has_compact_support, f.tsupport_eq, euclidean.is_compact_closed_ball]

lemma eventually_eq_one_of_mem_ball (h : x ∈ euclidean.ball c f.r) :
  f =ᶠ[𝓝 x] 1 :=
to_euclidean.continuous_at (f.to_cont_diff_bump_of_inner.eventually_eq_one_of_mem_ball h)

lemma eventually_eq_one : f =ᶠ[𝓝 c] 1 :=
f.eventually_eq_one_of_mem_ball $ euclidean.mem_ball_self f.r_pos

protected lemma cont_diff {n} :
  cont_diff ℝ n f :=
f.to_cont_diff_bump_of_inner.cont_diff.comp (to_euclidean : E ≃L[ℝ] _).cont_diff

protected lemma cont_diff_at {n} :
  cont_diff_at ℝ n f x :=
f.cont_diff.cont_diff_at

protected lemma cont_diff_within_at {s n} :
  cont_diff_within_at ℝ n f s x :=
f.cont_diff_at.cont_diff_within_at

lemma exists_tsupport_subset {s : set E} (hs : s ∈ 𝓝 c) :
  ∃ f : cont_diff_bump c, tsupport f ⊆ s :=
let ⟨R, h0, hR⟩ := euclidean.nhds_basis_closed_ball.mem_iff.1 hs
in ⟨⟨⟨R / 2, R, half_pos h0, half_lt_self h0⟩⟩, by rwa tsupport_eq⟩

lemma exists_closure_subset {R : ℝ} (hR : 0 < R)
  {s : set E} (hs : is_closed s) (hsR : s ⊆ euclidean.ball c R) :
  ∃ f : cont_diff_bump c, f.R = R ∧ s ⊆ euclidean.ball c f.r :=
begin
  rcases euclidean.exists_pos_lt_subset_ball hR hs hsR with ⟨r, hr, hsr⟩,
  exact ⟨⟨⟨r, R, hr.1, hr.2⟩⟩, rfl, hsr⟩
end

end cont_diff_bump

open finite_dimensional metric

/-- If `E` is a finite dimensional normed space over `ℝ`, then for any point `x : E` and its
neighborhood `s` there exists an infinitely smooth function with the following properties:

* `f y = 1` in a neighborhood of `x`;
* `f y = 0` outside of `s`;
*  moreover, `tsupport f ⊆ s` and `f` has compact support;
* `f y ∈ [0, 1]` for all `y`.

This lemma is a simple wrapper around lemmas about bundled smooth bump functions, see
`cont_diff_bump`. -/
lemma exists_cont_diff_bump_function_of_mem_nhds [normed_group E] [normed_space ℝ E]
  [finite_dimensional ℝ E] {x : E} {s : set E} (hs : s ∈ 𝓝 x) :
  ∃ f : E → ℝ, f =ᶠ[𝓝 x] 1 ∧ (∀ y, f y ∈ Icc (0 : ℝ) 1) ∧ cont_diff ℝ ⊤ f ∧
    has_compact_support f ∧ tsupport f ⊆ s :=
let ⟨f, hf⟩ := cont_diff_bump.exists_tsupport_subset hs in
⟨f, f.eventually_eq_one, λ y, ⟨f.nonneg, f.le_one⟩, f.cont_diff,
  f.has_compact_support, hf⟩


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/
import data.list.prod_sigma
import tactic.omega.clause
import tactic.omega.nat.form

/-!
# DNF transformation
-/

namespace omega
namespace nat

open_locale omega.nat

@[simp] def dnf_core : preform → list clause
| (p ∨* q) := (dnf_core p) ++ (dnf_core q)
| (p ∧* q) :=
  (list.product (dnf_core p) (dnf_core q)).map
  (λ pq, clause.append pq.fst pq.snd)
| (t =* s) :=
  [([term.sub (canonize s) (canonize t)],[])]
| (t ≤* s) := [([],[term.sub (canonize s) (canonize t)])]
| (¬* _)   := []

lemma exists_clause_holds_core {v : nat → nat} :
  ∀ {p : preform}, p.neg_free → p.sub_free → p.holds v →
  ∃ c ∈ (dnf_core p), clause.holds (λ x, ↑(v x)) c :=
begin
  preform.induce `[intros h1 h0 h2],
  { apply list.exists_mem_cons_of,
    constructor, rw list.forall_mem_singleton,
    cases h0 with ht hs,
    simp only [val_canonize ht, val_canonize hs,
      term.val_sub, preform.holds, sub_eq_add_neg] at *,
    rw [h2, add_neg_self], apply list.forall_mem_nil },
  { apply list.exists_mem_cons_of,
    constructor,
    apply list.forall_mem_nil,
    rw list.forall_mem_singleton,
    simp only [val_canonize (h0.left), val_canonize (h0.right),
      term.val_sub, preform.holds, sub_eq_add_neg] at *,
    rw [←sub_eq_add_neg, le_sub, sub_zero, int.coe_nat_le],
    assumption },
  { cases h1 },
  { cases h2 with h2 h2;
    [ {cases (ihp h1.left h0.left h2) with c h3},
      {cases (ihq h1.right h0.right h2) with c h3}];
    cases h3 with h3 h4;
    refine ⟨c, list.mem_append.elim_right _, h4⟩;
    [left,right]; assumption },
  { rcases (ihp h1.left h0.left h2.left) with ⟨cp, hp1, hp2⟩,
    rcases (ihq h1.right h0.right h2.right) with ⟨cq, hq1, hq2⟩,
    refine ⟨clause.append cp cq, ⟨_, clause.holds_append hp2 hq2⟩⟩,
    simp only [dnf_core, list.mem_map],
    refine ⟨(cp,cq),⟨_,rfl⟩⟩,
    rw list.mem_product,
    constructor; assumption }
end

def term.vars_core (is : list int) : list bool :=
is.map (λ i, if i = 0 then ff else tt)

/-- Return a list of bools that encodes which variables have nonzero coefficients -/
def term.vars (t : term) : list bool :=
term.vars_core t.snd

def bools.or : list bool → list bool → list bool
| []        bs2       := bs2
| bs1       []        := bs1
| (b1::bs1) (b2::bs2) := (b1 || b2)::(bools.or bs1 bs2)

/-- Return a list of bools that encodes which variables have nonzero coefficients in any one of the
input terms. -/
def terms.vars : list term → list bool
| []      := []
| (t::ts) := bools.or (term.vars t) (terms.vars ts)

open_locale list.func -- get notation for list.func.set

def nonneg_consts_core : nat → list bool → list term
| _ [] := []
| k (ff::bs) := nonneg_consts_core (k+1) bs
| k (tt::bs) := ⟨0, [] {k ↦ 1}⟩::nonneg_consts_core (k+1) bs

def nonneg_consts (bs : list bool) : list term :=
nonneg_consts_core 0 bs

def nonnegate : clause → clause | (eqs,les) :=
let xs := terms.vars eqs in
let ys := terms.vars les in
let bs := bools.or xs ys in
(eqs, nonneg_consts bs ++ les)

/-- DNF transformation -/
def dnf (p : preform) : list clause :=
(dnf_core p).map nonnegate

lemma holds_nonneg_consts_core {v : nat → int} (h1 : ∀ x, 0 ≤ v x) :
  ∀ m bs, (∀ t ∈ (nonneg_consts_core m bs), 0 ≤ term.val v t)
| _ []       := λ _ h2, by cases h2
| k (ff::bs) := holds_nonneg_consts_core (k+1) bs
| k (tt::bs) :=
  begin
    simp only [nonneg_consts_core],
    rw list.forall_mem_cons,
    constructor,
    { simp only [term.val, one_mul, zero_add, coeffs.val_set],
      apply h1 },
    { apply holds_nonneg_consts_core (k+1) bs }
  end

lemma holds_nonneg_consts {v : nat → int} {bs : list bool} :
  (∀ x, 0 ≤ v x) → (∀ t ∈ (nonneg_consts bs), 0 ≤ term.val v t)
| h1 :=
by apply holds_nonneg_consts_core h1

lemma exists_clause_holds {v : nat → nat} {p : preform} :
  p.neg_free → p.sub_free → p.holds v →
  ∃ c ∈ (dnf p), clause.holds (λ x, ↑(v x)) c :=
begin
  intros h1 h2 h3,
  rcases (exists_clause_holds_core h1 h2 h3) with ⟨c,h4,h5⟩,
  existsi (nonnegate c),
  have h6 : nonnegate c ∈ dnf p,
  { simp only [dnf], rw list.mem_map,
    refine ⟨c,h4,rfl⟩ },
  refine ⟨h6,_⟩, cases c with eqs les,
  simp only [nonnegate, clause.holds],
  constructor, apply h5.left,
  rw list.forall_mem_append,
  apply and.intro (holds_nonneg_consts _) h5.right,
  assume x,
  apply int.coe_nat_nonneg
end

lemma exists_clause_sat {p : preform} :
  p.neg_free → p.sub_free →
  p.sat → ∃ c ∈ (dnf p), clause.sat c :=
begin
  intros h1 h2 h3, cases h3 with v h3,
  rcases (exists_clause_holds h1 h2 h3) with ⟨c,h4,h5⟩,
  refine ⟨c,h4,_,h5⟩
end

lemma unsat_of_unsat_dnf (p : preform) :
  p.neg_free → p.sub_free → clauses.unsat (dnf p) → p.unsat :=
begin
  intros hnf hsf h1 h2, apply h1,
  apply exists_clause_sat hnf hsf h2
end

end nat

end omega


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import algebra.covariant_and_contravariant
import algebra.group.basic
import algebra.order.monoid.lemmas
import order.lattice

/-!
# Ordered Subtraction

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

This file proves lemmas relating (truncated) subtraction with an order. We provide a class
`has_ordered_sub` stating that `a - b ≤ c ↔ a ≤ c + b`.

The subtraction discussed here could both be normal subtraction in an additive group or truncated
subtraction on a canonically ordered monoid (`ℕ`, `multiset`, `part_enat`, `ennreal`, ...)

## Implementation details

`has_ordered_sub` is a mixin type-class, so that we can use the results in this file even in cases
where we don't have a `canonically_ordered_add_monoid` instance
(even though that is our main focus). Conversely, this means we can use
`canonically_ordered_add_monoid` without necessarily having to define a subtraction.

The results in this file are ordered by the type-class assumption needed to prove it.
This means that similar results might not be close to each other. Furthermore, we don't prove
implications if a bi-implication can be proven under the same assumptions.

Lemmas using this class are named using `tsub` instead of `sub` (short for "truncated subtraction").
This is to avoid naming conflicts with similar lemmas about ordered groups.

We provide a second version of most results that require `[contravariant_class α α (+) (≤)]`. In the
second version we replace this type-class assumption by explicit `add_le_cancellable` assumptions.

TODO: maybe we should make a multiplicative version of this, so that we can replace some identical
lemmas about subtraction/division in `ordered_[add_]comm_group` with these.

TODO: generalize `nat.le_of_le_of_sub_le_sub_right`, `nat.sub_le_sub_right_iff`,
  `nat.mul_self_sub_mul_self_eq`
-/

variables {α β : Type*}

/-- `has_ordered_sub α` means that `α` has a subtraction characterized by `a - b ≤ c ↔ a ≤ c + b`.
In other words, `a - b` is the least `c` such that `a ≤ b + c`.

This is satisfied both by the subtraction in additive ordered groups and by truncated subtraction
in canonically ordered monoids on many specific types.
-/
class has_ordered_sub (α : Type*) [has_le α] [has_add α] [has_sub α] :=
(tsub_le_iff_right : ∀ a b c : α, a - b ≤ c ↔ a ≤ c + b)

section has_add

variables [preorder α] [has_add α] [has_sub α] [has_ordered_sub α] {a b c d : α}

@[simp] lemma tsub_le_iff_right : a - b ≤ c ↔ a ≤ c + b :=
has_ordered_sub.tsub_le_iff_right a b c

/-- See `add_tsub_cancel_right` for the equality if `contravariant_class α α (+) (≤)`. -/
lemma add_tsub_le_right : a + b - b ≤ a :=
tsub_le_iff_right.mpr le_rfl

lemma le_tsub_add : b ≤ (b - a) + a :=
tsub_le_iff_right.mp le_rfl

end has_add

/-! ### Preorder -/

section ordered_add_comm_semigroup

section preorder
variables [preorder α]

section add_comm_semigroup
variables [add_comm_semigroup α] [has_sub α] [has_ordered_sub α] {a b c d : α}

lemma tsub_le_iff_left : a - b ≤ c ↔ a ≤ b + c :=
by rw [tsub_le_iff_right, add_comm]

lemma le_add_tsub : a ≤ b + (a - b) :=
tsub_le_iff_left.mp le_rfl

/-- See `add_tsub_cancel_left` for the equality if `contravariant_class α α (+) (≤)`. -/
lemma add_tsub_le_left : a + b - a ≤ b :=
tsub_le_iff_left.mpr le_rfl

lemma tsub_le_tsub_right (h : a ≤ b) (c : α) : a - c ≤ b - c :=
tsub_le_iff_left.mpr $ h.trans le_add_tsub

lemma tsub_le_iff_tsub_le : a - b ≤ c ↔ a - c ≤ b :=
by rw [tsub_le_iff_left, tsub_le_iff_right]

/-- See `tsub_tsub_cancel_of_le` for the equality. -/
lemma tsub_tsub_le : b - (b - a) ≤ a :=
tsub_le_iff_right.mpr le_add_tsub

section cov
variable [covariant_class α α (+) (≤)]

lemma tsub_le_tsub_left (h : a ≤ b) (c : α) : c - b ≤ c - a :=
tsub_le_iff_left.mpr $ le_add_tsub.trans $ add_le_add_right h _

lemma tsub_le_tsub (hab : a ≤ b) (hcd : c ≤ d) : a - d ≤ b - c :=
(tsub_le_tsub_right hab _).trans $ tsub_le_tsub_left hcd _

lemma antitone_const_tsub : antitone (λ x, c - x) :=
λ x y hxy, tsub_le_tsub rfl.le hxy

/-- See `add_tsub_assoc_of_le` for the equality. -/
lemma add_tsub_le_assoc : a + b - c ≤ a + (b - c) :=
by { rw [tsub_le_iff_left, add_left_comm], exact add_le_add_left le_add_tsub a }

/-- See `tsub_add_eq_add_tsub` for the equality. -/
lemma add_tsub_le_tsub_add : a + b - c ≤ a - c + b :=
by { rw [add_comm, add_comm _ b], exact add_tsub_le_assoc }

lemma add_le_add_add_tsub : a + b ≤ (a + c) + (b - c) :=
by { rw [add_assoc], exact add_le_add_left le_add_tsub a }

lemma le_tsub_add_add : a + b ≤ (a - c) + (b + c) :=
by { rw [add_comm a, add_comm (a - c)], exact add_le_add_add_tsub }

lemma tsub_le_tsub_add_tsub : a - c ≤ (a - b) + (b - c) :=
begin
  rw [tsub_le_iff_left, ← add_assoc, add_right_comm],
  exact le_add_tsub.trans (add_le_add_right le_add_tsub _),
end

lemma tsub_tsub_tsub_le_tsub : (c - a) - (c - b) ≤ b - a :=
begin
  rw [tsub_le_iff_left, tsub_le_iff_left, add_left_comm],
  exact le_tsub_add.trans (add_le_add_left le_add_tsub _),
end

lemma tsub_tsub_le_tsub_add {a b c : α} : a - (b - c) ≤ a - b + c :=
tsub_le_iff_right.2 $ calc
    a ≤ a - b + b : le_tsub_add
  ... ≤ a - b + (c + (b - c)) : add_le_add_left le_add_tsub _
  ... = a - b + c + (b - c) : (add_assoc _ _ _).symm

/-- See `tsub_add_tsub_comm` for the equality. -/
lemma add_tsub_add_le_tsub_add_tsub : a + b - (c + d) ≤ a - c + (b - d) :=
begin
  rw [add_comm c, tsub_le_iff_left, add_assoc, ←tsub_le_iff_left, ←tsub_le_iff_left],
  refine (tsub_le_tsub_right add_tsub_le_assoc c).trans _,
  rw [add_comm a, add_comm (a - c)],
  exact add_tsub_le_assoc,
end

/-- See `add_tsub_add_eq_tsub_left` for the equality. -/
lemma add_tsub_add_le_tsub_left : a + b - (a + c) ≤ b - c :=
by { rw [tsub_le_iff_left, add_assoc], exact add_le_add_left le_add_tsub _ }

/-- See `add_tsub_add_eq_tsub_right` for the equality. -/
lemma add_tsub_add_le_tsub_right : a + c - (b + c) ≤ a - b :=
by { rw [tsub_le_iff_left, add_right_comm], exact add_le_add_right le_add_tsub c }

end cov

/-! #### Lemmas that assume that an element is `add_le_cancellable` -/

namespace add_le_cancellable

protected lemma le_add_tsub_swap (hb : add_le_cancellable b) : a ≤ b + a - b := hb le_add_tsub

protected lemma le_add_tsub (hb : add_le_cancellable b) : a ≤ a + b - b :=
by { rw add_comm, exact hb.le_add_tsub_swap }

protected lemma le_tsub_of_add_le_left (ha : add_le_cancellable a) (h : a + b ≤ c) : b ≤ c - a :=
ha $ h.trans le_add_tsub

protected lemma le_tsub_of_add_le_right (hb : add_le_cancellable b) (h : a + b ≤ c) : a ≤ c - b :=
hb.le_tsub_of_add_le_left $ by rwa add_comm

end add_le_cancellable

/-! ### Lemmas where addition is order-reflecting -/

section contra
variable [contravariant_class α α (+) (≤)]

lemma le_add_tsub_swap : a ≤ b + a - b := contravariant.add_le_cancellable.le_add_tsub_swap

lemma le_add_tsub' : a ≤ a + b - b := contravariant.add_le_cancellable.le_add_tsub

lemma le_tsub_of_add_le_left (h : a + b ≤ c) : b ≤ c - a :=
contravariant.add_le_cancellable.le_tsub_of_add_le_left h

lemma le_tsub_of_add_le_right (h : a + b ≤ c) : a ≤ c - b :=
contravariant.add_le_cancellable.le_tsub_of_add_le_right h

end contra

end add_comm_semigroup

variables [add_comm_monoid α] [has_sub α] [has_ordered_sub α] {a b c d : α}

lemma tsub_nonpos : a - b ≤ 0 ↔ a ≤ b := by rw [tsub_le_iff_left, add_zero]

alias tsub_nonpos ↔ _ tsub_nonpos_of_le

end preorder

/-! ### Partial order -/

variables [partial_order α] [add_comm_semigroup α] [has_sub α] [has_ordered_sub α] {a b c d : α}

lemma tsub_tsub (b a c : α) : b - a - c = b - (a + c) :=
begin
  apply le_antisymm,
  { rw [tsub_le_iff_left, tsub_le_iff_left, ← add_assoc, ← tsub_le_iff_left] },
  { rw [tsub_le_iff_left, add_assoc, ← tsub_le_iff_left, ← tsub_le_iff_left] }
end

lemma tsub_add_eq_tsub_tsub (a b c : α) : a - (b + c) = a - b - c := (tsub_tsub _ _ _).symm

lemma tsub_add_eq_tsub_tsub_swap (a b c : α) : a - (b + c) = a - c - b :=
by { rw [add_comm], apply tsub_add_eq_tsub_tsub }

lemma tsub_right_comm : a - b - c = a - c - b :=
by simp_rw [← tsub_add_eq_tsub_tsub, add_comm]

/-! ### Lemmas that assume that an element is `add_le_cancellable`. -/

namespace add_le_cancellable

protected lemma tsub_eq_of_eq_add (hb : add_le_cancellable b) (h : a = c + b) : a - b = c :=
le_antisymm (tsub_le_iff_right.mpr h.le) $
  by { rw h, exact hb.le_add_tsub }

protected lemma eq_tsub_of_add_eq (hc : add_le_cancellable c) (h : a + c = b) : a = b - c :=
(hc.tsub_eq_of_eq_add h.symm).symm

protected theorem tsub_eq_of_eq_add_rev (hb : add_le_cancellable b) (h : a = b + c) : a - b = c :=
hb.tsub_eq_of_eq_add $ by rw [add_comm, h]

@[simp]
protected lemma add_tsub_cancel_right (hb : add_le_cancellable b) : a + b - b = a :=
hb.tsub_eq_of_eq_add $ by rw [add_comm]

@[simp]
protected lemma add_tsub_cancel_left (ha : add_le_cancellable a) : a + b - a = b :=
ha.tsub_eq_of_eq_add $ add_comm a b

protected lemma lt_add_of_tsub_lt_left (hb : add_le_cancellable b) (h : a - b < c) : a < b + c :=
begin
  rw [lt_iff_le_and_ne, ← tsub_le_iff_left],
  refine ⟨h.le, _⟩,
  rintro rfl,
  simpa [hb] using h,
end

protected lemma lt_add_of_tsub_lt_right (hc : add_le_cancellable c) (h : a - c < b) : a < b + c :=
begin
  rw [lt_iff_le_and_ne, ← tsub_le_iff_right],
  refine ⟨h.le, _⟩,
  rintro rfl,
  simpa [hc] using h,
end

protected lemma lt_tsub_of_add_lt_right (hc : add_le_cancellable c) (h : a + c < b) : a < b - c :=
(hc.le_tsub_of_add_le_right h.le).lt_of_ne $ by { rintro rfl, exact h.not_le le_tsub_add }

protected lemma lt_tsub_of_add_lt_left (ha : add_le_cancellable a) (h : a + c < b) : c < b - a :=
ha.lt_tsub_of_add_lt_right $ by rwa add_comm

end add_le_cancellable

/-! #### Lemmas where addition is order-reflecting. -/

section contra
variable [contravariant_class α α (+) (≤)]

lemma tsub_eq_of_eq_add (h : a = c + b) : a - b = c :=
contravariant.add_le_cancellable.tsub_eq_of_eq_add h

lemma eq_tsub_of_add_eq (h : a + c = b) : a = b - c :=
contravariant.add_le_cancellable.eq_tsub_of_add_eq h

lemma tsub_eq_of_eq_add_rev (h : a = b + c) : a - b = c :=
contravariant.add_le_cancellable.tsub_eq_of_eq_add_rev h

@[simp]
lemma add_tsub_cancel_right (a b : α) : a + b - b = a :=
contravariant.add_le_cancellable.add_tsub_cancel_right

@[simp]
lemma add_tsub_cancel_left (a b : α) : a + b - a = b :=
contravariant.add_le_cancellable.add_tsub_cancel_left

lemma lt_add_of_tsub_lt_left (h : a - b < c) : a < b + c :=
contravariant.add_le_cancellable.lt_add_of_tsub_lt_left h

lemma lt_add_of_tsub_lt_right (h : a - c < b) : a < b + c :=
contravariant.add_le_cancellable.lt_add_of_tsub_lt_right h

/-- This lemma (and some of its corollaries) also holds for `ennreal`, but this proof doesn't work
for it. Maybe we should add this lemma as field to `has_ordered_sub`? -/
lemma lt_tsub_of_add_lt_left : a + c < b → c < b - a :=
contravariant.add_le_cancellable.lt_tsub_of_add_lt_left

lemma lt_tsub_of_add_lt_right : a + c < b → a < b - c :=
contravariant.add_le_cancellable.lt_tsub_of_add_lt_right

end contra

section both
variables [covariant_class α α (+) (≤)] [contravariant_class α α (+) (≤)]

lemma add_tsub_add_eq_tsub_right (a c b : α) : (a + c) - (b + c) = a - b :=
begin
  refine add_tsub_add_le_tsub_right.antisymm (tsub_le_iff_right.2 $ le_of_add_le_add_right _), swap,
  rw add_assoc,
  exact le_tsub_add,
end

lemma add_tsub_add_eq_tsub_left (a b c : α) : (a + b) - (a + c) = b - c :=
by rw [add_comm a b, add_comm a c, add_tsub_add_eq_tsub_right]

end both

end ordered_add_comm_semigroup

/-! ### Lemmas in a linearly ordered monoid. -/
section linear_order
variables {a b c d : α} [linear_order α] [add_comm_semigroup α] [has_sub α] [has_ordered_sub α]

/-- See `lt_of_tsub_lt_tsub_right_of_le` for a weaker statement in a partial order. -/
lemma lt_of_tsub_lt_tsub_right (h : a - c < b - c) : a < b :=
lt_imp_lt_of_le_imp_le (λ h, tsub_le_tsub_right h c) h

/-- See `lt_tsub_iff_right_of_le` for a weaker statement in a partial order. -/
lemma lt_tsub_iff_right : a < b - c ↔ a + c < b :=
lt_iff_lt_of_le_iff_le tsub_le_iff_right

/-- See `lt_tsub_iff_left_of_le` for a weaker statement in a partial order. -/
lemma lt_tsub_iff_left : a < b - c ↔ c + a < b :=
lt_iff_lt_of_le_iff_le tsub_le_iff_left

lemma lt_tsub_comm : a < b - c ↔ c < b - a :=
lt_tsub_iff_left.trans lt_tsub_iff_right.symm

section cov
variable [covariant_class α α (+) (≤)]

/-- See `lt_of_tsub_lt_tsub_left_of_le` for a weaker statement in a partial order. -/
lemma lt_of_tsub_lt_tsub_left (h : a - b < a - c) : c < b :=
lt_imp_lt_of_le_imp_le (λ h, tsub_le_tsub_left h a) h

end cov

end linear_order

section ordered_add_comm_monoid
variables [partial_order α] [add_comm_monoid α] [has_sub α] [has_ordered_sub α]

@[simp] lemma tsub_zero (a : α) : a - 0 = a :=
add_le_cancellable.tsub_eq_of_eq_add add_le_cancellable_zero (add_zero _).symm

end ordered_add_comm_monoid