import definitions basic
universe u

namespace Algebra

variables {M : Type*} [monoid M] {s : set M}
variables {A : Type*} [add_monoid A] {t : set A}

structure submonoid (M : Type*) [monoid M] :=
(carrier : set M)
(has_ident : (0 : M) ∈ carrier)
(closure {a b} : a ∈ carrier → b ∈ carrier → a + b ∈ carrier)

namespace submonoid

instance : has_coe (submonoid M) (set M) := ⟨submonoid.carrier⟩

instance : has_mem M (submonoid M) := ⟨λ m S, m ∈ (S:set M)⟩

instance : has_coe_to_sort (submonoid M) := ⟨Type*, λ S, {x : M // x ∈ S}⟩

@[simp]
lemma mem_carrier {s : submonoid M} {x : M} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

@[simp]
lemma mem_coe {S : submonoid M} {m : M} : m ∈ (S : set M) ↔ m ∈ S := iff.rfl

@[simp]
lemma coe_coe (s : submonoid M) : ↥(s : set M) = s := rfl

protected lemma «exists» {s : submonoid M} {p : s → Prop} :
  (∃ x : s, p x) ↔ ∃ x ∈ s, p ⟨x, ‹x ∈ s›⟩ :=
set_coe.exists

protected lemma «forall» {s : submonoid M} {p : s → Prop} :
  (∀ x : s, p x) ↔ ∀ x ∈ s, p ⟨x, ‹x ∈ s›⟩ :=
set_coe.forall

/-- Two submonoids are equal if the underlying subsets are equal. -/
theorem ext' ⦃S T : submonoid M⦄ (h : (S : set M) = T) : S = T :=
by cases S; cases T; congr'

@[ext]
theorem ext {S T : submonoid M}(h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
ext' $ set.ext h

variable (S : submonoid M)

lemma ident : (0 : M) ∈ S := S.has_ident
lemma subset_closure {x y : M} : x ∈ S → y ∈ S → x + y ∈ S := submonoid.closure S

end submonoid

structure subgroup (G : Type*) [group G] extends submonoid G :=
(has_inv {x} : x ∈ carrier → -x ∈ carrier)

instance (G : Type u) [group G] : has_mem G (subgroup G) :=
{ mem := λ g H,  g ∈ H.carrier }

instance (G : Type u) [group G] : has_coe_to_sort (subgroup G) := ⟨Type u, λ S, {x : G // x ∈ S}⟩

namespace subgroup

variables {G : Type u} [group G] (H : subgroup G)

instance is_submonoid : has_coe (subgroup G) (submonoid G) := {coe := λ G, { carrier := G.carrier,
  has_ident := G.has_ident,
  closure := G.closure}}

instance : has_coe (subgroup G) (set G) := {coe := λ G, G.carrier}

instance : has_add H :=
{add := by
 {rintros ⟨a, Ha⟩ ⟨b,Hb⟩,
  use (a+b), apply H.closure, assumption, assumption}}

lemma associative : ∀ a b c : H, a + b + c = a + (b + c) :=
begin
  rintros ⟨a, h₁⟩ ⟨b, h₂⟩ ⟨c,h₃⟩,
  unfold has_add.add,
  rw subtype.mk_eq_mk,
  rw group.associative
end

end subgroup

def has_identity (G : Type u) [group G] (H : subgroup G) : Prop := (0 : G) ∈ H

namespace subgroup

variables (G : Type u) [group G] (H : subgroup G)

theorem has_identity : has_identity G H := by {rw has_identity, exact H.has_ident}

-- A subgroup is itself a group

lemma is_group (H : subgroup G) : group H :=
{ add := has_add.add,
  assoc := subgroup.associative H,
  zero :=
  by {have := subgroup.has_identity G H, use 0, assumption},
  ident_l :=
  by {dsimp,
      unfold has_add.add,  tidy},
  ident_r :=
  by {dsimp,
      unfold has_add.add,  tidy},
  neg := λ ⟨a,h⟩,
  by {have := H.has_inv h, use (-a), assumption} ,
  inv_l := λ ⟨a,h⟩,
  by { unfold has_add.add, simp,}
}

end subgroup

def is_subgroup_of (G : Type u) [group G] (H : subgroup G) : Prop := Algebra.has_identity G H ∧ (∀ h₁ h₂ : G, h₁ ∈ H → h₂ ∈ H → h₁ + h₂ ∈ H) ∧ (∀ g : G, g ∈ H → (-g) ∈ H)

namespace subgroup

variables (G : Type u) [group G] (H : subgroup G)

-- obviously, every [subgroup G] is a subgroup of G

lemma is_subgroup_of : is_subgroup_of G H :=
⟨subgroup.has_identity G H,H.closure,H.has_inv⟩

-- Every group G is a subgroup of G

def self : subgroup G :=
{ carrier := set.univ,
  has_ident := dec_trivial,
  closure := λ a b , by dec_trivial,
  has_inv := λ g, by dec_trivial}

lemma self.is_subgroup_of : Algebra.is_subgroup_of
G
(subgroup.self G) :=
begin
  split, exact has_identity G (self G),
  split,
  exact (self G).closure,
  exact (self G).has_inv,
end

-- Particular subgroups

def intersection (K₁ K₂ : subgroup G) : subgroup G :=
{ carrier := K₁ ∩ K₂,
  has_ident :=
  by {simp, split,
      exact K₁.has_ident, exact K₂.has_ident},
  closure :=
  by {
  intros a b H1 H2,
  cases H1 with L1 R1,
  cases H2 with L2 R2,
  simp, split,
  apply K₁.closure, assumption, assumption,
  apply K₂.closure, assumption, assumption},
  has_inv :=
  by {
  intros a H, simp at *, cases H with L R,
  split,
  exact K₁.has_inv L,
  exact K₂.has_inv R,
  }
}

def center_of (G : Type u) [group G] : set G := {x : G | ∀ g : G, g + x = x + g}

lemma center_closure : ∀ a b : G, a ∈ center_of G → b ∈ center_of G → a + b ∈ center_of G :=
begin
  intros a b H1 H2, rw center_of,
  simp at *, intro g, rw group.associative,
  replace H2 := H2 g, replace H1 := H1 g,
  rw [← H2, ← group.associative, H1,  group.associative]
end

lemma center_inv : ∀ x : G, x ∈ center_of G → -x ∈ center_of G := begin
  intros a, rw center_of, simp, intros H1 g,
  obtain H2 := H1 g,
  replace H2 := group.congr_l (-a) H2,
  replace H2 := group.congr_r (-a) H2,
  rw [← group.associative, ← (H1 g),
   group.associative, group.inv_r, group.ident_r] at H2,
  rw (H1 g) at H2,
  rw [← group.associative ,  group.inv_l,group.ident_l] at H2,
  symmetry, exact H2,
end

def center : subgroup G := {
  carrier := center_of G,
  has_ident :=
    by {rw center_of, simp},
  closure := center_closure G,
  has_inv := center_inv G
}

end subgroup

end Algebra


/-
Copyright (c) 2020 Kyle Miller All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller
-/
import data.finset.prod
import data.sym.basic
import data.set_like.basic
import tactic.linarith

/-!
# The symmetric square

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

This file defines the symmetric square, which is `α × α` modulo
swapping.  This is also known as the type of unordered pairs.

More generally, the symmetric square is the second symmetric power
(see `data.sym.basic`). The equivalence is `sym2.equiv_sym`.

From the point of view that an unordered pair is equivalent to a
multiset of cardinality two (see `sym2.equiv_multiset`), there is a
`has_mem` instance `sym2.mem`, which is a `Prop`-valued membership
test.  Given `h : a ∈ z` for `z : sym2 α`, then `h.other` is the other
element of the pair, defined using `classical.choice`.  If `α` has
decidable equality, then `h.other'` computably gives the other element.

The universal property of `sym2` is provided as `sym2.lift`, which
states that functions from `sym2 α` are equivalent to symmetric
two-argument functions from `α`.

Recall that an undirected graph (allowing self loops, but no multiple
edges) is equivalent to a symmetric relation on the vertex type `α`.
Given a symmetric relation on `α`, the corresponding edge set is
constructed by `sym2.from_rel` which is a special case of `sym2.lift`.

## Notation

The symmetric square has a setoid instance, so `⟦(a, b)⟧` denotes a
term of the symmetric square.

## Tags

symmetric square, unordered pairs, symmetric powers
-/

open finset function sym

universe u
variables {α β γ : Type*}

namespace sym2

/--
This is the relation capturing the notion of pairs equivalent up to permutations.
-/
inductive rel (α : Type u) : (α × α) → (α × α) → Prop
| refl (x y : α) : rel (x, y) (x, y)
| swap (x y : α) : rel (x, y) (y, x)

attribute [refl] rel.refl

@[symm] lemma rel.symm {x y : α × α} : rel α x y → rel α y x :=
by rintro ⟨_, _⟩; constructor

@[trans] lemma rel.trans {x y z : α × α} (a : rel α x y) (b : rel α y z) : rel α x z :=
by { cases_matching* rel _ _ _; apply rel.refl <|> apply rel.swap }

lemma rel.is_equivalence : equivalence (rel α) := by tidy; apply rel.trans; assumption

instance rel.setoid (α : Type u) : setoid (α × α) := ⟨rel α, rel.is_equivalence⟩

@[simp] lemma rel_iff {x y z w : α} :
  (x, y) ≈ (z, w) ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) :=
begin
  split; intro h,
  { cases h; simp },
  { cases h; rw [h.1, h.2], constructor }
end

end sym2

/--
`sym2 α` is the symmetric square of `α`, which, in other words, is the
type of unordered pairs.

It is equivalent in a natural way to multisets of cardinality 2 (see
`sym2.equiv_multiset`).
-/
@[reducible]
def sym2 (α : Type u) := quotient (sym2.rel.setoid α)

namespace sym2

@[elab_as_eliminator]
protected lemma ind {f : sym2 α → Prop} (h : ∀ x y, f ⟦(x, y)⟧) : ∀ i, f i :=
quotient.ind $ prod.rec $ by exact h

@[elab_as_eliminator]
protected lemma induction_on {f : sym2 α → Prop} (i : sym2 α) (hf : ∀ x y, f ⟦(x, y)⟧) : f i :=
i.ind hf

@[elab_as_eliminator]
protected lemma induction_on₂ {f : sym2 α → sym2 β → Prop} (i : sym2 α) (j : sym2 β)
  (hf : ∀ a₁ a₂ b₁ b₂, f ⟦(a₁, a₂)⟧ ⟦(b₁, b₂)⟧) : f i j :=
quotient.induction_on₂ i j $ by { rintros ⟨a₁, a₂⟩ ⟨b₁, b₂⟩, exact hf _ _ _ _ }

protected lemma «exists» {α : Sort*} {f : sym2 α → Prop} :
  (∃ (x : sym2 α), f x) ↔ ∃ x y, f ⟦(x, y)⟧ :=
(surjective_quotient_mk _).exists.trans prod.exists

protected lemma «forall» {α : Sort*} {f : sym2 α → Prop} :
  (∀ (x : sym2 α), f x) ↔ ∀ x y, f ⟦(x, y)⟧ :=
(surjective_quotient_mk _).forall.trans prod.forall

lemma eq_swap {a b : α} : ⟦(a, b)⟧ = ⟦(b, a)⟧ :=
by { rw quotient.eq, apply rel.swap }

@[simp] lemma mk_prod_swap_eq {p : α × α} : ⟦p.swap⟧ = ⟦p⟧ :=
by { cases p, exact eq_swap }

lemma congr_right {a b c : α} : ⟦(a, b)⟧ = ⟦(a, c)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

lemma congr_left {a b c : α} : ⟦(b, a)⟧ = ⟦(c, a)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

lemma eq_iff {x y z w : α} :
  ⟦(x, y)⟧ = ⟦(z, w)⟧ ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) :=
by simp

lemma mk_eq_mk_iff {p q : α × α} :
  ⟦p⟧ = ⟦q⟧ ↔ p = q ∨ p = q.swap :=
by { cases p, cases q, simp only [eq_iff, prod.mk.inj_iff, prod.swap_prod_mk] }

/-- The universal property of `sym2`; symmetric functions of two arguments are equivalent to
functions from `sym2`. Note that when `β` is `Prop`, it can sometimes be more convenient to use
`sym2.from_rel` instead. -/
def lift : {f : α → α → β // ∀ a₁ a₂, f a₁ a₂ = f a₂ a₁} ≃ (sym2 α → β) :=
{ to_fun := λ f, quotient.lift (uncurry ↑f) $ by { rintro _ _ ⟨⟩, exacts [rfl, f.prop _ _] },
  inv_fun := λ F, ⟨curry (F ∘ quotient.mk), λ a₁ a₂, congr_arg F eq_swap⟩,
  left_inv := λ f, subtype.ext rfl,
  right_inv := λ F, funext $ sym2.ind $ by exact λ x y, rfl }

@[simp]
lemma lift_mk (f : {f : α → α → β // ∀ a₁ a₂, f a₁ a₂ = f a₂ a₁}) (a₁ a₂ : α) :
  lift f ⟦(a₁, a₂)⟧ = (f : α → α → β) a₁ a₂ := rfl

@[simp]
lemma coe_lift_symm_apply (F : sym2 α → β) (a₁ a₂ : α) :
  (lift.symm F : α → α → β) a₁ a₂ = F ⟦(a₁, a₂)⟧ := rfl

/-- A two-argument version of `sym2.lift`. -/
def lift₂ : {f : α → α → β → β → γ // ∀ a₁ a₂ b₁ b₂,
  f a₁ a₂ b₁ b₂ = f a₂ a₁ b₁ b₂ ∧ f a₁ a₂ b₁ b₂ = f a₁ a₂ b₂ b₁} ≃ (sym2 α → sym2 β → γ) :=
{ to_fun := λ f, quotient.lift₂ (λ (a : α × α) (b : β × β), f.1 a.1 a.2 b.1 b.2) begin
    rintro _ _ _ _ ⟨⟩ ⟨⟩,
    exacts [rfl, (f.2 _ _ _ _).2, (f.2 _ _ _ _).1, (f.2 _ _ _ _).1.trans (f.2 _ _ _ _).2]
  end,
  inv_fun := λ F, ⟨λ a₁ a₂ b₁ b₂, F ⟦(a₁, a₂)⟧ ⟦(b₁, b₂)⟧, λ a₁ a₂ b₁ b₂,
    by { split, exacts [congr_arg2 F eq_swap rfl, congr_arg2 F rfl eq_swap] }⟩,
  left_inv := λ f, subtype.ext rfl,
  right_inv := λ F, funext₂ $ λ a b, sym2.induction_on₂ a b $ λ _ _ _ _, rfl }

@[simp]
lemma lift₂_mk (f : {f : α → α → β → β → γ // ∀ a₁ a₂ b₁ b₂,
  f a₁ a₂ b₁ b₂ = f a₂ a₁ b₁ b₂ ∧ f a₁ a₂ b₁ b₂ = f a₁ a₂ b₂ b₁}) (a₁ a₂ : α) (b₁ b₂ : β) :
  lift₂ f ⟦(a₁, a₂)⟧ ⟦(b₁, b₂)⟧ = (f : α → α → β → β → γ) a₁ a₂ b₁ b₂ := rfl

@[simp]
lemma coe_lift₂_symm_apply (F : sym2 α → sym2 β → γ) (a₁ a₂ : α) (b₁ b₂ : β) :
  (lift₂.symm F : α → α → β → β → γ) a₁ a₂ b₁ b₂ = F ⟦(a₁, a₂)⟧ ⟦(b₁, b₂)⟧ := rfl

/--
The functor `sym2` is functorial, and this function constructs the induced maps.
-/
def map (f : α → β) : sym2 α → sym2 β :=
quotient.map (prod.map f f)
  (by { rintros _ _ h, cases h, { refl }, apply rel.swap })

@[simp] lemma map_id : map (@id α) = id := by { ext ⟨⟨x,y⟩⟩, refl }

lemma map_comp {g : β → γ} {f : α → β} : sym2.map (g ∘ f) = sym2.map g ∘ sym2.map f :=
by { ext ⟨⟨x, y⟩⟩, refl }

lemma map_map {g : β → γ} {f : α → β} (x : sym2 α) :
  map g (map f x) = map (g ∘ f) x := by tidy

@[simp]
lemma map_pair_eq (f : α → β) (x y : α) : map f ⟦(x, y)⟧ = ⟦(f x, f y)⟧ := rfl

lemma map.injective {f : α → β} (hinj : injective f) : injective (map f) :=
begin
  intros z z',
  refine quotient.ind₂ (λ z z', _) z z',
  cases z with x y,
  cases z' with x' y',
  repeat { rw [map_pair_eq, eq_iff] },
  rintro (h|h); simp [hinj h.1, hinj h.2],
end

section membership

/-! ### Membership and set coercion -/

/--
This is a predicate that determines whether a given term is a member of a term of the
symmetric square.  From this point of view, the symmetric square is the subtype of
cardinality-two multisets on `α`.
-/
protected def mem (x : α) (z : sym2 α) : Prop :=
∃ (y : α), z = ⟦(x, y)⟧

lemma mem_iff' {a b c : α} : sym2.mem a ⟦(b, c)⟧ ↔ a = b ∨ a = c :=
{ mp  := by { rintro ⟨_, h⟩, rw eq_iff at h, tidy },
  mpr := by { rintro (rfl|rfl), { exact ⟨_, rfl⟩ }, rw eq_swap, exact ⟨_, rfl⟩ } }

instance : set_like (sym2 α) α :=
{ coe := λ z, {x | z.mem x},
  coe_injective' := λ z z' h, begin
    simp only [set.ext_iff, set.mem_set_of_eq] at h,
    induction z using sym2.ind with x y,
    induction z' using sym2.ind with x' y',
    have hx := h x, have hy := h y, have hx' := h x', have hy' := h y',
    simp only [mem_iff', eq_self_iff_true, or_true, iff_true, true_or, true_iff] at hx hy hx' hy',
    cases hx; cases hy; cases hx'; cases hy'; subst_vars,
    rw [sym2.eq_swap],
  end }

@[simp] lemma mem_iff_mem {x : α} {z : sym2 α} : sym2.mem x z ↔ x ∈ z := iff.rfl

lemma mem_iff_exists {x : α} {z : sym2 α} : x ∈ z ↔ ∃ (y : α), z = ⟦(x, y)⟧ := iff.rfl

@[ext] theorem ext {p q : sym2 α} (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := set_like.ext h

lemma mem_mk_left (x y : α) : x ∈ ⟦(x, y)⟧ := ⟨y, rfl⟩
lemma mem_mk_right (x y : α) : y ∈ ⟦(x, y)⟧ := eq_swap.subst $ mem_mk_left y x

@[simp]

lemma out_fst_mem (e : sym2 α) : e.out.1 ∈ e := ⟨e.out.2, by rw [prod.mk.eta, e.out_eq]⟩
lemma out_snd_mem (e : sym2 α) : e.out.2 ∈ e := ⟨e.out.1, by rw [eq_swap, prod.mk.eta, e.out_eq]⟩

lemma ball {p : α → Prop} {a b : α} : (∀ c ∈ ⟦(a, b)⟧, p c) ↔ p a ∧ p b :=
begin
  refine ⟨λ h, ⟨h _ $ mem_mk_left _ _, h _ $ mem_mk_right _ _⟩, λ h c hc, _⟩,
  obtain rfl | rfl := sym2.mem_iff.1 hc,
  { exact h.1 },
  { exact h.2 }
end

/--
Given an element of the unordered pair, give the other element using `classical.some`.
See also `mem.other'` for the computable version.
-/
noncomputable def mem.other {a : α} {z : sym2 α} (h : a ∈ z) : α :=
classical.some h

@[simp]
lemma other_spec {a : α} {z : sym2 α} (h : a ∈ z) : ⟦(a, h.other)⟧ = z :=
by erw ← classical.some_spec h

lemma other_mem {a : α} {z : sym2 α} (h : a ∈ z) : h.other ∈ z :=
by { convert mem_mk_right a h.other, rw other_spec h }

lemma mem_and_mem_iff {x y : α} {z : sym2 α} (hne : x ≠ y) : x ∈ z ∧ y ∈ z ↔ z = ⟦(x, y)⟧ :=
begin
  split,
  { induction z using sym2.ind with x' y',
    rw [mem_iff, mem_iff],
    rintro ⟨rfl | rfl, rfl | rfl⟩;
    try { trivial };
    simp only [sym2.eq_swap] },
  { rintro rfl, simp },
end

lemma eq_of_ne_mem {x y : α} {z z' : sym2 α} (h : x ≠ y)
  (h1 : x ∈ z) (h2 : y ∈ z) (h3 : x ∈ z') (h4 : y ∈ z') : z = z' :=
((mem_and_mem_iff h).mp ⟨h1, h2⟩).trans ((mem_and_mem_iff h).mp ⟨h3, h4⟩).symm

instance mem.decidable [decidable_eq α] (x : α) (z : sym2 α) : decidable (x ∈ z) :=
quotient.rec_on_subsingleton z (λ ⟨y₁, y₂⟩, decidable_of_iff' _ mem_iff)

end membership

@[simp] lemma mem_map {f : α → β} {b : β} {z : sym2 α} :
  b ∈ sym2.map f z ↔ ∃ a, a ∈ z ∧ f a = b :=
begin
  induction z using sym2.ind with x y,
  simp only [map, quotient.map_mk, prod.map_mk, mem_iff],
  split,
  { rintro (rfl | rfl),
    { exact ⟨x, by simp⟩, },
    { exact ⟨y, by simp⟩, } },
  { rintro ⟨w, rfl | rfl, rfl⟩; simp, },
end

@[congr] lemma map_congr {f g : α → β} {s : sym2 α} (h : ∀ x ∈ s, f x = g x) :
  map f s = map g s :=
begin
  ext y,
  simp only [mem_map],
  split; { rintro ⟨w, hw, rfl⟩, exact ⟨w, hw, by simp [hw, h]⟩ },
end

/-- Note: `sym2.map_id` will not simplify `sym2.map id z` due to `sym2.map_congr`. -/
@[simp] lemma map_id' : map (λ (x : α), x) = id := map_id

/-! ### Diagonal -/

/--
A type `α` is naturally included in the diagonal of `α × α`, and this function gives the image
of this diagonal in `sym2 α`.
-/
def diag (x : α) : sym2 α := ⟦(x, x)⟧

lemma diag_injective : function.injective (sym2.diag : α → sym2 α) :=
λ x y h, by cases quotient.exact h; refl

/--
A predicate for testing whether an element of `sym2 α` is on the diagonal.
-/
def is_diag : sym2 α → Prop :=
lift ⟨eq, λ _ _, propext eq_comm⟩

lemma mk_is_diag_iff {x y : α} : is_diag ⟦(x, y)⟧ ↔ x = y := iff.rfl

@[simp]
lemma is_diag_iff_proj_eq (z : α × α) : is_diag ⟦z⟧ ↔ z.1 = z.2 :=
prod.rec_on z $ λ _ _, mk_is_diag_iff

@[simp]
lemma diag_is_diag (a : α) : is_diag (diag a) := eq.refl a

lemma is_diag.mem_range_diag {z : sym2 α} : is_diag z → z ∈ set.range (@diag α) :=
begin
  induction z using sym2.ind with x y,
  rintro (rfl : x = y),
  exact ⟨_, rfl⟩,
end

lemma is_diag_iff_mem_range_diag (z : sym2 α) : is_diag z ↔ z ∈ set.range (@diag α) :=
⟨is_diag.mem_range_diag, λ ⟨i, hi⟩, hi ▸ diag_is_diag i⟩

instance is_diag.decidable_pred (α : Type u) [decidable_eq α] : decidable_pred (@is_diag α) :=
by { refine λ z, quotient.rec_on_subsingleton z (λ a, _), erw is_diag_iff_proj_eq, apply_instance }

lemma other_ne {a : α} {z : sym2 α} (hd : ¬is_diag z) (h : a ∈ z) : h.other ≠ a :=
begin
  contrapose! hd,
  have h' := sym2.other_spec h,
  rw hd at h',
  rw ←h',
  simp,
end

section relations

/-! ### Declarations about symmetric relations -/

variables {r : α → α → Prop}

/--
Symmetric relations define a set on `sym2 α` by taking all those pairs
of elements that are related.
-/
def from_rel (sym : symmetric r) : set (sym2 α) :=
set_of (lift ⟨r, λ x y, propext ⟨λ h, sym h, λ h, sym h⟩⟩)

@[simp]
lemma from_rel_proj_prop {sym : symmetric r} {z : α × α} : ⟦z⟧ ∈ from_rel sym ↔ r z.1 z.2 := iff.rfl

@[simp]
lemma from_rel_prop {sym : symmetric r} {a b : α} : ⟦(a, b)⟧ ∈ from_rel sym ↔ r a b := iff.rfl

lemma from_rel_bot : from_rel (λ (x y : α) z, z : symmetric ⊥) = ∅ :=
begin
  apply set.eq_empty_of_forall_not_mem (λ e, _),
  refine e.ind _,
  simp [-set.bot_eq_empty, Prop.bot_eq_false],
end

lemma from_rel_top : from_rel (λ (x y : α) z, z : symmetric ⊤) = set.univ :=
begin
  apply set.eq_univ_of_forall (λ e, _),
  refine e.ind _,
  simp [-set.top_eq_univ, Prop.top_eq_true],
end

lemma from_rel_irreflexive {sym : symmetric r} :
  irreflexive r ↔ ∀ {z}, z ∈ from_rel sym → ¬is_diag z :=
{ mp  := λ h, sym2.ind $ by { rintros a b hr (rfl : a = b), exact h _ hr },
  mpr := λ h x hr, h (from_rel_prop.mpr hr) rfl }

lemma mem_from_rel_irrefl_other_ne {sym : symmetric r} (irrefl : irreflexive r)
  {a : α} {z : sym2 α} (hz : z ∈ from_rel sym) (h : a ∈ z) : h.other ≠ a :=
other_ne (from_rel_irreflexive.mp irrefl hz) h

instance from_rel.decidable_pred (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (∈ sym2.from_rel sym) :=
λ z, quotient.rec_on_subsingleton z (λ x, h _ _)

/-- The inverse to `sym2.from_rel`. Given a set on `sym2 α`, give a symmetric relation on `α`
(see `sym2.to_rel_symmetric`). -/
def to_rel (s : set (sym2 α)) (x y : α) : Prop := ⟦(x, y)⟧ ∈ s

@[simp] lemma to_rel_prop (s : set (sym2 α)) (x y : α) : to_rel s x y ↔ ⟦(x, y)⟧ ∈ s := iff.rfl

lemma to_rel_symmetric (s : set (sym2 α)) : symmetric (to_rel s) := λ x y, by simp [eq_swap]

lemma to_rel_from_rel (sym : symmetric r) : to_rel (from_rel sym) = r := rfl

lemma from_rel_to_rel (s : set (sym2 α)) : from_rel (to_rel_symmetric s) = s :=
set.ext (λ z, sym2.ind (λ x y, iff.rfl) z)

end relations

section sym_equiv

/-! ### Equivalence to the second symmetric power -/

local attribute [instance] vector.perm.is_setoid

private def from_vector : vector α 2 → α × α
| ⟨[a, b], h⟩ := (a, b)

private lemma perm_card_two_iff {a₁ b₁ a₂ b₂ : α} :
  [a₁, b₁].perm [a₂, b₂] ↔ a₁ = a₂ ∧ b₁ = b₂ ∨ a₁ = b₂ ∧ b₁ = a₂ :=
{ mp  := by { simp [← multiset.coe_eq_coe, ← multiset.cons_coe, multiset.cons_eq_cons], tidy },
  mpr := by { intro h, cases h; rw [h.1, h.2], apply list.perm.swap', refl } }

/--
The symmetric square is equivalent to length-2 vectors up to permutations.
-/
def sym2_equiv_sym' : equiv (sym2 α) (sym' α 2) :=
{ to_fun := quotient.map
    (λ (x : α × α), ⟨[x.1, x.2], rfl⟩)
    (by { rintros _ _ ⟨_⟩, { refl }, apply list.perm.swap', refl }),
  inv_fun := quotient.map from_vector (begin
    rintros ⟨x, hx⟩ ⟨y, hy⟩ h,
    cases x with _ x, { simpa using hx, },
    cases x with _ x, { simpa using hx, },
    cases x with _ x, swap, { exfalso, simp at hx, linarith [hx] },
    cases y with _ y, { simpa using hy, },
    cases y with _ y, { simpa using hy, },
    cases y with _ y, swap, { exfalso, simp at hy, linarith [hy] },
    rcases perm_card_two_iff.mp h with ⟨rfl,rfl⟩|⟨rfl,rfl⟩, { refl },
    apply sym2.rel.swap,
  end),
  left_inv := by tidy,
  right_inv := λ x, begin
    refine quotient.rec_on_subsingleton x (λ x, _),
    { cases x with x hx,
      cases x with _ x, { simpa using hx, },
      cases x with _ x, { simpa using hx, },
      cases x with _ x, swap, { exfalso, simp at hx, linarith [hx] },
      refl },
  end }

/--
The symmetric square is equivalent to the second symmetric power.
-/
def equiv_sym (α : Type*) : sym2 α ≃ sym α 2 :=
equiv.trans sym2_equiv_sym' sym_equiv_sym'.symm

/--
The symmetric square is equivalent to multisets of cardinality
two. (This is currently a synonym for `equiv_sym`, but it's provided
in case the definition for `sym` changes.)
-/
def equiv_multiset (α : Type*) : sym2 α ≃ {s : multiset α // s.card = 2} :=
equiv_sym α

end sym_equiv

section decidable

/--
An algorithm for computing `sym2.rel`.
-/
def rel_bool [decidable_eq α] (x y : α × α) : bool :=
if x.1 = y.1 then x.2 = y.2 else
  if x.1 = y.2 then x.2 = y.1 else ff

lemma rel_bool_spec [decidable_eq α] (x y : α × α) : ↥(rel_bool x y) ↔ rel α x y :=
begin
  cases x with x₁ x₂, cases y with y₁ y₂,
  dsimp [rel_bool], split_ifs;
  simp only [false_iff, bool.coe_sort_ff, bool.of_to_bool_iff],
  rotate 2, { contrapose! h, cases h; cc },
  all_goals { subst x₁, split; intro h1,
    { subst h1; apply sym2.rel.swap },
    { cases h1; cc } }
end

/--
Given `[decidable_eq α]` and `[fintype α]`, the following instance gives `fintype (sym2 α)`.
-/
instance (α : Type*) [decidable_eq α] : decidable_rel (sym2.rel α) :=
λ x y, decidable_of_bool (rel_bool x y) (rel_bool_spec x y)

/-! ### The other element of an element of the symmetric square -/

/--
A function that gives the other element of a pair given one of the elements.  Used in `mem.other'`.
-/
private def pair_other [decidable_eq α] (a : α) (z : α × α) : α := if a = z.1 then z.2 else z.1

/--
Get the other element of the unordered pair using the decidable equality.
This is the computable version of `mem.other`.
-/
def mem.other' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : α :=
quot.rec (λ x h', pair_other a x) (begin
  clear h z,
  intros x y h,
  ext hy,
  convert_to pair_other a x = _,
  { have h' : ∀ {c e h}, @eq.rec _ ⟦x⟧ (λ s, a ∈ s → α)
      (λ _, pair_other a x) c e h = pair_other a x,
    { intros _ e _, subst e },
    apply h', },
  have h' := (rel_bool_spec x y).mpr h,
  cases x with x₁ x₂, cases y with y₁ y₂,
  cases mem_iff.mp hy with hy'; subst a; dsimp [rel_bool] at h';
    split_ifs at h'; try { rw bool.of_to_bool_iff at h', subst x₁, subst x₂ }; dsimp [pair_other],
  simp only [ne.symm h_1, if_true, eq_self_iff_true, if_false],
  exfalso, exact bool.not_ff h',
  simp only [h_1, if_true, eq_self_iff_true, if_false],
  exfalso, exact bool.not_ff h',
end) z h

@[simp]
lemma other_spec' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : ⟦(a, h.other')⟧ = z :=
begin
  induction z, cases z with x y,
  have h' := mem_iff.mp h,
  dsimp [mem.other', quot.rec, pair_other],
  cases h'; subst a,
  { simp only [eq_self_iff_true], refl, },
  { split_ifs, subst h_1, refl, rw eq_swap, refl, },
  refl,
end

@[simp]
lemma other_eq_other' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : h.other = h.other' :=
by rw [←congr_right, other_spec' h, other_spec]

lemma other_mem' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : h.other' ∈ z :=
by { rw ←other_eq_other', exact other_mem h }

lemma other_invol' [decidable_eq α] {a : α} {z : sym2 α} (ha : a ∈ z) (hb : ha.other' ∈ z) :
  hb.other' = a :=
begin
  induction z, cases z with x y,
  dsimp [mem.other', quot.rec, pair_other] at hb,
  split_ifs at hb; dsimp [mem.other', quot.rec, pair_other],
  simp only [h, if_true, eq_self_iff_true],
  split_ifs, assumption, refl,
  simp only [h, if_false, eq_self_iff_true],
  exact ((mem_iff.mp ha).resolve_left h).symm,
  refl,
end

lemma other_invol {a : α} {z : sym2 α} (ha : a ∈ z) (hb : ha.other ∈ z) : hb.other = a :=
begin
  classical,
  rw other_eq_other' at hb ⊢,
  convert other_invol' ha hb,
  rw other_eq_other',
end

lemma filter_image_quotient_mk_is_diag [decidable_eq α] (s : finset α) :
  ((s ×ˢ s).image quotient.mk).filter is_diag = s.diag.image quotient.mk :=
begin
  ext z,
  induction z using quotient.induction_on,
  rcases z with ⟨x, y⟩,
  simp only [mem_image, mem_diag, exists_prop, mem_filter, prod.exists, mem_product],
  split,
  { rintro ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩,
    rw [←h, sym2.mk_is_diag_iff] at hab,
    exact ⟨a, b, ⟨ha, hab⟩, h⟩ },
  { rintro ⟨a, b, ⟨ha, rfl⟩, h⟩,
    rw ←h,
    exact ⟨⟨a, a, ⟨ha, ha⟩, rfl⟩, rfl⟩ }
end

lemma filter_image_quotient_mk_not_is_diag [decidable_eq α] (s : finset α) :
  ((s ×ˢ s).image quotient.mk).filter (λ a : sym2 α, ¬a.is_diag) =
    s.off_diag.image quotient.mk :=
begin
  ext z,
  induction z using quotient.induction_on,
  rcases z with ⟨x, y⟩,
  simp only [mem_image, mem_off_diag, mem_filter, prod.exists, mem_product],
  split,
  { rintro ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩,
    rw [←h, sym2.mk_is_diag_iff] at hab,
    exact ⟨a, b, ⟨ha, hb, hab⟩, h⟩ },
  { rintro ⟨a, b, ⟨ha, hb, hab⟩, h⟩,
    rw [ne.def, ←sym2.mk_is_diag_iff, h] at hab,
    exact ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩ }
end

end decidable

instance [subsingleton α] : subsingleton (sym2 α) :=
(equiv_sym α).injective.subsingleton

instance [unique α] : unique (sym2 α) := unique.mk' _

instance [is_empty α] : is_empty (sym2 α) := (equiv_sym α).is_empty

instance [nontrivial α] : nontrivial (sym2 α) := diag_injective.nontrivial

end sym2


/-
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, Johan Commelin
-/
import algebra.char_zero.infinite
import data.polynomial.algebra_map
import data.polynomial.degree.lemmas
import data.polynomial.div
import ring_theory.localization.fraction_ring
import algebra.polynomial.big_operators

/-!
# Theory of univariate polynomials

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

This file starts looking like the ring theory of $ R[X] $

## Main definitions

* `polynomial.roots p`: The multiset containing all the roots of `p`, including their
  multiplicities.
* `polynomial.root_set p E`: The set of distinct roots of `p` in an algebra `E`.

## Main statements

* `polynomial.C_leading_coeff_mul_prod_multiset_X_sub_C`: If a polynomial has as many roots as its
  degree, it can be written as the product of its leading coefficient with `∏ (X - a)` where `a`
  ranges through its roots.

-/

noncomputable theory
open_locale classical polynomial

open finset

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

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

section
variables [semiring S]

lemma nat_degree_pos_of_aeval_root [algebra R S] {p : R[X]} (hp : p ≠ 0)
  {z : S} (hz : aeval z p = 0) (inj : ∀ (x : R), algebra_map R S x = 0 → x = 0) :
  0 < p.nat_degree :=
nat_degree_pos_of_eval₂_root hp (algebra_map R S) hz inj

lemma degree_pos_of_aeval_root [algebra R S] {p : R[X]} (hp : p ≠ 0)
  {z : S} (hz : aeval z p = 0) (inj : ∀ (x : R), algebra_map R S x = 0 → x = 0) :
  0 < p.degree :=
nat_degree_pos_iff_degree_pos.mp (nat_degree_pos_of_aeval_root hp hz inj)

lemma mod_by_monic_eq_of_dvd_sub (hq : q.monic) {p₁ p₂ : R[X]}
  (h : q ∣ (p₁ - p₂)) :
  p₁ %ₘ q = p₂ %ₘ q :=
begin
  nontriviality R,
  obtain ⟨f, sub_eq⟩ := h,
  refine (div_mod_by_monic_unique (p₂ /ₘ q + f) _ hq
    ⟨_, degree_mod_by_monic_lt _ hq⟩).2,
  rw [sub_eq_iff_eq_add.mp sub_eq, mul_add, ← add_assoc, mod_by_monic_add_div _ hq, add_comm]
end

lemma add_mod_by_monic (p₁ p₂ : R[X]) : (p₁ + p₂) %ₘ q = p₁ %ₘ q + p₂ %ₘ q :=
begin
  by_cases hq : q.monic,
  { nontriviality R,
    exact (div_mod_by_monic_unique (p₁ /ₘ q + p₂ /ₘ q) _ hq
      ⟨by rw [mul_add, add_left_comm, add_assoc, mod_by_monic_add_div _ hq, ← add_assoc,
              add_comm (q * _), mod_by_monic_add_div _ hq],
        (degree_add_le _ _).trans_lt (max_lt (degree_mod_by_monic_lt _ hq)
          (degree_mod_by_monic_lt _ hq))⟩).2 },
  { simp_rw mod_by_monic_eq_of_not_monic _ hq }
end

lemma smul_mod_by_monic (c : R) (p : R[X]) : (c • p) %ₘ q = c • (p %ₘ q) :=
begin
  by_cases hq : q.monic,
  { nontriviality R,
    exact (div_mod_by_monic_unique (c • (p /ₘ q)) (c • (p %ₘ q)) hq
      ⟨by rw [mul_smul_comm, ← smul_add, mod_by_monic_add_div p hq],
      (degree_smul_le _ _).trans_lt (degree_mod_by_monic_lt _ hq)⟩).2 },
  { simp_rw mod_by_monic_eq_of_not_monic _ hq }
end

/--  `_ %ₘ q` as an `R`-linear map. -/
@[simps]
def mod_by_monic_hom (q : R[X]) : R[X] →ₗ[R] R[X] :=
{ to_fun := λ p, p %ₘ q,
  map_add' := add_mod_by_monic,
  map_smul' := smul_mod_by_monic }

end

section
variables [ring S]

lemma aeval_mod_by_monic_eq_self_of_root [algebra R S]
  {p q : R[X]} (hq : q.monic) {x : S} (hx : aeval x q = 0) :
  aeval x (p %ₘ q) = aeval x p :=
-- `eval₂_mod_by_monic_eq_self_of_root` doesn't work here as it needs commutativity
by rw [mod_by_monic_eq_sub_mul_div p hq, _root_.map_sub, _root_.map_mul, hx, zero_mul, sub_zero]

end

end comm_ring

section no_zero_divisors
variables [semiring R] [no_zero_divisors R] {p q : R[X]}

instance : no_zero_divisors R[X] :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b h, begin
    rw [← leading_coeff_eq_zero, ← leading_coeff_eq_zero],
    refine eq_zero_or_eq_zero_of_mul_eq_zero _,
    rw [← leading_coeff_zero, ← leading_coeff_mul, h],
  end }

lemma nat_degree_mul (hp : p ≠ 0) (hq : q ≠ 0) : nat_degree (p * q) =
  nat_degree p + nat_degree q :=
by rw [← with_bot.coe_eq_coe, ← degree_eq_nat_degree (mul_ne_zero hp hq),
    with_bot.coe_add, ← degree_eq_nat_degree hp,
    ← degree_eq_nat_degree hq, degree_mul]

lemma trailing_degree_mul : (p * q).trailing_degree = p.trailing_degree + q.trailing_degree :=
begin
  by_cases hp : p = 0,
  { rw [hp, zero_mul, trailing_degree_zero, top_add] },
  by_cases hq : q = 0,
  { rw [hq, mul_zero, trailing_degree_zero, add_top] },
  rw [trailing_degree_eq_nat_trailing_degree hp, trailing_degree_eq_nat_trailing_degree hq,
      trailing_degree_eq_nat_trailing_degree (mul_ne_zero hp hq),
      nat_trailing_degree_mul hp hq, with_top.coe_add],
end

@[simp] lemma nat_degree_pow (p : R[X]) (n : ℕ) :
  nat_degree (p ^ n) = n * nat_degree p :=
if hp0 : p = 0
then if hn0 : n = 0 then by simp [hp0, hn0]
  else by rw [hp0, zero_pow (nat.pos_of_ne_zero hn0)]; simp
else nat_degree_pow'
  (by rw [← leading_coeff_pow, ne.def, leading_coeff_eq_zero]; exact pow_ne_zero _ hp0)

lemma degree_le_mul_left (p : R[X]) (hq : q ≠ 0) : degree p ≤ degree (p * q) :=
if hp : p = 0 then by simp only [hp, zero_mul, le_refl]
else by rw [degree_mul, degree_eq_nat_degree hp,
    degree_eq_nat_degree hq];
  exact with_bot.coe_le_coe.2 (nat.le_add_right _ _)

theorem nat_degree_le_of_dvd {p q : R[X]} (h1 : p ∣ q) (h2 : q ≠ 0) :
  p.nat_degree ≤ q.nat_degree :=
begin
  rcases h1 with ⟨q, rfl⟩, rw mul_ne_zero_iff at h2,
  rw [nat_degree_mul h2.1 h2.2], exact nat.le_add_right _ _
end

lemma degree_le_of_dvd {p q : R[X]} (h1 : p ∣ q) (h2 : q ≠ 0) : degree p ≤ degree q :=
begin
  rcases h1 with ⟨q, rfl⟩, rw mul_ne_zero_iff at h2,
  exact degree_le_mul_left p h2.2,
end

lemma eq_zero_of_dvd_of_degree_lt {p q : R[X]} (h₁ : p ∣ q) (h₂ : degree q < degree p) :
  q = 0 :=
begin
  by_contradiction hc,
  exact (lt_iff_not_ge _ _ ).mp h₂ (degree_le_of_dvd h₁ hc),
end

lemma eq_zero_of_dvd_of_nat_degree_lt {p q : R[X]} (h₁ : p ∣ q) (h₂ : nat_degree q < nat_degree p) :
  q = 0 :=
begin
  by_contradiction hc,
  exact (lt_iff_not_ge _ _ ).mp h₂ (nat_degree_le_of_dvd h₁ hc),
end

theorem not_dvd_of_degree_lt {p q : R[X]} (h0 : q ≠ 0)
  (hl : q.degree < p.degree) : ¬ p ∣ q :=
begin
  by_contra hcontra,
  exact h0 (eq_zero_of_dvd_of_degree_lt hcontra hl),
end

theorem not_dvd_of_nat_degree_lt {p q : R[X]} (h0 : q ≠ 0)
  (hl : q.nat_degree < p.nat_degree) : ¬ p ∣ q :=
begin
  by_contra hcontra,
  exact h0 (eq_zero_of_dvd_of_nat_degree_lt hcontra hl),
end

/-- This lemma is useful for working with the `int_degree` of a rational function. -/
lemma nat_degree_sub_eq_of_prod_eq {p₁ p₂ q₁ q₂ : R[X]} (hp₁ : p₁ ≠ 0) (hq₁ : q₁ ≠ 0)
  (hp₂ : p₂ ≠ 0) (hq₂ : q₂ ≠ 0) (h_eq : p₁ * q₂ = p₂ * q₁) :
  (p₁.nat_degree : ℤ) - q₁.nat_degree = (p₂.nat_degree : ℤ) - q₂.nat_degree :=
begin
  rw sub_eq_sub_iff_add_eq_add,
  norm_cast,
  rw [← nat_degree_mul hp₁ hq₂, ← nat_degree_mul hp₂ hq₁, h_eq]
end

lemma nat_degree_eq_zero_of_is_unit (h : is_unit p) : nat_degree p = 0 :=
begin
  nontriviality R,
  obtain ⟨q, hq⟩ := h.exists_right_inv,
  have := nat_degree_mul (left_ne_zero_of_mul_eq_one hq) (right_ne_zero_of_mul_eq_one hq),
  rw [hq, nat_degree_one, eq_comm, add_eq_zero_iff] at this,
  exact this.1,
end

lemma degree_eq_zero_of_is_unit [nontrivial R] (h : is_unit p) : degree p = 0 :=
(nat_degree_eq_zero_iff_degree_le_zero.mp $ nat_degree_eq_zero_of_is_unit h).antisymm
  (zero_le_degree_iff.mpr h.ne_zero)

@[simp] lemma degree_coe_units [nontrivial R] (u : R[X]ˣ) : degree (u : R[X]) = 0 :=
degree_eq_zero_of_is_unit ⟨u, rfl⟩

theorem is_unit_iff : is_unit p ↔ ∃ r : R, is_unit r ∧ C r = p :=
⟨λ hp, ⟨p.coeff 0, let h := eq_C_of_nat_degree_eq_zero (nat_degree_eq_zero_of_is_unit hp) in
  ⟨is_unit_C.1 (h ▸ hp), h.symm⟩⟩, λ ⟨r, hr, hrp⟩, hrp ▸ is_unit_C.2 hr⟩

variables [char_zero R]

@[simp] lemma degree_bit0_eq (p : R[X]) : degree (bit0 p) = degree p :=
by rw [bit0_eq_two_mul, degree_mul, (by simp : (2 : R[X]) = C 2),
  @polynomial.degree_C R _ _ two_ne_zero, zero_add]

@[simp] lemma nat_degree_bit0_eq (p : R[X]) : nat_degree (bit0 p) = nat_degree p :=
nat_degree_eq_of_degree_eq $ degree_bit0_eq p

@[simp]
lemma nat_degree_bit1_eq (p : R[X]) : nat_degree (bit1 p) = nat_degree p :=
begin
  rw bit1,
  apply le_antisymm,
  convert nat_degree_add_le _ _,
  { simp, },
  by_cases h : p.nat_degree = 0,
  { simp [h], },
  apply le_nat_degree_of_ne_zero,
  intro hh,
  apply h,
  simp [*, coeff_one, if_neg (ne.symm h)] at *,
end

lemma degree_bit1_eq {p : R[X]} (hp : 0 < degree p) : degree (bit1 p) = degree p :=
begin
  rw [bit1, degree_add_eq_left_of_degree_lt, degree_bit0_eq],
  rwa [degree_one, degree_bit0_eq]
end

end no_zero_divisors

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

lemma irreducible_of_monic (hp : p.monic) (hp1 : p ≠ 1) :
  irreducible p ↔ ∀ f g : R[X], f.monic → g.monic → f * g = p → f = 1 ∨ g = 1 :=
begin
  refine ⟨λ h f g hf hg hp, (h.2 f g hp.symm).imp hf.eq_one_of_is_unit hg.eq_one_of_is_unit,
    λ h, ⟨hp1 ∘ hp.eq_one_of_is_unit, λ f g hfg, (h (g * C f.leading_coeff) (f * C g.leading_coeff)
      _ _ _).symm.imp (is_unit_of_mul_eq_one f _) (is_unit_of_mul_eq_one g _)⟩⟩,
  { rwa [monic, leading_coeff_mul, leading_coeff_C, ←leading_coeff_mul, mul_comm, ←hfg, ←monic] },
  { rwa [monic, leading_coeff_mul, leading_coeff_C, ←leading_coeff_mul, ←hfg, ←monic] },
  { rw [mul_mul_mul_comm, ←C_mul, ←leading_coeff_mul, ←hfg, hp.leading_coeff, C_1, mul_one,
        mul_comm, ←hfg] },
end

lemma monic.irreducible_iff_nat_degree (hp : p.monic) : irreducible p ↔
  p ≠ 1 ∧ ∀ f g : R[X], f.monic → g.monic → f * g = p → f.nat_degree = 0 ∨ g.nat_degree = 0 :=
begin
  by_cases hp1 : p = 1, { simp [hp1] },
  rw [irreducible_of_monic hp hp1, and_iff_right hp1],
  refine forall₄_congr (λ a b ha hb, _),
  rw [ha.nat_degree_eq_zero_iff_eq_one, hb.nat_degree_eq_zero_iff_eq_one],
end

lemma monic.irreducible_iff_nat_degree' (hp : p.monic) : irreducible p ↔ p ≠ 1 ∧
  ∀ f g : R[X], f.monic → g.monic → f * g = p → g.nat_degree ∉ Ioc 0 (p.nat_degree / 2) :=
begin
  simp_rw [hp.irreducible_iff_nat_degree, mem_Ioc, nat.le_div_iff_mul_le zero_lt_two, mul_two],
  apply and_congr_right',
  split; intros h f g hf hg he; subst he,
  { rw [hf.nat_degree_mul hg, add_le_add_iff_right],
    exact λ ha, (h f g hf hg rfl).elim (ha.1.trans_le ha.2).ne' ha.1.ne' },
  { simp_rw [hf.nat_degree_mul hg, pos_iff_ne_zero] at h,
    contrapose! h,
    obtain hl|hl := le_total f.nat_degree g.nat_degree,
    { exact ⟨g, f, hg, hf, mul_comm g f, h.1, add_le_add_left hl _⟩ },
    { exact ⟨f, g, hf, hg, rfl, h.2, add_le_add_right hl _⟩ } },
end

lemma monic.not_irreducible_iff_exists_add_mul_eq_coeff (hm : p.monic) (hnd : p.nat_degree = 2) :
  ¬ irreducible p ↔ ∃ c₁ c₂, p.coeff 0 = c₁ * c₂ ∧ p.coeff 1 = c₁ + c₂ :=
begin
  casesI subsingleton_or_nontrivial R,
  { simpa only [nat_degree_of_subsingleton] using hnd },
  rw [hm.irreducible_iff_nat_degree', and_iff_right, hnd],
  push_neg, split,
  { rintros ⟨a, b, ha, hb, rfl, hdb|⟨⟨⟩⟩⟩,
    have hda := hnd, rw [ha.nat_degree_mul hb, hdb] at hda,
    use [a.coeff 0, b.coeff 0, mul_coeff_zero a b],
    simpa only [next_coeff, hnd, add_right_cancel hda, hdb] using ha.next_coeff_mul hb },
  { rintros ⟨c₁, c₂, hmul, hadd⟩,
    refine ⟨X + C c₁, X + C c₂, monic_X_add_C _, monic_X_add_C _, _, or.inl $ nat_degree_X_add_C _⟩,
    rw [p.as_sum_range_C_mul_X_pow, hnd, finset.sum_range_succ, finset.sum_range_succ,
      finset.sum_range_one, ← hnd, hm.coeff_nat_degree, hnd, hmul, hadd, C_mul, C_add, C_1],
    ring },
  { rintro rfl, simpa only [nat_degree_one] using hnd },
end

lemma root_mul : is_root (p * q) a ↔ is_root p a ∨ is_root q a :=
by simp_rw [is_root, eval_mul, mul_eq_zero]

lemma root_or_root_of_root_mul (h : is_root (p * q) a) : is_root p a ∨ is_root q a :=
root_mul.1 h

end no_zero_divisors

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

instance : is_domain R[X] :=
no_zero_divisors.to_is_domain _

end ring

section comm_ring
variable [comm_ring R]

/-- The multiplicity of `a` as root of a nonzero polynomial `p` is at least `n` iff
  `(X - a) ^ n` divides `p`. -/
lemma le_root_multiplicity_iff {p : R[X]} (p0 : p ≠ 0) {a : R} {n : ℕ} :
  n ≤ root_multiplicity a p ↔ (X - C a) ^ n ∣ p :=
begin
  simp_rw [root_multiplicity, dif_neg p0, nat.le_find_iff, not_not],
  refine ⟨λ h, _, λ h m hm, (pow_dvd_pow _ hm).trans h⟩,
  cases n, { rw pow_zero, apply one_dvd }, { exact h n n.lt_succ_self },
end

lemma root_multiplicity_le_iff {p : R[X]} (p0 : p ≠ 0) (a : R) (n : ℕ) :
  root_multiplicity a p ≤ n ↔ ¬ (X - C a) ^ (n + 1) ∣ p :=
by rw [← (le_root_multiplicity_iff p0).not, not_le, nat.lt_add_one_iff]

lemma pow_root_multiplicity_not_dvd {p : R[X]} (p0 : p ≠ 0) (a : R) :
  ¬ (X - C a) ^ (root_multiplicity a p + 1) ∣ p :=
by rw [← root_multiplicity_le_iff p0]

/-- The multiplicity of `p + q` is at least the minimum of the multiplicities. -/
lemma root_multiplicity_add {p q : R[X]} (a : R) (hzero : p + q ≠ 0) :
  min (root_multiplicity a p) (root_multiplicity a q) ≤ root_multiplicity a (p + q) :=
begin
  rw le_root_multiplicity_iff hzero,
  have hdivp : (X - C a) ^ root_multiplicity a p ∣ p := pow_root_multiplicity_dvd p a,
  have hdivq : (X - C a) ^ root_multiplicity a q ∣ q := pow_root_multiplicity_dvd q a,
  exact min_pow_dvd_add hdivp hdivq
end

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

section roots

open multiset

theorem prime_X_sub_C (r : R) : prime (X - C r) :=
⟨X_sub_C_ne_zero r, not_is_unit_X_sub_C r,
 λ _ _, by { simp_rw [dvd_iff_is_root, is_root.def, eval_mul, mul_eq_zero], exact id }⟩

theorem prime_X : prime (X : R[X]) :=
by { convert (prime_X_sub_C (0 : R)), simp }

lemma monic.prime_of_degree_eq_one (hp1 : degree p = 1) (hm : monic p) :
  prime p :=
have p = X - C (- p.coeff 0),
  by simpa [hm.leading_coeff] using eq_X_add_C_of_degree_eq_one hp1,
this.symm ▸ prime_X_sub_C _

theorem irreducible_X_sub_C (r : R) : irreducible (X - C r) :=
(prime_X_sub_C r).irreducible

theorem irreducible_X : irreducible (X : R[X]) :=
prime.irreducible prime_X

lemma monic.irreducible_of_degree_eq_one (hp1 : degree p = 1) (hm : monic p) :
  irreducible p :=
(hm.prime_of_degree_eq_one hp1).irreducible

theorem eq_of_monic_of_associated (hp : p.monic) (hq : q.monic) (hpq : associated p q) : p = q :=
begin
  obtain ⟨u, hu⟩ := hpq,
  unfold monic at hp hq,
  rw eq_C_of_degree_le_zero (degree_coe_units _).le at hu,
  rw [← hu, leading_coeff_mul, hp, one_mul, leading_coeff_C] at hq,
  rwa [hq, C_1, mul_one] at hu,
  all_goals { apply_instance },
end

lemma root_multiplicity_mul {p q : R[X]} {x : R} (hpq : p * q ≠ 0) :
  root_multiplicity x (p * q) = root_multiplicity x p + root_multiplicity x q :=
begin
  have hp : p ≠ 0 := left_ne_zero_of_mul hpq,
  have hq : q ≠ 0 := right_ne_zero_of_mul hpq,
  rw [root_multiplicity_eq_multiplicity (p * q), dif_neg hpq,
      root_multiplicity_eq_multiplicity p, dif_neg hp,
      root_multiplicity_eq_multiplicity q, dif_neg hq,
      multiplicity.mul' (prime_X_sub_C x)],
end

lemma root_multiplicity_X_sub_C_self {x : R} :
  root_multiplicity x (X - C x) = 1 :=
by rw [root_multiplicity_eq_multiplicity, dif_neg (X_sub_C_ne_zero x),
       multiplicity.get_multiplicity_self]

lemma root_multiplicity_X_sub_C {x y : R} :
  root_multiplicity x (X - C y) = if x = y then 1 else 0 :=
begin
  split_ifs with hxy,
  { rw hxy,
    exact root_multiplicity_X_sub_C_self },
  exact root_multiplicity_eq_zero (mt root_X_sub_C.mp (ne.symm hxy))
end

/-- The multiplicity of `a` as root of `(X - a) ^ n` is `n`. -/
lemma root_multiplicity_X_sub_C_pow (a : R) (n : ℕ) : root_multiplicity a ((X - C a) ^ n) = n :=
begin
  induction n with n hn,
  { refine root_multiplicity_eq_zero _,
    simp only [eval_one, is_root.def, not_false_iff, one_ne_zero, pow_zero] },
  have hzero := pow_ne_zero n.succ (X_sub_C_ne_zero a),
  rw pow_succ (X - C a) n at hzero ⊢,
  simp only [root_multiplicity_mul hzero, root_multiplicity_X_sub_C_self, hn, nat.one_add]
end

lemma exists_multiset_roots : ∀ {p : R[X]} (hp : p ≠ 0),
  ∃ s : multiset R, (s.card : with_bot ℕ) ≤ degree p ∧ ∀ a, s.count a = root_multiplicity a p
| p := λ hp, by haveI := classical.prop_decidable (∃ x, is_root p x); exact
if h : ∃ x, is_root p x
then
  let ⟨x, hx⟩ := h in
  have hpd : 0 < degree p := degree_pos_of_root hp hx,
  have hd0 : p /ₘ (X - C x) ≠ 0 :=
    λ h, by rw [← mul_div_by_monic_eq_iff_is_root.2 hx, h, mul_zero] at hp; exact hp rfl,
  have wf : degree (p /ₘ _) < degree p :=
    degree_div_by_monic_lt _ (monic_X_sub_C x) hp
    ((degree_X_sub_C x).symm ▸ dec_trivial),
  let ⟨t, htd, htr⟩ := @exists_multiset_roots (p /ₘ (X - C x)) hd0 in
  have hdeg : degree (X - C x) ≤ degree p := begin
    rw [degree_X_sub_C, degree_eq_nat_degree hp],
    rw degree_eq_nat_degree hp at hpd,
    exact with_bot.coe_le_coe.2 (with_bot.coe_lt_coe.1 hpd)
  end,
  have hdiv0 : p /ₘ (X - C x) ≠ 0 := mt (div_by_monic_eq_zero_iff (monic_X_sub_C x)).1 $
    not_lt.2 hdeg,
  ⟨x ::ₘ t, calc (card (x ::ₘ t) : with_bot ℕ) = t.card + 1 :
      by exact_mod_cast card_cons _ _
    ... ≤ degree p :
      by rw [← degree_add_div_by_monic (monic_X_sub_C x) hdeg,
          degree_X_sub_C, add_comm];
        exact add_le_add (le_refl (1 : with_bot ℕ)) htd,
  begin
    assume a,
    conv_rhs { rw ← mul_div_by_monic_eq_iff_is_root.mpr hx },
    rw [root_multiplicity_mul (mul_ne_zero (X_sub_C_ne_zero x) hdiv0),
        root_multiplicity_X_sub_C, ← htr a],
    split_ifs with ha,
    { rw [ha, count_cons_self, nat.succ_eq_add_one, add_comm] },
    { rw [count_cons_of_ne ha, zero_add] },
  end⟩
else
  ⟨0, (degree_eq_nat_degree hp).symm ▸ with_bot.coe_le_coe.2 (nat.zero_le _),
    by { intro a, rw [count_zero, root_multiplicity_eq_zero (not_exists.mp h a)] }⟩
using_well_founded {dec_tac := tactic.assumption}

/-- `roots p` noncomputably gives a multiset containing all the roots of `p`,
including their multiplicities. -/
noncomputable def roots (p : R[X]) : multiset R :=
if h : p = 0 then ∅ else classical.some (exists_multiset_roots h)

@[simp] lemma roots_zero : (0 : R[X]).roots = 0 :=
dif_pos rfl

lemma card_roots (hp0 : p ≠ 0) : ((roots p).card : with_bot ℕ) ≤ degree p :=
begin
  unfold roots,
  rw dif_neg hp0,
  exact (classical.some_spec (exists_multiset_roots hp0)).1
end

lemma card_roots' (p : R[X]) : p.roots.card ≤ nat_degree p :=
begin
  by_cases hp0 : p = 0,
  { simp [hp0], },
  exact with_bot.coe_le_coe.1 (le_trans (card_roots hp0) (le_of_eq $ degree_eq_nat_degree hp0))
end

lemma card_roots_sub_C {p : R[X]} {a : R} (hp0 : 0 < degree p) :
  ((p - C a).roots.card : with_bot ℕ) ≤ degree p :=
calc ((p - C a).roots.card : with_bot ℕ) ≤ degree (p - C a) :
  card_roots $ mt sub_eq_zero.1 $ λ h, not_le_of_gt hp0 $ h.symm ▸ degree_C_le
... = degree p : by rw [sub_eq_add_neg, ← C_neg]; exact degree_add_C hp0

lemma card_roots_sub_C' {p : R[X]} {a : R} (hp0 : 0 < degree p) :
  (p - C a).roots.card ≤ nat_degree p :=
with_bot.coe_le_coe.1 (le_trans (card_roots_sub_C hp0) (le_of_eq $ degree_eq_nat_degree
  (λ h, by simp [*, lt_irrefl] at *)))

@[simp] lemma count_roots (p : R[X]) : p.roots.count a = root_multiplicity a p :=
begin
  by_cases hp : p = 0,
  { simp [hp], },
  rw [roots, dif_neg hp],
  exact (classical.some_spec (exists_multiset_roots hp)).2 a
end

@[simp] lemma mem_roots' : a ∈ p.roots ↔ p ≠ 0 ∧ is_root p a :=
by rw [← count_pos, count_roots p, root_multiplicity_pos']

lemma mem_roots (hp : p ≠ 0) : a ∈ p.roots ↔ is_root p a := mem_roots'.trans $ and_iff_right hp

lemma ne_zero_of_mem_roots (h : a ∈ p.roots) : p ≠ 0 := (mem_roots'.1 h).1

lemma is_root_of_mem_roots (h : a ∈ p.roots) : is_root p a := (mem_roots'.1 h).2

theorem card_le_degree_of_subset_roots {p : R[X]} {Z : finset R} (h : Z.val ⊆ p.roots) :
  Z.card ≤ p.nat_degree :=
(multiset.card_le_of_le (finset.val_le_iff_val_subset.2 h)).trans (polynomial.card_roots' p)

lemma finite_set_of_is_root {p : R[X]} (hp : p ≠ 0) : set.finite {x | is_root p x} :=
by simpa only [← finset.set_of_mem, mem_to_finset, mem_roots hp]
  using p.roots.to_finset.finite_to_set

lemma eq_zero_of_infinite_is_root (p : R[X]) (h : set.infinite {x | is_root p x}) : p = 0 :=
not_imp_comm.mp finite_set_of_is_root h

lemma exists_max_root [linear_order R] (p : R[X]) (hp : p ≠ 0) :
  ∃ x₀, ∀ x, p.is_root x → x ≤ x₀ :=
set.exists_upper_bound_image _ _ $ finite_set_of_is_root hp

lemma exists_min_root [linear_order R] (p : R[X]) (hp : p ≠ 0) :
  ∃ x₀, ∀ x, p.is_root x → x₀ ≤ x :=
set.exists_lower_bound_image _ _ $ finite_set_of_is_root hp

lemma eq_of_infinite_eval_eq (p q : R[X]) (h : set.infinite {x | eval x p = eval x q}) : p = q :=
begin
  rw [← sub_eq_zero],
  apply eq_zero_of_infinite_is_root,
  simpa only [is_root, eval_sub, sub_eq_zero]
end

lemma roots_mul {p q : R[X]} (hpq : p * q ≠ 0) : (p * q).roots = p.roots + q.roots :=
multiset.ext.mpr $ λ r,
  by rw [count_add, count_roots, count_roots,
         count_roots, root_multiplicity_mul hpq]

lemma roots.le_of_dvd (h : q ≠ 0) : p ∣ q → roots p ≤ roots q :=
begin
  rintro ⟨k, rfl⟩,
  exact multiset.le_iff_exists_add.mpr ⟨k.roots, roots_mul h⟩
end

lemma mem_roots_sub_C' {p : R[X]} {a x : R} :
  x ∈ (p - C a).roots ↔ p ≠ C a ∧ p.eval x = a :=
by rw [mem_roots', is_root.def, sub_ne_zero, eval_sub, sub_eq_zero, eval_C]

lemma mem_roots_sub_C {p : R[X]} {a x : R} (hp0 : 0 < degree p) :
  x ∈ (p - C a).roots ↔ p.eval x = a :=
mem_roots_sub_C'.trans $ and_iff_right $ λ hp, hp0.not_le $ hp.symm ▸ degree_C_le

@[simp] lemma roots_X_sub_C (r : R) : roots (X - C r) = {r} :=
begin
  ext s,
  rw [count_roots, root_multiplicity_X_sub_C, count_singleton],
end

@[simp] lemma roots_X : roots (X : R[X]) = {0} := by rw [← roots_X_sub_C, C_0, sub_zero]

@[simp] lemma roots_C (x : R) : (C x).roots = 0 :=
if H : x = 0 then by rw [H, C_0, roots_zero] else multiset.ext.mpr $ λ r,
by rw [count_roots, count_zero, root_multiplicity_eq_zero (not_is_root_C _ _ H)]

@[simp] lemma roots_one : (1 : R[X]).roots = ∅ :=
roots_C 1

@[simp] lemma roots_C_mul (p : R[X]) (ha : a ≠ 0) : (C a * p).roots = p.roots :=
by by_cases hp : p = 0; simp only [roots_mul, *, ne.def, mul_eq_zero, C_eq_zero, or_self,
  not_false_iff, roots_C, zero_add, mul_zero]

@[simp] lemma roots_smul_nonzero (p : R[X]) (ha : a ≠ 0) : (a • p).roots = p.roots :=
by rw [smul_eq_C_mul, roots_C_mul _ ha]

lemma roots_list_prod (L : list R[X]) :
  ((0 : R[X]) ∉ L) → L.prod.roots = (L : multiset R[X]).bind roots :=
list.rec_on L (λ _, roots_one) $ λ hd tl ih H,
begin
  rw [list.mem_cons_iff, not_or_distrib] at H,
  rw [list.prod_cons, roots_mul (mul_ne_zero (ne.symm H.1) $ list.prod_ne_zero H.2),
      ← multiset.cons_coe, multiset.cons_bind, ih H.2]
end

lemma roots_multiset_prod (m : multiset R[X]) :
  (0 : R[X]) ∉ m → m.prod.roots = m.bind roots :=
by { rcases m with ⟨L⟩, simpa only [multiset.coe_prod, quot_mk_to_coe''] using roots_list_prod L }

lemma roots_prod {ι : Type*} (f : ι → R[X]) (s : finset ι) :
  s.prod f ≠ 0 → (s.prod f).roots = s.val.bind (λ i, roots (f i)) :=
begin
  rcases s with ⟨m, hm⟩,
  simpa [multiset.prod_eq_zero_iff, bind_map] using roots_multiset_prod (m.map f)
end

@[simp] lemma roots_pow (p : R[X]) (n : ℕ) : (p ^ n).roots = n • p.roots :=
begin
  induction n with n ihn,
  { rw [pow_zero, roots_one, zero_smul, empty_eq_zero] },
  { rcases eq_or_ne p 0 with rfl | hp,
    { rw [zero_pow n.succ_pos, roots_zero, smul_zero] },
    { rw [pow_succ', roots_mul (mul_ne_zero (pow_ne_zero _ hp) hp), ihn, nat.succ_eq_add_one,
        add_smul, one_smul] } }
end

lemma roots_X_pow (n : ℕ) : (X ^ n : R[X]).roots = n • {0} := by rw [roots_pow, roots_X]

lemma roots_C_mul_X_pow (ha : a ≠ 0) (n : ℕ) : (C a * X ^ n).roots = n • {0} :=
by rw [roots_C_mul _ ha, roots_X_pow]

@[simp] lemma roots_monomial (ha : a ≠ 0) (n : ℕ) : (monomial n a).roots = n • {0} :=
by rw [← C_mul_X_pow_eq_monomial, roots_C_mul_X_pow ha]

lemma roots_prod_X_sub_C (s : finset R) :
  (s.prod (λ a, X - C a)).roots = s.val :=
(roots_prod (λ a, X - C a) s (prod_ne_zero_iff.mpr (λ a _, X_sub_C_ne_zero a))).trans
  (by simp_rw [roots_X_sub_C, multiset.bind_singleton, multiset.map_id'])

@[simp] lemma roots_multiset_prod_X_sub_C (s : multiset R) :
  (s.map (λ a, X - C a)).prod.roots = s :=
begin
  rw [roots_multiset_prod, multiset.bind_map],
  { simp_rw [roots_X_sub_C, multiset.bind_singleton, multiset.map_id'] },
  { rw [multiset.mem_map], rintro ⟨a, -, h⟩, exact X_sub_C_ne_zero a h },
end

@[simp] lemma nat_degree_multiset_prod_X_sub_C_eq_card (s : multiset R):
  (s.map (λ a, X - C a)).prod.nat_degree = s.card :=
begin
  rw [nat_degree_multiset_prod_of_monic, multiset.map_map],
  { simp only [(∘), nat_degree_X_sub_C, multiset.map_const, multiset.sum_replicate, smul_eq_mul,
      mul_one] },
  { exact multiset.forall_mem_map_iff.2 (λ a _, monic_X_sub_C a) },
end

lemma card_roots_X_pow_sub_C {n : ℕ} (hn : 0 < n) (a : R) :
  (roots ((X : R[X]) ^ n - C a)).card ≤ n :=
with_bot.coe_le_coe.1 $
calc ((roots ((X : R[X]) ^ n - C a)).card : with_bot ℕ)
      ≤ degree ((X : R[X]) ^ n - C a) : card_roots (X_pow_sub_C_ne_zero hn a)
  ... = n : degree_X_pow_sub_C hn a

section nth_roots

/-- `nth_roots n a` noncomputably returns the solutions to `x ^ n = a`-/
def nth_roots (n : ℕ) (a : R) : multiset R :=
roots ((X : R[X]) ^ n - C a)

@[simp] lemma mem_nth_roots {n : ℕ} (hn : 0 < n) {a x : R} :
  x ∈ nth_roots n a ↔ x ^ n = a :=
by rw [nth_roots, mem_roots (X_pow_sub_C_ne_zero hn a),
  is_root.def, eval_sub, eval_C, eval_pow, eval_X, sub_eq_zero]

@[simp] lemma nth_roots_zero (r : R) : nth_roots 0 r = 0 :=
by simp only [empty_eq_zero, pow_zero, nth_roots, ← C_1, ← C_sub, roots_C]

lemma card_nth_roots (n : ℕ) (a : R) :
  (nth_roots n a).card ≤ n :=
if hn : n = 0 then
  if h : (X : R[X]) ^ n - C a = 0 then
    by simp only [nat.zero_le, nth_roots, roots, h, dif_pos rfl, empty_eq_zero, multiset.card_zero]
  else with_bot.coe_le_coe.1 (le_trans (card_roots h)
   (by { rw [hn, pow_zero, ← C_1, ← ring_hom.map_sub ],
         exact degree_C_le }))
else by rw [← with_bot.coe_le_coe, ← degree_X_pow_sub_C (nat.pos_of_ne_zero hn) a];
  exact card_roots (X_pow_sub_C_ne_zero (nat.pos_of_ne_zero hn) a)

@[simp]
lemma nth_roots_two_eq_zero_iff {r : R} : nth_roots 2 r = 0 ↔ ¬ is_square r :=
by simp_rw [is_square_iff_exists_sq, eq_zero_iff_forall_not_mem,
            mem_nth_roots (by norm_num : 0 < 2), ← not_exists, eq_comm]

/-- The multiset `nth_roots ↑n (1 : R)` as a finset. -/
def nth_roots_finset (n : ℕ) (R : Type*) [comm_ring R] [is_domain R] : finset R :=
multiset.to_finset (nth_roots n (1 : R))

@[simp] lemma mem_nth_roots_finset {n : ℕ} (h : 0 < n) {x : R} :
  x ∈ nth_roots_finset n R ↔ x ^ (n : ℕ) = 1 :=
by rw [nth_roots_finset, mem_to_finset, mem_nth_roots h]

@[simp] lemma nth_roots_finset_zero : nth_roots_finset 0 R = ∅ := by simp [nth_roots_finset]

end nth_roots

lemma monic.comp (hp : p.monic) (hq : q.monic) (h : q.nat_degree ≠ 0) : (p.comp q).monic :=
by rw [monic.def, leading_coeff_comp h, monic.def.1 hp, monic.def.1 hq, one_pow, one_mul]

lemma monic.comp_X_add_C (hp : p.monic) (r : R) : (p.comp (X + C r)).monic :=
begin
  refine hp.comp (monic_X_add_C _) (λ ha, _),
  rw [nat_degree_X_add_C] at ha,
  exact one_ne_zero ha
end

lemma monic.comp_X_sub_C (hp : p.monic) (r : R) : (p.comp (X - C r)).monic :=
by simpa using hp.comp_X_add_C (-r)

@[simp] lemma nat_degree_coe_units (u : R[X]ˣ) :
  nat_degree (u : R[X]) = 0 :=
nat_degree_eq_of_degree_eq_some (degree_coe_units u)

lemma comp_eq_zero_iff :
  p.comp q = 0 ↔ p = 0 ∨ (p.eval (q.coeff 0) = 0 ∧ q = C (q.coeff 0)) :=
begin
  split,
  { intro h,
    have key : p.nat_degree = 0 ∨ q.nat_degree = 0,
    { rw [←mul_eq_zero, ←nat_degree_comp, h, nat_degree_zero] },
    replace key := or.imp eq_C_of_nat_degree_eq_zero eq_C_of_nat_degree_eq_zero key,
    cases key,
    { rw [key, C_comp] at h,
      exact or.inl (key.trans h) },
    { rw [key, comp_C, C_eq_zero] at h,
      exact or.inr ⟨h, key⟩ }, },
  { exact λ h, or.rec (λ h, by rw [h, zero_comp]) (λ h, by rw [h.2, comp_C, h.1, C_0]) h },
end

lemma zero_of_eval_zero [infinite R] (p : R[X]) (h : ∀ x, p.eval x = 0) : p = 0 :=
by classical; by_contradiction hp; exact
fintype.false ⟨p.roots.to_finset, λ x, multiset.mem_to_finset.mpr ((mem_roots hp).mpr (h _))⟩

lemma funext [infinite R] {p q : R[X]} (ext : ∀ r : R, p.eval r = q.eval r) : p = q :=
begin
  rw ← sub_eq_zero,
  apply zero_of_eval_zero,
  intro x,
  rw [eval_sub, sub_eq_zero, ext],
end

variables [comm_ring T]

/-- The set of distinct roots of `p` in `E`.

If you have a non-separable polynomial, use `polynomial.roots` for the multiset
where multiple roots have the appropriate multiplicity. -/
def root_set (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] : set S :=
(p.map (algebra_map T S)).roots.to_finset

lemma root_set_def (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] :
  p.root_set S = (p.map (algebra_map T S)).roots.to_finset :=
rfl

@[simp] lemma root_set_C [comm_ring S] [is_domain S] [algebra T S] (a : T) :
  (C a).root_set S = ∅ :=
by rw [root_set_def, map_C, roots_C, multiset.to_finset_zero, finset.coe_empty]

@[simp] lemma root_set_zero (S) [comm_ring S] [is_domain S] [algebra T S] :
  (0 : T[X]).root_set S = ∅ :=
by rw [← C_0, root_set_C]

instance root_set_fintype (p : T[X])
  (S : Type*) [comm_ring S] [is_domain S] [algebra T S] : fintype (p.root_set S) :=
finset_coe.fintype _

lemma root_set_finite (p : T[X])
  (S : Type*) [comm_ring S] [is_domain S] [algebra T S] : (p.root_set S).finite :=
set.to_finite _

/-- The set of roots of all polynomials of bounded degree and having coefficients in a finite set
is finite. -/
lemma bUnion_roots_finite {R S : Type*} [semiring R] [comm_ring S] [is_domain S]
  (m : R →+* S) (d : ℕ) {U : set R} (h : U.finite) :
  (⋃ (f : R[X]) (hf : f.nat_degree ≤ d ∧ ∀ i, (f.coeff i) ∈ U),
    ((f.map m).roots.to_finset : set S)).finite :=
set.finite.bUnion begin
  -- We prove that the set of polynomials under consideration is finite because its
  -- image by the injective map `π` is finite
  let π : R[X] → fin (d+1) → R := λ f i, f.coeff i,
  refine ((set.finite.pi $ λ e, h).subset $ _).of_finite_image (_ : set.inj_on π _),
  { exact set.image_subset_iff.2 (λ f hf i _, hf.2 i) },
  { refine λ x hx y hy hxy, (ext_iff_nat_degree_le hx.1 hy.1).2 (λ i hi, _),
    exact id congr_fun hxy ⟨i, nat.lt_succ_of_le hi⟩ },
end $ λ i hi, finset.finite_to_set _

theorem mem_root_set' {p : T[X]} {S : Type*} [comm_ring S] [is_domain S] [algebra T S] {a : S} :
  a ∈ p.root_set S ↔ p.map (algebra_map T S) ≠ 0 ∧ aeval a p = 0 :=
by rw [root_set, finset.mem_coe, mem_to_finset, mem_roots', is_root.def, ← eval₂_eq_eval_map,
  aeval_def]

theorem mem_root_set {p : T[X]} {S : Type*} [comm_ring S] [is_domain S] [algebra T S]
  [no_zero_smul_divisors T S] {a : S} : a ∈ p.root_set S ↔ p ≠ 0 ∧ aeval a p = 0 :=
by rw [mem_root_set', (map_injective _
  (no_zero_smul_divisors.algebra_map_injective T S)).ne_iff' (polynomial.map_zero _)]

theorem mem_root_set_of_ne {p : T[X]} {S : Type*} [comm_ring S] [is_domain S] [algebra T S]
  [no_zero_smul_divisors T S] (hp : p ≠ 0) {a : S} : a ∈ p.root_set S ↔ aeval a p = 0 :=
mem_root_set.trans $ and_iff_right hp

lemma root_set_maps_to' {p : T[X]} {S S'} [comm_ring S] [is_domain S] [algebra T S]
  [comm_ring S'] [is_domain S'] [algebra T S']
  (hp : p.map (algebra_map T S') = 0 → p.map (algebra_map T S) = 0)
  (f : S →ₐ[T] S') : (p.root_set S).maps_to f (p.root_set S') :=
λ x hx, begin
  rw [mem_root_set'] at hx ⊢,
  rw [aeval_alg_hom, alg_hom.comp_apply, hx.2, _root_.map_zero],
  exact ⟨mt hp hx.1, rfl⟩
end

lemma ne_zero_of_mem_root_set {p : T[X]} [comm_ring S] [is_domain S] [algebra T S] {a : S}
  (h : a ∈ p.root_set S) : p ≠ 0 :=
λ hf, by rwa [hf, root_set_zero] at h

lemma aeval_eq_zero_of_mem_root_set {p : T[X]} [comm_ring S] [is_domain S] [algebra T S]
  {a : S} (hx : a ∈ p.root_set S) : aeval a p = 0 :=
(mem_root_set'.1 hx).2

lemma root_set_maps_to {p : T[X]} {S S'} [comm_ring S] [is_domain S] [algebra T S]
  [comm_ring S'] [is_domain S'] [algebra T S'] [no_zero_smul_divisors T S'] (f : S →ₐ[T] S') :
  (p.root_set S).maps_to f (p.root_set S') :=
begin
  refine root_set_maps_to' (λ h₀, _) f,
  obtain rfl : p = 0 := map_injective _
    (no_zero_smul_divisors.algebra_map_injective T S') (by rwa [polynomial.map_zero]),
  exact polynomial.map_zero _
end

end roots

lemma coeff_coe_units_zero_ne_zero (u : R[X]ˣ) :
  coeff (u : R[X]) 0 ≠ 0 :=
begin
  conv in (0) { rw [← nat_degree_coe_units u] },
  rw [← leading_coeff, ne.def, leading_coeff_eq_zero],
  exact units.ne_zero _
end

lemma degree_eq_degree_of_associated (h : associated p q) : degree p = degree q :=
let ⟨u, hu⟩ := h in by simp [hu.symm]

lemma degree_eq_one_of_irreducible_of_root (hi : irreducible p) {x : R} (hx : is_root p x) :
  degree p = 1 :=
let ⟨g, hg⟩ := dvd_iff_is_root.2 hx in
have is_unit (X - C x) ∨ is_unit g, from hi.is_unit_or_is_unit hg,
this.elim
  (λ h, have h₁ : degree (X - C x) = 1, from degree_X_sub_C x,
    have h₂ : degree (X - C x) = 0, from degree_eq_zero_of_is_unit h,
    by rw h₁ at h₂; exact absurd h₂ dec_trivial)
  (λ hgu, by rw [hg, degree_mul, degree_X_sub_C, degree_eq_zero_of_is_unit hgu, add_zero])

/-- Division by a monic polynomial doesn't change the leading coefficient. -/
lemma leading_coeff_div_by_monic_of_monic {R : Type u} [comm_ring R]
  {p q : R[X]} (hmonic : q.monic) (hdegree : q.degree ≤ p.degree) :
  (p /ₘ q).leading_coeff = p.leading_coeff :=
begin
  nontriviality,
  have h : q.leading_coeff * (p /ₘ q).leading_coeff ≠ 0,
  { simpa [div_by_monic_eq_zero_iff hmonic, hmonic.leading_coeff, nat.with_bot.one_le_iff_zero_lt]
      using hdegree },
  nth_rewrite_rhs 0 ←mod_by_monic_add_div p hmonic,
  rw [leading_coeff_add_of_degree_lt, leading_coeff_monic_mul hmonic],
  rw [degree_mul' h, degree_add_div_by_monic hmonic hdegree],
  exact (degree_mod_by_monic_lt p hmonic).trans_le hdegree
end

lemma leading_coeff_div_by_monic_X_sub_C (p : R[X]) (hp : degree p ≠ 0) (a : R) :
  leading_coeff (p /ₘ (X - C a)) = leading_coeff p :=
begin
  nontriviality,
  cases hp.lt_or_lt with hd hd,
  { rw [degree_eq_bot.mp $ (nat.with_bot.lt_zero_iff _).mp hd, zero_div_by_monic] },
  refine leading_coeff_div_by_monic_of_monic (monic_X_sub_C a) _,
  rwa [degree_X_sub_C, nat.with_bot.one_le_iff_zero_lt]
end

lemma eq_leading_coeff_mul_of_monic_of_dvd_of_nat_degree_le {R} [comm_ring R]
  {p q : R[X]} (hp : p.monic) (hdiv : p ∣ q)
  (hdeg : q.nat_degree ≤ p.nat_degree) : q = C q.leading_coeff * p :=
begin
  obtain ⟨r, hr⟩ := hdiv,
  obtain (rfl|hq) := eq_or_ne q 0, {simp},
  have rzero : r ≠ 0 := λ h, by simpa [h, hq] using hr,
  rw [hr, nat_degree_mul'] at hdeg, swap,
  { rw [hp.leading_coeff, one_mul, leading_coeff_ne_zero], exact rzero },
  rw [mul_comm, @eq_C_of_nat_degree_eq_zero _ _ r] at hr,
  { convert hr, convert leading_coeff_C _ using 1, rw [hr, leading_coeff_mul_monic hp] },
  { exact (add_right_inj _).1 (le_antisymm hdeg $ nat.le.intro rfl) },
end

lemma eq_of_monic_of_dvd_of_nat_degree_le {R} [comm_ring R]
  {p q : R[X]} (hp : p.monic) (hq : q.monic) (hdiv : p ∣ q)
  (hdeg : q.nat_degree ≤ p.nat_degree) : q = p :=
begin
  convert eq_leading_coeff_mul_of_monic_of_dvd_of_nat_degree_le hp hdiv hdeg,
  rw [hq.leading_coeff, C_1, one_mul],
end

lemma is_coprime_X_sub_C_of_is_unit_sub {R} [comm_ring R] {a b : R}
  (h : is_unit (a - b)) : is_coprime (X - C a) (X - C b) :=
⟨-C h.unit⁻¹.val, C h.unit⁻¹.val, by { rw [neg_mul_comm, ← left_distrib, neg_add_eq_sub,
  sub_sub_sub_cancel_left, ← C_sub, ← C_mul], convert C_1, exact h.coe_inv_mul }⟩

theorem pairwise_coprime_X_sub_C {K} [field K] {I : Type v} {s : I → K}
  (H : function.injective s) : pairwise (is_coprime on (λ i : I, X - C (s i))) :=
λ i j hij, is_coprime_X_sub_C_of_is_unit_sub (sub_ne_zero_of_ne $ H.ne hij).is_unit

lemma monic_prod_multiset_X_sub_C : monic (p.roots.map (λ a, X - C a)).prod :=
monic_multiset_prod_of_monic _ _ (λ a _, monic_X_sub_C a)

lemma prod_multiset_root_eq_finset_root :
  (p.roots.map (λ a, X - C a)).prod =
  p.roots.to_finset.prod (λ a, (X - C a) ^ root_multiplicity a p) :=
by simp only [count_roots, finset.prod_multiset_map_count]

/-- The product `∏ (X - a)` for `a` inside the multiset `p.roots` divides `p`. -/
lemma prod_multiset_X_sub_C_dvd (p : R[X]) : (p.roots.map (λ a, X - C a)).prod ∣ p :=
begin
  rw ← map_dvd_map _ (is_fraction_ring.injective R $ fraction_ring R) monic_prod_multiset_X_sub_C,
  rw [prod_multiset_root_eq_finset_root, polynomial.map_prod],
  refine finset.prod_dvd_of_coprime (λ a _ b _ h, _) (λ a _, _),
  { simp_rw [polynomial.map_pow, polynomial.map_sub, map_C, map_X],
    exact (pairwise_coprime_X_sub_C (is_fraction_ring.injective R $ fraction_ring R) h).pow },
  { exact polynomial.map_dvd _ (pow_root_multiplicity_dvd p a) },
end

/-- A Galois connection. -/
lemma _root_.multiset.prod_X_sub_C_dvd_iff_le_roots {p : R[X]} (hp : p ≠ 0) (s : multiset R) :
  (s.map (λ a, X - C a)).prod ∣ p ↔ s ≤ p.roots :=
⟨λ h, multiset.le_iff_count.2 $ λ r, begin
  rw [count_roots, le_root_multiplicity_iff hp, ← multiset.prod_replicate,
    ← multiset.map_replicate (λ a, X - C a), ← multiset.filter_eq],
  exact (multiset.prod_dvd_prod_of_le $ multiset.map_le_map $ s.filter_le _).trans h,
end, λ h, (multiset.prod_dvd_prod_of_le $ multiset.map_le_map h).trans p.prod_multiset_X_sub_C_dvd⟩

lemma exists_prod_multiset_X_sub_C_mul (p : R[X]) : ∃ q,
  (p.roots.map (λ a, X - C a)).prod * q = p ∧
  p.roots.card + q.nat_degree = p.nat_degree ∧
  q.roots = 0 :=
begin
  obtain ⟨q, he⟩ := p.prod_multiset_X_sub_C_dvd,
  use [q, he.symm],
  obtain (rfl|hq) := eq_or_ne q 0,
  { rw mul_zero at he, subst he, simp },
  split,
  { conv_rhs { rw he },
    rw [monic_prod_multiset_X_sub_C.nat_degree_mul' hq, nat_degree_multiset_prod_X_sub_C_eq_card] },
  { replace he := congr_arg roots he.symm,
    rw [roots_mul, roots_multiset_prod_X_sub_C] at he,
    exacts [add_right_eq_self.1 he, mul_ne_zero monic_prod_multiset_X_sub_C.ne_zero hq] },
end

/-- A polynomial `p` that has as many roots as its degree
can be written `p = p.leading_coeff * ∏(X - a)`, for `a` in `p.roots`. -/
lemma C_leading_coeff_mul_prod_multiset_X_sub_C (hroots : p.roots.card = p.nat_degree) :
  C p.leading_coeff * (p.roots.map (λ a, X - C a)).prod = p :=
(eq_leading_coeff_mul_of_monic_of_dvd_of_nat_degree_le monic_prod_multiset_X_sub_C
  p.prod_multiset_X_sub_C_dvd ((nat_degree_multiset_prod_X_sub_C_eq_card _).trans hroots).ge).symm

/-- A monic polynomial `p` that has as many roots as its degree
can be written `p = ∏(X - a)`, for `a` in `p.roots`. -/
lemma prod_multiset_X_sub_C_of_monic_of_roots_card_eq
  (hp : p.monic) (hroots : p.roots.card = p.nat_degree) :
  (p.roots.map (λ a, X - C a)).prod = p :=
by { convert C_leading_coeff_mul_prod_multiset_X_sub_C hroots, rw [hp.leading_coeff, C_1, one_mul] }

end comm_ring

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

lemma le_root_multiplicity_map {p : A[X]} {f : A →+* B} (hmap : map f p ≠ 0) (a : A) :
  root_multiplicity a p ≤ root_multiplicity (f a) (p.map f) :=
begin
  rw [le_root_multiplicity_iff hmap],
  refine trans _ ((map_ring_hom f).map_dvd (pow_root_multiplicity_dvd p a)),
  rw [map_pow, map_sub, coe_map_ring_hom, map_X, map_C],
end

lemma eq_root_multiplicity_map {p : A[X]} {f : A →+* B} (hf : function.injective f)
  (a : A) : root_multiplicity a p = root_multiplicity (f a) (p.map f) :=
begin
  by_cases hp0 : p = 0, { simp only [hp0, root_multiplicity_zero, polynomial.map_zero], },
  apply le_antisymm (le_root_multiplicity_map ((polynomial.map_ne_zero_iff hf).mpr hp0) a),
  rw [le_root_multiplicity_iff hp0, ← map_dvd_map f hf ((monic_X_sub_C a).pow _),
    polynomial.map_pow, polynomial.map_sub, map_X, map_C],
  apply pow_root_multiplicity_dvd,
end

lemma count_map_roots [is_domain A] {p : A[X]} {f : A →+* B} (hmap : map f p ≠ 0) (b : B) :
  (p.roots.map f).count b ≤ root_multiplicity b (p.map f) :=
begin
  rw [le_root_multiplicity_iff hmap, ← multiset.prod_replicate,
    ← multiset.map_replicate (λ a, X - C a)],
  rw ← multiset.filter_eq,
  refine (multiset.prod_dvd_prod_of_le $ multiset.map_le_map $ multiset.filter_le _ _).trans _,
  convert polynomial.map_dvd _ p.prod_multiset_X_sub_C_dvd,
  simp only [polynomial.map_multiset_prod, multiset.map_map],
  congr, ext1,
  simp only [function.comp_app, polynomial.map_sub, map_X, map_C],
end

lemma count_map_roots_of_injective [is_domain A] (p : A[X]) {f : A →+* B}
  (hf : function.injective f) (b : B) :
  (p.roots.map f).count b ≤ root_multiplicity b (p.map f) :=
begin
  by_cases hp0 : p = 0,
  { simp only [hp0, roots_zero, multiset.map_zero,
      multiset.count_zero, polynomial.map_zero, root_multiplicity_zero] },
  { exact count_map_roots ((polynomial.map_ne_zero_iff hf).mpr hp0) b },
end

lemma map_roots_le [is_domain A] [is_domain B] {p : A[X]} {f : A →+* B} (h : p.map f ≠ 0) :
  p.roots.map f ≤ (p.map f).roots :=
multiset.le_iff_count.2 $ λ b, by { rw count_roots, apply count_map_roots h }

lemma map_roots_le_of_injective [is_domain A] [is_domain B] (p : A[X])
  {f : A →+* B} (hf : function.injective f) :
  p.roots.map f ≤ (p.map f).roots :=
begin
  by_cases hp0 : p = 0, { simp only [hp0, roots_zero, multiset.map_zero, polynomial.map_zero], },
  exact map_roots_le ((polynomial.map_ne_zero_iff hf).mpr hp0),
end

lemma card_roots_le_map [is_domain A] [is_domain B] {p : A[X]} {f : A →+* B} (h : p.map f ≠ 0) :
  p.roots.card ≤ (p.map f).roots.card :=
by { rw ← p.roots.card_map f, exact multiset.card_le_of_le (map_roots_le h) }

lemma card_roots_le_map_of_injective [is_domain A] [is_domain B] {p : A[X]} {f : A →+* B}
  (hf : function.injective f) : p.roots.card ≤ (p.map f).roots.card :=
begin
  by_cases hp0 : p = 0, { simp only [hp0, roots_zero, polynomial.map_zero, multiset.card_zero], },
  exact card_roots_le_map ((polynomial.map_ne_zero_iff hf).mpr hp0),
end

lemma roots_map_of_injective_of_card_eq_nat_degree [is_domain A] [is_domain B] {p : A[X]}
  {f : A →+* B} (hf : function.injective f) (hroots : p.roots.card = p.nat_degree) :
  p.roots.map f = (p.map f).roots :=
begin
  apply multiset.eq_of_le_of_card_le (map_roots_le_of_injective p hf),
  simpa only [multiset.card_map, hroots] using (card_roots' _).trans (nat_degree_map_le f p),
end

end

section

variables [semiring R] [comm_ring S] [is_domain S] (φ : R →+* S)

lemma is_unit_of_is_unit_leading_coeff_of_is_unit_map
  {f : R[X]} (hf : is_unit f.leading_coeff) (H : is_unit (map φ f)) :
  is_unit f :=
begin
  have dz := degree_eq_zero_of_is_unit H,
  rw degree_map_eq_of_leading_coeff_ne_zero at dz,
  { rw eq_C_of_degree_eq_zero dz,
    refine is_unit.map C _,
    convert hf,
    rw (degree_eq_iff_nat_degree_eq _).1 dz,
    rintro rfl,
    simpa using H, },
  { intro h,
    have u : is_unit (φ f.leading_coeff) := is_unit.map φ hf,
    rw h at u,
    simpa using u, }
end

end

section
variables [comm_ring R] [is_domain R] [comm_ring S] [is_domain S] (φ : R →+* S)
/--
A polynomial over an integral domain `R` is irreducible if it is monic and
  irreducible after mapping into an integral domain `S`.

A special case of this lemma is that a polynomial over `ℤ` is irreducible if
  it is monic and irreducible over `ℤ/pℤ` for some prime `p`.
-/
lemma monic.irreducible_of_irreducible_map (f : R[X])
  (h_mon : monic f) (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨h_irr.not_unit ∘ is_unit.map (map_ring_hom φ), λ a b h, _⟩,
  dsimp [monic] at h_mon,
  have q := (leading_coeff_mul a b).symm,
  rw [←h, h_mon] at q,
  refine (h_irr.is_unit_or_is_unit $ (congr_arg (map φ) h).trans (polynomial.map_mul φ)).imp _ _;
    apply is_unit_of_is_unit_leading_coeff_of_is_unit_map;
    apply is_unit_of_mul_eq_one,
  { exact q }, { rw mul_comm, exact q },
end

end

end polynomial


import tactic
import data.fin
universes u v

variables {n : ℕ} {α : Type u} {β : Type v}

lemma fold_step (a1 : array n α) (a2 : array n.succ α) (b : β) (f : α → β → β)
  : (∀ i : fin n, a1.read i = a2.read ⟨i, nat.lt.step i.is_lt⟩) →
    a2.foldl b f = f (a2.read ⟨n, lt_add_one n⟩) (a1.foldl b f)
:=
begin
  intros,
  induction n with n n_ih,
  sorry
end

def array.simple_take (a : array n α) (m : nat) (h : m ≤ n) : array m α :=
  ⟨λ i : fin m, a.read ⟨i.val, lt_of_lt_of_le i.is_lt h⟩⟩
def foldl_inits (a : array n α) (b : β) (f : α → β → β) (k : ℕ) (h : k ≤ n) : β
  := (a.simple_take k h).foldl b f
lemma foldl_inits_eq
  (a : array n α) (b : β) (f : α → β → β) (f2 : Π (k : ℕ), k ≤ n → β)
  : f2 0 bot_le = b →
    (∀ i : fin n,
      f2 i.val.succ i.is_lt = f (a.read i) (f2 i.val (le_of_lt i.is_lt))) →
  f2 = foldl_inits a b f
:=
begin
  intros,
  apply funext, assume (k : ℕ),
  apply funext, assume (kn_le : k ≤ n),
  induction k with k k_ih,
  show f2 0 bot_le = foldl_inits a b f 0 bot_le, from a_1,
  let pref1 := a.simple_take k (le_of_lt kn_le),
  let pref2 := a.simple_take k.succ kn_le,
  apply eq.trans,
  have : f2 (nat.succ k) kn_le = f (a.read ⟨k, kn_le⟩) (pref1.foldl b f), begin
    apply eq.trans (a_2 ⟨k, kn_le⟩),
    congr,
    exact k_ih (le_of_lt kn_le),
  end,
  exact this,
  have : f (a.read ⟨k, kn_le⟩) (pref1.foldl b f) = pref2.foldl b f, begin
    have : a.read ⟨k, kn_le⟩ = pref2.read ⟨k, lt_add_one k⟩, from rfl,
    rw this,
    have : ∀ (i : fin k), pref1.read i = pref2.read ⟨i.val, nat.lt.step i.is_lt⟩, begin
      intros,
      exact rfl,
    end,
    show f (pref2.read ⟨k, lt_add_one k⟩) (pref1.foldl b f) = pref2.foldl b f,
      from (fold_step pref1 pref2 b f this).symm,
  end,
  exact this,
end


import InfinityCategory.CategoryTheory.Category.Category
import InfinityCategory.CategoryTheory.Category.Opposite

section SimplexCategory
def monotone (f : α → β) [LE α] [LE β] : Prop := ∀ a b : α, a ≤ b → f a ≤ f b

def simplex_hom (n m : Nat) := {f : Fin n → Fin m // monotone f}

theorem id_is_monotone : monotone (fun (x : Fin n) => x) :=
    fun _ _ h => h
theorem comp_is_monotone {n m k : Nat} (f : simplex_hom n m) (g : simplex_hom m k) : monotone (g.val ∘ f.val) :=
    fun a b h => g.property (f.val a) (f.val b) (f.property a b h)

def SimplexCategory : Category where
    ob      := Nat
    hom {n m : Nat} := simplex_hom n m
    id      := fun _ => ⟨fun x => x, id_is_monotone⟩
    comp    := by {
        intro X Y Z f g;
        exact ⟨g.val ∘ f.val, comp_is_monotone f g⟩;
    }
    id_comp := by {intro _ _ _; rfl;}
    comp_id := by {intro _ _ _; rfl;}
    assoc   := by {intro _ _ _ _ _ _ _; rfl;}
instance : OfNat SimplexCategory n where
    ofNat := n

def SimplexCategoryOp : Category := SimplexCategoryᵒᵖ
instance : OfNat SimplexCategoryOp n where
    ofNat := n

end SimplexCategory


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_410
  (x y : ℝ)
  (h₀ : y = x^2 - 6 * x + 13) :
  4 ≤ y :=
begin
  cases le_total x 3 with h,
  all_goals { nlinarith },
end


import data.set.basic -- hide
open set -- hide

variables {X Y : Type} -- hide

/- Lemma : no-side-bar
Giving two subsets of a type `A₁ ⊆ X` `A₂ ⊆ X` and two of another type `B₁ ⊆ Y` `B₂ ⊆ Y`
satisfying `A₁ ⊆ A₂` and `B₁ ⊆ B₂`, we can prove that `A₁ × B₁ ⊆ A₂ × B₂` (as products of sets).
-/
lemma sInter_of_inter {A₁ A₂ : set X} {B₁ B₂ : set Y} (hA : A₁ ⊆ A₂) (hB : B₁ ⊆ B₂) :
  A₁.prod B₁ ⊆ A₂.prod B₂ :=
begin
  intros x hx,
  exact ⟨hA hx.1, hB hx.2⟩,
end


import linear_algebra.bilinear_form

universes u v w

variables {R : Type u} [comm_ring R] {M₁ : Type v} {M₂ : Type w}
variables [add_comm_group M₁] [module R M₁] [add_comm_group M₂] [module R M₂]
variables {K : Type v} [field K] {V₁ : Type u} {V₂ : Type w}
variables [add_comm_group V₁] [vector_space K V₁] [add_comm_group V₂] [vector_space K V₂]
variables [finite_dimensional K V₁] [finite_dimensional K V₂]

open module

/-- Given `f : M₁ ≃ₗ[R] M₂` and `U` a submodule of `M₂`, `f.comap U` is the
induced `linear_equiv` from `U.comap f.to_linear_map` to `U`. -/
def linear_equiv.comap (f : M₁ ≃ₗ[R] M₂) (U : submodule R M₂) :
  U.comap f.to_linear_map ≃ₗ[R] U :=
f.of_submodules _ _
begin
  ext x,
  simp_rw [submodule.mem_map, submodule.mem_comap],
  split; intro hx,
  { rcases hx with ⟨y, hy, rfl⟩,
    exact hy },
  { refine ⟨f.inv_fun x, _⟩,
    simpa }
end

/-- Given `p` a submodule of the module `M` and `q` a submodule of `p`, `p.equiv_subtype_map q`
is the natural `linear_equiv` between `q` and `q.map p.subtype`. -/
def submodule.equiv_subtype_map
  (p : submodule R M₁) (q : submodule R p) : q ≃ₗ[R] q.map p.subtype :=
{ inv_fun :=
    begin
      rintro ⟨x, hx⟩,
      refine ⟨⟨x, _⟩, _⟩;
      rcases hx with ⟨⟨_, h⟩, _, rfl⟩;
      assumption
    end,
  left_inv := λ ⟨⟨_, _⟩, _⟩, rfl,
  right_inv := λ ⟨x, ⟨_, h⟩, _, rfl⟩, rfl, ..
  (p.subtype.dom_restrict q).cod_restrict _
    begin
      rintro ⟨x, hx⟩,
      refine ⟨x, hx, rfl⟩,
    end }

lemma finite_dimensional.subtype_eq_findim_eq (p : subspace K V₁) (q : subspace K p) :
  finite_dimensional.findim K (q.map p.subtype) = finite_dimensional.findim K q :=
linear_equiv.findim_eq (p.equiv_subtype_map q).symm

/-- The pullback of a submodule in the dual space along the evaluation map. -/
def submodule.dual_annihilator_comap (Φ : submodule R (module.dual R M₁)) : submodule R M₁ :=
Φ.dual_annihilator.comap (dual.eval R M₁)

lemma submodule.mem_dual_annihilator_comap_iff {Φ : submodule R (module.dual R M₁)} (x : M₁) :
  x ∈ Φ.dual_annihilator_comap ↔ ∀ φ : Φ, φ x = 0 :=
begin
  simp_rw [submodule.dual_annihilator_comap, submodule.mem_comap,
           submodule.mem_dual_annihilator],
  split; intros h φ,
  { exact h φ.1 φ.2 },
  { intro hφ, exact h ⟨φ, hφ⟩ }
end

lemma submodule.dual_annihilator_comp_findim_eq {Φ : submodule K (dual K V₁)} :
  finite_dimensional.findim K Φ.dual_annihilator_comap =
  finite_dimensional.findim K Φ.dual_annihilator :=
begin
  rw [submodule.dual_annihilator_comap,
      show dual.eval K V₁ = vector_space.eval_equiv.to_linear_map, by refl],
  apply linear_equiv.findim_eq,
  apply linear_equiv.comap,
end

lemma submodule.findim_add_findim_dual_annihilator_comap_eq
  (W : subspace K (module.dual K V₁)) : finite_dimensional.findim K W +
  finite_dimensional.findim K W.dual_annihilator_comap = finite_dimensional.findim K V₁ :=
begin
  rw [submodule.dual_annihilator_comp_findim_eq,
      W.quot_equiv_annihilator.findim_eq.symm, add_comm,
      submodule.findim_quotient_add_findim, subspace.dual_findim_eq],
end

namespace bilin_form

section finite_dimensional

open finite_dimensional bilin_form

/-- The restriction of a nondegenerate bilinear form `B` onto a submodule `W` is
nondegenerate if `W ⊓ B.orthogonal W ≤ ⊥`. -/
lemma nondegenerate_restrict_of_inf_orthogonal_le_bot
  (B : bilin_form R M₁) (hB : sym_bilin_form.is_sym B)
  {W : submodule R M₁} (hW : W ⊓ B.orthogonal W ≤ ⊥) :
  (B.restrict W).nondegenerate :=
begin
  rintro ⟨x, hx⟩ hB₁,
  rw [submodule.mk_eq_zero, ← submodule.mem_bot R],
  refine hW ⟨hx, λ y hy, _⟩,
  specialize hB₁ ⟨y, hy⟩,
  rwa [restrict_apply, submodule.coe_mk, submodule.coe_mk, hB] at hB₁
end

lemma to_lin_restrict_ker_eq_inf_orthogonal
  (B : bilin_form K V₁) (W : subspace K V₁) (hB : sym_bilin_form.is_sym B) :
  (B.to_lin.dom_restrict W).ker.map W.subtype = (W ⊓ B.orthogonal ⊤ : subspace K V₁) :=
begin
  ext x, split; intro hx,
  { rcases hx with ⟨⟨x, hx⟩, hker, rfl⟩,
    erw linear_map.mem_ker at hker,
    split,
    { simp [hx] },
    { intros y _,
      rw [is_ortho, hB],
      change (B.to_lin.dom_restrict W) ⟨x, hx⟩ y = 0,
      rw hker, refl } },
  { simp_rw [submodule.mem_map, linear_map.mem_ker],
    refine ⟨⟨x, hx.1⟩, _, rfl⟩,
    ext y, change B x y = 0,
    rw hB,
    exact hx.2 _ submodule.mem_top }
end

lemma to_lin_restrict_range_eq_dual_annihilator
  (B : bilin_form K V₁) (W : subspace K V₁) (hB : sym_bilin_form.is_sym B) :
  (B.to_lin.dom_restrict W).range.dual_annihilator_comap = B.orthogonal W :=
begin
  ext x, split; rw [mem_orthogonal_iff]; intro hx,
  { intros y hy,
    rw submodule.mem_dual_annihilator_comap_iff at hx,
    refine hx ⟨B.to_lin.dom_restrict W ⟨y, hy⟩, ⟨y, hy⟩, _, rfl⟩,
    simp only [submodule.top_coe] },
  { rw submodule.mem_dual_annihilator_comap_iff,
    rintro ⟨_, ⟨w, hw⟩, _, rfl⟩,
    exact hx w hw }
end

lemma findim_add_findim_orthogonal
  {B : bilin_form K V₁} {W : subspace K V₁} (hB₁ : sym_bilin_form.is_sym B) :
  findim K W + findim K (B.orthogonal W) =
  findim K V₁ + findim K (W ⊓ B.orthogonal ⊤ : subspace K V₁) :=
begin
  rw [← to_lin_restrict_ker_eq_inf_orthogonal _ _ hB₁,
      ← to_lin_restrict_range_eq_dual_annihilator _ _ hB₁,
      ← (B.to_lin.dom_restrict W).range.findim_add_findim_dual_annihilator_comap_eq,
      subtype_eq_findim_eq],
  conv_rhs { rw [add_comm, ← add_assoc, add_comm (findim K ↥((B.to_lin.dom_restrict W).ker)),
                 linear_map.findim_range_add_findim_ker] },
end

/-- A subspace is complement to its orthogonal complement with respect to some
bilinear form if that bilinear form restricted on to the subspace is nondegenerate. -/
lemma restrict_nondegenerate_of_is_compl_orthogonal
  {B : bilin_form K V₁} {W : subspace K V₁}
  (hB₁ : sym_bilin_form.is_sym B) (hB₂ : (B.restrict W).nondegenerate) :
  is_compl W (B.orthogonal W) :=
begin
  have : W ⊓ B.orthogonal W = ⊥,
  { rw eq_bot_iff,
    intros x hx,
    obtain ⟨hx₁, hx₂⟩ := submodule.mem_inf.1 hx,
    refine subtype.mk_eq_mk.1 (hB₂ ⟨x, hx₁⟩ _),
    rintro ⟨n, hn⟩,
    rw [restrict_apply, submodule.coe_mk, submodule.coe_mk, hB₁],
    exact hx₂ n hn },
  refine ⟨this ▸ le_refl _, _⟩,
  { rw top_le_iff,
    refine finite_dimensional.eq_top_of_findim_eq _,
    refine le_antisymm (submodule.findim_le _) _,
    conv_rhs { rw ← add_zero (findim K _) },
    rw [← findim_bot K V₁, ← this, submodule.dim_sup_add_dim_inf_eq,
        findim_add_findim_orthogonal hB₁],
    exact nat.le.intro rfl }
end

/-- A subspace is complement to its orthogonal complement with respect to some bilinear form
if and only if that bilinear form restricted on to the subspace is nondegenerate. -/
theorem restrict_nondegenerate_iff_is_compl_orthogonal
  {B : bilin_form K V₁} {W : subspace K V₁} (hB₁ : sym_bilin_form.is_sym B) :
  (B.restrict W).nondegenerate ↔ is_compl W (B.orthogonal W) :=
⟨ λ hB₂, restrict_nondegenerate_of_is_compl_orthogonal hB₁ hB₂,
  λ h, B.nondegenerate_restrict_of_inf_orthogonal_le_bot hB₁ h.1⟩

end finite_dimensional

end bilin_form