import analysis.asymptotics.asymptotics
import linear_algebra.dual
import measure_theory.integral.periodic
import analysis.calculus.parametric_integral

import to_mathlib.topology.periodic
import to_mathlib.measure_theory.borel_space

import loops.basic
import local.dual_pair

/-! # Theillière's corrugation operation

This files introduces the fundamental calculus tool of convex integration. The version of convex
integration that we formalize is Theillière's corrugation-based convex integration.
It improves a map `f : E → F` by adding to it some corrugation map
`λ x, (1/N) • ∫ t in 0..(N*π x), (γ x t - (γ x).average)` where `γ` is a family of loops in
`F` parametrized by `E` and `N` is some (very large) real number.

Under the assumption that `∀ x, (γ x).average = D f x p.v` for some dual pair `p`, this improved
map will have a derivative which is almost a value of `γ x` in direction `p.v` and almost the
derivative of `f` in direction `ker p.π`. More precisely, its derivative will be almost
`p.update (D f x) (γ x (N*p.π x))`. In addition the improved map will be very close to `f`
in C⁰ topology. All those "almost" and "very close" refer to the asymptotic behavior when `N`
is very large.

The main definition is `corrugation`. The main results are:
* `fderiv_corrugated_map` computing the difference between `D (f + corrugation p.π N γ) x` and
    `p.update (D f x) (γ x (N*p.π x)) + corrugation.remainder p.π N γ x`
* `remainder_c0_small_on` saying this difference is very small
* `corrugation.c0_small_on` saying that corrugations are C⁰-small

-/

noncomputable theory

open set function finite_dimensional asymptotics filter topological_space int measure_theory
     continuous_linear_map
open_locale topology unit_interval

