/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import linear_algebra.affine_space.independent
import linear_algebra.affine_space.finite_dimensional
import linear_algebra.determinant

/-!
# Affine bases and barycentric coordinates

Suppose `P` is an affine space modelled on the module `V` over the ring `k`, and `p : ι → P` is an
affine-independent family of points spanning `P`. Given this data, each point `q : P` may be written
uniquely as an affine combination: `q = w₀ p₀ + w₁ p₁ + ⋯` for some (finitely-supported) weights
`wᵢ`. For each `i : ι`, we thus have an affine map `P →ᵃ[k] k`, namely `q ↦ wᵢ`. This family of
maps is known as the family of barycentric coordinates. It is defined in this file.

## The construction

Fixing `i : ι`, and allowing `j : ι` to range over the values `j ≠ i`, we obtain a basis `bᵢ` of `V`
defined by `bᵢ j = p j -ᵥ p i`. Let `fᵢ j : V →ₗ[k] k` be the corresponding dual basis and let
`fᵢ = ∑ j, fᵢ j : V →ₗ[k] k` be the corresponding "sum of all coordinates" form. Then the `i`th
barycentric coordinate of `q : P` is `1 - fᵢ (q -ᵥ p i)`.

## Main definitions

 * `affine_basis`: a structure representing an affine basis of an affine space.
 * `affine_basis.coord`: the map `P →ᵃ[k] k` corresponding to `i : ι`.
 * `affine_basis.coord_apply_eq`: the behaviour of `affine_basis.coord i` on `p i`.
 * `affine_basis.coord_apply_neq`: the behaviour of `affine_basis.coord i` on `p j` when `j ≠ i`.
 * `affine_basis.coord_apply`: the behaviour of `affine_basis.coord i` on `p j` for general `j`.
 * `affine_basis.coord_apply_combination`: the characterisation of `affine_basis.coord i` in terms
    of affine combinations, i.e., `affine_basis.coord i (w₀ p₀ + w₁ p₁ + ⋯) = wᵢ`.

## TODO

 * Construct the affine equivalence between `P` and `{ f : ι →₀ k | f.sum = 1 }`.

-/

open_locale affine big_operators matrix
open set

universes u₁ u₂ u₃ u₄

/-- An affine basis is a family of affine-independent points whose span is the top subspace. -/
structure affine_basis (ι : Type u₁) (k : Type u₂) {V : Type u₃} (P : Type u₄)
  [add_comm_group V] [affine_space V P] [ring k] [module k V] :=
(points : ι → P)
(ind : affine_independent k points)
(tot : affine_span k (range points) = ⊤)

variables {ι : Type u₁} {k : Type u₂} {V : Type u₃} {P : Type u₄}
variables [add_comm_group V] [affine_space V P]

namespace affine_basis

section ring

variables [ring k] [module k V] (b : affine_basis ι k P)

/-- The unique point in a single-point space is the simplest example of an affine basis. -/
instance : inhabited (affine_basis punit k punit) :=
⟨{ points := id,
   ind    := affine_independent_of_subsingleton k id,
   tot    := by simp }⟩

/-- Given an affine basis for an affine space `P`, if we single out one member of the family, we
obtain a linear basis for the model space `V`.

The linear basis correpsonding to the singled-out member `i : ι` is indexed by `{j : ι // j ≠ i}`
and its `j`th element is `points j -ᵥ points i`. (See `basis_of_apply`.) -/
noncomputable def basis_of (i : ι) : basis {j : ι // j ≠ i} k V :=
basis.mk ((affine_independent_iff_linear_independent_vsub k b.points i).mp b.ind)
begin
  suffices : submodule.span k (range (λ (j : {x // x ≠ i}), b.points ↑j -ᵥ b.points i)) =
             vector_span k (range b.points),
  { rw [this, ← direction_affine_span, b.tot, affine_subspace.direction_top], },
  conv_rhs { rw ← image_univ, },
  rw vector_span_image_eq_span_vsub_set_right_ne k b.points (mem_univ i),
  congr,
  ext v,
  simp,
end

@[simp] lemma basis_of_apply (i : ι) (j : {j : ι // j ≠ i}) :
  b.basis_of i j = b.points ↑j -ᵥ b.points i :=
by simp [basis_of]

/-- The `i`th barycentric coordinate of a point. -/
noncomputable def coord (i : ι) : P →ᵃ[k] k :=
{ to_fun    := λ q, 1 - (b.basis_of i).sum_coords (q -ᵥ b.points i),
  linear    := -(b.basis_of i).sum_coords,
  map_vadd' := λ q v, by rw [vadd_vsub_assoc, linear_map.map_add, vadd_eq_add, linear_map.neg_apply,
    sub_add_eq_sub_sub_swap, add_comm, sub_eq_add_neg], }

@[simp] lemma linear_eq_sum_coords (i : ι) :
  (b.coord i).linear = -(b.basis_of i).sum_coords :=
rfl

@[simp] lemma coord_apply_eq (i : ι) :
  b.coord i (b.points i) = 1 :=
by simp only [coord, basis.coe_sum_coords, linear_equiv.map_zero, linear_equiv.coe_coe,
  sub_zero, affine_map.coe_mk, finsupp.sum_zero_index, vsub_self]

@[simp] lemma coord_apply_neq (i j : ι) (h : j ≠ i) :
  b.coord i (b.points j) = 0 :=
by rw [coord, affine_map.coe_mk, ← subtype.coe_mk j h, ← b.basis_of_apply i ⟨j, h⟩,
  basis.sum_coords_self_apply, sub_self]

lemma coord_apply [decidable_eq ι] (i j : ι) :
  b.coord i (b.points j) = if i = j then 1 else 0 :=
by { cases eq_or_ne i j; simp [h.symm], simp [h], }

@[simp] lemma coord_apply_combination_of_mem
  {s : finset ι} {i : ι} (hi : i ∈ s) {w : ι → k} (hw : s.sum w = 1) :
  b.coord i (s.affine_combination b.points w) = w i :=
begin
  classical,
  simp only [coord_apply, hi, finset.affine_combination_eq_linear_combination, if_true, mul_boole,
    hw, function.comp_app, smul_eq_mul, s.sum_ite_eq, s.map_affine_combination b.points w hw],
end

@[simp] lemma coord_apply_combination_of_not_mem
  {s : finset ι} {i : ι} (hi : i ∉ s) {w : ι → k} (hw : s.sum w = 1) :
  b.coord i (s.affine_combination b.points w) = 0 :=
begin
  classical,
  simp only [coord_apply, hi, finset.affine_combination_eq_linear_combination, if_false, mul_boole,
    hw, function.comp_app, smul_eq_mul, s.sum_ite_eq, s.map_affine_combination b.points w hw],
end

@[simp] lemma sum_coord_apply_eq_one [fintype ι] (q : P) :
  ∑ i, b.coord i q = 1 :=
begin
  have hq : q ∈ affine_span k (range b.points), { rw b.tot, exact affine_subspace.mem_top k V q, },
  obtain ⟨w, hw, rfl⟩ := eq_affine_combination_of_mem_affine_span_of_fintype hq,
  convert hw,
  ext i,
  exact b.coord_apply_combination_of_mem (finset.mem_univ i) hw,
end

@[simp] lemma affine_combination_coord_eq_self [fintype ι] (q : P) :
  finset.univ.affine_combination b.points (λ i, b.coord i q) = q :=
begin
  have hq : q ∈ affine_span k (range b.points), { rw b.tot, exact affine_subspace.mem_top k V q, },
  obtain ⟨w, hw, rfl⟩ := eq_affine_combination_of_mem_affine_span_of_fintype hq,
  congr,
  ext i,
  exact b.coord_apply_combination_of_mem (finset.mem_univ i) hw,
end

lemma ext_elem [fintype ι] {q₁ q₂ : P} (h : ∀ i, b.coord i q₁ = b.coord i q₂) : q₁ = q₂ :=
begin
  rw [← b.affine_combination_coord_eq_self q₁, ← b.affine_combination_coord_eq_self q₂],
  simp only [h],
end

@[simp] lemma coe_coord_of_subsingleton_eq_one [subsingleton ι] (i : ι) :
  (b.coord i : P → k) = 1 :=
begin
  ext q,
  have hp : (range b.points).subsingleton,
  { rw ← image_univ,
    apply subsingleton.image,
    apply subsingleton_of_subsingleton, },
  haveI := affine_subspace.subsingleton_of_subsingleton_span_eq_top hp b.tot,
  let s : finset ι := {i},
  have hi : i ∈ s, { simp, },
  have hw : s.sum (function.const ι (1 : k)) = 1, { simp, },
  have hq : q = s.affine_combination b.points (function.const ι (1 : k)), { simp, },
  rw [pi.one_apply, hq, b.coord_apply_combination_of_mem hi hw],
end

lemma surjective_coord [nontrivial ι] (i : ι) :
  function.surjective $ b.coord i :=
begin
  classical,
  intros x,
  obtain ⟨j, hij⟩ := exists_ne i,
  let s : finset ι := {i, j},
  have hi : i ∈ s, { simp, },
  have hj : j ∈ s, { simp, },
  let w : ι → k := λ j', if j' = i then x else 1-x,
  have hw : s.sum w = 1, { simp [hij, finset.sum_ite, finset.filter_insert, finset.filter_eq'], },
  use s.affine_combination b.points w,
  simp [b.coord_apply_combination_of_mem hi hw],
end

/-- Barycentric coordinates as an affine map. -/
noncomputable def coords : P →ᵃ[k] ι → k :=
{ to_fun    := λ q i, b.coord i q,
  linear    :=
  { to_fun    := λ v i, -(b.basis_of i).sum_coords v,
    map_add'  := λ v w, by { ext i, simp only [linear_map.map_add, pi.add_apply, neg_add], },
    map_smul' := λ t v, by { ext i, simpa only [linear_map.map_smul, pi.smul_apply, smul_neg] } },
  map_vadd' := λ p v, by
    { ext i,
      simp only [linear_eq_sum_coords, linear_map.coe_mk, linear_map.neg_apply, pi.vadd_apply',
        affine_map.map_vadd], }, }

@[simp] lemma coords_apply (q : P) (i : ι) :
  b.coords q i = b.coord i q :=
rfl

/-- Given an affine basis `p`, and a family of points `q : ι' → P`, this is the matrix whose
rows are the barycentric coordinates of `q` with respect to `p`.

It is an affine equivalent of `basis.to_matrix`. -/
noncomputable def to_matrix {ι' : Type*} (q : ι' → P) : matrix ι' ι k :=
λ i j, b.coord j (q i)

@[simp] lemma to_matrix_apply {ι' : Type*} (q : ι' → P) (i : ι') (j : ι) :
  b.to_matrix q i j = b.coord j (q i) :=
rfl

@[simp] lemma to_matrix_self [decidable_eq ι] :
  b.to_matrix b.points = (1 : matrix ι ι k) :=
begin
  ext i j,
  rw [to_matrix_apply, coord_apply, matrix.one_eq_pi_single, pi.single_apply],
end

variables {ι' : Type*} [fintype ι'] [fintype ι] (b₂ : affine_basis ι k P)

lemma to_matrix_row_sum_one {ι' : Type*} (q : ι' → P) (i : ι') :
  ∑ j, b.to_matrix q i j = 1 :=
by simp

/-- Given a family of points `p : ι' → P` and an affine basis `b`, if the matrix whose rows are the
coordinates of `p` with respect `b` has a right inverse, then `p` is affine independent. -/
lemma affine_independent_of_to_matrix_right_inv [decidable_eq ι']
  (p : ι' → P) {A : matrix ι ι' k} (hA : (b.to_matrix p) ⬝ A = 1) : affine_independent k p :=
begin
  rw affine_independent_iff_eq_of_fintype_affine_combination_eq,
  intros w₁ w₂ hw₁ hw₂ hweq,
  have hweq' : (b.to_matrix p).vec_mul w₁ = (b.to_matrix p).vec_mul w₂,
  { ext j,
    change ∑ i, (w₁ i) • (b.coord j (p i)) = ∑ i, (w₂ i) • (b.coord j (p i)),
    rw [← finset.univ.affine_combination_eq_linear_combination _ _ hw₁,
        ← finset.univ.affine_combination_eq_linear_combination _ _ hw₂,
        ← finset.univ.map_affine_combination p w₁ hw₁,
        ← finset.univ.map_affine_combination p w₂ hw₂, hweq], },
  replace hweq' := congr_arg (λ w, A.vec_mul w) hweq',
  simpa only [matrix.vec_mul_vec_mul, ← matrix.mul_eq_mul, hA, matrix.vec_mul_one] using hweq',
end

/-- Given a family of points `p : ι' → P` and an affine basis `b`, if the matrix whose rows are the
coordinates of `p` with respect `b` has a left inverse, then `p` spans the entire space. -/
lemma affine_span_eq_top_of_to_matrix_left_inv [decidable_eq ι] [nontrivial k]
  (p : ι' → P) {A : matrix ι ι' k} (hA : A ⬝ b.to_matrix p = 1) : affine_span k (range p) = ⊤ :=
begin
  suffices : ∀ i, b.points i ∈ affine_span k (range p),
  { rw [eq_top_iff, ← b.tot, affine_span_le],
    rintros q ⟨i, rfl⟩,
    exact this i, },
  intros i,
  have hAi : ∑ j, A i j = 1,
  { calc ∑ j, A i j = ∑ j, (A i j) * ∑ l, b.to_matrix p j l : by simp
                ... = ∑ j, ∑ l, (A i j) * b.to_matrix p j l : by simp_rw finset.mul_sum
                ... = ∑ l, ∑ j, (A i j) * b.to_matrix p j l : by rw finset.sum_comm
                ... = ∑ l, (A ⬝ b.to_matrix p) i l : rfl
                ... = 1 : by simp [hA, matrix.one_apply, finset.filter_eq], },
  have hbi : b.points i = finset.univ.affine_combination p (A i),
  { apply b.ext_elem,
    intros j,
    rw [b.coord_apply, finset.univ.map_affine_combination _ _ hAi,
      finset.univ.affine_combination_eq_linear_combination _ _ hAi],
    change _ = (A ⬝ b.to_matrix p) i j,
    simp_rw [hA, matrix.one_apply, @eq_comm _ i j],
    congr, },
  rw hbi,
  exact affine_combination_mem_affine_span hAi p,
end

/-- A change of basis formula for barycentric coordinates.

See also `affine_basis.to_matrix_inv_mul_affine_basis_to_matrix`. -/
@[simp] lemma to_matrix_vec_mul_coords (x : P) :
  (b.to_matrix b₂.points).vec_mul (b₂.coords x) = b.coords x :=
begin
  ext j,
  change _ = b.coord j x,
  conv_rhs { rw ← b₂.affine_combination_coord_eq_self x, },
  rw finset.map_affine_combination _ _ _ (b₂.sum_coord_apply_eq_one x),
  simp [matrix.vec_mul, matrix.dot_product, to_matrix_apply, coords],
end

variables [decidable_eq ι]

lemma to_matrix_mul_to_matrix :
  (b.to_matrix b₂.points) ⬝ (b₂.to_matrix b.points) = 1 :=
begin
  ext l m,
  change (b₂.to_matrix b.points).vec_mul (b.coords (b₂.points l)) m = _,
  rw [to_matrix_vec_mul_coords, coords_apply, ← to_matrix_apply, to_matrix_self],
end

lemma is_unit_to_matrix :
  is_unit (b.to_matrix b₂.points) :=
⟨{ val     := b.to_matrix b₂.points,
   inv     := b₂.to_matrix b.points,
   val_inv := b.to_matrix_mul_to_matrix b₂,
   inv_val := b₂.to_matrix_mul_to_matrix b, }, rfl⟩

lemma is_unit_to_matrix_iff [nontrivial k] (p : ι → P) :
  is_unit (b.to_matrix p) ↔ affine_independent k p ∧ affine_span k (range p) = ⊤ :=
begin
  split,
  { rintros ⟨⟨B, A, hA, hA'⟩, (rfl : B = b.to_matrix p)⟩,
    rw matrix.mul_eq_mul at hA hA',
    exact ⟨b.affine_independent_of_to_matrix_right_inv p hA,
           b.affine_span_eq_top_of_to_matrix_left_inv p hA'⟩, },
  { rintros ⟨h_tot, h_ind⟩,
    let b' : affine_basis ι k P := ⟨p, h_tot, h_ind⟩,
    change is_unit (b.to_matrix b'.points),
    exact b.is_unit_to_matrix b', },
end

end ring

section comm_ring

variables [comm_ring k] [module k V] [decidable_eq ι] [fintype ι]
variables (b b₂ : affine_basis ι k P)

/-- A change of basis formula for barycentric coordinates.

See also `affine_basis.to_matrix_vec_mul_coords`. -/
@[simp] lemma to_matrix_inv_vec_mul_to_matrix (x : P) :
  (b.to_matrix b₂.points)⁻¹.vec_mul (b.coords x) = b₂.coords x :=
begin
  have hu := b.is_unit_to_matrix b₂,
  rw matrix.is_unit_iff_is_unit_det at hu,
  rw [← b.to_matrix_vec_mul_coords b₂, matrix.vec_mul_vec_mul, matrix.mul_nonsing_inv _ hu,
    matrix.vec_mul_one],
end

/-- If we fix a background affine basis `b`, then for any other basis `b₂`, we can characterise
the barycentric coordinates provided by `b₂` in terms of determinants relative to `b`. -/
lemma det_smul_coords_eq_cramer_coords (x : P) :
  (b.to_matrix b₂.points).det • b₂.coords x = (b.to_matrix b₂.points)ᵀ.cramer (b.coords x) :=
begin
  have hu := b.is_unit_to_matrix b₂,
  rw matrix.is_unit_iff_is_unit_det at hu,
  rw [← b.to_matrix_inv_vec_mul_to_matrix, matrix.det_smul_inv_vec_mul_eq_cramer_transpose _ _ hu],
end

end comm_ring

section field

-- TODO Relax `field` to `division_ring` (results are still true)
variables [field k] [module k V]
include V

variables (k V P)

lemma exists_affine_basis : ∃ (s : set P), nonempty (affine_basis ↥s k P) :=
begin
  obtain ⟨s, -, h_tot, h_ind⟩ := exists_affine_independent k V (set.univ : set P),
  refine ⟨s, ⟨⟨(coe : s → P), h_ind, _⟩⟩⟩,
  rw [subtype.range_coe, h_tot, affine_subspace.span_univ],
end

variables {k V P}

lemma exists_affine_basis_of_finite_dimensional {ι : Type*} [fintype ι] [finite_dimensional k V]
  (h : fintype.card ι = finite_dimensional.finrank k V + 1) :
  nonempty (affine_basis ι k P) :=
begin
  obtain ⟨s, ⟨⟨incl, h_ind, h_tot⟩⟩⟩ := affine_basis.exists_affine_basis k V P,
  haveI : fintype s := fintype_of_fin_dim_affine_independent k h_ind,
  have hs : fintype.card ι = fintype.card s,
  { rw h, exact (h_ind.affine_span_eq_top_iff_card_eq_finrank_add_one.mp h_tot).symm, },
  rw ← affine_independent_equiv (fintype.equiv_of_card_eq hs) at h_ind,
  refine ⟨⟨_, h_ind, _⟩⟩,
  rw range_comp,
  simp [h_tot],
end

end field

end affine_basis


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.algebra_map
import data.polynomial.inductions
import data.polynomial.monic
import ring_theory.multiplicity

/-!
# Division of univariate polynomials

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

The main defs are `div_by_monic` and `mod_by_monic`.
The compatibility between these is given by `mod_by_monic_add_div`.
We also define `root_multiplicity`.
-/

noncomputable theory
open_locale classical big_operators polynomial

open finset
namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {a b : R} {n : ℕ}

section comm_semiring
variables [comm_semiring R]

theorem X_dvd_iff {f : R[X]} : X ∣ f ↔ f.coeff 0 = 0 :=
⟨λ ⟨g, hfg⟩, by rw [hfg, mul_comm, coeff_mul_X_zero],
λ hf, ⟨f.div_X, by rw [mul_comm, ← add_zero (f.div_X * X), ← C_0, ← hf, div_X_mul_X_add]⟩⟩

theorem X_pow_dvd_iff {f : R[X]} {n : ℕ} :
  X^n ∣ f ↔ ∀ d < n, f.coeff d = 0 :=
⟨λ ⟨g, hgf⟩ d hd, by simp only [hgf, coeff_X_pow_mul', ite_eq_right_iff, not_le_of_lt hd,
    is_empty.forall_iff], λ hd,
begin
  induction n with n hn,
  { simp only [pow_zero, one_dvd] },
  { obtain ⟨g, hgf⟩ := hn (λ d : ℕ, λ H : d < n, hd _ (nat.lt_succ_of_lt H)),
    have := coeff_X_pow_mul g n 0,
    rw [zero_add, ← hgf, hd n (nat.lt_succ_self n)] at this,
    obtain ⟨k, hgk⟩ := polynomial.X_dvd_iff.mpr this.symm,
    use k,
    rwa [pow_succ, mul_comm X _, mul_assoc, ← hgk]},
end⟩

end comm_semiring

section comm_semiring

variables [comm_semiring R] {p q : R[X]}

lemma multiplicity_finite_of_degree_pos_of_monic (hp : (0 : with_bot ℕ) < degree p)
  (hmp : monic p) (hq : q ≠ 0) : multiplicity.finite p q :=
have zn0 : (0 : R) ≠ 1, by haveI := nontrivial.of_polynomial_ne hq; exact zero_ne_one,
⟨nat_degree q, λ ⟨r, hr⟩,
  have hp0 : p ≠ 0, from λ hp0, by simp [hp0] at hp; contradiction,
  have hr0 : r ≠ 0, from λ hr0, by simp * at *,
  have hpn1 : leading_coeff p ^ (nat_degree q + 1) = 1,
    by simp [show _ = _, from hmp],
  have hpn0' : leading_coeff p ^ (nat_degree q + 1) ≠ 0,
    from hpn1.symm ▸ zn0.symm,
  have hpnr0 : leading_coeff (p ^ (nat_degree q + 1)) * leading_coeff r ≠ 0,
    by simp only [leading_coeff_pow' hpn0', leading_coeff_eq_zero, hpn1,
      one_pow, one_mul, ne.def, hr0]; simp,
  have hnp : 0 < nat_degree p,
    by rw [← with_bot.coe_lt_coe, ← degree_eq_nat_degree hp0];
    exact hp,
  begin
    have := congr_arg nat_degree hr,
    rw [nat_degree_mul' hpnr0,  nat_degree_pow' hpn0', add_mul, add_assoc] at this,
    exact ne_of_lt (lt_add_of_le_of_pos (le_mul_of_one_le_right (nat.zero_le _) hnp)
      (add_pos_of_pos_of_nonneg (by rwa one_mul) (nat.zero_le _))) this
  end⟩

end comm_semiring

section ring
variables [ring R] {p q : R[X]}

lemma div_wf_lemma (h : degree q ≤ degree p ∧ p ≠ 0) (hq : monic q) :
  degree (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) < degree p :=
have hp : leading_coeff p ≠ 0 := mt leading_coeff_eq_zero.1 h.2,
  have hq0 : q ≠ 0 := hq.ne_zero_of_polynomial_ne h.2,
  have hlt : nat_degree q ≤ nat_degree p := with_bot.coe_le_coe.1
    (by rw [← degree_eq_nat_degree h.2, ← degree_eq_nat_degree hq0];
    exact h.1),
  degree_sub_lt
  (by rw [hq.degree_mul, degree_C_mul_X_pow _ hp, degree_eq_nat_degree h.2,
      degree_eq_nat_degree hq0, ← with_bot.coe_add, tsub_add_cancel_of_le hlt])
  h.2
  (by rw [leading_coeff_mul_monic hq, leading_coeff_mul_X_pow, leading_coeff_C])

/-- See `div_by_monic`. -/
noncomputable def div_mod_by_monic_aux : Π (p : R[X]) {q : R[X]},
  monic q → R[X] × R[X]
| p := λ q hq, if h : degree q ≤ degree p ∧ p ≠ 0 then
  let z := C (leading_coeff p) * X^(nat_degree p - nat_degree q)  in
  have wf : _ := div_wf_lemma h hq,
  let dm := div_mod_by_monic_aux (p - z * q) hq in
  ⟨z + dm.1, dm.2⟩
  else ⟨0, p⟩
using_well_founded {dec_tac := tactic.assumption}

/-- `div_by_monic` gives the quotient of `p` by a monic polynomial `q`. -/
def div_by_monic (p q : R[X]) : R[X] :=
if hq : monic q then (div_mod_by_monic_aux p hq).1 else 0

/-- `mod_by_monic` gives the remainder of `p` by a monic polynomial `q`. -/
def mod_by_monic (p q : R[X]) : R[X] :=
if hq : monic q then (div_mod_by_monic_aux p hq).2 else p

infixl  ` /ₘ ` : 70 := div_by_monic

infixl ` %ₘ ` : 70 := mod_by_monic

lemma degree_mod_by_monic_lt [nontrivial R] : ∀ (p : R[X]) {q : R[X]}
  (hq : monic q), degree (p %ₘ q) < degree q
| p := λ q hq,
if h : degree q ≤ degree p ∧ p ≠ 0 then
  have wf : _ := div_wf_lemma ⟨h.1, h.2⟩ hq,
  have degree ((p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) %ₘ q) < degree q :=
      degree_mod_by_monic_lt (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q)
      hq,
  begin
    unfold mod_by_monic at this ⊢,
    unfold div_mod_by_monic_aux,
    rw dif_pos hq at this ⊢,
    rw if_pos h,
    exact this
  end
else
  or.cases_on (not_and_distrib.1 h) begin
    unfold mod_by_monic div_mod_by_monic_aux,
    rw [dif_pos hq, if_neg h],
    exact lt_of_not_ge,
  end
  begin
    assume hp,
    unfold mod_by_monic div_mod_by_monic_aux,
    rw [dif_pos hq, if_neg h, not_not.1 hp],
    exact lt_of_le_of_ne bot_le
      (ne.symm (mt degree_eq_bot.1 hq.ne_zero)),
  end
using_well_founded {dec_tac := tactic.assumption}

@[simp] lemma zero_mod_by_monic (p : R[X]) : 0 %ₘ p = 0 :=
begin
  unfold mod_by_monic div_mod_by_monic_aux,
  by_cases hp : monic p,
  { rw [dif_pos hp, if_neg (mt and.right (not_not_intro rfl))] },
  { rw [dif_neg hp] }
end

@[simp] lemma zero_div_by_monic (p : R[X]) : 0 /ₘ p = 0 :=
begin
  unfold div_by_monic div_mod_by_monic_aux,
  by_cases hp : monic p,
  { rw [dif_pos hp, if_neg (mt and.right (not_not_intro rfl))] },
  { rw [dif_neg hp] }
end

@[simp] lemma mod_by_monic_zero (p : R[X]) : p %ₘ 0 = p :=
if h : monic (0 : R[X]) then by { haveI := monic_zero_iff_subsingleton.mp h, simp }
else by unfold mod_by_monic div_mod_by_monic_aux; rw dif_neg h

@[simp] lemma div_by_monic_zero (p : R[X]) : p /ₘ 0 = 0 :=
if h : monic (0 : R[X]) then by { haveI := monic_zero_iff_subsingleton.mp h, simp }
else by unfold div_by_monic div_mod_by_monic_aux; rw dif_neg h

lemma div_by_monic_eq_of_not_monic (p : R[X]) (hq : ¬monic q) : p /ₘ q = 0 := dif_neg hq

lemma mod_by_monic_eq_of_not_monic (p : R[X]) (hq : ¬monic q) : p %ₘ q = p := dif_neg hq

lemma mod_by_monic_eq_self_iff [nontrivial R] (hq : monic q) : p %ₘ q = p ↔ degree p < degree q :=
⟨λ h, h ▸ degree_mod_by_monic_lt _ hq,
λ h, have ¬ degree q ≤ degree p := not_le_of_gt h,
  by unfold mod_by_monic div_mod_by_monic_aux; rw [dif_pos hq, if_neg (mt and.left this)]⟩

theorem degree_mod_by_monic_le (p : R[X]) {q : R[X]}
  (hq : monic q) : degree (p %ₘ q) ≤ degree q :=
by { nontriviality R, exact (degree_mod_by_monic_lt _ hq).le }

end ring

section comm_ring
variables [comm_ring R] {p q : R[X]}

lemma mod_by_monic_eq_sub_mul_div : ∀ (p : R[X]) {q : R[X]} (hq : monic q),
  p %ₘ q = p - q * (p /ₘ q)
| p := λ q hq,
  if h : degree q ≤ degree p ∧ p ≠ 0 then
    have wf : _ := div_wf_lemma h hq,
    have ih : _ := mod_by_monic_eq_sub_mul_div
      (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) hq,
    begin
      unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
      rw [dif_pos hq, if_pos h],
      rw [mod_by_monic, dif_pos hq] at ih,
      refine ih.trans _,
      unfold div_by_monic,
      rw [dif_pos hq, dif_pos hq, if_pos h, mul_add, sub_add_eq_sub_sub, mul_comm]
    end
  else
    begin
      unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
      rw [dif_pos hq, if_neg h, dif_pos hq, if_neg h, mul_zero, sub_zero]
    end
using_well_founded {dec_tac := tactic.assumption}

lemma mod_by_monic_add_div (p : R[X]) {q : R[X]} (hq : monic q) :
  p %ₘ q + q * (p /ₘ q) = p := eq_sub_iff_add_eq.1 (mod_by_monic_eq_sub_mul_div p hq)

lemma div_by_monic_eq_zero_iff [nontrivial R] (hq : monic q) : p /ₘ q = 0 ↔ degree p < degree q :=
⟨λ h, by have := mod_by_monic_add_div p hq;
  rwa [h, mul_zero, add_zero, mod_by_monic_eq_self_iff hq] at this,
λ h, have ¬ degree q ≤ degree p := not_le_of_gt h,
  by unfold div_by_monic div_mod_by_monic_aux; rw [dif_pos hq, if_neg (mt and.left this)]⟩

lemma degree_add_div_by_monic (hq : monic q) (h : degree q ≤ degree p) :
  degree q + degree (p /ₘ q) = degree p :=
begin
  nontriviality R,
  have hdiv0 : p /ₘ q ≠ 0 := by rwa [(≠), div_by_monic_eq_zero_iff hq, not_lt],
  have hlc : leading_coeff q * leading_coeff (p /ₘ q) ≠ 0 :=
    by rwa [monic.def.1 hq, one_mul, (≠), leading_coeff_eq_zero],
  have hmod : degree (p %ₘ q) < degree (q * (p /ₘ q)) :=
    calc degree (p %ₘ q) < degree q : degree_mod_by_monic_lt _ hq
    ... ≤ _ : by rw [degree_mul' hlc, degree_eq_nat_degree hq.ne_zero,
        degree_eq_nat_degree hdiv0, ← with_bot.coe_add, with_bot.coe_le_coe];
      exact nat.le_add_right _ _,
  calc degree q + degree (p /ₘ q) = degree (q * (p /ₘ q)) : eq.symm (degree_mul' hlc)
  ... = degree (p %ₘ q + q * (p /ₘ q)) : (degree_add_eq_right_of_degree_lt hmod).symm
  ... = _ : congr_arg _ (mod_by_monic_add_div _ hq)
end

lemma degree_div_by_monic_le (p q : R[X]) : degree (p /ₘ q) ≤ degree p :=
if hp0 : p = 0 then by simp only [hp0, zero_div_by_monic, le_refl]
else if hq : monic q then
  if h : degree q ≤ degree p
  then by haveI := nontrivial.of_polynomial_ne hp0;
    rw [← degree_add_div_by_monic hq h, degree_eq_nat_degree hq.ne_zero,
      degree_eq_nat_degree (mt (div_by_monic_eq_zero_iff hq).1 (not_lt.2 h))];
    exact with_bot.coe_le_coe.2 (nat.le_add_left _ _)
  else
    by unfold div_by_monic div_mod_by_monic_aux;
      simp only [dif_pos hq, h, false_and, if_false, degree_zero, bot_le]
else (div_by_monic_eq_of_not_monic p hq).symm ▸ bot_le

lemma degree_div_by_monic_lt (p : R[X]) {q : R[X]} (hq : monic q)
  (hp0 : p ≠ 0) (h0q : 0 < degree q) : degree (p /ₘ q) < degree p :=
if hpq : degree p < degree q
then begin
  haveI := nontrivial.of_polynomial_ne hp0,
  rw [(div_by_monic_eq_zero_iff hq).2 hpq, degree_eq_nat_degree hp0],
  exact with_bot.bot_lt_coe _
end
else begin
  haveI := nontrivial.of_polynomial_ne hp0,
  rw [← degree_add_div_by_monic hq (not_lt.1 hpq), degree_eq_nat_degree hq.ne_zero,
        degree_eq_nat_degree (mt (div_by_monic_eq_zero_iff hq).1 hpq)],
  exact with_bot.coe_lt_coe.2 (nat.lt_add_of_pos_left
    (with_bot.coe_lt_coe.1 $ (degree_eq_nat_degree hq.ne_zero) ▸ h0q))
end

theorem nat_degree_div_by_monic {R : Type u} [comm_ring R] (f : R[X]) {g : R[X]}
  (hg : g.monic) : nat_degree (f /ₘ g) = nat_degree f - nat_degree g :=
begin
  nontriviality R,
  by_cases hfg : f /ₘ g = 0,
  { rw [hfg, nat_degree_zero], rw div_by_monic_eq_zero_iff hg at hfg,
    rw tsub_eq_zero_iff_le.mpr (nat_degree_le_nat_degree $ le_of_lt hfg) },
  have hgf := hfg, rw div_by_monic_eq_zero_iff hg at hgf, push_neg at hgf,
  have := degree_add_div_by_monic hg hgf,
  have hf : f ≠ 0, { intro hf, apply hfg, rw [hf, zero_div_by_monic] },
  rw [degree_eq_nat_degree hf, degree_eq_nat_degree hg.ne_zero, degree_eq_nat_degree hfg,
      ← with_bot.coe_add, with_bot.coe_eq_coe] at this,
  rw [← this, add_tsub_cancel_left]
end

lemma div_mod_by_monic_unique {f g} (q r : R[X]) (hg : monic g)
  (h : r + g * q = f ∧ degree r < degree g) : f /ₘ g = q ∧ f %ₘ g = r :=
begin
  nontriviality R,
  have h₁ : r - f %ₘ g = -g * (q - f /ₘ g),
    from eq_of_sub_eq_zero
      (by rw [← sub_eq_zero_of_eq (h.1.trans (mod_by_monic_add_div f hg).symm)];
        simp [mul_add, mul_comm, sub_eq_add_neg, add_comm, add_left_comm, add_assoc]),
  have h₂ : degree (r - f %ₘ g) = degree (g * (q - f /ₘ g)),
    by simp [h₁],
  have h₄ : degree (r - f %ₘ g) < degree g,
    from calc degree (r - f %ₘ g) ≤ max (degree r) (degree (f %ₘ g)) :
      degree_sub_le _ _
    ... < degree g : max_lt_iff.2 ⟨h.2, degree_mod_by_monic_lt _ hg⟩,
  have h₅ : q - (f /ₘ g) = 0,
    from by_contradiction
      (λ hqf, not_le_of_gt h₄ $
        calc degree g ≤ degree g + degree (q - f /ₘ g) :
          by erw [degree_eq_nat_degree hg.ne_zero, degree_eq_nat_degree hqf,
              with_bot.coe_le_coe];
            exact nat.le_add_right _ _
        ... = degree (r - f %ₘ g) :
          by rw [h₂, degree_mul']; simpa [monic.def.1 hg]),
  exact ⟨eq.symm $ eq_of_sub_eq_zero h₅,
    eq.symm $ eq_of_sub_eq_zero $ by simpa [h₅] using h₁⟩
end

lemma map_mod_div_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p /ₘ q).map f = p.map f /ₘ q.map f ∧ (p %ₘ q).map f = p.map f %ₘ q.map f :=
begin
  nontriviality S,
  haveI : nontrivial R := f.domain_nontrivial,
  have : map f p /ₘ map f q = map f (p /ₘ q) ∧ map f p %ₘ map f q = map f (p %ₘ q),
  { exact (div_mod_by_monic_unique ((p /ₘ q).map f) _ (hq.map f)
      ⟨eq.symm $ by rw [← polynomial.map_mul, ← polynomial.map_add, mod_by_monic_add_div _ hq],
      calc _ ≤ degree (p %ₘ q) : degree_map_le _ _
      ... < degree q : degree_mod_by_monic_lt _ hq
      ... = _ : eq.symm $ degree_map_eq_of_leading_coeff_ne_zero _
        (by rw [monic.def.1 hq, f.map_one]; exact one_ne_zero)⟩) },
  exact ⟨this.1.symm, this.2.symm⟩
end

lemma map_div_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p /ₘ q).map f = p.map f /ₘ q.map f :=
(map_mod_div_by_monic f hq).1

lemma map_mod_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p %ₘ q).map f = p.map f %ₘ q.map f :=
(map_mod_div_by_monic f hq).2

lemma dvd_iff_mod_by_monic_eq_zero (hq : monic q) : p %ₘ q = 0 ↔ q ∣ p :=
⟨λ h, by rw [← mod_by_monic_add_div p hq, h, zero_add];
  exact dvd_mul_right _ _,
λ h, begin
  nontriviality R,
  obtain ⟨r, hr⟩ := exists_eq_mul_right_of_dvd h,
  by_contradiction hpq0,
  have hmod : p %ₘ q = q * (r - p /ₘ q),
  { rw [mod_by_monic_eq_sub_mul_div _ hq, mul_sub, ← hr] },
  have : degree (q * (r - p /ₘ q)) < degree q :=
    hmod ▸ degree_mod_by_monic_lt _ hq,
  have hrpq0 : leading_coeff (r - p /ₘ q) ≠ 0 :=
    λ h, hpq0 $ leading_coeff_eq_zero.1
      (by rw [hmod, leading_coeff_eq_zero.1 h, mul_zero, leading_coeff_zero]),
  have hlc : leading_coeff q * leading_coeff (r - p /ₘ q) ≠ 0 :=
    by rwa [monic.def.1 hq, one_mul],
  rw [degree_mul' hlc, degree_eq_nat_degree hq.ne_zero,
      degree_eq_nat_degree (mt leading_coeff_eq_zero.2 hrpq0)] at this,
    exact not_lt_of_ge (nat.le_add_right _ _) (with_bot.some_lt_some.1 this)
end⟩

theorem map_dvd_map [comm_ring S] (f : R →+* S) (hf : function.injective f) {x y : R[X]}
  (hx : x.monic) : x.map f ∣ y.map f ↔ x ∣ y :=
begin
  rw [← dvd_iff_mod_by_monic_eq_zero hx, ← dvd_iff_mod_by_monic_eq_zero (hx.map f),
    ← map_mod_by_monic f hx],
  exact ⟨λ H, map_injective f hf $ by rw [H, polynomial.map_zero],
  λ H, by rw [H, polynomial.map_zero]⟩
end

@[simp] lemma mod_by_monic_one (p : R[X]) : p %ₘ 1 = 0 :=
(dvd_iff_mod_by_monic_eq_zero (by convert monic_one)).2 (one_dvd _)

@[simp] lemma div_by_monic_one (p : R[X]) : p /ₘ 1 = p :=
by conv_rhs { rw [← mod_by_monic_add_div p monic_one] }; simp

@[simp] lemma mod_by_monic_X_sub_C_eq_C_eval (p : R[X]) (a : R) :
  p %ₘ (X - C a) = C (p.eval a) :=
begin
  nontriviality R,
  have h : (p %ₘ (X - C a)).eval a = p.eval a,
  { rw [mod_by_monic_eq_sub_mul_div _ (monic_X_sub_C a), eval_sub, eval_mul,
        eval_sub, eval_X, eval_C, sub_self, zero_mul, sub_zero] },
  have : degree (p %ₘ (X - C a)) < 1 :=
    degree_X_sub_C a ▸ degree_mod_by_monic_lt p (monic_X_sub_C a),
  have : degree (p %ₘ (X - C a)) ≤ 0,
  { cases (degree (p %ₘ (X - C a))),
    { exact bot_le },
    { exact with_bot.some_le_some.2 (nat.le_of_lt_succ (with_bot.some_lt_some.1 this)) } },
  rw [eq_C_of_degree_le_zero this, eval_C] at h,
  rw [eq_C_of_degree_le_zero this, h]
end

lemma mul_div_by_monic_eq_iff_is_root : (X - C a) * (p /ₘ (X - C a)) = p ↔ is_root p a :=
⟨λ h, by rw [← h, is_root.def, eval_mul, eval_sub, eval_X, eval_C, sub_self, zero_mul],
λ h : p.eval a = 0,
  by conv {to_rhs, rw ← mod_by_monic_add_div p (monic_X_sub_C a)};
    rw [mod_by_monic_X_sub_C_eq_C_eval, h, C_0, zero_add]⟩

lemma dvd_iff_is_root : (X - C a) ∣ p ↔ is_root p a :=
⟨λ h, by rwa [← dvd_iff_mod_by_monic_eq_zero (monic_X_sub_C _),
    mod_by_monic_X_sub_C_eq_C_eval, ← C_0, C_inj] at h,
  λ h, ⟨(p /ₘ (X - C a)), by rw mul_div_by_monic_eq_iff_is_root.2 h⟩⟩

lemma mod_by_monic_X (p : R[X]) : p %ₘ X = C (p.eval 0) :=
by rw [← mod_by_monic_X_sub_C_eq_C_eval, C_0, sub_zero]

lemma eval₂_mod_by_monic_eq_self_of_root [comm_ring S] {f : R →+* S}
  {p q : R[X]} (hq : q.monic) {x : S} (hx : q.eval₂ f x = 0) :
  (p %ₘ q).eval₂ f x = p.eval₂ f x :=
by rw [mod_by_monic_eq_sub_mul_div p hq, eval₂_sub, eval₂_mul, hx, zero_mul, sub_zero]

lemma sum_mod_by_monic_coeff (hq : q.monic) {n : ℕ} (hn : q.degree ≤ n) :
  ∑ (i : fin n), monomial i ((p %ₘ q).coeff i) = p %ₘ q :=
begin
  nontriviality R,
  exact (sum_fin (λ i c, monomial i c) (by simp)
    ((degree_mod_by_monic_lt _ hq).trans_le hn)).trans
    (sum_monomial_eq _)
end

lemma sub_dvd_eval_sub (a b : R) (p : R[X]) : a - b ∣ p.eval a - p.eval b :=
begin
  suffices : X - C b ∣ p - C (p.eval b),
  { simpa only [coe_eval_ring_hom, eval_sub, eval_X, eval_C] using (eval_ring_hom a).map_dvd this },
  simp [dvd_iff_is_root]
end

lemma mul_div_mod_by_monic_cancel_left (p : R[X]) {q : R[X]} (hmo : q.monic) : q * p /ₘ q = p :=
begin
  nontriviality R,
  refine (div_mod_by_monic_unique _ 0 hmo ⟨by rw [zero_add], _⟩).1,
  rw [degree_zero],
  exact ne.bot_lt (λ h, hmo.ne_zero (degree_eq_bot.1 h))
end

variable (R)

lemma not_is_field : ¬ is_field R[X] :=
begin
  nontriviality R,
  rw ring.not_is_field_iff_exists_ideal_bot_lt_and_lt_top,
  use ideal.span {polynomial.X},
  split,
  { rw [bot_lt_iff_ne_bot, ne.def, ideal.span_singleton_eq_bot],
    exact polynomial.X_ne_zero, },
  { rw [lt_top_iff_ne_top, ne.def, ideal.eq_top_iff_one, ideal.mem_span_singleton,
      polynomial.X_dvd_iff, polynomial.coeff_one_zero],
    exact one_ne_zero, }
end

variable {R}

lemma ker_eval_ring_hom (x : R) : (eval_ring_hom x).ker = ideal.span {X - C x} :=
by { ext y, simpa only [ideal.mem_span_singleton, dvd_iff_is_root] }

section multiplicity
/-- An algorithm for deciding polynomial divisibility.
The algorithm is "compute `p %ₘ q` and compare to `0`".
See `polynomial.mod_by_monic` for the algorithm that computes `%ₘ`.
-/
def decidable_dvd_monic (p : R[X]) (hq : monic q) : decidable (q ∣ p) :=
decidable_of_iff (p %ₘ q = 0) (dvd_iff_mod_by_monic_eq_zero hq)

open_locale classical

lemma multiplicity_X_sub_C_finite (a : R) (h0 : p ≠ 0) :
  multiplicity.finite (X - C a) p :=
begin
  haveI := nontrivial.of_polynomial_ne h0,
  refine multiplicity_finite_of_degree_pos_of_monic _ (monic_X_sub_C _) h0,
  rw degree_X_sub_C,
  dec_trivial,
end

/-- The largest power of `X - C a` which divides `p`.
This is computable via the divisibility algorithm `polynomial.decidable_dvd_monic`. -/
def root_multiplicity (a : R) (p : R[X]) : ℕ :=
if h0 : p = 0 then 0
else let I : decidable_pred (λ n : ℕ, ¬(X - C a) ^ (n + 1) ∣ p) :=
  λ n, @not.decidable _ (decidable_dvd_monic p ((monic_X_sub_C a).pow (n + 1))) in
by exactI nat.find (multiplicity_X_sub_C_finite a h0)

lemma root_multiplicity_eq_multiplicity (p : R[X]) (a : R) :
  root_multiplicity a p = if h0 : p = 0 then 0 else
  (multiplicity (X - C a) p).get (multiplicity_X_sub_C_finite a h0) :=
by simp [multiplicity, root_multiplicity, part.dom];
  congr; funext; congr

@[simp] lemma root_multiplicity_zero {x : R} : root_multiplicity x 0 = 0 := dif_pos rfl

@[simp] lemma root_multiplicity_eq_zero_iff {p : R[X]} {x : R} :
  root_multiplicity x p = 0 ↔ (is_root p x → p = 0) :=
by simp only [root_multiplicity_eq_multiplicity, dite_eq_left_iff, part_enat.get_eq_iff_eq_coe,
  nat.cast_zero, multiplicity.multiplicity_eq_zero, dvd_iff_is_root, not_imp_not]

lemma root_multiplicity_eq_zero {p : R[X]} {x : R} (h : ¬ is_root p x) :
  root_multiplicity x p = 0 :=
root_multiplicity_eq_zero_iff.2 (λ h', (h h').elim)

@[simp] lemma root_multiplicity_pos' {p : R[X]} {x : R} :
  0 < root_multiplicity x p ↔ p ≠ 0 ∧ is_root p x :=
by rw [pos_iff_ne_zero, ne.def, root_multiplicity_eq_zero_iff, not_imp, and.comm]

lemma root_multiplicity_pos {p : R[X]} (hp : p ≠ 0) {x : R} :
  0 < root_multiplicity x p ↔ is_root p x :=
root_multiplicity_pos'.trans (and_iff_right hp)

@[simp] lemma root_multiplicity_C (r a : R) : root_multiplicity a (C r) = 0 :=
by simp only [root_multiplicity_eq_zero_iff, is_root, eval_C, C_eq_zero, imp_self]

lemma pow_root_multiplicity_dvd (p : R[X]) (a : R) :
  (X - C a) ^ root_multiplicity a p ∣ p :=
if h : p = 0 then by simp [h]
else by rw [root_multiplicity_eq_multiplicity, dif_neg h];
  exact multiplicity.pow_multiplicity_dvd _

lemma div_by_monic_mul_pow_root_multiplicity_eq
  (p : R[X]) (a : R) :
  p /ₘ ((X - C a) ^ root_multiplicity a p) *
  (X - C a) ^ root_multiplicity a p = p :=
have monic ((X - C a) ^ root_multiplicity a p),
  from (monic_X_sub_C _).pow _,
by conv_rhs { rw [← mod_by_monic_add_div p this,
    (dvd_iff_mod_by_monic_eq_zero this).2 (pow_root_multiplicity_dvd _ _)] };
  simp [mul_comm]

lemma eval_div_by_monic_pow_root_multiplicity_ne_zero
  {p : R[X]} (a : R) (hp : p ≠ 0) :
  eval a (p /ₘ ((X - C a) ^ root_multiplicity a p)) ≠ 0 :=
begin
  haveI : nontrivial R := nontrivial.of_polynomial_ne hp,
  rw [ne.def, ← is_root.def, ← dvd_iff_is_root],
  rintros ⟨q, hq⟩,
  have := div_by_monic_mul_pow_root_multiplicity_eq p a,
  rw [mul_comm, hq, ← mul_assoc, ← pow_succ',
    root_multiplicity_eq_multiplicity, dif_neg hp] at this,
  exact multiplicity.is_greatest'
    (multiplicity_finite_of_degree_pos_of_monic
    (show (0 : with_bot ℕ) < degree (X - C a),
      by rw degree_X_sub_C; exact dec_trivial) (monic_X_sub_C _) hp)
    (nat.lt_succ_self _) (dvd_of_mul_right_eq _ this)
end

end multiplicity
end comm_ring

end polynomial


/-
  Package the definition of an open cover of an open set.
-/

import topology.basic
import topology.opens
import to_mathlib.opens

universes u

open topological_space lattice

section covering

variables {α : Type u} [topological_space α]

-- Open cover.

structure covering (U : opens α) :=
{γ    : Type u}
(Uis  : γ → opens α)
(Hcov : ⋃ Uis = U)

variable (α)

def covering.univ := covering (@opens.univ α _)

variable {α}

-- If ⋃ Ui = U then for all i, Ui ⊆ U.

lemma subset_covering {U : opens α} {OC : covering U} :
∀ i, OC.Uis i ⊆ U :=
λ i x Hx, OC.Hcov ▸ opens_supr_mem OC.Uis i x Hx

-- Make covering from standard definition. Used for instance in compactness.

def opens.from_sets {A : Type*} [topological_space A]
: set (set A) → set (opens A) := λ C, { x | x.1 ∈ C }

lemma opens.from_sets.eq {A : Type*} [topological_space A]
(S : set (set A)) (HS : ∀ (t : set A), t ∈ S → is_open t)
: subtype.val '' (opens.from_sets S) = S :=
set.ext $ λ x, ⟨
  λ ⟨x', Hx', Hval⟩, Hval ▸ Hx',
  λ Hx, by simp [HS x Hx]; by exact Hx⟩

@[reducible] def covering.from_cover {A : Type*} [topological_space A]
(U     : opens A)
(C     : set (set A))
(HC    : ∀ (t : set A), t ∈ C → is_open t)
(Hcov : U.1 = ⋃₀ C)
: covering U :=
{ γ := opens.from_sets C,
  Uis := λ x, x,
  Hcov :=
    begin
      apply subtype.ext.2,
      rw Hcov,
      apply set.ext,
      intros x,
      split,
      { intros Hx,
        rcases Hx with ⟨U, HU, HxU⟩,
        existsi U,
        simp at HU,
        rcases HU with ⟨OU, HU⟩,
        rw ←opens.from_sets.eq C HC,
        split,
        { simp [HU],
          use OU, },
        { exact HxU, } },
      { intros Hx,
        rcases Hx with ⟨U, HU, HxU⟩,
        use U,
        simp,
        use (HC U HU),
        { simp [opens.from_sets],
          exact HU, },
        { exact HxU, }  }
    end, }

lemma covering.from_cover.Uis {A : Type*} [topological_space A]
(U     : opens A)
(C     : set (set A))
(HC    : ∀ (t : set A), t ∈ C → is_open t)
(Hcov : U.1 = ⋃₀ C)
: ∀ i, ((covering.from_cover U C HC Hcov).Uis i).1 ∈ C :=
begin
  intros i,
  simp [covering.from_cover] at *,
  cases i with i Hi,
  simp,
  simp [opens.from_sets] at *,
  exact Hi,
end

-- TODO -- should be in mathlib?
lemma opens.supr_val {X γ : Type*} [topological_space X] (ι : γ → opens X) :
  (⨆ i, ι i).val = ⨆ i, (ι i).val :=
@galois_connection.l_supr (opens X) (set X) _ _ _ (subtype.val : opens X → set X)
    opens.interior opens.gc _

--lemma opens.supr_comap_val {X Y : Type*} [topological_space X] [topological_space Y] {f : X → Y}
--  (hf : continuous f) {γ : Type*}
--  (ι : γ → opens Y) :
--(⨆ (j : γ), hf.comap (ι j)).val = set.Union (λ (j : γ), f ⁻¹' (ι j).val) :=
--by simp [set.ext_iff, opens.supr_val, continuous.comap]

/-- pullback of a covering is a covering -/
def covering.comap {X Y : Type*} [topological_space X] [topological_space Y]
  {U : opens Y} (OC : covering U) {f : X → Y} (hf : continuous f) : covering (hf.comap U) :=
{ γ := OC.γ,
  Uis := λ i, hf.comap $ OC.Uis i,
  Hcov := by simp [subtype.ext, continuous.comap, (subtype.ext.1 OC.Hcov).symm, opens.supr_val]
}

end covering


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.algebra.module.basic
import topology.instances.rat

/-!
# Continuous additive maps are `ℝ`-linear

In this file we prove that a continuous map `f : E →+ F` between two topological vector spaces
over `ℝ` is `ℝ`-linear
-/

variables {E : Type*} [add_comm_group E] [module ℝ E] [topological_space E]
  [has_continuous_smul ℝ E] {F : Type*} [add_comm_group F] [module ℝ F]
  [topological_space F] [has_continuous_smul ℝ F] [t2_space F]

/-- A continuous additive map between two vector spaces over `ℝ` is `ℝ`-linear. -/
lemma map_real_smul {G} [add_monoid_hom_class G E F] (f : G) (hf : continuous f) (c : ℝ) (x : E) :
  f (c • x) = c • f x :=
suffices (λ c : ℝ, f (c • x)) = λ c : ℝ, c • f x, from _root_.congr_fun this c,
rat.dense_embedding_coe_real.dense.equalizer
  (hf.comp $ continuous_id.smul continuous_const)
  (continuous_id.smul continuous_const)
  (funext $ λ r, map_rat_cast_smul f ℝ ℝ r x)

namespace add_monoid_hom

/-- Reinterpret a continuous additive homomorphism between two real vector spaces
as a continuous real-linear map. -/
def to_real_linear_map (f : E →+ F) (hf : continuous f) : E →L[ℝ] F :=
⟨{ to_fun := f, map_add' := f.map_add, map_smul' := map_real_smul f hf }, hf⟩

@[simp] lemma coe_to_real_linear_map (f : E →+ F) (hf : continuous f) :
  ⇑(f.to_real_linear_map hf) = f := rfl

end add_monoid_hom

/-- Reinterpret a continuous additive equivalence between two real vector spaces
as a continuous real-linear map. -/
def add_equiv.to_real_linear_equiv (e : E ≃+ F) (h₁ : continuous e)
  (h₂ : continuous e.symm) : E ≃L[ℝ] F :=
{ .. e,
  .. e.to_add_monoid_hom.to_real_linear_map h₁ }

/-- A topological group carries at most one structure of a topological `ℝ`-module, so for any
topological `ℝ`-algebra `A` (e.g. `A = ℂ`) and any topological group that is both a topological
`ℝ`-module and a topological `A`-module, these structures agree. -/
@[priority 900]
instance real.is_scalar_tower [t2_space E] {A : Type*} [topological_space A]
  [ring A] [algebra ℝ A] [module A E] [has_continuous_smul ℝ A]
  [has_continuous_smul A E] : is_scalar_tower ℝ A E :=
⟨λ r x y, map_real_smul ((smul_add_hom A E).flip y) (continuous_id.smul continuous_const) r x⟩


-- BMO2 2020 problem 1.

-- Choices made for formalization: the original problem does not
-- specify a type for the terms of the sequence; we choose ℤ.  We also
-- index the sequence starting at 0 rather than at 1 as in the
-- original problem.

import data.int.parity
import tactic.basic
import tactic.linarith
import tactic.norm_num
import tactic.ring
import tactic.ring_exp

open int

-- Next term in sequence.
def p1_seq_next (a : ℤ) : ℤ := a * (a - 1) / 2

-- Condition that sequence satisfies recurrence.
def p1_recurrence (a : ℕ → ℤ) : Prop := ∀ n : ℕ, a (n + 1) = p1_seq_next (a n)

-- Odd numbers.
def all_odd (a : ℕ → ℤ) : Prop := ∀ n : ℕ, odd (a n)

/-- If an integer is `a` mod `b`, there are corresponding cases for its
value mod `c * b`. -/
lemma mod_mul_eq_cases {n a b c : ℤ} (hbpos : 0 < b) (hcpos : 0 < c) (hmod : n % b = a) :
  ∃ d : ℤ, 0 ≤ d ∧ d < c ∧ n % (c * b) = a + d * b :=
begin
  use ((n % (c * b)) / b),
  split,
  { exact int.div_nonneg (mod_nonneg _ (mul_ne_zero (ne_of_gt hcpos) (ne_of_gt hbpos)))
                         (int.le_of_lt hbpos) },
  split,
  { rw int.div_lt_iff_lt_mul hbpos,
    exact mod_lt_of_pos n (mul_pos hcpos hbpos) },
  { rw [←hmod, ←mod_mod_of_dvd n (dvd_mul_left b c), mod_def (n % (c * b)) b,
        mul_comm b (n % (c * b) / b)],
    simp }
end

-- If an integer is a mod b, it is a or a + b mod 2b.
theorem mod_mul_2 (n : ℤ) (a : ℤ) (b : ℤ) (hbpos : 0 < b) (hmod : n % b = a) :
  n % (2 * b) = a ∨ n % (2 * b) = a + b :=
begin
  rcases mod_mul_eq_cases hbpos (dec_trivial : (0 : ℤ) < 2) hmod with ⟨d, ⟨hd0, ⟨hd2, hdmod⟩⟩⟩,
  have hd01 : d = 0 ∨ d = 1,
  { by_cases h : 1 ≤ d,
    { right,
      linarith },
    { left,
      linarith } },
  cases hd01,
  { left,
    rw [hd01, zero_mul, add_zero] at hdmod,
    exact hdmod },
  { right,
    rw [hd01, one_mul] at hdmod,
    exact hdmod }
end

-- Powers of 2 are positive.
theorem power_of_2_pos (k : ℕ) : 0 < (2^k : ℤ) :=
pow_pos dec_trivial k

-- The main part of the induction step in the proof.  If two
-- consecutive terms are 3 mod 2^m, the first must be 3 mod 2^(m+1).
-- Note: with (3 % 2^m) the result could be stated in a more
-- complicated way meaningful for m = 1 as well.
theorem induction_main (m : ℕ) (a : ℤ) (hm : 2 ≤ m) (ha : a % 2^m = 3)
    (hb : (p1_seq_next a) % 2^m = 3) : a % 2^(m+1) = 3 :=
begin
  have h2m1 : (2^(m+1) : ℤ) = (2 * 2^m : ℤ) := rfl,
  rw h2m1,
  have hcases : a % (2 * 2^m) = 3 ∨ a % (2 * 2^m) = 3 + 2^m,
  { exact mod_mul_2 _ _ _ (power_of_2_pos m) ha },
  cases hcases with hc1 hc2,
  { exact hc1 },
  { exfalso,
    unfold p1_seq_next at hb,
    rw mod_def at hc2,
    set d := a / (2 * 2^m) with hd,
    have hc2m : a = 3 + 2^m + 2 * 2^m * d,
    { rw ← hc2,
      simp, },
    have hc2mm : a = 3 + 2 ^ m * (1 + 2 * d),
    { rw hc2m,
      ring },
    have hm1 : ∃ m1 : ℕ, m = 1 + m1,
    { have hm2 : ∃ m2 : ℕ, m = 2 + m2 := nat.exists_eq_add_of_le hm,
      cases hm2 with m2 hm2_h,
      use 1 + m2,
      rw hm2_h,
      ring },
    cases hm1 with m1 hmm1,
    rw [hc2mm, hmm1,
        (show (3 + 2 ^ (1 + m1) * (1 + 2 * d)) * (3 + 2 ^ (1 + m1) * (1 + 2 * d) - 1) =
               2 * (3 + 2^m1 + 2^(1 + m1) * (2 + 5 * d + 2^m1 * (1 + 2 * d) * (1 + 2 * d))),
         by ring_exp),
        int.mul_div_cancel_left _ (show (2 : ℤ) ≠ 0, by norm_num), ← hmm1,
        ← add_mod_mod, mul_assoc, mul_mod_right, add_zero] at hb,
    have hbbx : (3 + (2 : ℤ)^m1) % 2^m = 3 % 2^m, { rw [← mod_mod, hb] },
    rw [mod_eq_mod_iff_mod_sub_eq_zero, add_comm, add_sub_assoc, sub_self, add_zero,
        hmm1, add_comm, pow_succ] at hbbx,
    have hdvd : (2^m1 : ℤ) ∣ 2^m,
    { use 2,
      rw [mul_comm, hmm1, add_comm, ← pow_succ], },
    have hrdvd : (2^m : ℤ) ∣ 2^m1,
    { rw [hmm1, add_comm, pow_succ],
      exact dvd_of_mod_eq_zero hbbx, },
    have heq : (2^m1 : ℤ) = 2^m,
    { exact dvd_antisymm (int.le_of_lt (power_of_2_pos m1))
                         (int.le_of_lt (power_of_2_pos m)) hdvd hrdvd, },
    rw [hmm1, add_comm, pow_succ] at heq,
    have heqx : (2^m1 : ℤ) - 2^m1 = 2*2^m1 - 2^m1,
    { conv_lhs { congr, rw heq } },
    rw sub_self at heqx,
    have heqxx : 2 * (2^m1 : ℤ) - 2^m1 = 2^m1, { ring },
    rw heqxx at heqx,
    have heqz : 0 < (2^m1 : ℤ) := power_of_2_pos m1,
    rw ← heqx at heqz,
    exact lt_irrefl (0 : ℤ) heqz, },
end

-- Base case: if two consecutive terms are odd, the first is 3 mod 4.
theorem induction_base (a : ℤ) (ha : odd a) (hb : odd (p1_seq_next a)) : a % 2^2 = 3 :=
begin
  rw [odd_iff] at ha hb,
  rw (show (2^2 : ℤ) = 2 * 2, by norm_num),
  have hcases : a % (2 * 2) = 1 ∨ a % (2 * 2) = 1 + 2,
  { exact mod_mul_2 _ _ _ dec_trivial ha },
  cases hcases with hc1 hc2,
  { exfalso,
    unfold p1_seq_next at hb,
    rw mod_def at hc1,
    set d := a / (2 * 2) with hd,
    have hc1m : a = 1 + 2 * 2 * d,
    { conv_rhs { congr, rw ←hc1 },
      simp },
    rw hc1m at hb,
    conv_lhs at hb { congr, congr, congr, skip, rw [add_comm, add_sub_assoc, sub_self, add_zero] },
    rw [mul_comm, mul_assoc, mul_assoc] at hb,
    have hbm : 2 * (2 * (d * (1 + 2 * 2 * d))) / 2 = 2 * (d * (1 + 2 * 2 * d)) :=
      int.mul_div_cancel_left _ dec_trivial,
    rw [hbm, mul_mod_right] at hb,
    norm_num at hb },
  { rw hc2, norm_num, },
end

-- Base case for whole sequence.
theorem induction_base_all (a : ℕ → ℤ) (hodd : all_odd a) (hrec : p1_recurrence a) :
  ∀ n : ℕ, (a n) % 2^2 = 3 :=
begin
  intro n,
  let an : ℤ := a n,
  set an1 : ℤ := a (n + 1) with han1,
  have hrecn : a (n + 1) = p1_seq_next an, { rw hrec n },
  rw ← han1 at hrecn,
  have hanodd : odd an := hodd n,
  have han1odd : odd an1 := hodd (n + 1),
  rw hrecn at han1odd,
  exact induction_base an hanodd han1odd,
end

-- Induction step for whole sequence.
theorem induction_main_all (m : ℕ) (a : ℕ → ℤ) (hm : 2 ≤ m)
    (hmod : ∀ k : ℕ, (a k) % 2^m = 3) (hrec : p1_recurrence a) :
  ∀ n : ℕ, (a n) % 2^(m+1) = 3 :=
begin
  intro n,
  let an : ℤ := a n,
  set an1 : ℤ := a (n + 1) with han1,
  have hrecn : a (n + 1) = p1_seq_next an, { rw hrec n },
  rw ← han1 at hrecn,
  have hanmod : an % 2^m = 3 := hmod n,
  have han1mod : an1 % 2^m = 3 := hmod (n + 1),
  rw hrecn at han1mod,
  exact induction_main m an hm hanmod han1mod,
end

-- All terms are 3 mod all powers of 2.
theorem three_mod_all_powers (a : ℕ → ℤ) (hodd : all_odd a) (hrec : p1_recurrence a) :
  ∀ m : ℕ, 2 ≤ m → ∀ n : ℕ, (a n) % 2^m = 3 :=
begin
  intro m,
  induction m with k hk,
  { intro hx,
    exfalso,
    norm_num at hx, },
  { by_cases h2k : 2 ≤ k,
    { intro hsk,
      exact induction_main_all k a h2k (hk h2k) hrec },
    { by_cases hk1 : k = 1,
      { intro h22,
        rw hk1,
        exact induction_base_all a hodd hrec, },
      { intro h2sk,
        exfalso,
        rw [(show 2 = nat.succ 1, by norm_num), nat.succ_le_iff, nat.lt_add_one_iff] at h2sk,
        rw not_le at h2k,
        exact hk1 (le_antisymm (nat.le_of_lt_succ h2k) h2sk) }}},
end

-- The first term of the sequence is 3.
theorem first_term_three (a : ℕ → ℤ) (hodd : all_odd a)
    (hrec : p1_recurrence a) : a 0 = 3 :=
begin
  set k : ℕ := 2 ^ (2 + nat_abs (a 0 - 3)) with hk,
  have hltk : 2 + nat_abs (a 0 - 3) < k := nat.lt_two_pow _,
  have hmod : a 0 % k = 3,
  { rw hk,
    push_cast,
    norm_num,
    exact three_mod_all_powers a hodd hrec (2 + nat_abs (a 0 + -3)) (by linarith) 0 },
  rw ←nat_abs_of_nat k at hltk,
  exact eq_of_mod_eq_of_nat_abs_sub_lt_nat_abs hmod (by linarith)
end

-- The actual result of the problem.
theorem p1_result  (a : ℕ → ℤ) (hrec : p1_recurrence a) (ha3 : 2 < a 0) :
    all_odd a ↔ a 0 = 3 :=
begin
  split,
  { intro hodd, exact first_term_three a hodd hrec, },
  { intro h03,
    have halln : ∀ n : ℕ, a n = 3,
    { intro n,
      induction n with k hk,
      { exact h03, },
      { rw hrec k,
        unfold p1_seq_next,
        rw hk,
        norm_num, } },
    intro n,
    rw halln n,
    norm_num },
end


import game.world3.level7 -- hide
namespace mynat -- hide

/-
# Multiplication World

## Level 8: `mul_comm`

Finally, the boss level of multiplication world. But (assuming you
didn't cheat) you are well-prepared for it -- you have `zero_mul`
and `mul_zero`, as well as `succ_mul` and `mul_succ`. After this
level you can of course throw away one of each pair if you like,
but I would recommend you hold on to them, sometimes it's convenient
to have exactly the right tools to do a job.
-/

/- Lemma
Multiplication is commutative.
-/
lemma mul_comm (a b : mynat) : a * b = b * a :=
begin [nat_num_game]
  induction b with d hd,
  {
    rw zero_mul,
    rw mul_zero,
    refl,
  },
  {
    rw succ_mul,
    rw ←hd,
    rw mul_succ,
    refl,
  }
end

/-
You've now proved that the natural numbers are a commutative semiring!
That's the last collectible in Multiplication World.
-/
instance mynat.comm_semiring : comm_semiring mynat := by structure_helper
/-
But don't leave multiplication just yet -- prove `mul_left_comm`, the last
level of the world, and then we can beef up the power of `simp`.
-/

end mynat -- hide


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module topology.algebra.order.archimedean
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Order.Basic
import Mathlib.GroupTheory.Archimedean

/-!
# Topology on archimedean groups and fields

In this file we prove the following theorems:

- `Rat.denseRange_cast`: the coercion from `ℚ` to a linear ordered archimedean field has dense
  range;

- `AddSubgroup.dense_of_not_isolated_zero`, `AddSubgroup.dense_of_no_min`: two sufficient conditions
  for a subgroup of an archimedean linear ordered additive commutative group to be dense;

- `AddSubgroup.dense_or_cyclic`: an additive subgroup of an archimedean linear ordered additive
  commutative group `G` with order topology either is dense in `G` or is a cyclic subgroup.
-/

open Set

/-- Rational numbers are dense in a linear ordered archimedean field. -/
theorem Rat.denseRange_cast {𝕜} [LinearOrderedField 𝕜] [TopologicalSpace 𝕜] [OrderTopology 𝕜]
  [Archimedean 𝕜] : DenseRange ((↑) : ℚ → 𝕜) :=
  dense_of_exists_between fun _ _ h => Set.exists_range_iff.2 <| exists_rat_btwn h
#align rat.dense_range_cast Rat.denseRange_cast

namespace AddSubgroup

variable {G : Type _} [LinearOrderedAddCommGroup G] [TopologicalSpace G] [OrderTopology G]
  [Archimedean G]

/-- An additive subgroup of an archimedean linear ordered additive commutative group with order
topology is dense provided that for all positive `ε` there exists a positive element of the
subgroup that is less than `ε`. -/
theorem dense_of_not_isolated_zero (S : AddSubgroup G) (hS : ∀ ε > 0, ∃ g ∈ S, g ∈ Ioo 0 ε) :
    Dense (S : Set G) := by
  cases subsingleton_or_nontrivial G
  · refine fun x => _root_.subset_closure ?_
    rw [Subsingleton.elim x 0]
    exact zero_mem S
  refine dense_of_exists_between fun a b hlt => ?_
  rcases hS (b - a) (sub_pos.2 hlt) with ⟨g, hgS, hg0, hg⟩
  rcases (existsUnique_add_zsmul_mem_Ioc hg0 0 a).exists with ⟨m, hm⟩
  rw [zero_add] at hm
  refine ⟨m • g, zsmul_mem hgS _, hm.1, hm.2.trans_lt ?_⟩
  rwa [lt_sub_iff_add_lt'] at hg

/-- Let `S` be a nontrivial additive subgroup in an archimedean linear ordered additive commutative
group `G` with order topology. If the set of positive elements of `S` does not have a minimal
element, then `S` is dense `G`. -/
theorem dense_of_no_min (S : AddSubgroup G) (hbot : S ≠ ⊥)
    (H : ¬∃ a : G, IsLeast { g : G | g ∈ S ∧ 0 < g } a) : Dense (S : Set G) := by
  refine S.dense_of_not_isolated_zero fun ε ε0 => ?_
  contrapose! H
  exact exists_isLeast_pos hbot ε0 (disjoint_left.2 H)
#align real.subgroup_dense_of_no_min AddSubgroup.dense_of_no_minₓ

/-- An additive subgroup of an archimedean linear ordered additive commutative group `G` with order
topology either is dense in `G` or is a cyclic subgroup. -/
theorem dense_or_cyclic (S : AddSubgroup G) : Dense (S : Set G) ∨ ∃ a : G, S = closure {a} := by
  refine (em _).imp (dense_of_not_isolated_zero S) fun h => ?_
  push_neg at h
  rcases h with ⟨ε, ε0, hε⟩
  exact cyclic_of_isolated_zero ε0 (disjoint_left.2 hε)
#align real.subgroup_dense_or_cyclic AddSubgroup.dense_or_cyclicₓ


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

import .finite

-- Definitions and theorems relating to countability
namespace hidden
namespace myset

universes u v w

open myset

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

def countable {α : Type u} (s : myset α) : Prop :=
finite s ∨ equinumerous (all_of mynat) s
def uncountable {α : Type u} (s : myset α) : Prop :=
¬countable s

-- Proven, given some theorems in finite.lean
theorem uncountability_of_power_set_of_naturals:
uncountable (power_set (all_of mynat)) :=
begin
  assume h,
  cases h with hfinite hcountinf, {
    -- Using revert here is quite nice
    revert hfinite,
    -- Although this line is stupid
    suffices : infinite (power_set (all_of mynat)), from this,
    rw ←inf_iff_powerset_inf (all_of mynat),
    from naturals_infinite,
  }, {
    have := card_ne_power_set (all_of mynat),
    contradiction,
  },
end

end myset
end hidden


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Linear natural number arithmetic preformulas in pre-normalized preform.
-/

import tactic.omega.nat.preterm

namespace omega

namespace nat

/-- Intermediate shadow syntax for LNA formulas that includes unreified exprs -/
meta inductive exprform
| eq  : exprterm → exprterm → exprform
| le  : exprterm → exprterm → exprform
| not : exprform → exprform
| or  : exprform → exprform → exprform
| and : exprform → exprform → exprform

/-- Intermediate shadow syntax for LNA formulas that includes non-canonical terms -/
@[derive has_reflect, derive inhabited]
inductive preform
| eq  : preterm → preterm → preform
| le  : preterm → preterm → preform
| not : preform → preform
| or  : preform → preform → preform
| and : preform → preform → preform

localized "notation x ` =* ` y := omega.nat.preform.eq x y" in omega.nat
localized "notation x ` ≤* ` y := omega.nat.preform.le x y" in omega.nat
localized "notation `¬* ` p    := omega.nat.preform.not p" in omega.nat
localized "notation p ` ∨* ` q := omega.nat.preform.or p q" in omega.nat
localized "notation p ` ∧* ` q := omega.nat.preform.and p q" in omega.nat

namespace preform

/-- Evaluate a preform into prop using the valuation `v`. -/
@[simp] def holds (v : nat → nat) : preform → Prop
| (t =* s) := t.val v = s.val v
| (t ≤* s) := t.val v ≤ s.val v
| (¬* p)   := ¬ p.holds
| (p ∨* q) := p.holds ∨ q.holds
| (p ∧* q) := p.holds ∧ q.holds

end preform

/-- `univ_close p n` := `p` closed by prepending `n` universal quantifiers -/
@[simp] def univ_close (p : preform) : (nat → nat) → nat → Prop
| v 0     := p.holds v
| v (k+1) := ∀ i : nat, univ_close (update_zero i v) k

namespace preform

/-- Argument is free of negations -/
def neg_free : preform → Prop
| (t =* s) := true
| (t ≤* s) := true
| (p ∨* q) := neg_free p ∧ neg_free q
| (p ∧* q) := neg_free p ∧ neg_free q
| _        := false

/-- Return expr of proof that argument is free of subtractions -/
def sub_free : preform → Prop
| (t =* s) := t.sub_free ∧ s.sub_free
| (t ≤* s) := t.sub_free ∧ s.sub_free
| (¬* p)   := p.sub_free
| (p ∨* q) := p.sub_free ∧ q.sub_free
| (p ∧* q) := p.sub_free ∧ q.sub_free

/-- Fresh de Brujin index not used by any variable in argument -/
def fresh_index : preform → nat
| (t =* s) := max t.fresh_index s.fresh_index
| (t ≤* s) := max t.fresh_index s.fresh_index
| (¬* p)   := p.fresh_index
| (p ∨* q) := max p.fresh_index q.fresh_index
| (p ∧* q) := max p.fresh_index q.fresh_index

lemma holds_constant {v w : nat → nat} :
  ∀ p : preform,
  ( (∀ x < p.fresh_index, v x = w x) →
    (p.holds v ↔ p.holds w) )
| (t =* s) h1 :=
  begin
    simp only [holds],
    apply pred_mono_2;
    apply preterm.val_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (t ≤* s) h1 :=
  begin
    simp only [holds],
    apply pred_mono_2;
    apply preterm.val_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (¬* p)   h1 :=
  begin
    apply not_iff_not_of_iff,
    apply holds_constant p h1
  end
| (p ∨* q) h1 :=
  begin
    simp only [holds],
    apply pred_mono_2';
    apply holds_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end
| (p ∧* q) h1 :=
  begin
    simp only [holds],
    apply pred_mono_2';
    apply holds_constant;
    intros x h2; apply h1 _ (lt_of_lt_of_le h2 _),
    apply le_max_left, apply le_max_right
  end

/-- All valuations satisfy argument -/
def valid (p : preform) : Prop :=
∀ v, holds v p

/-- There exists some valuation that satisfies argument -/
def sat (p : preform) : Prop :=
∃ v, holds v p

/-- `implies p q` := under any valuation, `q` holds if `p` holds -/
def implies (p q : preform) : Prop :=
∀ v, (holds v p → holds v q)

/-- `equiv p q` := under any valuation, `p` holds iff `q` holds -/
def equiv (p q : preform) : Prop :=
∀ v, (holds v p ↔ holds v q)

lemma sat_of_implies_of_sat {p q : preform} :
  implies p q → sat p → sat q :=
begin intros h1 h2, apply exists_imp_exists h1 h2 end

lemma sat_or {p q : preform} :
  sat (p ∨* q) ↔ sat p ∨ sat q :=
begin
  constructor; intro h1,
  { cases h1 with v h1, cases h1 with h1 h1;
    [left,right]; refine ⟨v,_⟩; assumption },
  { cases h1 with h1 h1; cases h1 with v h1;
    refine ⟨v,_⟩; [left,right]; assumption }
end

/-- There does not exist any valuation that satisfies argument -/
def unsat (p : preform) : Prop := ¬ sat p

def repr : preform → string
| (t =* s) := "(" ++ t.repr ++ " = " ++ s.repr ++ ")"
| (t ≤* s) := "(" ++ t.repr ++ " ≤ " ++ s.repr ++ ")"
| (¬* p)   := "¬" ++ p.repr
| (p ∨* q) := "(" ++ p.repr ++ " ∨ " ++ q.repr ++ ")"
| (p ∧* q) := "(" ++ p.repr ++ " ∧ " ++ q.repr ++ ")"

instance has_repr : has_repr preform := ⟨repr⟩
meta instance has_to_format : has_to_format preform := ⟨λ x, x.repr⟩

end preform

lemma univ_close_of_valid {p : preform} :
  ∀ {m : nat} {v : nat → nat}, p.valid → univ_close p v m
| 0 v h1     := h1 _
| (m+1) v h1 := λ i, univ_close_of_valid h1

lemma valid_of_unsat_not {p : preform} : (¬*p).unsat → p.valid :=
begin
  simp only [preform.sat, preform.unsat, preform.valid, preform.holds],
  rw not_exists_not, intro h, assumption
end

/-- Tactic for setting up proof by induction over preforms. -/
meta def preform.induce (t : tactic unit := tactic.skip) : tactic unit :=
`[ intro p, induction p with t s t s p ih p q ihp ihq p q ihp ihq; t ]

end nat

end omega


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

! This file was ported from Lean 3 source module order.extension.linear
! leanprover-community/mathlib commit baba818b9acea366489e8ba32d2cc0fcaf50a1f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Zorn
import Mathbin.Tactic.ByContra

/-!
# Extend a partial order to a linear order

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

This file constructs a linear order which is an extension of the given partial order, using Zorn's
lemma.
-/

universe u

open Set Classical

open Classical

#print extend_partialOrder /-
/-- Any partial order can be extended to a linear order.
-/
theorem extend_partialOrder {α : Type u} (r : α → α → Prop) [IsPartialOrder α r] :
    ∃ (s : α → α → Prop)(_ : IsLinearOrder α s), r ≤ s :=
  by
  let S := { s | IsPartialOrder α s }
  have hS : ∀ c, c ⊆ S → IsChain (· ≤ ·) c → ∀ y ∈ c, ∃ ub ∈ S, ∀ z ∈ c, z ≤ ub :=
    by
    rintro c hc₁ hc₂ s hs
    haveI := (hc₁ hs).1
    refine' ⟨Sup c, _, fun z hz => le_supₛ hz⟩
    refine'
        { refl := _
          trans := _
          antisymm := _ } <;>
      simp_rw [binary_relation_supₛ_iff]
    · intro x
      exact ⟨s, hs, refl x⟩
    · rintro x y z ⟨s₁, h₁s₁, h₂s₁⟩ ⟨s₂, h₁s₂, h₂s₂⟩
      haveI : IsPartialOrder _ _ := hc₁ h₁s₁
      haveI : IsPartialOrder _ _ := hc₁ h₁s₂
      cases hc₂.total h₁s₁ h₁s₂
      · exact ⟨s₂, h₁s₂, trans (h _ _ h₂s₁) h₂s₂⟩
      · exact ⟨s₁, h₁s₁, trans h₂s₁ (h _ _ h₂s₂)⟩
    · rintro x y ⟨s₁, h₁s₁, h₂s₁⟩ ⟨s₂, h₁s₂, h₂s₂⟩
      haveI : IsPartialOrder _ _ := hc₁ h₁s₁
      haveI : IsPartialOrder _ _ := hc₁ h₁s₂
      cases hc₂.total h₁s₁ h₁s₂
      · exact antisymm (h _ _ h₂s₁) h₂s₂
      · apply antisymm h₂s₁ (h _ _ h₂s₂)
  obtain ⟨s, hs₁ : IsPartialOrder _ _, rs, hs₂⟩ := zorn_nonempty_partialOrder₀ S hS r ‹_›
  skip
  refine' ⟨s, { Total := _ }, rs⟩
  intro x y
  by_contra' h
  let s' x' y' := s x' y' ∨ s x' x ∧ s y y'
  rw [← hs₂ s' _ fun _ _ => Or.inl] at h
  · apply h.1 (Or.inr ⟨refl _, refl _⟩)
  · refine'
      { refl := fun x => Or.inl (refl _)
        trans := _
        antisymm := _ }
    · rintro a b c (ab | ⟨ax : s a x, yb : s y b⟩) (bc | ⟨bx : s b x, yc : s y c⟩)
      · exact Or.inl (trans ab bc)
      · exact Or.inr ⟨trans ab bx, yc⟩
      · exact Or.inr ⟨ax, trans yb bc⟩
      · exact Or.inr ⟨ax, yc⟩
    · rintro a b (ab | ⟨ax : s a x, yb : s y b⟩) (ba | ⟨bx : s b x, ya : s y a⟩)
      · exact antisymm ab ba
      · exact (h.2 (trans ya (trans ab bx))).elim
      · exact (h.2 (trans yb (trans ba ax))).elim
      · exact (h.2 (trans yb bx)).elim
#align extend_partial_order extend_partialOrder
-/

#print LinearExtension /-
/-- A type alias for `α`, intended to extend a partial order on `α` to a linear order. -/
def LinearExtension (α : Type u) : Type u :=
  α
#align linear_extension LinearExtension
-/

noncomputable instance {α : Type u} [PartialOrder α] : LinearOrder (LinearExtension α)
    where
  le := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).some
  le_refl := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).choose_spec.some.1.1.1.1
  le_trans := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).choose_spec.some.1.1.2.1
  le_antisymm := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).choose_spec.some.1.2.1
  le_total := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).choose_spec.some.2.1
  decidableLe := Classical.decRel _

/- warning: to_linear_extension -> toLinearExtension is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : PartialOrder.{u1} α], RelHom.{u1, u1} α (LinearExtension.{u1} α) (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1))) (LE.le.{u1} (LinearExtension.{u1} α) (Preorder.toLE.{u1} (LinearExtension.{u1} α) (PartialOrder.toPreorder.{u1} (LinearExtension.{u1} α) (SemilatticeInf.toPartialOrder.{u1} (LinearExtension.{u1} α) (Lattice.toSemilatticeInf.{u1} (LinearExtension.{u1} α) (LinearOrder.toLattice.{u1} (LinearExtension.{u1} α) (LinearExtension.linearOrder.{u1} α _inst_1)))))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : PartialOrder.{u1} α], RelHom.{u1, u1} α (LinearExtension.{u1} α) (fun (x._@.Mathlib.Order.Extension.Linear._hyg.957 : α) (x._@.Mathlib.Order.Extension.Linear._hyg.959 : α) => LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) x._@.Mathlib.Order.Extension.Linear._hyg.957 x._@.Mathlib.Order.Extension.Linear._hyg.959) (fun (x._@.Mathlib.Order.Extension.Linear._hyg.981 : LinearExtension.{u1} α) (x._@.Mathlib.Order.Extension.Linear._hyg.983 : LinearExtension.{u1} α) => LE.le.{u1} (LinearExtension.{u1} α) (Preorder.toLE.{u1} (LinearExtension.{u1} α) (PartialOrder.toPreorder.{u1} (LinearExtension.{u1} α) (SemilatticeInf.toPartialOrder.{u1} (LinearExtension.{u1} α) (Lattice.toSemilatticeInf.{u1} (LinearExtension.{u1} α) (DistribLattice.toLattice.{u1} (LinearExtension.{u1} α) (instDistribLattice.{u1} (LinearExtension.{u1} α) (instLinearOrderLinearExtension.{u1} α _inst_1))))))) x._@.Mathlib.Order.Extension.Linear._hyg.981 x._@.Mathlib.Order.Extension.Linear._hyg.983)
Case conversion may be inaccurate. Consider using '#align to_linear_extension toLinearExtensionₓ'. -/
/-- The embedding of `α` into `linear_extension α` as a relation homomorphism. -/
def toLinearExtension {α : Type u} [PartialOrder α] :
    ((· ≤ ·) : α → α → Prop) →r ((· ≤ ·) : LinearExtension α → LinearExtension α → Prop)
    where
  toFun x := x
  map_rel' a b := (extend_partialOrder ((· ≤ ·) : α → α → Prop)).choose_spec.choose_spec _ _
#align to_linear_extension toLinearExtension

instance {α : Type u} [Inhabited α] : Inhabited (LinearExtension α) :=
  ⟨(default : α)⟩