variables
  {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  {F : Type*} [normed_add_comm_group F] [normed_space ℝ F] [finite_dimensional ℝ F]
  {G : Type*} [normed_add_comm_group G] [normed_space ℝ G]
  {H : Type*} [normed_add_comm_group H] [normed_space ℝ H] [finite_dimensional ℝ H]
  {π : E →L[ℝ] ℝ} (N : ℝ) (γ : E → loop F)

open_locale borelize

/-- Theillière's corrugations. -/
def corrugation (π : E →L[ℝ] ℝ) (N : ℝ) (γ : E → loop F) : E → F :=
λ x, (1/N) • ∫ t in 0..(N*π x), (γ x t - (γ x).average)

local notation `𝒯` := corrugation π

/-- The integral appearing in corrugations is periodic. -/
lemma per_corrugation (γ : loop F) (hγ : ∀ s t, interval_integrable γ volume s t) :
  one_periodic (λ s, ∫ t in 0..s, γ t - γ.average) :=
begin
  have int_avg : ∀ s t,  interval_integrable (λ u : ℝ, γ.average) volume s t,
    from λ s t, interval_integrable_const,
  intros s,
  have int₁ : interval_integrable (λ t, γ t - γ.average) volume 0 s,
    from (hγ _ _).sub (int_avg _ _),
  have int₂ : interval_integrable (λ t, γ t - γ.average) volume s (s + 1),
    from (hγ _ _).sub (int_avg _ _),
  have int₃ : interval_integrable γ volume s (s + 1), from hγ _ _,
  have int₄ : interval_integrable (λ t, γ.average) volume s (s + 1), from int_avg _ _,
  dsimp only,
  /- Rmk: Lean doesn't want to rewrite using `interval_integral.integral_sub` without being
    given the integrability assumptions :-( -/
  rw [← interval_integral.integral_add_adjacent_intervals int₁ int₂,
      interval_integral.integral_sub int₃ int₄, γ.periodic.interval_integral_add_eq s 0,
      zero_add, loop.average],
  simp only [add_zero, add_tsub_cancel_left, interval_integral.integral_const, one_smul, sub_self]
end

@[simp] lemma corrugation_const {x : E} (h : (γ x).is_const) : 𝒯 N γ x = 0 :=
begin
  unfold corrugation,
  rw loop.is_const_iff_const_avg at h,
  rw h,
  simp only [add_zero, interval_integral.integral_const, loop.const_apply, loop.average_const, smul_zero, sub_self]
end

variables (γ π N)

lemma corrugation.support : support (𝒯 N γ) ⊆ loop.support γ :=
begin
  intros x x_in,
  apply subset_closure,
  intro h,
  apply x_in,
  simp [h]
end

lemma corrugation_eq_zero (x ∉ loop.support γ) : corrugation π N γ x = 0 :=
nmem_support.mp (λ hx, H (corrugation.support N γ hx))

lemma corrugation.c0_small_on [first_countable_topology E]
  [locally_compact_space E] {γ : ℝ → E → loop F} {K : set E} (hK : is_compact K)
  (h_le : ∀ x, ∀ t ≤ 0, γ t x = γ 0 x) (h_ge : ∀ x, ∀ t ≥ 1, γ t x = γ 1 x)
  (hγ_cont : continuous ↿γ) {ε : ℝ} (ε_pos : 0 < ε) :
  ∀ᶠ N in at_top, ∀ (x ∈ K) t, ‖𝒯 N (γ t) x‖ < ε :=
begin
  have cont' : continuous ↿(λ (q : ℝ × E)  t, ∫ t in 0..t, (γ q.1 q.2) t - (γ q.1 q.2).average),
  { refine continuous_parametric_interval_integral_of_continuous _ continuous_snd,
    refine (hγ_cont.comp₃ continuous_fst.fst.fst continuous_fst.fst.snd continuous_snd).sub _,
    refine loop.continuous_average _,
    exact hγ_cont.comp₃ continuous_fst.fst.fst.fst continuous_fst.fst.fst.snd continuous_snd },
  rcases cont'.bounded_on_compact_of_one_periodic _ ((is_compact_Icc : is_compact I).prod hK) with ⟨C, hC⟩,
  { apply (const_mul_one_div_lt ε_pos C).mono,
    intros N hN x hx t,
    rw [corrugation, norm_smul, mul_comm],
    apply (mul_le_mul_of_nonneg_right _ (norm_nonneg $ 1/N)).trans_lt hN,
    cases le_or_lt t 0 with ht ht,
    { rw h_le x t ht,
      apply hC (0, x),
      simp [hx] },
    { cases le_or_lt 1 t with ht' ht',
      { rw h_ge x t ht',
        apply hC (1, x),
        simp [hx] },
      { exact hC (t, x) (mk_mem_prod ⟨ht.le, ht'.le⟩ hx) _ } } },
  { rintros ⟨t, x⟩,
    apply per_corrugation,
    intros a b,
    exact (hγ_cont.comp₃ continuous_const continuous_const continuous_id).interval_integrable _ _ }
end

variables {γ}

lemma corrugation.cont_diff' {n : ℕ∞} {γ : G → E → loop F} (hγ_diff : 𝒞 n ↿γ)
  {x : H → E} (hx : 𝒞 n x) {g : H → G} (hg : 𝒞 n g) :
  𝒞 n (λ h, 𝒯 N (γ $ g h) $ x h) :=
begin
  apply cont_diff.const_smul,
  apply cont_diff_parametric_primitive_of_cont_diff,
  { apply cont_diff.sub,
    { exact hγ_diff.comp₃ hg.fst' hx.fst' cont_diff_snd },
    { apply cont_diff_average,
      exact hγ_diff.comp₃ hg.fst'.fst' hx.fst'.fst' cont_diff_snd } },
  { apply cont_diff_const.mul (π.cont_diff.comp hx) },
end

lemma corrugation.cont_diff [finite_dimensional ℝ E] {n : ℕ∞} (hγ_diff : 𝒞 n ↿γ) :
  𝒞 n (𝒯 N γ) :=
(cont_diff_parametric_primitive_of_cont_diff
  (cont_diff_sub_average hγ_diff) (π.cont_diff.const_smul N) 0).const_smul _

notation `∂₁` := partial_fderiv_fst ℝ

/--
The remainder appearing when differentiating a corrugation.
-/
def corrugation.remainder (π : E → ℝ) (N : ℝ) (γ : E → loop F) : E → (E →L[ℝ] F) :=
λ x, (1/N) • ∫ t in 0..(N*π x), ∂₁ (λ x t, (γ x).normalize t) x t

local notation `R` := corrugation.remainder π

variable [finite_dimensional ℝ E]

lemma remainder_eq (N : ℝ) {γ : E → loop F} (h : 𝒞 1 ↿γ) :
R N γ = λ x, (1/N) • ∫ t in 0..(N*π x), (loop.diff γ x).normalize t :=
by { simp_rw loop.diff_normalize h, refl }

-- The next lemma is a restatement of the above to emphasize that remainder is a corrugation
-- unused
lemma remainder_eq_corrugation (N : ℝ) {γ : E → loop F} (h : 𝒞 1 ↿γ) :
R N γ = 𝒯 N (λ x, (loop.diff γ x)) :=
remainder_eq _ _ h

@[simp]
lemma remainder_eq_zero (N : ℝ) {γ : E → loop F} (h : 𝒞 1 ↿γ) {x : E} (hx : x ∉ loop.support γ) :
  R N γ x = 0 :=
begin
  have hx' : x ∉ loop.support (loop.diff γ), from (λ h, hx $ loop.support_diff h),
  simp [remainder_eq π N h, loop.normalize_of_is_const (loop.is_const_of_not_mem_support hx')]
end

lemma corrugation.fderiv_eq {N : ℝ} (hN : N ≠ 0) (hγ_diff : 𝒞 1 ↿γ) :
  D (𝒯 N γ) = λ x : E, (γ x (N*π x) - (γ x).average) ⬝ π + R N γ x :=
begin
  ext1 x₀,
  have hπ_diff := π.cont_diff,
  have diff := cont_diff_sub_average hγ_diff,
  have key :=
    (has_fderiv_at_parametric_primitive_of_cont_diff' diff (hπ_diff.const_smul N) x₀ 0).2,
  erw [fderiv_const_smul key.differentiable_at,
       key.fderiv,
       smul_add, add_comm],
  congr' 1,
  rw [fderiv_const_smul (hπ_diff.differentiable le_rfl).differentiable_at N, π.fderiv],
  simp only [smul_smul, inv_mul_cancel hN, one_div, algebra.id.smul_eq_mul, one_smul,
              continuous_linear_map.comp_smul]
end

lemma corrugation.fderiv_apply (hN : N ≠ 0) (hγ_diff : 𝒞 1 ↿γ) (x v : E) :
  D (𝒯 N γ) x v = (π v) • (γ x (N*π x) - (γ x).average) + R N γ x v :=
by simp only [corrugation.fderiv_eq hN hγ_diff, to_span_singleton_apply, add_apply,
              coe_comp', comp_app]

lemma fderiv_corrugated_map (hN : N ≠ 0) (hγ_diff : 𝒞 1 ↿γ) {f : E → F} (hf : 𝒞 1 f)
  (p : dual_pair E) {x} (hfγ : (γ x).average = D f x p.v) :
D (f + corrugation p.π N γ) x = p.update (D f x) (γ x (N*p.π x)) + corrugation.remainder p.π N γ x :=
begin
  ext v,
  erw fderiv_add (hf.differentiable le_rfl).differentiable_at
      ((corrugation.cont_diff N hγ_diff).differentiable le_rfl).differentiable_at,
  simp_rw [continuous_linear_map.add_apply, corrugation.fderiv_apply N hN hγ_diff, hfγ,
    dual_pair.update, continuous_linear_map.add_apply,p.π.comp_to_span_singleton_apply, add_assoc],
end

lemma remainder.smooth {γ : G → E → loop F} (hγ_diff : 𝒞 ∞ ↿γ)
  {x : H → E} (hx : 𝒞 ∞ x) {g : H → G} (hg : 𝒞 ∞ g) :
  𝒞 ∞ (λ h, R N (γ $ g h) $ x h) :=
begin
  apply cont_diff.const_smul,
  apply cont_diff_parametric_primitive_of_cont_diff,
  { let ψ : E → (H × ℝ) → F := λ x q, (γ (g q.1) x).normalize q.2,
    change 𝒞 ⊤ (λ (q : H × ℝ), ∂₁ ψ (x q.1) (q.1, q.2)),
    refine (cont_diff.cont_diff_top_partial_fst _).comp₂ hx.fst'
      (cont_diff_fst.prod cont_diff_snd),
    dsimp [ψ, loop.normalize],
    apply cont_diff.sub,
    apply hγ_diff.comp₃ hg.fst'.snd' cont_diff_fst cont_diff_snd.snd,
    apply cont_diff_average,
    exact hγ_diff.comp₃ hg.fst'.snd'.fst' cont_diff_fst.fst' cont_diff_snd },
  { exact cont_diff_const.mul (π.cont_diff.comp hx) },
end

lemma remainder_c0_small_on {K : set E} (hK : is_compact K)
  (hγ_diff : 𝒞 1 ↿γ) {ε : ℝ} (ε_pos : 0 < ε) :
  ∀ᶠ N in at_top, ∀ x ∈ K, ‖R N γ x‖ < ε :=
begin
  have : ∀ N : ℝ, R N γ = 𝒯 N (loop.diff γ),
  { intro N,
    exact remainder_eq π N hγ_diff },
  simp_rw (λ N, remainder_eq π N hγ_diff),
  let g : ℝ → E → loop (E →L[ℝ] F) := λ t, (loop.diff γ),
  have g_le : ∀ x (t : ℝ), t ≤ 0 → g t x = g 0 x, from λ _ _ _, rfl,
  have g_ge : ∀ x (t : ℝ), t ≥ 1 → g t x = g 1 x, from λ _ _ _, rfl,
  have g_cont : continuous ↿g, from (loop.continuous_diff hγ_diff).snd',
  apply (corrugation.c0_small_on hK g_le g_ge g_cont ε_pos).mono,
  intros N H x x_in,
  exact H x x_in 0
end


import algebra.order.archimedean
import algebra.big_operators.basic
import data.finset.basic
import data.nat.parity
import data.rat.defs
import data.rat.order
import data.set.intervals.basic
import logic.function.basic

import tactic.field_simp
import tactic.linarith

/-
  A set S contains 0 and 1, and the mean of every finite nonempty subset of S.
  Prove that S contains all of the rational numbers in the unit interval.
-/

open_locale big_operators

lemma contains_dyadics
  (S : set ℚ)
  (h0 : (0 : ℚ) ∈ S)
  (h1 : (1 : ℚ) ∈ S)
  (hm : ∀s: finset {q // q ∈ S}, (∑i in s, i.val / finset.card s) ∈ S)
  (m n : ℕ)
  (hmn : m ≤ 2^n) :
  (m : ℚ) / 2^n ∈ S :=
begin
  revert m,
  induction n with pn hpn,
  { intros m hmn,
    rw pow_zero at hmn,
    cases m,
    { simpa },
    { simpa [le_zero_iff.mp (nat.succ_le_succ_iff.mp hmn)] } },
  {
    intros m hmn,
    obtain ⟨t, ht : m = t + t⟩ | ⟨t, ht : m = 2 * t + 1⟩ := m.even_or_odd,
    { -- m is even. reduces to smaller exponent
      rw ht,
      have h2 : ↑(t + t) / 2 ^ pn.succ = ((t : ℕ) : ℚ) / 2 ^ pn :=
        by {field_simp[pow_succ], ring },
      rw h2,
      have h3 : t ≤ 2 ^ pn := by { rw [ht, pow_succ] at hmn, linarith },
      exact hpn t h3 },
    { -- m is odd. need to take midpoint
      -- m = 2 * t + 1 =  (t  + (t + 1))
      -- so m / 2^pn.succ = (t / 2^pn + (t + 1)/2^pn) / 2
      have h3 : t + 1 ≤ 2 ^ pn := by { rw [ht, pow_succ] at hmn, linarith},
      have h4 : t ≤ 2 ^ pn := nat.le_of_succ_le h3,

      let t1 : ℚ := t / 2^pn,
      let t2 : ℚ := ((t + 1):ℕ)/2^pn,

      have h5 : (m:ℚ) / 2 ^ pn.succ = (t1 + t2) / 2 := by { field_simp[pow_succ, ht], ring },
      rw h5,

      have h6 : t1 ∈ S := hpn t h4,
      have h7 : t2 ∈ S := hpn (t+1) h3,

      let ps' : finset {q // q ∈ S} := {⟨t1, h6⟩},
      let ps : finset {q // q ∈ S} := insert ⟨t2, h7⟩ ps',

      have hnotmem: (⟨t2, h7⟩ : {q // q ∈ S}) ∉ ps',
      { have hne : t2 ≠ t1 := by field_simp,
        have : ps'.card = 1 := finset.card_singleton _,
        simp [this],
        solve_by_elim },

      have hcard : ps.card = 2,
      { have hinsertcard := finset.card_insert_of_not_mem hnotmem,
        rwa [finset.card_singleton] at hinsertcard },

      have hmean := hm ps,
      rw hcard at hmean,
      norm_cast at hmean,

      have hsum2 : ∑ (i : {q // q ∈ S}) in ps, i.val/2 =
                  t2/2 + ∑ (i : {q // q ∈ S}) in ps', i.val/2 := finset.sum_insert hnotmem,

      have hsum1 : ∑ (i : {q // q ∈ S}) in ps', i.val / 2 = t1/2,
      { simp only [finset.sum_singleton, subtype.coe_mk] },

      rw [hsum2, hsum1] at hmean,
      have : t2 / 2 + t1 /2 = (t1 + t2) / 2 := by { field_simp, ring },
      rwa this at hmean,
    },
  },
end

lemma dyadic_sum (q : ℚ) (n k : ℕ) :
  (∑i in finset.range (2 * k), ((q - (2 * k - 1) / 2 ^ n.succ) + i / 2 ^ n)) = 2 * k * q :=
begin
  induction k with pk hpk,
  { simp },
  { have h1 : 2 * pk.succ = (2 * pk).succ.succ := rfl,
    rw [h1, finset.sum_range_succ, finset.sum_range_succ],
    have h2 : ∀ i ∈ finset.range (2 * pk),
      (q - (2 * ↑(pk.succ) - 1) / 2 ^ n.succ + ↑i / 2 ^ n) =
      (q - (2 * ↑pk - 1) / 2 ^ n.succ + ↑i / 2 ^ n - 1 / 2^n),
    { intros i hi,
      have h3: ((2:ℚ) * ↑(pk.succ) - 1) = (2 * ↑pk - 1) + 2,
      { rw [nat.cast_succ], ring, },
      have h4 : ((2:ℚ) * ↑pk - 1 + 2) / 2 ^ n.succ =
                ((2:ℚ) * ↑pk - 1) / 2 ^ n.succ + 2 / 2^n.succ := add_div (2 * ↑pk - 1) 2 (2 ^ nat.succ n),

      have h5 : (2:ℚ) / 2^n.succ = 1 / 2^n,
      { field_simp, exact (pow_succ 2 n).symm },

      rw [h3, h4, h5],
      ring },

    sorry,
  },
end

lemma dyadic_summand_injective (q : ℚ) (n k : ℕ) :
  function.injective (λ i : ℕ, (q - (2 * k - 1) / 2 ^ n.succ) + i / 2 ^ n) :=
begin
  intros i1 i2 h,
  simp only [add_right_inj] at h,
  have h1 : (0:ℚ) < 2^n := pow_pos zero_lt_two _,
  have h2 : 2^n ≠ (0:ℚ) := ne_of_gt h1,
  have h3 : (i1:ℚ)  = ↑i2 / 2 ^ n * 2^n := (div_eq_iff h2).mp h,
  field_simp at h3,
  assumption
end

lemma exists_pow_denom_lt_both (x y z : ℚ) (xpos : 0 < x) (ypos : 0 < y) :
  (∃ n : ℕ, z / 2^n < x ∧ z / 2 ^n < y) :=
begin
  obtain ⟨n, hn⟩ := pow_unbounded_of_one_lt (z / min x y) one_lt_two,
  use n,
  have hm : 0 < min x y := lt_min xpos ypos,
  have h1 : z < 2 ^ n * min x y := (div_lt_iff hm).mp hn,
  have h2 : (0:ℚ) < 2^n := pow_pos zero_lt_two _,
  rw mul_comm at h1,
  have h3 : z / 2 ^ n < min x y := (div_lt_iff h2).mpr h1,
  split,
  { exact gt_of_ge_of_gt (min_le_left x y) h3 },
  { exact gt_of_ge_of_gt (min_le_right x y) h3 },
end

theorem generating_the_rationals
  (S : set ℚ)
  (h0 : (0 : ℚ) ∈ S)
  (h1 : (1 : ℚ) ∈ S)
  (hm : ∀s: finset {q // q ∈ S}, (∑i in s, i.val / finset.card s) ∈ S) :
  set.Icc 0 1 ⊆ S :=
begin
  intros q hq,
  obtain ⟨hq0, hq1⟩ := hq,

  -- First deal with the endpoints.

  obtain (heq0 : 0 = q) | (hgt0 : 0 < q) := or.comm.mp (lt_or_eq_of_le hq0),
  { rwa ←heq0 },
  clear hq0,

  obtain (heq1 : q = 1) | (hlt1 : q < 1) := or.comm.mp (lt_or_eq_of_le hq1),
  { rwa heq1 },
  clear hq1,

  -- Now find dyadics a b such that 0 < a < q < b < 1.

  obtain ⟨na, hna⟩ := pow_unbounded_of_one_lt (1/q) one_lt_two,
  let a : ℚ := 1 / 2^na,
  have ha0 : 0 < a := one_div_pos.mpr (by norm_num),
  have haq : a < q := (one_div_lt hgt0 (by norm_num)).mp hna,

  obtain ⟨nb, hnb⟩ := pow_unbounded_of_one_lt (1/(1-q)) one_lt_two,
  let b : ℚ := 1 - 1 / 2^nb,
  let b' : ℚ := 1 / 2^nb,
  have hb' : b = 1 - b' := rfl,
  have hb0 : (0:ℚ) < b' := one_div_pos.mpr (by norm_num),
  have hb1 : b < 1 := by { rw[hb'], linarith },
  have haq : q < b,
  { have hbb : 0 < (1 - q) := sub_pos.mpr hlt1,
    have hbb': 1 < (1 - q) * 2 ^ nb := (div_lt_iff' hbb).mp hnb,
    rw mul_comm at hbb',
    have := (div_lt_iff' (by norm_num)).mpr hbb',
    exact lt_sub_comm.mp this },

  -- if we could pick an element more than once,
  -- we would choose (q - a).num * (b - q).denom copies of a
  -- and (b - q).num * (q - a).denom copies of b.

  let ka : ℕ := (q - a).num.nat_abs * (b - q).denom,
  let kb : ℕ := (b - q).num.nat_abs * (q - a).denom,

  -- choose Na such that (2 * ka - 1) / 2 ^ n.succ < min ((b - a) / 2) (1 - b)

  have h3 : 0 < 1 - b := by linarith,
  have h4 : 0 < (b - a) / 2 := by linarith,

  obtain ⟨Na, hNa1, hNa2⟩ := exists_pow_denom_lt_both ((b - a) / 2) (1 - b) (2 * (ka:ℚ) - 1) h4 h3,
  obtain ⟨Nb, hNb1, hNb2⟩ := exists_pow_denom_lt_both ((b - a) / 2) (1 - b) (2 * (kb:ℚ) - 1) h4 h3,
  clear h3 h4,

  have h5 := dyadic_sum a Na ka,
  have h6 := dyadic_sum b Nb kb,

  let ta : ℕ ↪ ℚ := ⟨_, dyadic_summand_injective a Na ka⟩,
  let tb : ℕ ↪ ℚ := ⟨_, dyadic_summand_injective b Nb kb⟩,

  have hta := finset.sum_map (finset.range (2 * ka)) ta id,
  have htb := finset.sum_map (finset.range (2 * kb)) tb id,

  dsimp at hta,
  rw ←hta at h5,

  dsimp at htb,
  rw ←htb at h6,

  have h7: disjoint (finset.map ta (finset.range (2 * ka)))
                    (finset.map tb (finset.range (2 * kb))),
  { sorry, },

  let s := (finset.map ta (finset.range (2 * ka))) ∪ (finset.map tb (finset.range (2 * kb))),
  have h8 : s.sum id = (finset.map ta (finset.range (2 * ka))).sum id +
               (finset.map tb (finset.range (2 * kb))).sum id := finset.sum_union h7,
  rw [h5, h6] at h8,

  have h9 : s.card = 2 * ↑ka + 2 * ↑kb := sorry,

  have hra : ∀ r ∈ (finset.map ta (finset.range (2 * ka))), q ∈ S,
  {
     intros r hr,
     -- use contains_dyadics ...
     sorry,
  },

  have hrb : ∀ r ∈ (finset.map tb (finset.range (2 * kb))), q ∈ S,
  {
     intros r hr,
     -- use contains_dyadics ...
     sorry,
  },

  have hrs : ∀ r ∈ s, q ∈ S,
  { intros r hr,
    obtain ha | hb := finset.mem_union.mp hr,
    { exact hra r ha },
    { exact hrb r hb } },

  -- hm... maybe we actually want `ta : ℕ ↪ {q // q ∈ S}`

  sorry
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import algebra.big_operators.order
import data.mv_polynomial.rename

/-!
# Degrees and variables of polynomials

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

This file establishes many results about the degree and variable sets of a multivariate polynomial.

The *variable set* of a polynomial $P \in R[X]$ is a `finset` containing each $x \in X$
that appears in a monomial in $P$.

The *degree set* of a polynomial $P \in R[X]$ is a `multiset` containing, for each $x$ in the
variable set, $n$ copies of $x$, where $n$ is the maximum number of copies of $x$ appearing in a
monomial of $P$.

## Main declarations

* `mv_polynomial.degrees p` : the multiset of variables representing the union of the multisets
  corresponding to each non-zero monomial in `p`.
  For example if `7 ≠ 0` in `R` and `p = x²y+7y³` then `degrees p = {x, x, y, y, y}`

* `mv_polynomial.vars p` : the finset of variables occurring in `p`.
  For example if `p = x⁴y+yz` then `vars p = {x, y, z}`

* `mv_polynomial.degree_of n p : ℕ` : the total degree of `p` with respect to the variable `n`.
  For example if `p = x⁴y+yz` then `degree_of y p = 1`.

* `mv_polynomial.total_degree p : ℕ` :
  the max of the sizes of the multisets `s` whose monomials `X^s` occur in `p`.
  For example if `p = x⁴y+yz` then `total_degree p = 5`.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ τ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `r : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

-/

noncomputable theory

open_locale classical big_operators

open set function finsupp add_monoid_algebra
open_locale big_operators

universes u v w
variables {R : Type u} {S : Type v}

namespace mv_polynomial
variables {σ τ : Type*} {r : R} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section comm_semiring
variables [comm_semiring R] {p q : mv_polynomial σ R}

section degrees

/-! ### `degrees` -/

/--
The maximal degrees of each variable in a multi-variable polynomial, expressed as a multiset.

(For example, `degrees (x^2 * y + y^3)` would be `{x, x, y, y, y}`.)
-/
def degrees (p : mv_polynomial σ R) : multiset σ :=
p.support.sup (λs:σ →₀ ℕ, s.to_multiset)

lemma degrees_monomial (s : σ →₀ ℕ) (a : R) : degrees (monomial s a) ≤ s.to_multiset :=
finset.sup_le $ assume t h,
begin
  have := finsupp.support_single_subset h,
  rw [finset.mem_singleton] at this,
  rw this
end

lemma degrees_monomial_eq (s : σ →₀ ℕ) (a : R) (ha : a ≠ 0) :
  degrees (monomial s a) = s.to_multiset :=
le_antisymm (degrees_monomial s a) $ finset.le_sup $
  by rw [support_monomial, if_neg ha, finset.mem_singleton]

lemma degrees_C (a : R) : degrees (C a : mv_polynomial σ R) = 0 :=
multiset.le_zero.1 $ degrees_monomial _ _

lemma degrees_X' (n : σ) : degrees (X n : mv_polynomial σ R) ≤ {n} :=
le_trans (degrees_monomial _ _) $ le_of_eq $ to_multiset_single _ _

@[simp] lemma degrees_X [nontrivial R] (n : σ) : degrees (X n : mv_polynomial σ R) = {n} :=
(degrees_monomial_eq _ (1 : R) one_ne_zero).trans (to_multiset_single _ _)

@[simp] lemma degrees_zero : degrees (0 : mv_polynomial σ R) = 0 :=
by { rw ← C_0, exact degrees_C 0 }

@[simp] lemma degrees_one : degrees (1 : mv_polynomial σ R) = 0 := degrees_C 1

lemma degrees_add (p q : mv_polynomial σ R) : (p + q).degrees ≤ p.degrees ⊔ q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  have := finsupp.support_add hb, rw finset.mem_union at this,
  cases this,
  { exact le_sup_of_le_left (finset.le_sup this) },
  { exact le_sup_of_le_right (finset.le_sup this) },
end

lemma degrees_sum {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (∑ i in s, f i).degrees ≤ s.sup (λi, (f i).degrees) :=
begin
  refine s.induction _ _,
  { simp only [finset.sum_empty, finset.sup_empty, degrees_zero], exact le_rfl },
  { assume i s his ih,
    rw [finset.sup_insert, finset.sum_insert his],
    exact le_trans (degrees_add _ _) (sup_le_sup_left ih _) }
end

lemma degrees_mul (p q : mv_polynomial σ R) : (p * q).degrees ≤ p.degrees + q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  have := support_mul p q hb,
  simp only [finset.mem_bUnion, finset.mem_singleton] at this,
  rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
  rw [finsupp.to_multiset_add],
  exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂)
end

lemma degrees_prod {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (∏ i in s, f i).degrees ≤ ∑ i in s, (f i).degrees :=
begin
  refine s.induction _ _,
  { simp only [finset.prod_empty, finset.sum_empty, degrees_one] },
  { assume i s his ih,
    rw [finset.prod_insert his, finset.sum_insert his],
    exact le_trans (degrees_mul _ _) (add_le_add_left ih _) }
end

lemma degrees_pow (p : mv_polynomial σ R) :
  ∀(n : ℕ), (p^n).degrees ≤ n • p.degrees
| 0       := begin rw [pow_zero, degrees_one], exact multiset.zero_le _ end
| (n + 1) := by { rw [pow_succ, add_smul, add_comm, one_smul],
    exact le_trans (degrees_mul _ _) (add_le_add_left (degrees_pow n) _) }

lemma mem_degrees {p : mv_polynomial σ R} {i : σ} :
  i ∈ p.degrees ↔ ∃ d, p.coeff d ≠ 0 ∧ i ∈ d.support :=
by simp only [degrees, multiset.mem_sup, ← mem_support_iff,
    finsupp.mem_to_multiset, exists_prop]

lemma le_degrees_add {p q : mv_polynomial σ R} (h : p.degrees.disjoint q.degrees) :
  p.degrees ≤ (p + q).degrees :=
begin
  apply finset.sup_le,
  intros d hd,
  rw multiset.disjoint_iff_ne at h,
  rw multiset.le_iff_count,
  intros i,
  rw [degrees, multiset.count_finset_sup],
  simp only [finsupp.count_to_multiset],
  by_cases h0 : d = 0,
  { simp only [h0, zero_le, finsupp.zero_apply], },
  { refine @finset.le_sup _ _ _ _ (p + q).support _ d _,
    rw [mem_support_iff, coeff_add],
    suffices : q.coeff d = 0,
    { rwa [this, add_zero, coeff, ← finsupp.mem_support_iff], },
    rw [← finsupp.support_eq_empty, ← ne.def, ← finset.nonempty_iff_ne_empty] at h0,
    obtain ⟨j, hj⟩ := h0,
    contrapose! h,
    rw mem_support_iff at hd,
    refine ⟨j, _, j, _, rfl⟩,
    all_goals { rw mem_degrees, refine ⟨d, _, hj⟩, assumption } }
end

lemma degrees_add_of_disjoint
  {p q : mv_polynomial σ R} (h : multiset.disjoint p.degrees q.degrees) :
  (p + q).degrees = p.degrees ∪ q.degrees :=
begin
  apply le_antisymm,
  { apply degrees_add },
  { apply multiset.union_le,
    { apply le_degrees_add h },
    { rw add_comm, apply le_degrees_add h.symm } }
end

lemma degrees_map [comm_semiring S] (p : mv_polynomial σ R) (f : R →+* S) :
  (map f p).degrees ⊆ p.degrees :=
begin
  dsimp only [degrees],
  apply multiset.subset_of_le,
  apply finset.sup_mono,
  apply mv_polynomial.support_map_subset
end

lemma degrees_rename (f : σ → τ) (φ : mv_polynomial σ R) :
  (rename f φ).degrees ⊆ (φ.degrees.map f) :=
begin
  intros i,
  rw [mem_degrees, multiset.mem_map],
  rintro ⟨d, hd, hi⟩,
  obtain ⟨x, rfl, hx⟩ := coeff_rename_ne_zero _ _ _ hd,
  simp only [map_domain, finsupp.mem_support_iff] at hi,
  rw [sum_apply, finsupp.sum] at hi,
  contrapose! hi,
  rw [finset.sum_eq_zero],
  intros j hj,
  simp only [exists_prop, mem_degrees] at hi,
  specialize hi j ⟨x, hx, hj⟩,
  rw [single_apply, if_neg hi],
end

lemma degrees_map_of_injective [comm_semiring S] (p : mv_polynomial σ R)
  {f : R →+* S} (hf : injective f) : (map f p).degrees = p.degrees :=
by simp only [degrees, mv_polynomial.support_map_of_injective _ hf]

lemma degrees_rename_of_injective {p : mv_polynomial σ R} {f : σ → τ} (h : function.injective f) :
  degrees (rename f p) = (degrees p).map f :=
begin
  simp only [degrees, multiset.map_finset_sup p.support finsupp.to_multiset f h,
             support_rename_of_injective h, finset.sup_image],
  refine finset.sup_congr rfl (λ x hx, _),
  exact (finsupp.to_multiset_map _ _).symm,
end

end degrees

section vars

/-! ### `vars` -/

/-- `vars p` is the set of variables appearing in the polynomial `p` -/
def vars (p : mv_polynomial σ R) : finset σ := p.degrees.to_finset

@[simp] lemma vars_0 : (0 : mv_polynomial σ R).vars = ∅ :=
by rw [vars, degrees_zero, multiset.to_finset_zero]

@[simp] lemma vars_monomial (h : r ≠ 0) : (monomial s r).vars = s.support :=
by rw [vars, degrees_monomial_eq _ _ h, finsupp.to_finset_to_multiset]

@[simp] lemma vars_C : (C r : mv_polynomial σ R).vars = ∅ :=
by rw [vars, degrees_C, multiset.to_finset_zero]

@[simp] lemma vars_X [nontrivial R] : (X n : mv_polynomial σ R).vars = {n} :=
by rw [X, vars_monomial (one_ne_zero' R), finsupp.support_single_ne_zero _ (one_ne_zero' ℕ)]

lemma mem_vars (i : σ) :
  i ∈ p.vars ↔ ∃ (d : σ →₀ ℕ) (H : d ∈ p.support), i ∈ d.support :=
by simp only [vars, multiset.mem_to_finset, mem_degrees, mem_support_iff,
  exists_prop]

lemma mem_support_not_mem_vars_zero
  {f : mv_polynomial σ R} {x : σ →₀ ℕ} (H : x ∈ f.support) {v : σ} (h : v ∉ vars f) :
  x v = 0 :=
begin
  rw [vars, multiset.mem_to_finset] at h,
  rw ← finsupp.not_mem_support_iff,
  contrapose! h,
  unfold degrees,
  rw (show f.support = insert x f.support, from eq.symm $ finset.insert_eq_of_mem H),
  rw finset.sup_insert,
  simp only [multiset.mem_union, multiset.sup_eq_union],
  left,
  rwa [←to_finset_to_multiset, multiset.mem_to_finset] at h,
end

lemma vars_add_subset (p q : mv_polynomial σ R) :
  (p + q).vars ⊆ p.vars ∪ q.vars :=
begin
  intros x hx,
  simp only [vars, finset.mem_union, multiset.mem_to_finset] at hx ⊢,
  simpa using multiset.mem_of_le (degrees_add _ _) hx,
end

section mul

lemma vars_mul (φ ψ : mv_polynomial σ R) : (φ * ψ).vars ⊆ φ.vars ∪ ψ.vars :=
begin
  intro i,
  simp only [mem_vars, finset.mem_union],
  rintro ⟨d, hd, hi⟩,
  rw [mem_support_iff, coeff_mul] at hd,
  contrapose! hd, cases hd,
  rw finset.sum_eq_zero,
  rintro ⟨d₁, d₂⟩ H,
  rw finsupp.mem_antidiagonal at H,
  subst H,
  obtain H|H : i ∈ d₁.support ∨ i ∈ d₂.support,
  { simpa only [finset.mem_union] using finsupp.support_add hi, },
  { suffices : coeff d₁ φ = 0, by simp [this],
    rw [coeff, ← finsupp.not_mem_support_iff], intro, solve_by_elim, },
  { suffices : coeff d₂ ψ = 0, by simp [this],
    rw [coeff, ← finsupp.not_mem_support_iff], intro, solve_by_elim, },
end

@[simp] lemma vars_one : (1 : mv_polynomial σ R).vars = ∅ :=
vars_C

lemma vars_pow (φ : mv_polynomial σ R) (n : ℕ) : (φ ^ n).vars ⊆ φ.vars :=
begin
  induction n with n ih,
  { simp },
  { rw pow_succ,
    apply finset.subset.trans (vars_mul _ _),
    exact finset.union_subset (finset.subset.refl _) ih }
end

/--
The variables of the product of a family of polynomials
are a subset of the union of the sets of variables of each polynomial.
-/
lemma vars_prod {ι : Type*} {s : finset ι} (f : ι → mv_polynomial σ R) :
  (∏ i in s, f i).vars ⊆ s.bUnion (λ i, (f i).vars) :=
begin
  apply s.induction_on,
  { simp },
  { intros a s hs hsub,
    simp only [hs, finset.bUnion_insert, finset.prod_insert, not_false_iff],
    apply finset.subset.trans (vars_mul _ _),
    exact finset.union_subset_union (finset.subset.refl _) hsub }
end

section is_domain
variables {A : Type*} [comm_ring A] [is_domain A]

lemma vars_C_mul (a : A) (ha : a ≠ 0) (φ : mv_polynomial σ A) : (C a * φ).vars = φ.vars :=
begin
  ext1 i,
  simp only [mem_vars, exists_prop, mem_support_iff],
  apply exists_congr,
  intro d,
  apply and_congr _ iff.rfl,
  rw [coeff_C_mul, mul_ne_zero_iff, eq_true_intro ha, true_and],
end

end is_domain

end mul

section sum

variables {ι : Type*} (t : finset ι) (φ : ι → mv_polynomial σ R)

lemma vars_sum_subset :
  (∑ i in t, φ i).vars ⊆ finset.bUnion t (λ i, (φ i).vars) :=
begin
  apply t.induction_on,
  { simp },
  { intros a s has hsum,
    rw [finset.bUnion_insert, finset.sum_insert has],
    refine finset.subset.trans (vars_add_subset _ _)
      (finset.union_subset_union (finset.subset.refl _) _),
    assumption }
end

lemma vars_sum_of_disjoint (h : pairwise $ disjoint on (λ i, (φ i).vars)) :
  (∑ i in t, φ i).vars = finset.bUnion t (λ i, (φ i).vars) :=
begin
  apply t.induction_on,
  { simp },
  { intros a s has hsum,
    rw [finset.bUnion_insert, finset.sum_insert has, vars_add_of_disjoint, hsum],
    unfold pairwise on_fun at h,
    rw hsum,
    simp only [finset.disjoint_iff_ne] at h ⊢,
    intros v hv v2 hv2,
    rw finset.mem_bUnion at hv2,
    rcases hv2 with ⟨i, his, hi⟩,
    refine h _ _ hv _ hi,
    rintro rfl,
    contradiction }
end

end sum

section map

variables [comm_semiring S] (f : R →+* S)
variable (p)

lemma vars_map : (map f p).vars ⊆ p.vars :=
by simp [vars, degrees_map]

variable {f}
lemma vars_map_of_injective (hf : injective f) :
  (map f p).vars = p.vars :=
by simp [vars, degrees_map_of_injective _ hf]

lemma vars_monomial_single (i : σ) {e : ℕ} {r : R} (he : e ≠ 0) (hr : r ≠ 0) :
  (monomial (finsupp.single i e) r).vars = {i} :=
by rw [vars_monomial hr, finsupp.support_single_ne_zero _ he]

lemma vars_eq_support_bUnion_support : p.vars = p.support.bUnion finsupp.support :=
by { ext i, rw [mem_vars, finset.mem_bUnion] }

end map

end vars

section degree_of

/-! ### `degree_of` -/

/-- `degree_of n p` gives the highest power of X_n that appears in `p` -/
def degree_of (n : σ) (p : mv_polynomial σ R) : ℕ := p.degrees.count n

lemma degree_of_eq_sup (n : σ) (f : mv_polynomial σ R) :
  degree_of n f = f.support.sup (λ m, m n) :=
begin
  rw [degree_of, degrees, multiset.count_finset_sup],
  congr,
  ext,
  simp,
end

lemma degree_of_lt_iff {n : σ} {f : mv_polynomial σ R} {d : ℕ} (h : 0 < d) :
  degree_of n f < d ↔ ∀ m : σ →₀ ℕ, m ∈ f.support → m n < d :=
by rwa [degree_of_eq_sup n f, finset.sup_lt_iff]

@[simp] lemma degree_of_zero (n : σ) :
  degree_of n (0 : mv_polynomial σ R) = 0 :=
by simp only [degree_of, degrees_zero, multiset.count_zero]

@[simp] lemma degree_of_C (a : R) (x : σ):
  degree_of x (C a : mv_polynomial σ R) = 0 := by simp [degree_of, degrees_C]

lemma degree_of_X (i j : σ) [nontrivial R] :
  degree_of i (X j : mv_polynomial σ R) = if i = j then 1 else 0 :=
begin
  by_cases c : i = j,
  { simp only [c, if_true, eq_self_iff_true, degree_of, degrees_X, multiset.count_singleton] },
  simp [c, if_false, degree_of, degrees_X],
end

lemma degree_of_add_le (n : σ) (f g : mv_polynomial σ R) :
  degree_of n (f + g) ≤ max (degree_of n f) (degree_of n g) :=
begin
  repeat {rw degree_of},
  apply (multiset.count_le_of_le n (degrees_add f g)).trans,
  dsimp,
  rw multiset.count_union,
end

lemma monomial_le_degree_of (i : σ) {f : mv_polynomial σ R} {m : σ →₀ ℕ}
  (h_m : m ∈ f.support) : m i ≤ degree_of i f :=
begin
  rw degree_of_eq_sup i,
  apply finset.le_sup h_m,
end

-- TODO we can prove equality here if R is a domain
lemma degree_of_mul_le (i : σ) (f g: mv_polynomial σ R) :
  degree_of i (f * g) ≤ degree_of i f + degree_of i g :=
begin
  repeat {rw degree_of},
  convert multiset.count_le_of_le i (degrees_mul f g),
  rw multiset.count_add,
end

lemma degree_of_mul_X_ne {i j : σ} (f : mv_polynomial σ R) (h : i ≠ j) :
  degree_of i (f * X j) = degree_of i f :=
begin
  repeat {rw degree_of_eq_sup i},
  rw support_mul_X,
  simp only [finset.sup_map],
  congr,
  ext,
  simp only [single, nat.one_ne_zero, add_right_eq_self, add_right_embedding_apply, coe_mk,
             pi.add_apply, comp_app, ite_eq_right_iff, finsupp.coe_add, pi.single_eq_of_ne h],
end

/- TODO in the following we have equality iff f ≠ 0 -/
lemma degree_of_mul_X_eq (j : σ) (f : mv_polynomial σ R) :
  degree_of j (f * X j) ≤ degree_of j f + 1 :=
begin
  repeat {rw degree_of},
  apply (multiset.count_le_of_le j (degrees_mul f (X j))).trans,
  simp only [multiset.count_add, add_le_add_iff_left],
  convert multiset.count_le_of_le j (degrees_X' j),
  rw multiset.count_singleton_self,
end

lemma degree_of_rename_of_injective {p : mv_polynomial σ R} {f : σ → τ} (h : function.injective f)
  (i : σ) : degree_of (f i) (rename f p) = degree_of i p :=
by simp only [degree_of, degrees_rename_of_injective h,
              multiset.count_map_eq_count' f (p.degrees) h]

end degree_of

section total_degree

/-! ### `total_degree` -/

/-- `total_degree p` gives the maximum |s| over the monomials X^s in `p` -/
def total_degree (p : mv_polynomial σ R) : ℕ := p.support.sup (λs, s.sum $ λn e, e)

lemma total_degree_eq (p : mv_polynomial σ R) :
  p.total_degree = p.support.sup (λm, m.to_multiset.card) :=
begin
  rw [total_degree],
  congr, funext m,
  exact (finsupp.card_to_multiset _).symm
end

lemma total_degree_le_degrees_card (p : mv_polynomial σ R) :
  p.total_degree ≤ p.degrees.card :=
begin
  rw [total_degree_eq],
  exact finset.sup_le (assume s hs, multiset.card_le_of_le $ finset.le_sup hs)
end

@[simp] lemma total_degree_C (a : R) : (C a : mv_polynomial σ R).total_degree = 0 :=
nat.eq_zero_of_le_zero $ finset.sup_le $ assume n hn,
  have _ := finsupp.support_single_subset hn,
  begin
    rw [finset.mem_singleton] at this,
    subst this,
    exact le_rfl
  end

@[simp] lemma total_degree_zero : (0 : mv_polynomial σ R).total_degree = 0 :=
by rw [← C_0]; exact total_degree_C (0 : R)

@[simp] lemma total_degree_one : (1 : mv_polynomial σ R).total_degree = 0 :=
total_degree_C (1 : R)

@[simp] lemma total_degree_X {R} [comm_semiring R] [nontrivial R] (s : σ) :
  (X s : mv_polynomial σ R).total_degree = 1 :=
begin
  rw [total_degree, support_X],
  simp only [finset.sup, sum_single_index, finset.fold_singleton, sup_bot_eq],
end

lemma total_degree_add (a b : mv_polynomial σ R) :
  (a + b).total_degree ≤ max a.total_degree b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := finsupp.support_add hn,
  begin
    rw finset.mem_union at this,
    cases this,
    { exact le_max_of_le_left (finset.le_sup this) },
    { exact le_max_of_le_right (finset.le_sup this) }
  end

lemma total_degree_add_eq_left_of_total_degree_lt {p q : mv_polynomial σ R}
  (h : q.total_degree < p.total_degree) : (p + q).total_degree = p.total_degree :=
begin
  classical,
  apply le_antisymm,
  { rw ← max_eq_left_of_lt h,
    exact total_degree_add p q, },
  by_cases hp : p = 0,
  { simp [hp], },
  obtain ⟨b, hb₁, hb₂⟩ := p.support.exists_mem_eq_sup (finsupp.support_nonempty_iff.mpr hp)
    (λ (m : σ →₀ ℕ), m.to_multiset.card),
  have hb : ¬ b ∈ q.support,
  { contrapose! h,
    rw [total_degree_eq p, hb₂, total_degree_eq],
    apply finset.le_sup h, },
  have hbb : b ∈ (p + q).support,
  { apply support_sdiff_support_subset_support_add,
    rw finset.mem_sdiff,
    exact ⟨hb₁, hb⟩, },
  rw [total_degree_eq, hb₂, total_degree_eq],
  exact finset.le_sup hbb,
end

lemma total_degree_add_eq_right_of_total_degree_lt {p q : mv_polynomial σ R}
  (h : q.total_degree < p.total_degree) : (q + p).total_degree = p.total_degree :=
by rw [add_comm, total_degree_add_eq_left_of_total_degree_lt h]

lemma total_degree_mul (a b : mv_polynomial σ R) :
  (a * b).total_degree ≤ a.total_degree + b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := add_monoid_algebra.support_mul a b hn,
  begin
    simp only [finset.mem_bUnion, finset.mem_singleton] at this,
    rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
    rw [finsupp.sum_add_index'],
    { exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂) },
    { assume a, refl },
    { assume a b₁ b₂, refl }
  end

lemma total_degree_smul_le [comm_semiring S] [distrib_mul_action R S] (a : R)
  (f : mv_polynomial σ S) :
  (a • f).total_degree ≤ f.total_degree :=
finset.sup_mono support_smul

lemma total_degree_pow (a : mv_polynomial σ R) (n : ℕ) :
  (a ^ n).total_degree ≤ n * a.total_degree :=
begin
  induction n with n ih,
  { simp only [nat.nat_zero_eq_zero, zero_mul, pow_zero, total_degree_one] },
  rw pow_succ,
  calc total_degree (a * a ^ n) ≤ a.total_degree + (a^n).total_degree : total_degree_mul _ _
    ... ≤ a.total_degree + n * a.total_degree : add_le_add_left ih _
    ... = (n+1) * a.total_degree : by rw [add_mul, one_mul, add_comm]
end

@[simp] lemma total_degree_monomial (s : σ →₀ ℕ) {c : R} (hc : c ≠ 0) :
  (monomial s c : mv_polynomial σ R).total_degree = s.sum (λ _ e, e) :=
by simp [total_degree, support_monomial, if_neg hc]

@[simp] lemma total_degree_X_pow [nontrivial R] (s : σ) (n : ℕ) :
  (X s ^ n : mv_polynomial σ R).total_degree = n :=
by simp [X_pow_eq_monomial, one_ne_zero]

lemma total_degree_list_prod :
  ∀(s : list (mv_polynomial σ R)), s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum
| []        := by rw [@list.prod_nil (mv_polynomial σ R) _, total_degree_one]; refl
| (p :: ps) :=
  begin
    rw [@list.prod_cons (mv_polynomial σ R) _, list.map, list.sum_cons],
    exact le_trans (total_degree_mul _ _) (add_le_add_left (total_degree_list_prod ps) _)
  end

lemma total_degree_multiset_prod (s : multiset (mv_polynomial σ R)) :
  s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum :=
begin
  refine quotient.induction_on s (assume l, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod, multiset.coe_map, multiset.coe_sum],
  exact total_degree_list_prod l
end

lemma total_degree_finset_prod {ι : Type*}
  (s : finset ι) (f : ι → mv_polynomial σ R) :
  (s.prod f).total_degree ≤ ∑ i in s, (f i).total_degree :=
begin
  refine le_trans (total_degree_multiset_prod _) _,
  rw [multiset.map_map],
  refl
end

lemma total_degree_finset_sum {ι : Type*} (s : finset ι) (f : ι → mv_polynomial σ R) :
  (s.sum f).total_degree ≤ finset.sup s (λ i, (f i).total_degree) :=
begin
  induction s using finset.cons_induction with a s has hind,
  { exact zero_le _ },
  { rw [finset.sum_cons, finset.sup_cons, sup_eq_max],
    exact (mv_polynomial.total_degree_add _ _).trans (max_le_max le_rfl hind), }
end

lemma exists_degree_lt [fintype σ] (f : mv_polynomial σ R) (n : ℕ)
  (h : f.total_degree < n * fintype.card σ) {d : σ →₀ ℕ} (hd : d ∈ f.support) :
  ∃ i, d i < n :=
begin
  contrapose! h,
  calc n * fintype.card σ
        = ∑ s:σ, n         : by rw [finset.sum_const, nat.nsmul_eq_mul, mul_comm, finset.card_univ]
    ... ≤ ∑ s, d s         : finset.sum_le_sum (λ s _, h s)
    ... ≤ d.sum (λ i e, e) : by { rw [finsupp.sum_fintype], intros, refl }
    ... ≤ f.total_degree   : finset.le_sup hd,
end

lemma coeff_eq_zero_of_total_degree_lt {f : mv_polynomial σ R} {d : σ →₀ ℕ}
  (h : f.total_degree < ∑ i in d.support, d i) :
  coeff d f = 0 :=
begin
  classical,
  rw [total_degree, finset.sup_lt_iff] at h,
  { specialize h d, rw mem_support_iff at h,
    refine not_not.mp (mt h _), exact lt_irrefl _, },
  { exact lt_of_le_of_lt (nat.zero_le _) h, }
end

lemma total_degree_rename_le (f : σ → τ) (p : mv_polynomial σ R) :
  (rename f p).total_degree ≤ p.total_degree :=
finset.sup_le $ assume b,
begin
  assume h,
  rw rename_eq at h,
  have h' := finsupp.map_domain_support h,
  rw finset.mem_image at h',
  rcases h' with ⟨s, hs, rfl⟩,
  rw finsupp.sum_map_domain_index,
  exact le_trans le_rfl (finset.le_sup hs),
  exact assume _, rfl,
  exact assume _ _ _, rfl
end

end total_degree

section eval_vars

/-! ### `vars` and `eval` -/

variables [comm_semiring S]

lemma eval₂_hom_eq_constant_coeff_of_vars (f : R →+* S) {g : σ → S}
  {p : mv_polynomial σ R} (hp : ∀ i ∈ p.vars, g i = 0) :
  eval₂_hom f g p = f (constant_coeff p) :=
begin
  conv_lhs { rw p.as_sum },
  simp only [ring_hom.map_sum, eval₂_hom_monomial],
  by_cases h0 : constant_coeff p = 0,
  work_on_goal 1
  { rw [h0, f.map_zero, finset.sum_eq_zero],
    intros d hd },
  work_on_goal 2
  { rw [finset.sum_eq_single (0 : σ →₀ ℕ)],
    { rw [finsupp.prod_zero_index, mul_one],
      refl },
    intros d hd hd0, },
  repeat
  { obtain ⟨i, hi⟩ : d.support.nonempty,
    { rw [constant_coeff_eq, coeff, ← finsupp.not_mem_support_iff] at h0,
      rw [finset.nonempty_iff_ne_empty, ne.def, finsupp.support_eq_empty],
      rintro rfl, contradiction },
    rw [finsupp.prod, finset.prod_eq_zero hi, mul_zero],
    rw [hp, zero_pow (nat.pos_of_ne_zero $ finsupp.mem_support_iff.mp hi)],
    rw [mem_vars],
    exact ⟨d, hd, hi⟩ },
  { rw [constant_coeff_eq, coeff, ← ne.def, ← finsupp.mem_support_iff] at h0,
    intro, contradiction }
end

lemma aeval_eq_constant_coeff_of_vars [algebra R S] {g : σ → S}
  {p : mv_polynomial σ R} (hp : ∀ i ∈ p.vars, g i = 0) :
  aeval g p = algebra_map _ _ (constant_coeff p) :=
eval₂_hom_eq_constant_coeff_of_vars _ hp

lemma eval₂_hom_congr' {f₁ f₂ : R →+* S} {g₁ g₂ : σ → S} {p₁ p₂ : mv_polynomial σ R} :
  f₁ = f₂ → (∀ i, i ∈ p₁.vars → i ∈ p₂.vars → g₁ i = g₂ i) → p₁ = p₂ →
   eval₂_hom f₁ g₁ p₁ = eval₂_hom f₂ g₂ p₂ :=
begin
  rintro rfl h rfl,
  rename [p₁ p, f₁ f],
  rw p.as_sum,
  simp only [ring_hom.map_sum, eval₂_hom_monomial],
  apply finset.sum_congr rfl,
  intros d hd,
  congr' 1,
  simp only [finsupp.prod],
  apply finset.prod_congr rfl,
  intros i hi,
  have : i ∈ p.vars, { rw mem_vars, exact ⟨d, hd, hi⟩ },
  rw h i this this,
end

/-- If `f₁` and `f₂` are ring homs out of the polynomial ring and `p₁` and `p₂` are polynomials,
  then `f₁ p₁ = f₂ p₂` if `p₁ = p₂` and `f₁` and `f₂` are equal on `R` and on the variables
  of `p₁`.  -/
lemma hom_congr_vars {f₁ f₂ : mv_polynomial σ R →+* S} {p₁ p₂ : mv_polynomial σ R}
  (hC : f₁.comp C = f₂.comp C) (hv : ∀ i, i ∈ p₁.vars → i ∈ p₂.vars → f₁ (X i) = f₂ (X i))
  (hp : p₁ = p₂) : f₁ p₁ = f₂ p₂ :=
calc f₁ p₁ = eval₂_hom (f₁.comp C) (f₁ ∘ X) p₁ : ring_hom.congr_fun (by ext; simp) _
... = eval₂_hom (f₂.comp C) (f₂ ∘ X) p₂ :
  eval₂_hom_congr' hC hv hp
... = f₂ p₂ : ring_hom.congr_fun (by ext; simp) _

lemma exists_rename_eq_of_vars_subset_range
  (p : mv_polynomial σ R) (f : τ → σ)
  (hfi : injective f) (hf : ↑p.vars ⊆ set.range f) :
  ∃ q : mv_polynomial τ R, rename f q = p :=
⟨aeval (λ i : σ, option.elim 0 X $ partial_inv f i) p,
  begin
    show (rename f).to_ring_hom.comp _ p = ring_hom.id _ p,
    refine hom_congr_vars _ _ _,
    { ext1,
      simp [algebra_map_eq] },
    { intros i hip _,
      rcases hf hip with ⟨i, rfl⟩,
      simp [partial_inv_left hfi] },
    { refl }
  end⟩

lemma vars_rename (f : σ → τ) (φ : mv_polynomial σ R) :
  (rename f φ).vars ⊆ (φ.vars.image f) :=
begin
  intros i hi,
  simp only [vars, exists_prop, multiset.mem_to_finset, finset.mem_image] at hi ⊢,
  simpa only [multiset.mem_map] using degrees_rename _ _ hi
end

lemma mem_vars_rename (f : σ → τ) (φ : mv_polynomial σ R) {j : τ} (h : j ∈ (rename f φ).vars) :
  ∃ (i : σ), i ∈ φ.vars ∧ f i = j :=
by simpa only [exists_prop, finset.mem_image] using vars_rename f φ h

end eval_vars

end comm_semiring

end mv_polynomial


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import category_theory.adjunction.basic
import order.galois_connection

/-!

# Preorders as categories

We install a category instance on any preorder. This is not to be confused with the category _of_
preorders, defined in `order/category/Preorder`.

We show that monotone functions between preorders correspond to functors of the associated
categories. Furthermore, galois connections correspond to adjoint functors.

## Main definitions

* `hom_of_le` and `le_of_hom` provide translations between inequalities in the preorder, and
  morphisms in the associated category.
* `monotone.functor` is the functor associated to a monotone function.
* `galois_connection.adjunction` is the adjunction associated to a galois connection.
* `Preorder_to_Cat` is the functor embedding the category of preorders into `Cat`.

-/

universes u v

namespace preorder

open category_theory

/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ulift (plift (X ≤ Y))`.
See `category_theory.hom_of_le` and `category_theory.le_of_hom`.

See <https://stacks.math.columbia.edu/tag/00D3>.
-/
@[priority 100] -- see Note [lower instance priority]
instance small_category (α : Type u) [preorder α] : small_category α :=
{ hom  := λ U V, ulift (plift (U ≤ V)),
  id   := λ X, ⟨ ⟨ le_refl X ⟩ ⟩,
  comp := λ X Y Z f g, ⟨ ⟨ le_trans _ _ _ f.down.down g.down.down ⟩ ⟩ }

end preorder

namespace category_theory

open opposite

variables {X : Type u} [preorder X]

/--
Express an inequality as a morphism in the corresponding preorder category.
-/
def hom_of_le {x y : X} (h : x ≤ y) : x ⟶ y := ulift.up (plift.up h)

alias hom_of_le ← _root_.has_le.le.hom

@[simp] lemma hom_of_le_refl {x : X} : (le_refl x).hom = 𝟙 x := rfl
@[simp] lemma hom_of_le_comp {x y z : X} (h : x ≤ y) (k : y ≤ z) :
  h.hom ≫ k.hom = (h.trans k).hom := rfl

/--
Extract the underlying inequality from a morphism in a preorder category.
-/
lemma le_of_hom {x y : X} (h : x ⟶ y) : x ≤ y := h.down.down

alias le_of_hom ← _root_.quiver.hom.le

@[simp] lemma le_of_hom_hom_of_le {x y : X} (h : x ≤ y) : h.hom.le = h := rfl
@[simp] lemma hom_of_le_le_of_hom {x y : X} (h : x ⟶ y) : h.le.hom = h :=
by { cases h, cases h, refl, }

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def op_hom_of_le {x y : Xᵒᵖ} (h : unop x ≤ unop y) : y ⟶ x := h.hom.op

lemma le_of_op_hom {x y : Xᵒᵖ} (h : x ⟶ y) : unop y ≤ unop x := h.unop.le

instance unique_to_top [order_top X] {x : X} : unique (x ⟶ ⊤) := by tidy
instance unique_from_bot [order_bot X] {x : X} : unique (⊥ ⟶ x) := by tidy

end category_theory

section

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
A monotone function between preorders induces a functor between the associated categories.
-/
def monotone.functor {f : X → Y} (h : monotone f) : X ⥤ Y :=
{ obj := f,
  map := λ x₁ x₂ g, (h g.le).hom }

@[simp] lemma monotone.functor_obj {f : X → Y} (h : monotone f) : h.functor.obj = f := rfl

/--
A galois connection between preorders induces an adjunction between the associated categories.
-/
def galois_connection.adjunction {l : X → Y} {u : Y → X} (gc : galois_connection l u) :
  gc.monotone_l.functor ⊣ gc.monotone_u.functor :=
category_theory.adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, ⟨λ f, (gc.le_u f.le).hom, λ f, (gc.l_le f.le).hom, by tidy, by tidy⟩ }

end

namespace category_theory

section preorder

variables {X : Type u} {Y : Type v} [preorder X] [preorder Y]

/--
A functor between preorder categories is monotone.
-/
@[mono] lemma functor.monotone (f : X ⥤ Y) : monotone f.obj :=
λ x y hxy, (f.map hxy.hom).le

/--
An adjunction between preorder categories induces a galois connection.
-/
lemma adjunction.gc {L : X ⥤ Y} {R : Y ⥤ X} (adj : L ⊣ R) :
  galois_connection L.obj R.obj :=
λ x y, ⟨λ h, ((adj.hom_equiv x y).to_fun h.hom).le, λ h, ((adj.hom_equiv x y).inv_fun h.hom).le⟩

end preorder

section partial_order

variables {X : Type u} {Y : Type v} [partial_order X] [partial_order Y]

lemma iso.to_eq {x y : X} (f : x ≅ y) : x = y := le_antisymm f.hom.le f.inv.le

/--
A categorical equivalence between partial orders is just an order isomorphism.
-/
def equivalence.to_order_iso (e : X ≌ Y) : X ≃o Y :=
{ to_fun := e.functor.obj,
  inv_fun := e.inverse.obj,
  left_inv := λ a, (e.unit_iso.app a).to_eq.symm,
  right_inv := λ b, (e.counit_iso.app b).to_eq,
  map_rel_iff' := λ a a',
    ⟨λ h, ((equivalence.unit e).app a ≫ e.inverse.map h.hom ≫ (equivalence.unit_inv e).app a').le,
     λ (h : a ≤ a'), (e.functor.map h.hom).le⟩, }

-- `@[simps]` on `equivalence.to_order_iso` produces lemmas that fail the `simp_nf` linter,
-- so we provide them by hand:
@[simp]
lemma equivalence.to_order_iso_apply (e : X ≌ Y) (x : X) :
  e.to_order_iso x = e.functor.obj x := rfl

@[simp]
lemma equivalence.to_order_iso_symm_apply (e : X ≌ Y) (y : Y) :
  e.to_order_iso.symm y = e.inverse.obj y := rfl

end partial_order

end category_theory


open Nat

def double : Nat → Nat
  | zero   => 0
  | succ n => succ (succ (double n))

theorem double.inj : double n = double m → n = m := by
  intro h
  induction n generalizing m with
  | zero => cases m <;> trivial
  | succ n ih =>
    cases m with
    | zero   => contradiction
    | succ m =>
      simp [double] at h |-
      apply ih h

theorem double.inj' : double n = double m → n = m := by
  intro h
  induction n generalizing m with
  | zero => cases m <;> trivial
  | succ n ih =>
    cases m with
    | zero => contradiction
    | succ m =>
      simp
      apply ih
      simp_all [double]

theorem double.inj'' : double n = double m → n = m := by
  intro h
  induction n generalizing m with
  | zero => cases m <;> trivial
  | succ n ih =>
    cases m with
    | zero   => contradiction
    | succ m =>
      simp [ih, double]
      simp [double] at h
      apply ih h

theorem double.inj''' : double n = double m → n = m := by
  simp (config := { maxDischargeDepth := 2 })
  simp (config := { maxSteps := 2000000 })
  admit