/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes

Theory of univariate polynomials, represented as finsupps, ℕ →₀ α, with α a comm_semiring
-/

import data.finsupp algebra.euclidean_domain
open finsupp finset lattice

set_option old_structure_cmd true

class nonzero_comm_ring (α : Type*) extends zero_ne_one_class α, comm_ring α

instance integral_domain.to_nonzero_comm_ring (α : Type*) [hd : integral_domain α] : nonzero_comm_ring α :=
{ ..hd }

namespace finset

lemma sup_lt_nat : ∀ {s t : finset ℕ}, s ⊆ t → t.sup id ∉ s
  → 0 < t.sup id → s.sup id < t.sup id :=
λ s, finset.induction_on s (λ _ _ _, id) begin
  assume a s has ih t hst hsup hpos,
  rw finset.sup_insert,
  exact max_lt_iff.2 ⟨lt_of_le_of_ne (finset.le_sup (hst (finset.mem_insert_self _ _)))
      (λ h, by simpa [h.symm] using hsup),
    ih (λ a ha, hst (finset.mem_insert_of_mem ha))
      (hsup ∘ finset.mem_insert_of_mem) hpos⟩,
end

lemma sup_mem_nat {s : finset ℕ} : s ≠ ∅ → s.sup id ∈ s :=
finset.induction_on s (by simp * at *) $
begin
  assume a s has ih _,
  by_cases h₁ : s = ∅,
  { simp * },
  { cases (le_total a (s.sup id)) with h₂ h₂,
    { simp [lattice.sup_of_le_right h₂, ih h₁] },
    { simp [lattice.sup_of_le_left h₂] } }
end

end finset

namespace finsupp

@[simp] lemma erase_single {α β : Type*} [decidable_eq α] [decidable_eq β] [has_zero β]
  (a : α) (b : β) : (single a b).erase a = (0 : α →₀ β) :=
ext (λ x, begin
  by_cases hxa : x = a,
  { simp [hxa, erase_same] },
  { simp [erase_ne hxa, single_apply, if_neg (ne.symm hxa)] },
end)

end finsupp

def polynomial (α : Type*) [comm_semiring α] := ℕ →₀ α

namespace polynomial
variables {α : Type*} {a b : α} {m n : ℕ}
variables [decidable_eq α]

section comm_semiring
variables [comm_semiring α] {p q : polynomial α}

instance : has_coe_to_fun (polynomial α) := finsupp.has_coe_to_fun
instance : has_zero (polynomial α) := finsupp.has_zero
instance : has_one (polynomial α) := finsupp.has_one
instance : has_add (polynomial α) := finsupp.has_add
instance : has_mul (polynomial α) := finsupp.has_mul
instance : comm_semiring (polynomial α) := finsupp.to_comm_semiring

local attribute [instance] finsupp.to_comm_semiring

/-- `monomial n a` is the polynomial `a * X^n` -/
def monomial (n : ℕ) (a : α) : polynomial α := single n a

/-- `C a` is the constant polynomial a -/
def C (a : α) : polynomial α := monomial 0 a

/-- `X` is the polynomial whose evaluation is the identity funtion -/
def X : polynomial α := monomial 1 1

@[simp] lemma C_0 : C 0 = (0 : polynomial α) := by simp [C, monomial]; refl

@[simp] lemma C_1 : C 1 = (1 : polynomial α) := rfl

@[simp] lemma C_mul_monomial : C a * monomial n b = monomial n (a * b) :=
by simp [C, monomial, single_mul_single]

@[simp] lemma C_mul_C : C a * C b = C (a * b) :=
by simp [C, monomial, single_mul_single]

@[simp] lemma monomial_mul_monomial : monomial n a * monomial m b = monomial (n + m) (a * b) :=
single_mul_single

@[simp] lemma monomial_zero_right (n : ℕ) : monomial n (0 : α) = 0 :=
finsupp.ext $ λ a, show ite _ _ _ = (0 : α), by split_ifs; simp

lemma X_pow_eq_monomial : (X : polynomial α) ^ n = monomial n (1 : α) :=
by induction n; simp [X, C_1.symm, -C_1, C, pow_succ, *] at *

lemma monomial_add_right : monomial (n + m) a = (monomial n a * X ^ m):=
by rw [X_pow_eq_monomial, monomial, monomial, monomial, single_mul_single]; simp

lemma monomial_add_left : monomial (m + n) a = (X ^ m * monomial n a):=
by rw [X_pow_eq_monomial, monomial, monomial, monomial, single_mul_single]; simp

lemma monomial_eq : monomial n a = C a * X ^ n :=
by rw [X_pow_eq_monomial, C_mul_monomial, mul_one]

lemma erase_monomial : (monomial n a).erase n = 0 := finsupp.erase_single _ _

@[elab_as_eliminator] lemma induction_on {M : polynomial α → Prop} (p : polynomial α)
  (h_C : ∀a, M (C a)) (h_add : ∀p q, M p → M q → M (p + q))
  (h_X : ∀(n : ℕ) (a : α), M (monomial n a) → M (monomial n a * X)) :
  M p :=
have ∀n a, M (monomial n a),
begin
  assume n a,
  induction n with n ih,
  { exact h_C _ },
  { rw [← nat.add_one, monomial_add_right, pow_one],
    exact h_X _ _ ih }
end,
finsupp.induction p (show M (0 : polynomial α), by rw ← C_0; exact h_C 0) $
λ n a f hfn ha ih, (show M (monomial n a + f), from h_add _ _ (this _ _) ih)

lemma monomial_apply : @coe_fn (polynomial α) polynomial.has_coe_to_fun (monomial n a) m = ite (n = m) a 0 :=
finsupp.single_apply

lemma monomial_apply_self : @coe_fn (polynomial α) polynomial.has_coe_to_fun (monomial n a) n = a :=
by simp [monomial_apply]

lemma C_apply : @coe_fn (polynomial α) polynomial.has_coe_to_fun (C a) n = ite (0 = n) a 0 := finsupp.single_apply

lemma add_apply (p q : polynomial α) (n : ℕ) : (p + q) n = p n + q n := add_apply

@[simp] lemma C_mul_apply (p : polynomial α) : (C a * p) n = a * p n :=
induction_on p (λ b, show (monomial 0 a * monomial 0 b) n = a *
  @coe_fn (polynomial α) polynomial.has_coe_to_fun (monomial 0 b) n,
  begin
    rw [monomial_mul_monomial, monomial_apply, monomial_apply],
    split_ifs; simp
  end)
  begin
    intros,
    rw [mul_add, add_apply, add_apply, mul_add],
    simp *,
  end
  begin
    intros,
    rw [X, monomial_mul_monomial, C, monomial_mul_monomial, monomial_apply, monomial_apply],
    split_ifs;
    simp * at *,
  end

@[elab_as_eliminator] lemma monomial_induction_on {M : polynomial α → Prop} (p : polynomial α)
  (h0 : M 0)
  (h : ∀ (n : ℕ) (a : α) (p : polynomial α), p n = 0 → a ≠ 0 → M p →
  M (monomial n a + p)) : M p :=
finsupp.induction p h0 (λ n a p hpn, h n a p (by rwa [mem_support_iff, ne.def, not_not] at hpn))

section eval
variable {x : α}

/-- `eval x p` is the evaluation of the polynomial x at p -/
def eval (x : α) (p : polynomial α) : α :=
p.sum (λ e a, a * x ^ e)

@[simp] lemma eval_zero : (0 : polynomial α).eval x = 0 :=
finsupp.sum_zero_index

lemma eval_add : (p + q).eval x = p.eval x + q.eval x :=
finsupp.sum_add_index (by simp) (by simp [add_mul])

lemma eval_monomial : (monomial n a).eval x = a * x ^ n :=
finsupp.sum_single_index (zero_mul _)

@[simp] lemma eval_C : (C a).eval x = a :=
by simp [eval_monomial, C, prod_zero_index]

@[simp] lemma eval_X : X.eval x = x :=
by simp [eval_monomial, X, prod_single_index, pow_one]

lemma eval_mul_monomial :
  ∀{n a}, (p * monomial n a).eval x = p.eval x * a * x ^ n :=
begin
  apply polynomial.induction_on p,
  { assume a' s a, by simp [C_mul_monomial, eval_monomial] },
  { assume p q ih_p ih_q, simp [add_mul, eval_add, ih_p, ih_q] },
  { assume m b ih n a,
    unfold X,
    rw [mul_assoc, ih, monomial_mul_monomial, ih, pow_add],
    simp [mul_assoc, mul_comm, mul_left_comm] }
end

lemma eval_mul : ∀{p}, (p * q).eval x = p.eval x * q.eval x :=
begin
  apply polynomial.induction_on q,
  { simp [C, eval_monomial, eval_mul_monomial, prod_zero_index] },
  { simp [mul_add, eval_add] {contextual := tt} },
  { simp [X, eval_monomial, eval_mul_monomial, (mul_assoc _ _ _).symm] { contextual := tt} }
end

/-- `is_root p x` implies `x` is a root of `p`. The evaluation of `p` at `x` is zero -/
def is_root (p : polynomial α) (a : α) : Prop := p.eval a = 0

instance : decidable (is_root p a) := by unfold is_root; apply_instance

lemma is_root.def : is_root p a ↔ p.eval a = 0 := iff.rfl

lemma root_mul_left_of_is_root (q : polynomial α) : is_root p a → is_root (q * p) a :=
by simp [is_root.def, eval_mul] {contextual := tt}

lemma root_mul_right_of_is_root (q : polynomial α) : is_root p a → is_root (p * q) a :=
by simp [is_root.def, eval_mul] {contextual := tt}

end eval

/-- `degree p` gives the highest power of `X` that appears in `p` -/
def degree (p : polynomial α) : with_bot ℕ := p.support.sup some

/-- `leading_coeff p` gives the coefficient of the highest power of `X` in `p`-/
def leading_coeff (p : polynomial α) : α :=
option.cases_on (degree p) 0 p

/-- a polynomial is `monic` if its leading coefficient is 1 -/
def monic (p : polynomial α) := leading_coeff p = (1 : α)

lemma monic.def : monic p ↔ leading_coeff p = 1 := iff.rfl

instance monic.decidable : decidable (monic p) :=
by unfold monic; apply_instance

@[simp] lemma degree_zero : degree (0 : polynomial α) = ⊥ := rfl

lemma degree_C {a : α} (ha : a ≠ 0) : degree (C a) = (0 : with_bot ℕ) :=
begin
  unfold C single monomial degree finsupp.support,
  rw if_neg ha,
  refl
end

lemma degree_monomial_le (n : ℕ) (a : α) : degree (monomial n a) ≤ n :=
begin
  unfold single monomial degree finsupp.support,
  by_cases a = 0;
  simp [*, sup];
  refl
end

@[simp] lemma degree_monomial (n : ℕ) (ha : a ≠ 0) : degree (monomial n a) = n :=
begin
  unfold X single monomial degree finsupp.support,
  rw if_neg ha,
  simp [sup]
end

lemma le_degree_of_ne_zero (h : p n ≠ 0) : n ≤ degree p :=
show id n ≤ p.support.sup id,
from finset.le_sup ((finsupp.mem_support_iff _ _).2 h)

lemma eq_zero_of_degree_lt (h : degree p < n) : p n = 0 :=
not_not.1 (mt le_degree_of_ne_zero (not_le_of_gt h))

lemma eq_C_of_degree_eq_zero (h : degree p = 0) : p = C (p 0) :=
ext begin
  assume n,
  cases n,
  { refl },
  { have h : degree p < nat.succ n := h.symm ▸ nat.succ_pos _,
    rw [eq_zero_of_degree_lt h, C_apply, if_neg],
    exact λ h, nat.no_confusion h }
end

lemma degree_add_le (p q : polynomial α) :
  degree (p + q) ≤ max (degree p) (degree q) :=
show _ ≤ (finset.sup (p.support) id) ⊔ (finset.sup (q.support) id),
by rw ← finset.sup_union;
  exact finset.sup_mono support_add

@[simp] lemma leading_coeff_zero : leading_coeff (0 : polynomial α) = 0 := rfl

@[simp] lemma leading_coeff_eq_zero : leading_coeff p = 0 ↔ p = 0 :=
⟨λ h, by_contradiction (λ h₁, (mem_support_iff _ _).1 (finset.sup_mem_nat (mt support_eq_empty.1 h₁)) h),
by simp { contextual := tt }⟩

lemma degree_add_eq_of_degree_lt (h : degree p < degree q) : degree (p + q) = degree q :=
le_antisymm (max_eq_right_of_lt h ▸ degree_add_le _ _)
  (le_degree_of_ne_zero begin
    rw [add_apply, eq_zero_of_degree_lt h, zero_add],
    exact mt leading_coeff_eq_zero.1 (λ h₁, by simpa [h₁, nat.not_lt_zero] using h)
  end)

lemma degree_add_eq_of_apply_ne_zero (h : leading_coeff p + q (degree p) ≠ 0) :
  degree (p + q) = max p.degree q.degree :=
le_antisymm (degree_add_le _ _) (le_degree_of_ne_zero begin
  rw add_apply,
  unfold max,
  split_ifs,
  { cases lt_or_eq_of_le h_1 with h₁ h₁,
    { rw [not_not.1 (mt le_degree_of_ne_zero (not_le_of_gt h₁)), zero_add],
      exact mt leading_coeff_eq_zero.1 (λ h, by simpa [h, nat.not_lt_zero] using h₁) },
    { rwa ← h₁ } },
  assumption
end)

lemma degree_erase_lt (h : 0 < degree p) :
  degree (p.erase (degree p)) < degree p :=
finset.sup_lt_nat (erase_subset _ _) (not_mem_erase _ _) h

lemma degree_mul_le : ∀ (p q : polynomial α), degree (p * q) ≤ degree p + degree q :=
have hsup : ∀ {n : ℕ} {q : polynomial α} {a : α},
    sup ((sum q (λ (m : ℕ) (x : α), single (n + m) (a * x))).support) id
  ≤ n + degree q := λ n q a, sup_le (λ b hb, begin
    rcases mem_bind.1 (finsupp.support_sum hb) with ⟨x, hx₁, hx₂⟩,
    rw mem_support_iff at hx₁ hx₂,
    rw single_apply at hx₂,
    by_cases hnx : n + x = b,
    { rw [← hnx, id.def],
      exact add_le_add_left (le_degree_of_ne_zero hx₁) _ },
    { simpa [hnx] using hx₂ }
  end),
λ p, monomial_induction_on p
(by simp [nat.zero_le])
(assume n a p hpn ha ih q,
calc degree ((single n a + p) * q) ≤ max (degree (single n a * q)) (degree (p * q)) :
  by rw add_mul; exact degree_add_le _ _
  ... = max ((q.sum (λ m x, single (n + m) (a * x))).support.sup id) (degree (p * q)) :
    by rw [mul_def, sum_single_index, degree]; simp
  ... ≤ max (n + degree q) (degree p + degree q) : by exact max_le_max hsup (ih _)
  ... ≤ max n (degree p) + degree q : max_le (add_le_add_right
    (le_max_left _ _) _) (add_le_add_right (le_max_right _ _) _)
  ... = degree (monomial n a + p) + degree q :
    begin
      rw [degree_add_eq_of_apply_ne_zero, degree_monomial _ ha],
      rwa [leading_coeff, degree_monomial _ ha, monomial_apply_self, hpn, add_zero]
    end)

lemma degree_erase_le (p : polynomial α) (n : ℕ) : degree (p.erase n) ≤ degree p :=
sup_mono (erase_subset _ _)

@[simp] lemma leading_coeff_monomial (a : α) (n : ℕ) : leading_coeff (monomial n a) = a :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  { simp [leading_coeff, degree_monomial _ ha, monomial_apply] },
end

@[simp] lemma leading_coeff_C (a : α) : leading_coeff (C a) = a :=
leading_coeff_monomial _ _

@[simp] lemma monic_one : monic (1 : polynomial α) := leading_coeff_C _

lemma leading_coeff_add_of_lt (h : degree p < degree q) :
  leading_coeff (p + q) = leading_coeff q :=
by unfold leading_coeff;
  rw [degree_add_eq_of_degree_lt h, add_apply, eq_zero_of_degree_lt h, zero_add]

@[simp] lemma mul_apply_degree_add_degree (p q : polynomial α) :
  (p * q) (degree p + degree q) = leading_coeff p * leading_coeff q :=
if hp : degree p = 0 then begin
  rw [eq_C_of_degree_eq_zero hp],
  simp [leading_coeff, C_apply]
end
else
have h₁ : p * q = monomial (degree p + degree q) (p (degree p) * q (degree q)) +
  erase (degree p) p * monomial (degree q) (q (degree q)) +
  (erase (degree q) q * monomial (degree p) (p (degree p)) +
  erase (degree p) p * erase (degree q) q),
begin
  unfold monomial,
  conv {to_lhs, rw [← @single_add_erase _ _ _ _ _ (degree p) p,
      ← @single_add_erase _ _ _ _ _ (degree q) q,
      mul_add, add_mul, add_mul, single_mul_single] },
  simp [mul_comm],
end,
have h₂ : ∀ {p q r : polynomial α}, degree r ≤ degree q →
  (erase (degree p) p * r) (degree p + degree q) = 0,
from λ p q r hr, if hp : degree p = 0 then
  by rw [hp, eq_C_of_degree_eq_zero hp, C, erase_monomial, zero_add, zero_mul, zero_apply]
else
eq_zero_of_degree_lt
  (calc degree (erase (degree p) p * r)
      ≤ _ : degree_mul_le _ _
  ... < _ : add_lt_add_of_lt_of_le (degree_erase_lt (nat.pos_of_ne_zero hp)) hr),
begin
  rw [h₁, add_apply, add_apply, add_apply, monomial_apply, if_pos rfl],
  rw [h₂ (degree_monomial_le _ _), h₂ (degree_erase_le _ _),
    add_comm (degree p), h₂ (degree_monomial_le _ _), add_zero, add_zero, add_zero],
  refl,
end

lemma degree_mul_eq' {p q : polynomial α} (h : leading_coeff p * leading_coeff q ≠ 0) :
  degree (p * q) = degree p + degree q :=
le_antisymm (degree_mul_le _ _) (le_degree_of_ne_zero (by rwa mul_apply_degree_add_degree))

end comm_semiring

section comm_ring
variables [comm_ring α] {p q : polynomial α}
instance : comm_ring (polynomial α) := finsupp.to_comm_ring
instance : has_scalar α (polynomial α) := finsupp.to_has_scalar
instance : module α (polynomial α) := finsupp.to_module
instance {x : α} : is_ring_hom (eval x) := ⟨λ x y, eval_add, λ x y, eval_mul, eval_C⟩

@[simp] lemma degree_neg (p : polynomial α) : degree (-p) = degree p :=
by unfold degree; rw support_neg

@[simp] lemma neg_apply (p : polynomial α) (n : ℕ) : (-p) n = - p n := neg_apply

lemma eval_neg (p : polynomial α) (x : α) : (-p).eval x = -p.eval x :=
is_ring_hom.map_neg _

lemma eval_sub (p q : polynomial α) (x : α) : (p - q).eval x = p.eval x - q.eval x :=
is_ring_hom.map_sub _

lemma degree_sub_lt (hd : degree p = degree q)
  (hpos : 0 < degree p) (hlc : leading_coeff p = leading_coeff q) :
  degree (p - q) < degree p :=
have hlc' : p (degree p) = q (degree q) := hlc,
have hp : single (degree p) (p (degree p)) + p.erase (degree p) = p :=
  finsupp.single_add_erase,
have hq : single (degree q) (q (degree q)) + q.erase (degree q) = q :=
  finsupp.single_add_erase,
begin
  conv { to_lhs, rw [← hp, ← hq, hlc', hd, add_sub_add_left_eq_sub] },
  exact calc degree (erase (degree q) p + -erase (degree q) q)
    ≤ max (degree (erase (degree q) p)) (degree (erase (degree q) q))
    : by rw ← degree_neg (erase (degree q) q);
      exact degree_add_le _ _
  ... < degree p : max_lt_iff.2
    ⟨hd ▸ degree_erase_lt hpos,
    hd.symm ▸ degree_erase_lt (hd ▸ hpos)⟩
end

def euclid_val_poly (p : polynomial α) :=
if p = 0 then 0 else degree p + 1

@[simp] lemma euclid_val_poly_zero : euclid_val_poly (0 : polynomial α) = 0 := rfl

@[simp] lemma euclid_val_poly_eq_zero_iff : euclid_val_poly p = 0 ↔ p = 0 :=
⟨λ h, if hp : p = 0 then hp else by rw [euclid_val_poly, if_neg hp] at h;
  exact (nat.succ_ne_zero _ h).elim,
by simp {contextual := tt}⟩

lemma div_wf_lemma (h : euclid_val_poly q ≤ euclid_val_poly p ∧ p ≠ 0) (hq : monic q) :
  euclid_val_poly (p - monomial (degree p - degree q) (leading_coeff p) * q) < euclid_val_poly p :=
have hp : leading_coeff p ≠ 0 := mt leading_coeff_eq_zero.1 h.2,
have hpq : leading_coeff (monomial (degree p - degree q) (leading_coeff p)) * leading_coeff q ≠ 0,
  by rwa [leading_coeff, degree_monomial _ hp, monomial_apply, if_pos rfl, monic.def.1 hq, mul_one],
have hzq : leading_coeff (monomial (degree p - degree q) (p (degree p))) * leading_coeff q ≠ 0 :=
  by rwa [monic.def.1 hq, leading_coeff_monomial, mul_one],
if h0 : p - monomial (degree p - degree q) (leading_coeff p) * q = 0
  then by rw [euclid_val_poly, euclid_val_poly, if_pos h0, if_neg h.2]; exact nat.succ_pos _
  else if hq0 : degree p = 0 then begin simp [hq0], end

  else by rw [euclid_val_poly, euclid_val_poly, if_neg h0, if_neg h.2];
exact nat.succ_lt_succ (
degree_sub_lt (by rw [degree_mul_eq' hpq, degree_monomial _ hp, nat.sub_add_cancel h.1])
h.2
(by rw [leading_coeff, leading_coeff, degree_mul_eq' hzq, mul_apply_degree_add_degree,
      leading_coeff_monomial, monic.def.1 hq, mul_one])

def div_mod_by_monic_aux : Π (p : polynomial α) {q : polynomial α},
  monic q → polynomial α × polynomial α
| p := λ q hq, if h : degree q ≤ degree p ∧ 0 < degree p then
have h : _ := div_wf_lemma h hq,
let z := monomial (degree p - degree q) (leading_coeff p) in
let dm := div_mod_by_monic_aux (p - z * q) hq in
⟨z + dm.1, dm.2⟩
else if degree p = 0 ∧ degree q = 0
  then ⟨C (leading_coeff p), 0⟩
else ⟨0, p⟩
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf degree⟩]}

/-- `div_by_monic` gives the quotient of `p` by a monic polynomial `q`. -/
def div_by_monic (p q : polynomial α) : polynomial α :=
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 : polynomial α) : polynomial α :=
if hq : monic q then (div_mod_by_monic_aux p hq).2 else p

notation p `/ₘ` q := div_by_monic p q

notation p `%ₘ` q := mod_by_monic p q

lemma degree_mod_by_monic_lt : ∀ (p : polynomial α) {q : polynomial α} (hq : monic q)
  (hq0 : 0 < degree q), degree (mod_by_monic p q) < degree q
| p := λ q hq hq0, if h : degree q ≤ degree p ∧ 0 < degree p then
have wf : _ := div_wf_lemma h hq,
have degree (mod_by_monic (p - monomial (degree p - degree q)
  (leading_coeff p) * q) q) < degree q :=
    degree_mod_by_monic_lt (p - monomial (degree p - degree q) (leading_coeff p) * q)
    hq hq0,
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
have h₁ : ¬ (degree p = 0 ∧ degree q = 0) := λ h₁, by simpa [h₁.2, lt_irrefl] using hq0,
begin
  unfold mod_by_monic div_mod_by_monic_aux,
  rw [dif_pos hq, if_neg h, if_neg h₁],
  cases not_and_distrib.1 h with h₂ h₂,
  { exact lt_of_not_ge h₂ },
  { simpa [nat.le_zero_iff.1 (le_of_not_gt h₂)] }
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf degree⟩]}

@[simp] lemma mod_by_monic_one : ∀ p : polynomial α, mod_by_monic p 1 = 0
| p := if hp0 : 0 < degree p then
have hd : degree 1 ≤ degree p ∧ 0 < degree p := ⟨by rw @degree_one α _ _; exact nat.zero_le _, hp0⟩,
have wf : degree (p + -monomial (degree p) (leading_coeff p)) < degree p :=
  by have := div_wf_lemma hd monic_one; simpa using this,
have h : _ := mod_by_monic_one (p - monomial (degree p - degree (1 : polynomial α)) (leading_coeff p) * 1),
begin
  unfold mod_by_monic div_mod_by_monic_aux,
  rw [dif_pos monic_one, if_pos hd],
  rwa [mod_by_monic, dif_pos monic_one] at h
end else
have hp0' : degree p = 0 := not_not.1 $ mt nat.pos_of_ne_zero hp0,
begin
  unfold mod_by_monic div_mod_by_monic_aux,
  simp [hp0, hp0']
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf degree⟩]}

lemma degree_mod_by_monic_lt_or_eq_zero (p : polynomial α) {q : polynomial α} (hq : monic q)
  : degree (mod_by_monic p q) < degree q ∨ mod_by_monic p q = 0 :=
if hq0 : 0 < degree q then or.inl $ degree_mod_by_monic_lt p hq hq0
else have hq0 : degree q = 0 := not_not.1 $ mt nat.pos_of_ne_zero hq0,
have hq : q = 1 :=
  by rw [eq_C_of_degree_eq_zero hq0, ← hq0, (show q (degree q) = 1, from hq)]; refl,
by subst hq;
  simp [mod_by_monic_one]

lemma mod_by_monic_eq_sub_mul_div : ∀ (p : polynomial α) {q : polynomial α} (hq : monic q),
  mod_by_monic p q = p - q * div_by_monic p q
| p := λ q hq, if h : degree q ≤ degree p ∧ 0 < degree p then
  have wf : _ := div_wf_lemma h hq,
  have ih : _ := mod_by_monic_eq_sub_mul_div (p - monomial (degree p - degree q) (leading_coeff p) * 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 _,
  simp [mul_add, add_mul, mul_comm, hq, h, div_by_monic]
end
else if h₁ : degree p = 0 ∧ degree q = 0 then
have hq0 : q 0 = 1 := h₁.2 ▸ hq,
begin
  unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
  rw [dif_pos hq, if_neg h, if_pos h₁],
  rw [eq_C_of_degree_eq_zero h₁.1, eq_C_of_degree_eq_zero h₁.2] at *,
  conv {to_rhs, congr, rw eq_C_of_degree_eq_zero h₁.1},
  simp [hq0, leading_coeff, h₁.1, h₁.2, h, hq, lt_irrefl, C_apply],
end
else begin
  unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
  simp [hq, h, h₁]
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf degree⟩]}

lemma mod_by_monic_add_div (p : polynomial α) {q : polynomial α} (hq : monic q) :
  mod_by_monic p q + q * div_by_monic p q = p := eq_sub_iff_add_eq.1 (mod_by_monic_eq_sub_mul_div p hq)

lemma degree_div_by_monic_lt (p : polynomial α) {q : polynomial α} (hq : monic q)
  (hq0 : 0 < degree q) (hp0 : 0 < degree p) : degree (div_by_monic p q) < degree p :=
if hdp : div_by_monic p q = 0 then by simpa [hdp] else
have h₁ : leading_coeff q * leading_coeff (div_by_monic p q) ≠ 0 :=
by rw [monic.def.1 hq, one_mul];
  exact mt leading_coeff_eq_zero.1 hdp,
have h₂ : degree (mod_by_monic p q) < degree (q * div_by_monic p q) :=
by rw degree_mul_eq' h₁;
  exact calc degree (mod_by_monic p q) < degree q : degree_mod_by_monic_lt p hq hq0
    ... ≤ degree q + _ : nat.le_add_right _ _,
begin
  conv {to_rhs, rw ← mod_by_monic_add_div p hq},
  rw [degree_add_eq_of_degree_lt h₂, degree_mul_eq' h₁],
  exact (lt_add_iff_pos_left _).2 hq0,
end

lemma dvd_iff_mod_by_monic_eq_zero (hq : monic q) : mod_by_monic p q = 0 ↔ q ∣ p :=
⟨λ h, by rw [← mod_by_monic_add_div p hq, h, zero_add];
  exact dvd_mul_right _ _,
λ h, or.cases_on (degree_mod_by_monic_lt_or_eq_zero p hq)
(λ hlt, let ⟨r, hr⟩ := exists_eq_mul_right_of_dvd h in
have hr : mod_by_monic p q = q * (r - div_by_monic p q) :=
  by rwa [← mod_by_monic_add_div p hq, ← eq_sub_iff_add_eq, ← mul_sub] at hr,
have r - div_by_monic p q = 0 := classical.by_contradiction
  (λ h,
  have hlc : leading_coeff q * leading_coeff (r - div_by_monic p q) ≠ 0 :=
    by rwa [monic.def.1 hq, one_mul, ne.def, leading_coeff_eq_zero],
  have hq : degree (q * (r - div_by_monic p q)) =
    degree q + degree (r - div_by_monic p q) :=
      by rw degree_mul_eq' hlc,
  by rw [hr, hq] at hlt;
    exact not_lt_of_ge (nat.le_add_right _ _) hlt),
by rwa [this, mul_zero] at hr) id⟩

end comm_ring

section nonzero_comm_ring
variables [nonzero_comm_ring α] {p q : polynomial α}

instance : nonzero_comm_ring (polynomial α) :=
{ zero_ne_one := λ (h : (0 : polynomial α) = 1),
    @zero_ne_one α _ $
    calc (0 : α) = eval 0 0 : eval_zero.symm
      ... = eval 0 1 : congr_arg _ h
      ... = 1 : eval_C,
  ..polynomial.comm_ring }

@[simp] lemma degree_one : degree (1 : polynomial α) = (0 : with_bot ℕ) :=
degree_C (show (1 : α) ≠ 0, from zero_ne_one.symm)

@[simp] lemma not_monic_zero : ¬monic (0 : polynomial α) :=
by simp [monic, zero_ne_one]

lemma degree_X : degree (X : polynomial α) = 1 :=
begin
  unfold X monomial degree single finsupp.support,
  rw if_neg (zero_ne_one).symm,
  simp [sup],
end

lemma degree_X_sub_C (a : α) : degree (X - C a) = 1 :=
begin
  rw [sub_eq_add_neg, add_comm, ← @degree_X α],
  exact degree_add_eq_of_degree_lt (by simp [degree_X, degree_neg, degree_C, nat.succ_pos])
end

lemma monic_X_sub_C (a : α) : monic (X - C a) :=
begin
  unfold monic leading_coeff,
  rw [degree_X_sub_C, sub_eq_add_neg, add_apply, X, C, monomial_apply, neg_apply, monomial_apply],
  split_ifs; simp * at *
end

lemma root_X_sub_C : is_root (X - C a) b ↔ a = b :=
by rw [is_root.def, eval_sub, eval_X, eval_C, sub_eq_zero_iff_eq, eq_comm]

lemma mod_by_monic_X_sub_C_eq_C_eval (p : polynomial α) (a : α) : mod_by_monic p (X - C a) = C (p.eval a) :=
have h : (mod_by_monic p (X - C a)).eval a = p.eval a :=
  by 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 (mod_by_monic p (X - C a)) < 1 :=
  degree_X_sub_C a ▸ degree_mod_by_monic_lt p (monic_X_sub_C a) ((degree_X_sub_C a).symm ▸ nat.succ_pos _),
have degree (mod_by_monic p (X - C a)) = 0 := nat.eq_zero_of_le_zero (nat.le_of_lt_succ this),
begin
  rw [eq_C_of_degree_eq_zero this, eval_C] at h,
  rw [eq_C_of_degree_eq_zero this, h]
end

lemma mul_div_eq_iff_is_root : (X - C a) * div_by_monic 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]⟩

end nonzero_comm_ring

section integral_domain
variables [integral_domain α] {p q : polynomial α}

lemma degree_mul_eq (hp : p ≠ 0) (hq : q ≠ 0) : degree (p * q) = degree p + degree q :=
degree_mul_eq' $ mul_ne_zero (mt leading_coeff_eq_zero.1 hp)
    (mt leading_coeff_eq_zero.1 hq)

lemma leading_coeff_mul (p q : polynomial α) : leading_coeff (p * q) =
  leading_coeff p * leading_coeff q :=
begin
  by_cases hp : p = 0,
  { simp [hp] },
  { by_cases hq : q = 0,
    { simp [hq] },
    { rw [leading_coeff, degree_mul_eq hp hq, mul_apply_degree_add_degree] } },
end

instance : integral_domain (polynomial α) :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b h, begin
    have : leading_coeff 0 = leading_coeff a * leading_coeff b := h ▸ leading_coeff_mul a b,
    rw [leading_coeff_zero, eq_comm] at this,
    rw [← leading_coeff_eq_zero, ← leading_coeff_eq_zero],
    exact eq_zero_or_eq_zero_of_mul_eq_zero this
  end,
  ..polynomial.nonzero_comm_ring }

lemma root_or_root_of_root_mul (h : is_root (p * q) a) : is_root p a ∨ is_root q a :=
by rw [is_root, eval_mul] at h;
  exact eq_zero_or_eq_zero_of_mul_eq_zero h

lemma exists_finset_roots : Π {p : polynomial α} (hp : p ≠ 0),
  ∃ s : finset α, s.card ≤ degree p ∧ ∀ x, x ∈ s ↔ is_root p x
| 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 := nat.pos_of_ne_zero
    (λ h, begin
      rw [eq_C_of_degree_eq_zero h, is_root, eval_C] at hx,
      have h1 : p (degree p) ≠ 0 := mt leading_coeff_eq_zero.1 hp,
      rw h at h1,
      contradiction,
    end),
  have hd0 : div_by_monic p (X - C x) ≠ 0 :=
    λ h, by have := mul_div_eq_iff_is_root.2 hx;
      simp * at *,
  have wf : degree (div_by_monic p _) < degree p :=
    degree_div_by_monic_lt _ (monic_X_sub_C x)
    ((degree_X_sub_C x).symm ▸ nat.succ_pos _) hpd,
  let ⟨t, htd, htr⟩ := @exists_finset_roots (div_by_monic p (X - C x)) hd0 in
  ⟨insert x t, calc (insert x t).card ≤ t.card + 1 : finset.card_insert_le _ _
    ... ≤ degree (div_by_monic p (X - C x)) + 1 : nat.succ_le_succ htd
    ... ≤ _ : nat.succ_le_of_lt wf,
  begin
    assume y,
    rw [mem_insert, htr, eq_comm, ← root_X_sub_C],
    conv {to_rhs, rw ← mul_div_eq_iff_is_root.2 hx},
    exact ⟨λ h, or.cases_on h (root_mul_right_of_is_root _) (root_mul_left_of_is_root _),
      root_or_root_of_root_mul⟩
  end⟩
else
  ⟨∅, nat.zero_le _, by clear exists_finset_roots; finish⟩
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf degree⟩]}

/-- `roots p` noncomputably gives a finset containing all the roots of `p` -/
noncomputable def roots (p : polynomial α) : finset α :=
if h : p = 0 then ∅ else classical.some (exists_finset_roots h)

lemma card_roots (p : polynomial α) : (roots p).card ≤ degree p :=
begin
  unfold roots,
  split_ifs,
  { exact nat.zero_le _ },
  { exact (classical.some_spec (exists_finset_roots h)).1 }
end

lemma mem_roots (hp : p ≠ 0) : a ∈ p.roots ↔ is_root p a :=
by unfold roots; rw dif_neg hp; exact (classical.some_spec (exists_finset_roots hp)).2 _

end integral_domain

section field
variables [field α] {p q : polynomial α}
instance : vector_space α (polynomial α) :=
{ ..finsupp.to_module }

lemma monic_mul_leading_coeff_inv (h : p ≠ 0) :
  monic (p * C (leading_coeff p)⁻¹) :=
by rw [monic, leading_coeff_mul, leading_coeff_C,
  mul_inv_cancel (show leading_coeff p ≠ 0, from mt leading_coeff_eq_zero.1 h)]

lemma degree_mul_leading_coeff_inv (h : p ≠ 0) :
  degree (p * C (leading_coeff p)⁻¹) = degree p :=
have C (leading_coeff p)⁻¹ ≠ 0 := mt leading_coeff_eq_zero.2
  $ by rw [leading_coeff_C];
  exact inv_ne_zero (mt leading_coeff_eq_zero.1 h),
by rw [degree_mul_eq h this, degree_C, add_zero]

def div_aux (p q : polynomial α) :=
C (leading_coeff q)⁻¹ * div_by_monic p (q * C (leading_coeff q)⁻¹)

def mod_aux (p q : polynomial α) :=
mod_by_monic p (q * C (leading_coeff q)⁻¹)

private lemma quotient_mul_add_remainder_eq_aux (p q : polynomial α) :
  q * div_aux p q + mod_aux p q = p :=
if h : q = 0 then by simp [h, mod_by_monic, div_aux, mod_aux]
else begin
  conv {to_rhs, rw ← mod_by_monic_add_div p (monic_mul_leading_coeff_inv h)},
  rw [mod_aux, div_aux, add_comm, mul_assoc]
end

/-- `euclid_val_poly` is the Euclidean size function, used in the proof that polynomials over a
field are a Euclidean domain. `euclid_val_poly 0 = 0` and `euclid_val_poly p = degree p + 1`
for `p ≠ 0`. -/
def euclid_val_poly (p : polynomial α) :=
if p = 0 then 0 else degree p + 1

lemma euclid_val_poly_lt_of_degree_lt (h : degree p < degree q) :
  euclid_val_poly p < euclid_val_poly q :=
begin
  unfold euclid_val_poly,
  split_ifs;
  simp [*, nat.succ_pos, -add_comm, nat.not_lt_zero,
    iff.intro nat.lt_of_succ_lt_succ nat.succ_lt_succ] at *
end

private lemma val_remainder_lt_aux (p : polynomial α) (hq : q ≠ 0) :
  euclid_val_poly (mod_aux p q) < euclid_val_poly q :=
or.cases_on (degree_mod_by_monic_lt_or_eq_zero p (monic_mul_leading_coeff_inv hq))
begin
  unfold mod_aux,
  rw [degree_mul_leading_coeff_inv hq],
  exact euclid_val_poly_lt_of_degree_lt
end
(λ h, begin
  rw [mod_aux, h, euclid_val_poly, if_pos rfl, euclid_val_poly, if_neg hq],
  exact nat.succ_pos _
end)

instance : euclidean_domain (polynomial α) :=
{ quotient := div_aux,
  remainder := mod_aux,
  quotient_mul_add_remainder_eq := quotient_mul_add_remainder_eq_aux,
  valuation := euclid_val_poly,
  val_remainder_lt := λ p q hq, val_remainder_lt_aux _ hq,
  val_le_mul_left := λ p q hq,
    if hp : p = 0 then begin
        unfold euclid_val_poly,
        rw [if_pos hp],
        exact nat.zero_le _
      end
    else begin
        unfold euclid_val_poly,
        rw [if_neg hp, if_neg (mul_ne_zero hp hq), degree_mul_eq hp hq],
        exact nat.succ_le_succ (nat.le_add_right _ _),
      end }

end field

end polynomial


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.ring.ulift
import algebra.module.equiv

/-!
# `ulift` instances for module and multiplicative actions

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

This file defines instances for module, mul_action and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We also provide `ulift.module_equiv : ulift M ≃ₗ[R] M`.

-/

namespace ulift
universes u v w
variable {R : Type u}
variable {M : Type v}
variable {N : Type w}

@[to_additive]
instance has_smul_left [has_smul R M] :
  has_smul (ulift R) M :=
⟨λ s x, s.down • x⟩

@[simp, to_additive]
lemma smul_def [has_smul R M] (s : ulift R) (x : M) : s • x = s.down • x := rfl

instance is_scalar_tower [has_smul R M] [has_smul M N] [has_smul R N]
  [is_scalar_tower R M N] : is_scalar_tower (ulift R) M N :=
⟨λ x y z, show (x.down • y) • z = x.down • y • z, from smul_assoc _ _ _⟩

instance is_scalar_tower' [has_smul R M] [has_smul M N] [has_smul R N]
  [is_scalar_tower R M N] : is_scalar_tower R (ulift M) N :=
⟨λ x y z, show (x • y.down) • z = x • y.down • z, from smul_assoc _ _ _⟩

instance is_scalar_tower'' [has_smul R M] [has_smul M N] [has_smul R N]
  [is_scalar_tower R M N] : is_scalar_tower R M (ulift N) :=
⟨λ x y z, show up ((x • y) • z.down) = ⟨x • y • z.down⟩, by rw smul_assoc⟩

instance [has_smul R M] [has_smul Rᵐᵒᵖ M] [is_central_scalar R M] :
  is_central_scalar R (ulift M) :=
⟨λ r m, congr_arg up $ op_smul_eq_smul r m.down⟩

@[to_additive]
instance mul_action [monoid R] [mul_action R M] : mul_action (ulift R) M :=
{ smul := (•),
  mul_smul := λ _ _, mul_smul _ _,
  one_smul := one_smul _ }

@[to_additive]
instance mul_action' [monoid R] [mul_action R M] :
  mul_action R (ulift M) :=
{ smul := (•),
  mul_smul := λ r s ⟨f⟩, ext _ _ $ mul_smul _ _ _,
  one_smul := λ ⟨f⟩, ext _ _ $ one_smul _ _ }

instance smul_zero_class [has_zero M] [smul_zero_class R M] :
  smul_zero_class (ulift R) M :=
{ smul_zero := λ _, smul_zero _,
  .. ulift.has_smul_left }

instance smul_zero_class' [has_zero M] [smul_zero_class R M] :
  smul_zero_class R (ulift M) :=
{ smul_zero := λ c, by { ext, simp [smul_zero], } }

instance distrib_smul [add_zero_class M] [distrib_smul R M] :
  distrib_smul (ulift R) M :=
{ smul_add := λ _, smul_add _ }

instance distrib_smul' [add_zero_class M] [distrib_smul R M] :
  distrib_smul R (ulift M) :=
{ smul_add := λ c f g, by { ext, simp [smul_add], } }

instance distrib_mul_action [monoid R] [add_monoid M] [distrib_mul_action R M] :
  distrib_mul_action (ulift R) M :=
{ ..ulift.mul_action,
  ..ulift.distrib_smul }

instance distrib_mul_action' [monoid R] [add_monoid M] [distrib_mul_action R M] :
  distrib_mul_action R (ulift M) :=
{ ..ulift.mul_action',
  ..ulift.distrib_smul' }

instance mul_distrib_mul_action [monoid R] [monoid M] [mul_distrib_mul_action R M] :
  mul_distrib_mul_action (ulift R) M :=
{ smul_one := λ _, smul_one _,
  smul_mul := λ _, smul_mul' _ }

instance mul_distrib_mul_action' [monoid R] [monoid M] [mul_distrib_mul_action R M] :
  mul_distrib_mul_action R (ulift M) :=
{ smul_one := λ _, by { ext, simp [smul_one], },
  smul_mul := λ c f g, by { ext, simp [smul_mul'], },
  ..ulift.mul_action' }

instance smul_with_zero [has_zero R] [has_zero M] [smul_with_zero R M] :
  smul_with_zero (ulift R) M :=
{ smul_zero := λ _, smul_zero _,
  zero_smul := zero_smul _,
  ..ulift.has_smul_left }

instance smul_with_zero' [has_zero R] [has_zero M] [smul_with_zero R M] :
  smul_with_zero R (ulift M) :=
{ smul_zero := λ _, ulift.ext _ _ $ smul_zero _,
  zero_smul := λ _, ulift.ext _ _ $ zero_smul _ _ }

instance mul_action_with_zero [monoid_with_zero R] [has_zero M] [mul_action_with_zero R M] :
  mul_action_with_zero (ulift R) M :=
{ ..ulift.smul_with_zero }

instance mul_action_with_zero' [monoid_with_zero R] [has_zero M] [mul_action_with_zero R M] :
  mul_action_with_zero R (ulift M) :=
{ ..ulift.smul_with_zero' }

instance module [semiring R] [add_comm_monoid M] [module R M] : module (ulift R) M :=
{ add_smul := λ _ _, add_smul _ _,
  ..ulift.smul_with_zero }

instance module' [semiring R] [add_comm_monoid M] [module R M] : module R (ulift M) :=
{ add_smul := λ _ _ _, ulift.ext _ _ $ add_smul _ _ _,
  ..ulift.smul_with_zero' }

/--
The `R`-linear equivalence between `ulift M` and `M`.
-/
@[simps apply symm_apply]
def module_equiv [semiring R] [add_comm_monoid M] [module R M] : ulift M ≃ₗ[R] M :=
{ to_fun := ulift.down,
  inv_fun := ulift.up,
  map_smul' := λ r x, rfl,
  map_add' := λ x y, rfl,
  left_inv := by tidy,
  right_inv := by tidy, }

end ulift


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Robert Y. Lewis

! This file was ported from Lean 3 source module data.real.cau_seq_completion
! leanprover-community/mathlib commit cf4c49c445991489058260d75dae0ff2b1abca28
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Real.CauSeq

/-!
# Cauchy completion

This file generalizes the Cauchy completion of `(ℚ, abs)` to the completion of a ring
with absolute value.
-/

namespace CauSeq.Completion

open CauSeq

section

variable {α : Type _} [LinearOrderedField α]

variable {β : Type _} [Ring β] (abv : β → α) [IsAbsoluteValue abv]

-- TODO: rename this to `CauSeq.Completion` instead of `CauSeq.Completion.Caucy`.
/-- The Cauchy completion of a ring with absolute value. -/
def Cauchy :=
  @Quotient (CauSeq _ abv) CauSeq.equiv
set_option linter.uppercaseLean3 false in
#align cau_seq.completion.Cauchy CauSeq.Completion.Cauchy

variable {abv}

/-- The map from Cauchy sequences into the Cauchy completion. -/
def mk : CauSeq _ abv → Cauchy abv :=
  Quotient.mk''
#align cau_seq.completion.mk CauSeq.Completion.mk

@[simp]
theorem mk_eq_mk (f : CauSeq _ abv) : @Eq (Cauchy abv) ⟦f⟧ (mk f) :=
  rfl
#align cau_seq.completion.mk_eq_mk CauSeq.Completion.mk_eq_mk

theorem mk_eq {f g : CauSeq _ abv} : mk f = mk g ↔ f ≈ g :=
  Quotient.eq
#align cau_seq.completion.mk_eq CauSeq.Completion.mk_eq

/-- The map from the original ring into the Cauchy completion. -/
def ofRat (x : β) : Cauchy abv :=
  mk (const abv x)
#align cau_seq.completion.of_rat CauSeq.Completion.ofRat

instance : Zero (Cauchy abv) :=
  ⟨ofRat 0⟩

instance : One (Cauchy abv) :=
  ⟨ofRat 1⟩

instance : Inhabited (Cauchy abv) :=
  ⟨0⟩

theorem ofRat_zero : (ofRat 0 : Cauchy abv) = 0 :=
  rfl
#align cau_seq.completion.of_rat_zero CauSeq.Completion.ofRat_zero

theorem ofRat_one : (ofRat 1 : Cauchy abv) = 1 :=
  rfl
#align cau_seq.completion.of_rat_one CauSeq.Completion.ofRat_one

@[simp]
theorem mk_eq_zero {f : CauSeq _ abv} : mk f = 0 ↔ LimZero f := by
  have : mk f = 0 ↔ LimZero (f - 0) := Quotient.eq
  rwa [sub_zero] at this
#align cau_seq.completion.mk_eq_zero CauSeq.Completion.mk_eq_zero

instance : Add (Cauchy abv) :=
  ⟨(Quotient.map₂ (· + ·)) fun _ _ hf _ _ hg => add_equiv_add hf hg⟩

@[simp]
theorem mk_add (f g : CauSeq β abv) : mk f + mk g = mk (f + g) :=
  rfl
#align cau_seq.completion.mk_add CauSeq.Completion.mk_add

instance : Neg (Cauchy abv) :=
  ⟨(Quotient.map Neg.neg) fun _ _ hf => neg_equiv_neg hf⟩

@[simp]
theorem mk_neg (f : CauSeq β abv) : -mk f = mk (-f) :=
  rfl
#align cau_seq.completion.mk_neg CauSeq.Completion.mk_neg

instance : Mul (Cauchy abv) :=
  ⟨(Quotient.map₂ (· * ·)) fun _ _ hf _ _ hg => mul_equiv_mul hf hg⟩

@[simp]
theorem mk_mul (f g : CauSeq β abv) : mk f * mk g = mk (f * g) :=
  rfl
#align cau_seq.completion.mk_mul CauSeq.Completion.mk_mul

instance : Sub (Cauchy abv) :=
  ⟨(Quotient.map₂ Sub.sub) fun _ _ hf _ _ hg => sub_equiv_sub hf hg⟩

@[simp]
theorem mk_sub (f g : CauSeq β abv) : mk f - mk g = mk (f - g) :=
  rfl
#align cau_seq.completion.mk_sub CauSeq.Completion.mk_sub

instance {γ : Type _} [SMul γ β] [IsScalarTower γ β β] : SMul γ (Cauchy abv) :=
  ⟨fun c => (Quotient.map ((· • ·) c)) fun _ _ hf => smul_equiv_smul _ hf⟩

@[simp]
theorem mk_smul {γ : Type _} [SMul γ β] [IsScalarTower γ β β] (c : γ) (f : CauSeq β abv) :
    c • mk f = mk (c • f) :=
  rfl
#align cau_seq.completion.mk_smul CauSeq.Completion.mk_smul

instance : Pow (Cauchy abv) ℕ :=
  ⟨fun x n => Quotient.map (· ^ n) (fun _ _ hf => pow_equiv_pow hf _) x⟩

@[simp]
theorem mk_pow (n : ℕ) (f : CauSeq β abv) : mk f ^ n = mk (f ^ n) :=
  rfl
#align cau_seq.completion.mk_pow CauSeq.Completion.mk_pow

instance : NatCast (Cauchy abv) :=
  ⟨fun n => mk n⟩

instance : IntCast (Cauchy abv) :=
  ⟨fun n => mk n⟩

@[simp]

@[simp]
theorem ofRat_intCast (z : ℤ) : (ofRat z : Cauchy abv) = z :=
  rfl
#align cau_seq.completion.of_rat_int_cast CauSeq.Completion.ofRat_intCast

theorem ofRat_add (x y : β) :
    ofRat (x + y) = (ofRat x + ofRat y : Cauchy abv) :=
  congr_arg mk (const_add _ _)
#align cau_seq.completion.of_rat_add CauSeq.Completion.ofRat_add

theorem ofRat_neg (x : β) : ofRat (-x) = (-ofRat x : Cauchy abv) :=
  congr_arg mk (const_neg _)
#align cau_seq.completion.of_rat_neg CauSeq.Completion.ofRat_neg

theorem ofRat_mul (x y : β) :
    ofRat (x * y) = (ofRat x * ofRat y : Cauchy abv) :=
  congr_arg mk (const_mul _ _)
#align cau_seq.completion.of_rat_mul CauSeq.Completion.ofRat_mul

private theorem zero_def : 0 = @mk _ _ _ _ abv _ 0 :=
  rfl

private theorem one_def : 1 = @mk _ _ _ _ abv _ 1 :=
  rfl

instance Cauchy.ring : Ring (Cauchy abv) :=
  Function.Surjective.ring mk (surjective_quotient_mk _) zero_def.symm one_def.symm
    (fun _ _ => (mk_add _ _).symm) (fun _ _ => (mk_mul _ _).symm) (fun _ => (mk_neg _).symm)
    (fun _ _ => (mk_sub _ _).symm) (fun _ _ => (mk_smul _ _).symm) (fun _ _ => (mk_smul _ _).symm)
    (fun _ _ => (mk_pow _ _).symm) (fun _ => rfl) fun _ => rfl

/-- `CauSeq.Completion.ofRat` as a `RingHom` -/
@[simps]
def ofRatRingHom : β →+* (Cauchy abv) where
  toFun := ofRat
  map_zero' := ofRat_zero
  map_one' := ofRat_one
  map_add' := ofRat_add
  map_mul' := ofRat_mul
#align cau_seq.completion.of_rat_ring_hom CauSeq.Completion.ofRatRingHom
#align cau_seq.completion.of_rat_ring_hom_apply CauSeq.Completion.ofRatRingHom_apply

theorem ofRat_sub (x y : β) : ofRat (x - y) = (ofRat x - ofRat y : Cauchy abv) :=
  congr_arg mk (const_sub _ _)
#align cau_seq.completion.of_rat_sub CauSeq.Completion.ofRat_sub

end

section

variable {α : Type _} [LinearOrderedField α]

variable {β : Type _} [CommRing β] {abv : β → α} [IsAbsoluteValue abv]

instance Cauchy.commRing : CommRing (Cauchy abv) :=
  Function.Surjective.commRing mk (surjective_quotient_mk _) zero_def.symm one_def.symm
    (fun _ _ => (mk_add _ _).symm) (fun _ _ => (mk_mul _ _).symm) (fun _ => (mk_neg _).symm)
    (fun _ _ => (mk_sub _ _).symm) (fun _ _ => (mk_smul _ _).symm) (fun _ _ => (mk_smul _ _).symm)
    (fun _ _ => (mk_pow _ _).symm) (fun _ => rfl) fun _ => rfl

end

open Classical

section

variable {α : Type _} [LinearOrderedField α]

variable {β : Type _} [DivisionRing β] {abv : β → α} [IsAbsoluteValue abv]

instance : RatCast (Cauchy abv) :=
  ⟨fun q => ofRat q⟩

@[simp, coe]
theorem ofRat_ratCast (q : ℚ) : ofRat (↑q : β) = (q : (Cauchy abv)) :=
  rfl
#align cau_seq.completion.of_rat_rat_cast CauSeq.Completion.ofRat_ratCast

noncomputable instance : Inv (Cauchy abv) :=
  ⟨fun x =>
    (Quotient.liftOn x fun f => mk <| if h : LimZero f then 0 else inv f h) fun f g fg =>
      by
      have := limZero_congr fg
      by_cases hf : LimZero f
      · simp [hf, this.1 hf, Setoid.refl]
      · have hg := mt this.2 hf
        simp [hf, hg]
        have If : mk (inv f hf) * mk f = 1 := mk_eq.2 (inv_mul_cancel hf)
        have Ig : mk (inv g hg) * mk g = 1 := mk_eq.2 (inv_mul_cancel hg)
        have Ig' : mk g * mk (inv g hg) = 1 := mk_eq.2 (mul_inv_cancel hg)
        rw [mk_eq.2 fg, ← Ig] at If
        rw [← mul_one (mk (inv f hf)), ← Ig', ← mul_assoc, If, mul_assoc, Ig', mul_one]⟩

-- porting note: simp can prove this
-- @[simp]
theorem inv_zero : (0 : (Cauchy abv))⁻¹ = 0 :=
  congr_arg mk <| by rw [dif_pos] <;> [rfl, exact zero_limZero]
#align cau_seq.completion.inv_zero CauSeq.Completion.inv_zero

@[simp]
theorem inv_mk {f} (hf) : (@mk α _ β _ abv _ f)⁻¹ = mk (inv f hf) :=
  congr_arg mk <| by rw [dif_neg]
#align cau_seq.completion.inv_mk CauSeq.Completion.inv_mk

theorem cau_seq_zero_ne_one : ¬(0 : CauSeq _ abv) ≈ 1 := fun h =>
  have : LimZero (1 - 0) := Setoid.symm h
  have : LimZero 1 := by simpa
  by apply one_ne_zero <| const_limZero.1 this
#align cau_seq.completion.cau_seq_zero_ne_one CauSeq.Completion.cau_seq_zero_ne_one

theorem zero_ne_one : (0 : (Cauchy abv)) ≠ 1 := fun h => cau_seq_zero_ne_one <| mk_eq.1 h
#align cau_seq.completion.zero_ne_one CauSeq.Completion.zero_ne_one

protected theorem inv_mul_cancel {x : (Cauchy abv)} : x ≠ 0 → x⁻¹ * x = 1 :=
  Quotient.inductionOn x fun f hf => by
    simp only [mk_eq_mk, ne_eq, mk_eq_zero] at hf
    simp [hf]
    exact Quotient.sound (CauSeq.inv_mul_cancel hf)
#align cau_seq.completion.inv_mul_cancel CauSeq.Completion.inv_mul_cancel

protected theorem mul_inv_cancel {x : (Cauchy abv)} : x ≠ 0 → x * x⁻¹ = 1 :=
  Quotient.inductionOn x fun f hf => by
    simp only [mk_eq_mk, ne_eq, mk_eq_zero] at hf
    simp [hf]
    exact Quotient.sound (CauSeq.mul_inv_cancel hf)
#align cau_seq.completion.mul_inv_cancel CauSeq.Completion.mul_inv_cancel

theorem ofRat_inv (x : β) : ofRat x⁻¹ = ((ofRat x)⁻¹ : (Cauchy abv)) :=
  congr_arg mk <| by split_ifs with h <;> [simp [const_limZero.1 h], rfl]
#align cau_seq.completion.of_rat_inv CauSeq.Completion.ofRat_inv

/- porting note: This takes a long time to compile.
   Also needed to rewrite the proof of ratCast_mk due to simp issues -/
/-- The Cauchy completion forms a division ring. -/
noncomputable instance Cauchy.divisionRing : DivisionRing (Cauchy abv) where
  exists_pair_ne := ⟨0, 1, zero_ne_one⟩
  inv_zero := inv_zero
  mul_inv_cancel x := CauSeq.Completion.mul_inv_cancel
  ratCast q := ofRat q
  ratCast_mk n d hd hnd := by rw [← ofRat_ratCast, Rat.cast_mk', ofRat_mul, ofRat_inv]; rfl

theorem ofRat_div (x y : β) : ofRat (x / y) = (ofRat x / ofRat y : Cauchy abv) := by
  simp only [div_eq_mul_inv, ofRat_inv, ofRat_mul]
#align cau_seq.completion.of_rat_div CauSeq.Completion.ofRat_div

/-- Show the first 10 items of a representative of this equivalence class of cauchy sequences.

The representative chosen is the one passed in the VM to `quot.mk`, so two cauchy sequences
converging to the same number may be printed differently.
-/
unsafe instance [Repr β] : Repr (Cauchy abv) where
  reprPrec r _ :=
    let N := 10
    let seq := r.unquot
    "(sorry /- " ++ Std.Format.joinSep ((List.range N).map <| repr ∘ seq) ", " ++ ", ... -/)"

end

section

variable {α : Type _} [LinearOrderedField α]

variable {β : Type _} [Field β] {abv : β → α} [IsAbsoluteValue abv]

/-- The Cauchy completion forms a field. -/
noncomputable instance Cauchy.field : Field (Cauchy abv) :=
  { Cauchy.divisionRing, Cauchy.commRing with }

end

end CauSeq.Completion

variable {α : Type _} [LinearOrderedField α]

namespace CauSeq

section

variable (β : Type _) [Ring β] (abv : β → α) [IsAbsoluteValue abv]

/-- A class stating that a ring with an absolute value is complete, i.e. every Cauchy
sequence has a limit. -/
class IsComplete : Prop where
  /-- Every Cauchy sequence has a limit. -/
  isComplete : ∀ s : CauSeq β abv, ∃ b : β, s ≈ const abv b
#align cau_seq.is_complete CauSeq.IsComplete
#align cau_seq.is_complete.is_complete CauSeq.IsComplete.isComplete

end

section

variable {β : Type _} [Ring β] {abv : β → α} [IsAbsoluteValue abv]

variable [IsComplete β abv]

theorem complete : ∀ s : CauSeq β abv, ∃ b : β, s ≈ const abv b :=
  IsComplete.isComplete
#align cau_seq.complete CauSeq.complete

/-- The limit of a Cauchy sequence in a complete ring. Chosen non-computably. -/
noncomputable def lim (s : CauSeq β abv) : β :=
  Classical.choose (complete s)
#align cau_seq.lim CauSeq.lim

theorem equiv_lim (s : CauSeq β abv) : s ≈ const abv (lim s) :=
  Classical.choose_spec (complete s)
#align cau_seq.equiv_lim CauSeq.equiv_lim

theorem eq_lim_of_const_equiv {f : CauSeq β abv} {x : β} (h : CauSeq.const abv x ≈ f) : x = lim f :=
  const_equiv.mp <| Setoid.trans h <| equiv_lim f
#align cau_seq.eq_lim_of_const_equiv CauSeq.eq_lim_of_const_equiv

theorem lim_eq_of_equiv_const {f : CauSeq β abv} {x : β} (h : f ≈ CauSeq.const abv x) : lim f = x :=
  (eq_lim_of_const_equiv <| Setoid.symm h).symm
#align cau_seq.lim_eq_of_equiv_const CauSeq.lim_eq_of_equiv_const

theorem lim_eq_lim_of_equiv {f g : CauSeq β abv} (h : f ≈ g) : lim f = lim g :=
  lim_eq_of_equiv_const <| Setoid.trans h <| equiv_lim g
#align cau_seq.lim_eq_lim_of_equiv CauSeq.lim_eq_lim_of_equiv

@[simp]
theorem lim_const (x : β) : lim (const abv x) = x :=
  lim_eq_of_equiv_const <| Setoid.refl _
#align cau_seq.lim_const CauSeq.lim_const

theorem lim_add (f g : CauSeq β abv) : lim f + lim g = lim (f + g) :=
  eq_lim_of_const_equiv <|
    show LimZero (const abv (lim f + lim g) - (f + g)) by
      rw [const_add, add_sub_add_comm]
      exact add_limZero (Setoid.symm (equiv_lim f)) (Setoid.symm (equiv_lim g))
#align cau_seq.lim_add CauSeq.lim_add

theorem lim_mul_lim (f g : CauSeq β abv) : lim f * lim g = lim (f * g) :=
  eq_lim_of_const_equiv <|
    show LimZero (const abv (lim f * lim g) - f * g) by
      have h :
        const abv (lim f * lim g) - f * g =
          (const abv (lim f) - f) * g + const abv (lim f) * (const abv (lim g) - g) := by
              apply Subtype.ext
              rw [coe_add]
              simp [sub_mul, mul_sub]
      rw [h]
      exact
        add_limZero (mul_limZero_left _ (Setoid.symm (equiv_lim _)))
          (mul_limZero_right _ (Setoid.symm (equiv_lim _)))
#align cau_seq.lim_mul_lim CauSeq.lim_mul_lim

theorem lim_mul (f : CauSeq β abv) (x : β) : lim f * x = lim (f * const abv x) := by
  rw [← lim_mul_lim, lim_const]
#align cau_seq.lim_mul CauSeq.lim_mul

theorem lim_neg (f : CauSeq β abv) : lim (-f) = -lim f :=
  lim_eq_of_equiv_const
    (show LimZero (-f - const abv (-lim f)) by
      rw [const_neg, sub_neg_eq_add, add_comm, ← sub_eq_add_neg]
      exact Setoid.symm (equiv_lim f))
#align cau_seq.lim_neg CauSeq.lim_neg

theorem lim_eq_zero_iff (f : CauSeq β abv) : lim f = 0 ↔ LimZero f :=
  ⟨fun h => by
    have hf := equiv_lim f
    rw [h] at hf
    exact (limZero_congr hf).mpr (const_limZero.mpr rfl),
   fun h => by
    have h₁ : f = f - const abv 0 := ext fun n => by simp [sub_apply, const_apply]
    rw [h₁] at h
    exact lim_eq_of_equiv_const h⟩
#align cau_seq.lim_eq_zero_iff CauSeq.lim_eq_zero_iff

end

section

variable {β : Type _} [Field β] {abv : β → α} [IsAbsoluteValue abv] [IsComplete β abv]

theorem lim_inv {f : CauSeq β abv} (hf : ¬LimZero f) : lim (inv f hf) = (lim f)⁻¹ :=
  have hl : lim f ≠ 0 := by rwa [← lim_eq_zero_iff] at hf
  lim_eq_of_equiv_const <|
    show LimZero (inv f hf - const abv (lim f)⁻¹) from
      have h₁ : ∀ (g f : CauSeq β abv) (hf : ¬LimZero f), LimZero (g - f * inv f hf * g) :=
        fun g f hf => by
          have h₂ : g - f * inv f hf * g = 1 * g - f * inv f hf * g := by rw [one_mul g]
          have h₃ : f * inv f hf * g = (f * inv f hf) * g := by simp [mul_assoc]
          have h₄ : g - f * inv f hf * g = (1 - f * inv f hf) * g := by rw [h₂, h₃, ← sub_mul]
          have h₅ : g - f * inv f hf * g = g * (1 - f * inv f hf) := by rw [h₄, mul_comm]
          have h₆ : g - f * inv f hf * g = g * (1 - inv f hf * f) := by rw [h₅, mul_comm f]
          rw [h₆]; exact mul_limZero_right _ (Setoid.symm (CauSeq.inv_mul_cancel _))
      have h₂ :
        LimZero
          (inv f hf - const abv (lim f)⁻¹ -
            (const abv (lim f) - f) * (inv f hf * const abv (lim f)⁻¹)) := by
              rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add]
              show LimZero
                (inv f hf - const abv (lim f) * (inv f hf * const abv (lim f)⁻¹) -
                  (const abv (lim f)⁻¹ - f * (inv f hf * const abv (lim f)⁻¹)))
              exact sub_limZero
                (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
                (by rw [← mul_assoc]; exact h₁ _ _ _)
      (limZero_congr h₂).mpr <| mul_limZero_left _ (Setoid.symm (equiv_lim f))
#align cau_seq.lim_inv CauSeq.lim_inv

end

section

variable [IsComplete α abs]

theorem lim_le {f : CauSeq α abs} {x : α} (h : f ≤ CauSeq.const abs x) : lim f ≤ x :=
  CauSeq.const_le.1 <| CauSeq.le_of_eq_of_le (Setoid.symm (equiv_lim f)) h
#align cau_seq.lim_le CauSeq.lim_le

theorem le_lim {f : CauSeq α abs} {x : α} (h : CauSeq.const abs x ≤ f) : x ≤ lim f :=
  CauSeq.const_le.1 <| CauSeq.le_of_le_of_eq h (equiv_lim f)
#align cau_seq.le_lim CauSeq.le_lim

theorem lt_lim {f : CauSeq α abs} {x : α} (h : CauSeq.const abs x < f) : x < lim f :=
  CauSeq.const_lt.1 <| CauSeq.lt_of_lt_of_eq h (equiv_lim f)
#align cau_seq.lt_lim CauSeq.lt_lim

theorem lim_lt {f : CauSeq α abs} {x : α} (h : f < CauSeq.const abs x) : lim f < x :=
  CauSeq.const_lt.1 <| CauSeq.lt_of_eq_of_lt (Setoid.symm (equiv_lim f)) h
#align cau_seq.lim_lt CauSeq.lim_lt

end

end CauSeq


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.erase_dup

/-!
# The fold operation for a commutative associative operation over a multiset.
-/

namespace multiset
variables {α β : Type*}

/-! ### fold -/
section fold
variables (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op]
local notation a * b := op a b
include hc ha

/-- `fold op b s` folds a commutative associative operation `op` over
  the multiset `s`. -/
def fold : α → multiset α → α := foldr op (left_comm _ hc.comm ha.assoc)

theorem fold_eq_foldr (b : α) (s : multiset α) :
  fold op b s = foldr op (left_comm _ hc.comm ha.assoc) b s := rfl

@[simp] theorem coe_fold_r (b : α) (l : list α) : fold op b l = l.foldr op b := rfl

theorem coe_fold_l (b : α) (l : list α) : fold op b l = l.foldl op b :=
(coe_foldr_swap op _ b l).trans $ by simp [hc.comm]

theorem fold_eq_foldl (b : α) (s : multiset α) :
  fold op b s = foldl op (right_comm _ hc.comm ha.assoc) b s :=
quot.induction_on s $ λ l, coe_fold_l _ _ _

@[simp] theorem fold_zero (b : α) : (0 : multiset α).fold op b = b := rfl

@[simp] theorem fold_cons_left : ∀ (b a : α) (s : multiset α),
  (a ::ₘ s).fold op b = a * s.fold op b := foldr_cons _ _

theorem fold_cons_right (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op b * a :=
by simp [hc.comm]

theorem fold_cons'_right (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op (b * a) :=
by rw [fold_eq_foldl, foldl_cons, ← fold_eq_foldl]

theorem fold_cons'_left (b a : α) (s : multiset α) : (a ::ₘ s).fold op b = s.fold op (a * b) :=
by rw [fold_cons'_right, hc.comm]

theorem fold_add (b₁ b₂ : α) (s₁ s₂ : multiset α) :
  (s₁ + s₂).fold op (b₁ * b₂) = s₁.fold op b₁ * s₂.fold op b₂ :=
multiset.induction_on s₂
  (by rw [add_zero, fold_zero, ← fold_cons'_right, ← fold_cons_right op])
  (by simp {contextual := tt}; cc)

theorem fold_singleton (b a : α) : (a ::ₘ 0 : multiset α).fold op b = a * b := by simp

theorem fold_distrib {f g : β → α} (u₁ u₂ : α) (s : multiset β) :
  (s.map (λx, f x * g x)).fold op (u₁ * u₂) = (s.map f).fold op u₁ * (s.map g).fold op u₂ :=
multiset.induction_on s (by simp) (by simp {contextual := tt}; cc)

theorem fold_hom {op' : β → β → β} [is_commutative β op'] [is_associative β op']
  {m : α → β} (hm : ∀x y, m (op x y) = op' (m x) (m y)) (b : α) (s : multiset α) :
  (s.map m).fold op' (m b) = m (s.fold op b) :=
multiset.induction_on s (by simp) (by simp [hm] {contextual := tt})

theorem fold_union_inter [decidable_eq α] (s₁ s₂ : multiset α) (b₁ b₂ : α) :
  (s₁ ∪ s₂).fold op b₁ * (s₁ ∩ s₂).fold op b₂ = s₁.fold op b₁ * s₂.fold op b₂ :=
by rw [← fold_add op, union_add_inter, fold_add op]

@[simp] theorem fold_erase_dup_idem [decidable_eq α] [hi : is_idempotent α op] (s : multiset α)
  (b : α) :
  (erase_dup s).fold op b = s.fold op b :=
multiset.induction_on s (by simp) $ λ a s IH, begin
  by_cases a ∈ s; simp [IH, h],
  show fold op b s = op a (fold op b s),
  rw [← cons_erase h, fold_cons_left, ← ha.assoc, hi.idempotent],
end

end fold

open nat

theorem le_smul_erase_dup [decidable_eq α] (s : multiset α) :
  ∃ n : ℕ, s ≤ n • erase_dup s :=
⟨(s.map (λ a, count a s)).fold max 0, le_iff_count.2 $ λ a, begin
  rw count_nsmul, by_cases a ∈ s,
  { refine le_trans _ (mul_le_mul_left _ $ count_pos.2 $ mem_erase_dup.2 h),
    have : count a s ≤ fold max 0 (map (λ a, count a s) (a ::ₘ erase s a));
    [simp [le_max_left], simpa [cons_erase h]] },
  { simp [count_eq_zero.2 h, nat.zero_le] }
end⟩

end multiset


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

! This file was ported from Lean 3 source module algebra.module.bimodule
! leanprover-community/mathlib commit 58cef51f7a819e7227224461e392dee423302f2d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.TensorProduct

/-!
# Bimodules

One frequently encounters situations in which several sets of scalars act on a single space, subject
to compatibility condition(s). A distinguished instance of this is the theory of bimodules: one has
two rings `R`, `S` acting on an additive group `M`, with `R` acting covariantly ("on the left")
and `S` acting contravariantly ("on the right"). The compatibility condition is just:
`(r • m) • s = r • (m • s)` for all `r : R`, `s : S`, `m : M`.

This situation can be set up in Mathlib as:
```lean
variables (R S M : Type*) [ring R] [ring S]
variables [add_comm_group M] [module R M] [module Sᵐᵒᵖ M] [smul_comm_class R Sᵐᵒᵖ M]
```
The key fact is:
```lean
example : module (R ⊗[ℕ] Sᵐᵒᵖ) M := tensor_product.algebra.module
```
Note that the corresponding result holds for the canonically isomorphic ring `R ⊗[ℤ] Sᵐᵒᵖ` but it is
preferable to use the `R ⊗[ℕ] Sᵐᵒᵖ` instance since it works without additive inverses.

Bimodules are thus just a special case of `module`s and most of their properties follow from the
theory of `module`s`. In particular a two-sided submodule of a bimodule is simply a term of type
`submodule (R ⊗[ℕ] Sᵐᵒᵖ) M`.

This file is a place to collect results which are specific to bimodules.

## Main definitions

 * `subbimodule.mk`
 * `subbimodule.smul_mem`
 * `subbimodule.smul_mem'`
 * `subbimodule.to_submodule`
 * `subbimodule.to_submodule'`

## Implementation details

For many definitions and lemmas it is preferable to set things up without opposites, i.e., as:
`[module S M] [smul_comm_class R S M]` rather than `[module Sᵐᵒᵖ M] [smul_comm_class R Sᵐᵒᵖ M]`.
The corresponding results for opposites then follow automatically and do not require taking
advantage of the fact that `(Sᵐᵒᵖ)ᵐᵒᵖ` is defeq to `S`.

## TODO

Develop the theory of two-sided ideals, which have type `submodule (R ⊗[ℕ] Rᵐᵒᵖ) R`.

-/

open TensorProduct

attribute [local instance] TensorProduct.Algebra.module

namespace Subbimodule

section Algebra

variable {R A B M : Type _}

variable [CommSemiring R] [AddCommMonoid M] [Module R M]

variable [Semiring A] [Semiring B] [Module A M] [Module B M]

variable [Algebra R A] [Algebra R B]

variable [IsScalarTower R A M] [IsScalarTower R B M]

variable [SMulCommClass A B M]

/-- A constructor for a subbimodule which demands closure under the two sets of scalars
individually, rather than jointly via their tensor product.

Note that `R` plays no role but it is convenient to make this generalisation to support the cases
`R = ℕ` and `R = ℤ` which both show up naturally. See also `base_change`. -/
@[simps]
def mk (p : AddSubmonoid M) (hA : ∀ (a : A) {m : M}, m ∈ p → a • m ∈ p)
    (hB : ∀ (b : B) {m : M}, m ∈ p → b • m ∈ p) : Submodule (A ⊗[R] B) M :=
  { p with
    carrier := p
    smul_mem' := fun ab m =>
      TensorProduct.induction_on ab (fun hm => by simpa only [zero_smul] using p.zero_mem)
        (fun a b hm => by simpa only [TensorProduct.Algebra.smul_def] using hA a (hB b hm))
        fun z w hz hw hm => by simpa only [add_smul] using p.add_mem (hz hm) (hw hm) }
#align subbimodule.mk Subbimodule.mk

theorem smul_mem (p : Submodule (A ⊗[R] B) M) (a : A) {m : M} (hm : m ∈ p) : a • m ∈ p :=
  by
  suffices a • m = a ⊗ₜ[R] (1 : B) • m by exact this.symm ▸ p.smul_mem _ hm
  simp [TensorProduct.Algebra.smul_def]
#align subbimodule.smul_mem Subbimodule.smul_mem

theorem smul_mem' (p : Submodule (A ⊗[R] B) M) (b : B) {m : M} (hm : m ∈ p) : b • m ∈ p :=
  by
  suffices b • m = (1 : A) ⊗ₜ[R] b • m by exact this.symm ▸ p.smul_mem _ hm
  simp [TensorProduct.Algebra.smul_def]
#align subbimodule.smul_mem' Subbimodule.smul_mem'

/-- If `A` and `B` are also `algebra`s over yet another set of scalars `S` then we may "base change"
from `R` to `S`. -/
@[simps]
def baseChange (S : Type _) [CommSemiring S] [Module S M] [Algebra S A] [Algebra S B]
    [IsScalarTower S A M] [IsScalarTower S B M] (p : Submodule (A ⊗[R] B) M) :
    Submodule (A ⊗[S] B) M :=
  mk p.toAddSubmonoid (smul_mem p) (smul_mem' p)
#align subbimodule.base_change Subbimodule.baseChange

/-- Forgetting the `B` action, a `submodule` over `A ⊗[R] B` is just a `submodule` over `A`. -/
@[simps]
def toSubmodule (p : Submodule (A ⊗[R] B) M) : Submodule A M :=
  { p with
    carrier := p
    smul_mem' := smul_mem p }
#align subbimodule.to_submodule Subbimodule.toSubmodule

/-- Forgetting the `A` action, a `submodule` over `A ⊗[R] B` is just a `submodule` over `B`. -/
@[simps]
def toSubmodule' (p : Submodule (A ⊗[R] B) M) : Submodule B M :=
  { p with
    carrier := p
    smul_mem' := smul_mem' p }
#align subbimodule.to_submodule' Subbimodule.toSubmodule'

end Algebra

section Ring

variable (R S M : Type _) [Ring R] [Ring S]

variable [AddCommGroup M] [Module R M] [Module S M] [SMulCommClass R S M]

/-- A `submodule` over `R ⊗[ℕ] S` is naturally also a `submodule` over the canonically-isomorphic
ring `R ⊗[ℤ] S`. -/
@[simps]
def toSubbimoduleInt (p : Submodule (R ⊗[ℕ] S) M) : Submodule (R ⊗[ℤ] S) M :=
  baseChange ℤ p
#align subbimodule.to_subbimodule_int Subbimodule.toSubbimoduleInt

/-- A `submodule` over `R ⊗[ℤ] S` is naturally also a `submodule` over the canonically-isomorphic
ring `R ⊗[ℕ] S`. -/
@[simps]
def toSubbimoduleNat (p : Submodule (R ⊗[ℤ] S) M) : Submodule (R ⊗[ℕ] S) M :=
  baseChange ℕ p
#align subbimodule.to_subbimodule_nat Subbimodule.toSubbimoduleNat

end Ring

end Subbimodule


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.data.fin
import Mathlib.PostPort

universes u u_1

namespace Mathlib

namespace list

/- of_fn -/

theorem length_of_fn_aux {α : Type u} {n : ℕ} (f : fin n → α) (m : ℕ) (h : m ≤ n) (l : List α) : length (of_fn_aux f m h l) = length l + m := sorry

@[simp] theorem length_of_fn {α : Type u} {n : ℕ} (f : fin n → α) : length (of_fn f) = n :=
  Eq.trans (length_of_fn_aux f n of_fn._proof_1 []) (zero_add n)

theorem nth_of_fn_aux {α : Type u} {n : ℕ} (f : fin n → α) (i : ℕ) (m : ℕ) (h : m ≤ n) (l : List α) : (∀ (i : ℕ), nth l i = of_fn_nth_val f (i + m)) → nth (of_fn_aux f m h l) i = of_fn_nth_val f i := sorry

@[simp] theorem nth_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (i : ℕ) : nth (of_fn f) i = of_fn_nth_val f i := sorry

theorem nth_le_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (i : fin n) : nth_le (of_fn f) (↑i) (Eq.symm (length_of_fn f) ▸ subtype.property i) = f i := sorry

@[simp] theorem nth_le_of_fn' {α : Type u} {n : ℕ} (f : fin n → α) {i : ℕ} (h : i < length (of_fn f)) : nth_le (of_fn f) i h = f { val := i, property := length_of_fn f ▸ h } :=
  nth_le_of_fn f { val := i, property := length_of_fn f ▸ h }

@[simp] theorem map_of_fn {α : Type u} {β : Type u_1} {n : ℕ} (f : fin n → α) (g : α → β) : map g (of_fn f) = of_fn (g ∘ f) := sorry

theorem array_eq_of_fn {α : Type u} {n : ℕ} (a : array n α) : array.to_list a = of_fn (array.read a) := sorry

@[simp] theorem of_fn_zero {α : Type u} (f : fin 0 → α) : of_fn f = [] :=
  rfl

@[simp] theorem of_fn_succ {α : Type u} {n : ℕ} (f : fin (Nat.succ n) → α) : of_fn f = f 0 :: of_fn fun (i : fin n) => f (fin.succ i) := sorry

theorem of_fn_nth_le {α : Type u} (l : List α) : (of_fn fun (i : fin (length l)) => nth_le l (↑i) (subtype.property i)) = l := sorry

-- not registered as a simp lemma, as otherwise it fires before `forall_mem_of_fn_iff` which

-- is much more useful

theorem mem_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (a : α) : a ∈ of_fn f ↔ a ∈ set.range f := sorry

@[simp] theorem forall_mem_of_fn_iff {α : Type u} {n : ℕ} {f : fin n → α} {P : α → Prop} : (∀ (i : α), i ∈ of_fn f → P i) ↔ ∀ (j : fin n), P (f j) := sorry

@[simp] theorem of_fn_const {α : Type u} (n : ℕ) (c : α) : (of_fn fun (i : fin n) => c) = repeat c n := sorry


/-
Copyright (c) 2021 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying
-/
import measure_theory.measure.vector_measure
import measure_theory.function.ae_eq_of_integral

/-!

# Vector measure defined by an integral

Given a measure `μ` and an integrable function `f : α → E`, we can define a vector measure `v` such
that for all measurable set `s`, `v i = ∫ x in s, f x ∂μ`. This definition is useful for
the Radon-Nikodym theorem for signed measures.

## Main definitions

* `measure_theory.measure.with_densityᵥ`: the vector measure formed by integrating a function `f`
  with respect to a measure `μ` on some set if `f` is integrable, and `0` otherwise.

-/

noncomputable theory
open_locale classical measure_theory nnreal ennreal

variables {α β : Type*} {m : measurable_space α}

namespace measure_theory

open topological_space

variables {μ ν : measure α}
variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [complete_space E]

/-- Given a measure `μ` and an integrable function `f`, `μ.with_densityᵥ f` is
the vector measure which maps the set `s` to `∫ₛ f ∂μ`. -/
def measure.with_densityᵥ {m : measurable_space α} (μ : measure α) (f : α → E) :
  vector_measure α E :=
if hf : integrable f μ then
{ measure_of' := λ s, if measurable_set s then ∫ x in s, f x ∂μ else 0,
  empty' := by simp,
  not_measurable' := λ s hs, if_neg hs,
  m_Union' := λ s hs₁ hs₂,
  begin
    convert has_sum_integral_Union hs₁ hs₂ hf.integrable_on,
    { ext n, rw if_pos (hs₁ n) },
    { rw if_pos (measurable_set.Union hs₁) }
  end }
else 0

open measure

include m

variables {f g : α → E}

lemma with_densityᵥ_apply (hf : integrable f μ) {s : set α} (hs : measurable_set s) :
  μ.with_densityᵥ f s = ∫ x in s, f x ∂μ :=
by { rw [with_densityᵥ, dif_pos hf], exact dif_pos hs }

@[simp] lemma with_densityᵥ_zero : μ.with_densityᵥ (0 : α → E) = 0 :=
by { ext1 s hs, erw [with_densityᵥ_apply (integrable_zero α E μ) hs], simp, }

@[simp] lemma with_densityᵥ_neg : μ.with_densityᵥ (-f) = -μ.with_densityᵥ f :=
begin
  by_cases hf : integrable f μ,
  { ext1 i hi,
    rw [vector_measure.neg_apply, with_densityᵥ_apply hf hi,
        ← integral_neg, with_densityᵥ_apply hf.neg hi],
    refl },
  { rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg, neg_zero],
    rwa integrable_neg_iff }
end

lemma with_densityᵥ_neg' : μ.with_densityᵥ (λ x, -f x) = -μ.with_densityᵥ f :=
with_densityᵥ_neg

@[simp] lemma with_densityᵥ_add (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (f + g) = μ.with_densityᵥ f + μ.with_densityᵥ g :=
begin
  ext1 i hi,
  rw [with_densityᵥ_apply (hf.add hg) hi, vector_measure.add_apply,
      with_densityᵥ_apply hf hi, with_densityᵥ_apply hg hi],
  simp_rw [pi.add_apply],
  rw integral_add; rw ← integrable_on_univ,
  { exact hf.integrable_on.restrict measurable_set.univ },
  { exact hg.integrable_on.restrict measurable_set.univ }
end

lemma with_densityᵥ_add' (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (λ x, f x + g x) = μ.with_densityᵥ f + μ.with_densityᵥ g :=
with_densityᵥ_add hf hg

@[simp] lemma with_densityᵥ_sub (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (f - g) = μ.with_densityᵥ f - μ.with_densityᵥ g :=
by rw [sub_eq_add_neg, sub_eq_add_neg, with_densityᵥ_add hf hg.neg, with_densityᵥ_neg]

lemma with_densityᵥ_sub' (hf : integrable f μ) (hg : integrable g μ) :
  μ.with_densityᵥ (λ x, f x - g x) = μ.with_densityᵥ f - μ.with_densityᵥ g :=
with_densityᵥ_sub hf hg

@[simp] lemma with_densityᵥ_smul {𝕜 : Type*} [nontrivially_normed_field 𝕜] [normed_space 𝕜 E]
  [smul_comm_class ℝ 𝕜 E] (f : α → E) (r : 𝕜) :
  μ.with_densityᵥ (r • f) = r • μ.with_densityᵥ f :=
begin
  by_cases hf : integrable f μ,
  { ext1 i hi,
    rw [with_densityᵥ_apply (hf.smul r) hi, vector_measure.smul_apply,
        with_densityᵥ_apply hf hi, ← integral_smul r f],
    refl },
  { by_cases hr : r = 0,
    { rw [hr, zero_smul, zero_smul, with_densityᵥ_zero] },
    { rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg, smul_zero],
      rwa integrable_smul_iff hr f } }
end

lemma with_densityᵥ_smul' {𝕜 : Type*} [nontrivially_normed_field 𝕜] [normed_space 𝕜 E]
  [smul_comm_class ℝ 𝕜 E] (f : α → E) (r : 𝕜) :
  μ.with_densityᵥ (λ x, r • f x) = r • μ.with_densityᵥ f :=
with_densityᵥ_smul f r

lemma measure.with_densityᵥ_absolutely_continuous (μ : measure α) (f : α → ℝ) :
  μ.with_densityᵥ f ≪ᵥ μ.to_ennreal_vector_measure :=
begin
  by_cases hf : integrable f μ,
  { refine vector_measure.absolutely_continuous.mk (λ i hi₁ hi₂, _),
    rw to_ennreal_vector_measure_apply_measurable hi₁ at hi₂,
    rw [with_densityᵥ_apply hf hi₁, measure.restrict_zero_set hi₂, integral_zero_measure] },
  { rw [with_densityᵥ, dif_neg hf],
    exact vector_measure.absolutely_continuous.zero _ }
end

/-- Having the same density implies the underlying functions are equal almost everywhere. -/
lemma integrable.ae_eq_of_with_densityᵥ_eq {f g : α → E} (hf : integrable f μ) (hg : integrable g μ)
  (hfg : μ.with_densityᵥ f = μ.with_densityᵥ g) :
  f =ᵐ[μ] g :=
begin
  refine hf.ae_eq_of_forall_set_integral_eq f g hg (λ i hi _, _),
  rw [← with_densityᵥ_apply hf hi, hfg, with_densityᵥ_apply hg hi]
end

lemma with_densityᵥ_eq.congr_ae {f g : α → E} (h : f =ᵐ[μ] g) :
  μ.with_densityᵥ f = μ.with_densityᵥ g :=
begin
  by_cases hf : integrable f μ,
  { ext i hi,
    rw [with_densityᵥ_apply hf hi, with_densityᵥ_apply (hf.congr h) hi],
    exact integral_congr_ae (ae_restrict_of_ae h) },
  { have hg : ¬ integrable g μ,
    { intro hg, exact hf (hg.congr h.symm) },
    rw [with_densityᵥ, with_densityᵥ, dif_neg hf, dif_neg hg] }
end

section signed_measure

lemma with_densityᵥ_to_real {f : α → ℝ≥0∞} (hfm : ae_measurable f μ) (hf : ∫⁻ x, f x ∂μ ≠ ∞) :
  μ.with_densityᵥ (λ x, (f x).to_real) =
  @to_signed_measure α _ (μ.with_density f) (is_finite_measure_with_density hf) :=
begin
  have hfi := integrable_to_real_of_lintegral_ne_top hfm hf,
  ext i hi,
  rw [with_densityᵥ_apply hfi hi, to_signed_measure_apply_measurable hi,
      with_density_apply _ hi, integral_to_real hfm.restrict],
  refine ae_lt_top' hfm.restrict (ne_top_of_le_ne_top hf _),
  conv_rhs { rw ← set_lintegral_univ },
  exact lintegral_mono_set (set.subset_univ _),
end

lemma with_densityᵥ_eq_with_density_pos_part_sub_with_density_neg_part
  {f : α → ℝ} (hfi : integrable f μ) :
  μ.with_densityᵥ f =
  @to_signed_measure α _ (μ.with_density (λ x, ennreal.of_real $ f x))
    (is_finite_measure_with_density_of_real hfi.2) -
  @to_signed_measure α _ (μ.with_density (λ x, ennreal.of_real $ -f x))
    (is_finite_measure_with_density_of_real hfi.neg.2) :=
begin
  ext i hi,
  rw [with_densityᵥ_apply hfi hi,
      integral_eq_lintegral_pos_part_sub_lintegral_neg_part hfi.integrable_on,
      vector_measure.sub_apply, to_signed_measure_apply_measurable hi,
      to_signed_measure_apply_measurable hi, with_density_apply _ hi, with_density_apply _ hi],
end

lemma integrable.with_densityᵥ_trim_eq_integral {m m0 : measurable_space α}
  {μ : measure α} (hm : m ≤ m0) {f : α → ℝ} (hf : integrable f μ)
  {i : set α} (hi : measurable_set[m] i) :
  (μ.with_densityᵥ f).trim hm i = ∫ x in i, f x ∂μ :=
by rw [vector_measure.trim_measurable_set_eq hm hi, with_densityᵥ_apply hf (hm _ hi)]

lemma integrable.with_densityᵥ_trim_absolutely_continuous
  {m m0 : measurable_space α} {μ : measure α} (hm : m ≤ m0) (hfi : integrable f μ) :
  (μ.with_densityᵥ f).trim hm ≪ᵥ (μ.trim hm).to_ennreal_vector_measure :=
begin
  refine vector_measure.absolutely_continuous.mk (λ j hj₁ hj₂, _),
  rw [measure.to_ennreal_vector_measure_apply_measurable hj₁, trim_measurable_set_eq hm hj₁] at hj₂,
  rw [vector_measure.trim_measurable_set_eq hm hj₁, with_densityᵥ_apply hfi (hm _ hj₁)],
  simp only [measure.restrict_eq_zero.mpr hj₂, integral_zero_measure]
end

end signed_measure

end measure_theory


import tactic
variables P Q : Prop

example (p q : ℕ → Prop) :
  (∃ x, p x ∧ q x) → ∃ x, q x ∧ p x :=
begin
  intro h,
  cases h with x hpq,
  cases hpq with hp hq,
  existsi x,
  split,
   exact hq,
  exact hp,
end


import fol
import Rings.Notation
import Rings.Rings
import field_theory.algebraic_closure
import Rings.ToMathlib.algebraic_closure

universe u

notation h :: t  := dvector.cons h t
notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

local infix ` ≃ `:64 := fol.bounded_preformula.bd_equal

-- open classical
-- local attribute [instance] prop_decidable

namespace Fields
open fol
open Rings
open Rings.ring_signature
open Rings.struc_to_ring_struc

def mul_inv : sentence ring_signature :=
∀' (x_ 1 ≃ 0) ⊔ (∃' x_ 1 * x_ 0 ≃ 1)

def non_triv : sentence ring_signature := 0 ≄ 1

def field_theory : Theory ring_signature := ring_theory ∪ {mul_inv , non_triv}

lemma mul_inv_in_field_theory : mul_inv ∈ field_theory :=
begin right, left, refl end

lemma non_triv_in_field_theory : non_triv ∈ field_theory :=
begin right, right, exact set.mem_singleton _ end

lemma ring_theory_sub_field_theory : ring_theory ⊆ field_theory :=
begin intros f hf, left, exact hf end

namespace field_to
  variables
    {K : Type u} [field K]

  lemma K_is_field : is_field K := field.to_is_field K

open Rings.models_ring_theory_to_comm_ring

  lemma realize_field_theory :
    Structure K ⊨ field_theory := -- squeeze_simp, val_zero
  begin
    intros ϕ h,
    cases h,
    {apply (comm_ring_to_model.realize_ring_theory K h)},
    repeat {cases h},
     {
       intro,
       unfold fol.bd_or,
       simp only [models_ring_theory_to_comm_ring.realize_one,
         ring_signature.mul, struc_to_ring_struc.func_map,
         fin.val_zero', realize_bounded_formula_not,
         struc_to_ring_struc.binaries_map,
         fin.val_eq_coe, dvector.last,
         realize_bounded_formula_ex, realize_bounded_term_bd_app,
         realize_bounded_formula, realize_bounded_term,
         fin.val_one, dvector.nth,
         models_ring_theory_to_comm_ring.realize_zero],
       apply is_field.mul_inv_cancel,
       apply K_is_field,
     },
    { unfold fol.realize_sentence,
      simp only [forall_false_left, ring_signature.one, realize_bounded_formula,
        realize_bounded_term, struc_to_ring_struc.realize_one, func_map, const_map,
        zero_ne_one, struc_to_ring_struc.realize_zero, ring_signature.zero] },
  end

  /-- Fields are models of the theory of fields -/
  def models_field_theory : Model field_theory.{u} :=
  ⟨ Structure K ,  realize_field_theory ⟩

end field_to

namespace models_theory_of_fields_to_is_field

  variables {M : Structure ring_signature} (h : M ⊨ field_theory)
  -- M inherits instances of 0 1 - + * from Rings.ModelTo

  include h

  lemma ring_model : M ⊨ ring_theory :=
  begin
    intros f hf,
    apply h,
    apply ring_theory_sub_field_theory,
    exact hf
  end

  instance comm_ring : comm_ring M :=
  models_ring_theory_to_comm_ring.comm_ring (ring_model h)

  instance ring : ring M := @comm_ring.to_ring M (models_theory_of_fields_to_is_field.comm_ring h)

  lemma zero_ne_one : (0 : M) ≠ 1 := by simpa using (h non_triv_in_field_theory)

  lemma mul_inv (a : M) (ha : a ≠ 0) : (∃ (b : M), a * b = 1) :=
  let hmulinv := h mul_inv_in_field_theory in by simpa using hmulinv a ha

  lemma is_field : @is_field M (models_theory_of_fields_to_is_field.ring h) :=
  begin
    split,
    {exact ⟨ 0 , 1 , zero_ne_one h ⟩},
    {exact (models_theory_of_fields_to_is_field.comm_ring h).mul_comm},
    {exact mul_inv h},
  end
  -- ⟨
  --   ⟨ 0 , 1 , zero_ne_one ⟩,
  --   models_ring_theory_to_comm_ring.mul_comm,
  --   mul_inv
  -- ⟩
  noncomputable instance field : field M :=
  @is_field.to_field M (models_theory_of_fields_to_is_field.ring h)
  (models_theory_of_fields_to_is_field.is_field h)

end models_theory_of_fields_to_is_field

/-- GenPoly n is the polynomial aₙ₊₁ xⁿ + ⋯ + a₂ x + a₁
 where aₖ = x_ k and x = x_ 0, i.e. we are seeing the variables x_ k with 0 < k as coefficients
 and x_ 0 as the indeterminate -/
@[simp] def gen_poly : Π (n : ℕ), bounded_term ring_signature (n + 2)
| 0       := x_ ⟨ 1 , by exact dec_trivial ⟩
| (n + 1) :=
  (x_ ⟨ n + 2 , add_lt_add_right (nat.lt_succ_self _) _ ⟩)
  * (npow_rec (n + 1) (x_ ⟨ 0 , nat.zero_lt_succ _ ⟩)) +
  bounded_preterm.lift_succ (gen_poly n)

/-- Adds a monic term at the beginning of gen_poly.
 We will require that these polynomials have solutions for `algebraically closed`.
 We cannot just use gen_poly as we need the polynomials to have 0 < deg -/
@[simp] def gen_monic_poly (n : ℕ) : bounded_term ring_signature (n + 2) :=
npow_rec (n + 1) (x_ 0) + gen_poly n

section poly_lemmas

variables {A : Type u} [hcomm : comm_ring A] [hnt : nontrivial A] [hde : decidable_eq A]

include hcomm hnt hde

/-- xᵐ has degree m -/
lemma deg_pow {n m : ℕ} {as : dvector A (n + 1)} :
  (polynomial.term_evaluated_at_coeffs as
    (npow_rec m x_ ⟨ 0 , nat.zero_lt_succ _ ⟩)).degree
  = m :=
begin
  rw polynomial.term_evaluated_at_coeffs_pow,
  apply polynomial.degree_X_pow,
end

/-- degree of gen_poly n < n + 1 -/
lemma gen_poly_degree : Π {n} {as : dvector A (n + 1)},
  (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree < n.succ
| nat.zero as :=
begin
  simp only [gen_poly],
  have h : polynomial.term_evaluated_at_coeffs as x_ ⟨ 1 , _ ⟩
    = polynomial.C (as.nth' 0),
  {rw ← polynomial.term_evaluated_at_coeffs_coeff, simp only [fin.val_zero'] },
  rw h,
  by_cases h0 : as.nth' 0 = 0,
  {
    rw h0,
    rw polynomial.C_0,
    rw polynomial.degree_zero,
    exact dec_trivial,
  },
  {
    rw polynomial.degree_C h0,
    exact dec_trivial,
  }
end
| (nat.succ n) as :=
begin
  simp only [gen_poly, polynomial.term_evaluated_at_coeffs_add],
  rw polynomial.term_evaluated_at_coeffs_monomial' (nat.lt_succ_self _),
  rw polynomial.lift_succ_remove_last,
  -- have am : dvector A n.succ := dvector.remove_mth (n + 2) as,
  apply has_le.le.trans_lt (polynomial.degree_add_le _ _),
  apply max_lt,
  {
    apply has_le.le.trans_lt (polynomial.degree_monomial_le _ _),
    exact with_bot.succ_lt_succ_succ,
  },
  {
    apply lt_trans (@gen_poly_degree n (dvector.remove_mth (n.succ + 2) as)),
    exact with_bot.succ_lt_succ_succ,
  },
end

/-- gen_monic_poly has non-zero degree -/
lemma gen_monic_poly_non_const {n} {as : dvector A (n + 1)} :
  polynomial.degree (polynomial.term_evaluated_at_coeffs as (gen_monic_poly n)) ≠ 0 :=
begin
  unfold gen_monic_poly,
  apply ne_of_gt,
  have hp : (polynomial.term_evaluated_at_coeffs as (npow_rec (n + 1) x_ 0)).degree = n + 1,
  {apply deg_pow},
  have hq : (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree < (n + 1),
  {
    apply lt_of_lt_of_le gen_poly_degree,
    {
      rw le_iff_eq_or_lt,
      left, refl,
    },
    exact hnt, -- why??
    exact hde, -- why??
  },
  have hle : (polynomial.term_evaluated_at_coeffs as (gen_poly n)).degree
    < (polynomial.term_evaluated_at_coeffs as (npow_rec (n + 1) x_ 0)).degree,
  { rw hp, exact hq },
  rw polynomial.term_evaluated_at_coeffs_add,
  rw (polynomial.degree_add_eq_left_of_degree_lt hle),
  rw hp,
  exact dec_trivial,
end

end poly_lemmas

/-- ∀ a₁ ⋯ ∀ aₙ, ∃ x₀, (aₙ x₀ⁿ⁻¹ + ⋯ + a₂ x₀+ a₁ = 0) -/
@[simp] def all_gen_monic_poly_has_root (n : ℕ) :
  sentence ring_signature :=
fol.bd_alls (n + 1) (∃' gen_monic_poly n ≃ 0)

/-- The thoery of algebraically closed fields -/
def ACF : Theory ring_signature :=
field_theory ∪ (set.range all_gen_monic_poly_has_root)
-- the latter stands for {gen_monic_polyHasSolution n | n : ℕ}

/-- The theory of algebraically closed fields of prime characteristic -/

def ACFₚ {p : ℕ} (h : prime p) : Theory ring_signature :=
set.insert (p ≃ 0) ACF

@[reducible] def plus_one_ne_zero (p : ℕ) : sentence ring_signature :=
p + 1 ≄ 0

/-- The theory of algebraically closed fields of characterstic zero -/
def ACF₀ : Theory ring_signature := ACF ∪ (set.range plus_one_ne_zero)

lemma ACF_subset_ACFₚ {p} {h : prime p} : ACF ⊆ ACFₚ h :=
set.subset_insert _ _

lemma ACF_subset_ACF₀ : ACF ⊆ ACF₀ :=
set.subset_union_left _ _

lemma realize_plus_one_ne_zero {M : Structure ring_signature} {p} :
  (M ⊨ plus_one_ne_zero p) ↔ (p.succ : M) ≠ 0 :=
begin
  simp only [plus_one_ne_zero],
  have hrw : add (p : bounded_ring_term 0) one = ↑(p.succ) := rfl,
  rw hrw,
  simp only [bd_notequal, realize_sentence_not,
    realize_sentence_equal, realize_closed_term,
    models_ring_theory_to_comm_ring.realize_nat,
    not_iff_not],
  refl,
end

namespace is_alg_closed_to

variables {K : Type u} [field K] [is_alg_closed K] [decidable_eq K]

open Rings.struc_to_ring_struc

  -- should be in the library
theorem is_alg_closed.exists_root (f : polynomial K) (h : f.degree ≠ 0) :
  ∃ x : K, f.eval x = 0 :=
polynomial.exists_root_of_splits _ (is_alg_closed.splits f) h

/-- Algebraically closed fields model the theory ACF-/
lemma realize_ACF : Structure K ⊨ ACF :=
begin
  intros ϕ h,
  cases h,
  {apply field_to.realize_field_theory h},
  {
    cases h with n hϕ,
    rw ← hϕ,
    simp only [all_gen_monic_poly_has_root, realize_sentence_bd_alls,
      realize_bounded_formula_ex, realize_bounded_formula,
      models_ring_theory_to_comm_ring.realize_zero, zero],
    intro as,
    have root := is_alg_closed.exists_root
      (polynomial.term_evaluated_at_coeffs as (gen_monic_poly n)) gen_monic_poly_non_const,
    cases root with x hx,
    use x,
    rw polynomial.eval_term_evaluated_at_coeffs_eq_realize_bounded_term at hx,
    exact hx,
  },
end

lemma realize_ACF₀ [char_zero K] : Structure K ⊨ ACF₀ :=
begin
  simp only [ACF₀, all_realize_sentence_union, all_realize_sentence_range,
    bd_notequal, realize_sentence_not, realize_sentence_equal],
  refine ⟨ realize_ACF , λ n, _ ⟩,
  simp only [realize_plus_one_ne_zero],
  intro hbot,
  have hbot1 : (n.succ : K) = ((0 : ℕ) : K) := hbot,
  have hbot2 := char_zero.cast_injective hbot1,
  exact nat.succ_ne_zero _ hbot2,
end

end is_alg_closed_to

namespace models_ACF_to
noncomputable theory

variables {M : Structure ring_signature} [hM : fact (M ⊨ ACF)]

include hM

instance Field : field M :=
  models_theory_of_fields_to_is_field.field
(begin
  rw [ACF, all_realize_sentence_union] at hM,
  exact hM.1.1,
end)

-- @[reducible] noncomputable def term_evaluated_at_coeffs {n} (as : dvector M n)
--   (t : bounded_ring_term n.succ) : polynomial M :=
-- let σ : fin n.succ → polynomial M :=
-- @fin.cases n (λ _, polynomial M) polynomial.X (λ i, polynomial.C (dvector.nth' as i)) in
-- mv_polynomial.eval σ (mv_polynomial.term t)

-- /-- terms realized at values in A are the corresponding polynomials -/
-- /- evaluated at those values -/
-- lemma realized_term_is_evaluated_poly {n} {as : dvector M n} :
-- Π (t : bounded_ring_term n),
--   @realize_bounded_term _ M _ as _ t dvector.nil
--   = mv_polynomial.eval (dvector.fin_val as) (mv_polynomial.term t) :=
-- @ring_term_rec n (λ (t : bounded_ring_term n),
--   @realize_bounded_term _ M _ as _ t dvector.nil
--     = mv_polynomial.eval (dvector.fin_val as) (mv_polynomial.term t))
--   (begin intro k, simpa, end) -- variables
--   (begin -- zero
--     simpa only [struc_to_ring_struc.apps_zero, dvector.fin_val,
--       realize_bounded_term,
--       struc_to_ring_struc.realize_zero, mv_polynomial.term_zero, zero],
--   end)
--   (by simp)
--   -- simp only [struc_to_ring_struc.apps_one, dvector.fin_val, realize_bounded_term,
--   --   struc_to_ring_struc.realize_one, term_one, one,
--   --   mv_polynomial.coe_mv_poly_one, ring_hom.map_one],
--   (begin -- neg
--     intros t h,
--     unfold_coes,
--     unfold_coes at h,
--     simp only [ring_hom.to_fun_eq_coe, mv_polynomial.eval_map] at h,
--     rw mv_polynomial.term_neg,
--     simp only [struc_to_ring_struc.unaries_map, struc_to_ring_struc.func_map,
--       dvector.last, realize_bounded_term, neg, dvector.nth,
--       mv_polynomial.coe_mv_poly_neg, h, ring_hom.to_fun_eq_coe,
--       ring_hom.map_neg, models_ring_theory_to_comm_ring.realize_neg,
--       mv_polynomial.eval_map, neg_inj, struc_to_ring_struc.apps_neg],
--   end)
--   (begin -- add
--     intros s t hs ht,
--     unfold_coes,
--     rw mv_polynomial.term_add,
--     simp only [add, struc_to_ring_struc.binaries_map, dvector.last, struc_to_ring_struc.func_map,
--       dvector.last, realize_bounded_term, dvector.nth, mv_polynomial.coe_mv_poly_neg],
--     rw [hs, ht],
--     unfold_coes,
--     simp,
--   end)
--   (begin -- mul
--     intros s t hs ht,
--     unfold_coes,
--     rw mv_polynomial.term_mul,
--     simp only [mul, struc_to_ring_struc.binaries_map, dvector.last, struc_to_ring_struc.func_map,
--       dvector.last, realize_bounded_term, dvector.nth, mv_polynomial.coe_mv_poly_neg],
--     rw [hs, ht],
--     unfold_coes,
--     simp,
--   end)

-- lemma eval_term_evaluated_at_coeffs_eq_realize_bounded_term
--   {n} {as : dvector M n} {x : M} (t : bounded_term ring_signature n.succ) :
--   (polynomial.eval x (term_evaluated_at_coeffs as t)
--     = @realize_bounded_term _ M n.succ (x::as) _ t dvector.nil) :=
-- begin
--   rw realized_term_is_evaluated_poly,
--   rw dvector.fin_val_eq_x_val,
--   rw mv_polynomial.eval_eq_poly_eval_mv_coeffs,
--   simp only [dvector.fin_val, function.comp_app, fin.x_val,
--     mv_polynomial.to_polynomial, term_evaluated_at_coeffs],
--   have hcoes : polynomial.C.comp (int.cast_ring_hom M) =
--     int.cast_ring_hom (polynomial M) :=
--   by simp,
--   unfold_coes,
--   rw ← hcoes,
--   simp only [ring_hom.to_fun_eq_coe, mv_polynomial.eval₂_map,
--     mv_polynomial.eval_map],
-- end

-- lemma idk {p : polynomial M} :
--   p =
--   (@mv_polynomial.eval
--     (@fin.cases
--       _
--       (λ _, polynomial M)
--       polynomial.X
--       (λ (i : fin (p.nat_degree + 1)), polynomial.C (p.coeff i))
--     )
--   )
--       (mv_polynomial.term (gen_monic_poly p.nat_degree))

lemma realize_npow_rec
  {m n} {as : dvector M m} {t : bounded_term ring_signature m} :
  realize_bounded_term as (npow_rec n t) dvector.nil =
  (realize_bounded_term as t dvector.nil) ^ n :=
begin
  induction n with n hn,
  { simpa only [npow_rec, one, realize_one, realize_bounded_term,
    _root_.pow_zero] },
  { simpa only [npow_rec, mul, models_ring_theory_to_comm_ring.realize_mul,
      realize_bounded_term, hn] },
end

lemma realize_gen_poly {n : ℕ} {root} {c : ℕ → M} :
realize_bounded_term
  (dvector.cons root (dvector.of_fn (λ (i : fin (n + 1)), c i)))
  (gen_poly n) dvector.nil =
(finset.range (n + 1)).sum (λ (x : ℕ), c x * root ^ x)
     :=
begin
  induction n with n hn,
  {
    simp only [finset.sum_range_one, _root_.pow_zero, mul_one,
      gen_poly, dvector.nth_of_fn,
      realize_bounded_term, dvector.nth_cons _ _ _ (nat.zero_lt_one)],
    refl,
  },
  {
    simp only [finset.sum_range_add, hn, finset.sum_range_one, mul_one,
      gen_poly, dvector.nth_of_fn, add_zero, fin.mk_zero, fin.val_zero',
      models_ring_theory_to_comm_ring.realize_add, add,
      models_ring_theory_to_comm_ring.realize_mul, realize_bounded_term,
      dvector.nth, realize_lift_succ, dvector.remove_mth],
    rw [dvector.remove_mth_of_fn_last, hn,
      add_comm ((finset.range (n + 1)).sum (λ (x : ℕ), c x * root ^ x))],
    congr1,
    simp only [mul, fin.val_zero', models_ring_theory_to_comm_ring.realize_mul,
      realize_bounded_term, dvector.nth, dvector.nth_of_fn,
      fin.coe_mk, realize_npow_rec],
  }
end

instance is_alg_closed : is_alg_closed M :=
begin
  apply is_alg_closed.of_monic_nat_degree_ne_zero_exists_root,
  intros p hmonic hdeg,
  simp only [ACF, all_realize_sentence_union, all_realize_sentence_range,
    all_gen_monic_poly_has_root, realize_sentence_bd_alls,
    realize_bounded_formula, models_ring_theory_to_comm_ring.realize_zero, zero,
    realize_bounded_formula_ex] at hM,
  obtain ⟨ _ , halg_closed ⟩ := hM.1,
  set n := polynomial.nat_degree p - 1 with hn,
  set xs := dvector.of_fn (λ (i : fin (n + 1)), polynomial.coeff p i) with hxs,
  obtain ⟨ root , hroot ⟩ := halg_closed n xs,
  use root,
  convert hroot,
  rw polynomial.eval_eq_finset_sum,
  simp only [gen_monic_poly],
  simp only [mul, fin.val_zero',
    models_ring_theory_to_comm_ring.realize_add, add,
    models_ring_theory_to_comm_ring.realize_mul,
    realize_bounded_term, dvector.nth,
    models_ring_theory_to_comm_ring.realize_pow],
  simp only [polynomial.monic, polynomial.leading_coeff] at hmonic,
  simp only [finset.sum_range_add, finset.sum_range_one, add_zero, hmonic,
    one_mul],
  have hpow : npow_rec (n + 1) root = root ^ p.nat_degree,
  { simp only [pow, hn], rw nat.sub_add_cancel, refl,
    rw ← nat.one_lt_bit0_iff, exact nat.one_lt_bit0 hdeg },
  rw [add_comm _ (root ^ p.nat_degree), hpow, hxs, hn],
  congr,
  rw realize_gen_poly,
  rw nat.sub_add_cancel,
  rw ← nat.one_lt_bit0_iff, exact nat.one_lt_bit0 hdeg,
end

end models_ACF_to

variables {M : Structure ring_signature} {h : M ⊨ ACF} {p : ℕ}

lemma models_ACFₚ_iff {hp : prime p} :
  M ⊨ ACFₚ hp ↔ (p : M) = 0 ∧ M ⊨ ACF :=
by simp only [ACFₚ, all_realize_sentence_insert, realize_sentence_equal, zero,
    realize_closed_term, models_ring_theory_to_comm_ring.realize_nat,
    models_ring_theory_to_comm_ring.realize_zero]

end Fields


theorem ex1 (x y : Nat) (h : x + 2 = y + 2) : x = y := by
  injection h with h
  traceState -- without smart unfolding the state would be a mess
  injection h with h
  traceState -- without smart unfolding the state would be a mess
  assumption


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Eric Wieser
-/
import algebra.group.to_additive
import data.prod.basic
import logic.unique
import tactic.congr
import tactic.simpa
import tactic.split_ifs

/-!
# Instances and theorems on pi types

This file provides basic definitions and notation instances for Pi types.

Instances of more sophisticated classes are defined in `pi.lean` files elsewhere.
-/

open function

universes u v₁ v₂ v₃
variable {I : Type u}     -- The indexing type
variables {α β γ : Type*}
-- The families of types already equipped with instances
variables {f : I → Type v₁} {g : I → Type v₂} {h : I → Type v₃}
variables (x y : Π i, f i) (i : I)

namespace pi

/-! `1`, `0`, `+`, `*`, `-`, `⁻¹`, and `/` are defined pointwise. -/

@[to_additive] instance has_one [∀ i, has_one $ f i] :
  has_one (Π i : I, f i) :=
⟨λ _, 1⟩
@[simp, to_additive] lemma one_apply [∀ i, has_one $ f i] : (1 : Π i, f i) i = 1 := rfl

@[to_additive] lemma one_def [Π i, has_one $ f i] : (1 : Π i, f i) = λ i, 1 := rfl

@[simp, to_additive] lemma const_one [has_one β] : const α (1 : β) = 1 := rfl

@[simp, to_additive] lemma one_comp [has_one γ] (x : α → β) : (1 : β → γ) ∘ x = 1 := rfl

@[simp, to_additive] lemma comp_one [has_one β] (x : β → γ) : x ∘ 1 = const α (x 1) := rfl

@[to_additive]
instance has_mul [∀ i, has_mul $ f i] :
  has_mul (Π i : I, f i) :=
⟨λ f g i, f i * g i⟩
@[simp, to_additive] lemma mul_apply [∀ i, has_mul $ f i] : (x * y) i = x i * y i := rfl

@[to_additive] lemma mul_def [Π i, has_mul $ f i] : x * y = λ i, x i * y i := rfl

@[simp, to_additive] lemma const_mul [has_mul β] (a b : β) :
  const α a * const α b = const α (a * b) := rfl

@[to_additive] lemma mul_comp [has_mul γ] (x y : β → γ) (z : α → β) :
  (x * y) ∘ z = x ∘ z * y ∘ z := rfl

@[simp] lemma bit0_apply [Π i, has_add $ f i] : (bit0 x) i = bit0 (x i) := rfl

@[simp] lemma bit1_apply [Π i, has_add $ f i] [Π i, has_one $ f i] : (bit1 x) i = bit1 (x i) := rfl

@[to_additive] instance has_inv [∀ i, has_inv $ f i] :
  has_inv (Π i : I, f i) :=
  ⟨λ f i, (f i)⁻¹⟩
@[simp, to_additive] lemma inv_apply [∀ i, has_inv $ f i] : x⁻¹ i = (x i)⁻¹ := rfl
@[to_additive] lemma inv_def [Π i, has_inv $ f i] : x⁻¹ = λ i, (x i)⁻¹ := rfl

@[to_additive] lemma const_inv [has_inv β] (a : β) : (const α a)⁻¹ = const α a⁻¹ := rfl

@[to_additive] lemma inv_comp [has_inv γ] (x : β → γ) (y : α → β) : x⁻¹ ∘ y = (x ∘ y)⁻¹ := rfl

@[to_additive] instance has_div [Π i, has_div $ f i] :
  has_div (Π i : I, f i) :=
⟨λ f g i, f i / g i⟩
@[simp, to_additive] lemma div_apply [Π i, has_div $ f i] : (x / y) i = x i / y i := rfl
@[to_additive] lemma div_def [Π i, has_div $ f i] : x / y = λ i, x i / y i := rfl

@[to_additive] lemma div_comp [has_div γ] (x y : β → γ) (z : α → β) :
  (x / y) ∘ z = x ∘ z / y ∘ z := rfl

@[simp, to_additive] lemma const_div [has_div β] (a b : β) :
  const α a / const α b = const α (a / b) := rfl

section

variables [decidable_eq I]
variables [Π i, has_one (f i)] [Π i, has_one (g i)] [Π i, has_one (h i)]

/-- The function supported at `i`, with value `x` there, and `1` elsewhere. -/
@[to_additive pi.single "The function supported at `i`, with value `x` there, and `0` elsewhere." ]
def mul_single (i : I) (x : f i) : Π i, f i :=
function.update 1 i x

@[simp, to_additive]
lemma mul_single_eq_same (i : I) (x : f i) : mul_single i x i = x :=
function.update_same i x _

@[simp, to_additive]
lemma mul_single_eq_of_ne {i i' : I} (h : i' ≠ i) (x : f i) : mul_single i x i' = 1 :=
function.update_noteq h x _

/-- Abbreviation for `mul_single_eq_of_ne h.symm`, for ease of use by `simp`. -/
@[simp, to_additive "Abbreviation for `single_eq_of_ne h.symm`, for ease of
use by `simp`."]
lemma mul_single_eq_of_ne' {i i' : I} (h : i ≠ i') (x : f i) : mul_single i x i' = 1 :=
mul_single_eq_of_ne h.symm x

@[simp, to_additive]
lemma mul_single_one (i : I) : mul_single i (1 : f i) = 1 :=
function.update_eq_self _ _

/-- On non-dependent functions, `pi.mul_single` can be expressed as an `ite` -/
@[to_additive "On non-dependent functions, `pi.single` can be expressed as an `ite`"]
lemma mul_single_apply {β : Sort*} [has_one β] (i : I) (x : β) (i' : I) :
  mul_single i x i' = if i' = i then x else 1 :=
function.update_apply 1 i x i'

/-- On non-dependent functions, `pi.mul_single` is symmetric in the two indices. -/
@[to_additive "On non-dependent functions, `pi.single` is symmetric in the two
indices."]
lemma mul_single_comm {β : Sort*} [has_one β] (i : I) (x : β) (i' : I) :
  mul_single i x i' = mul_single i' x i :=
by simp [mul_single_apply, eq_comm]

@[to_additive]
lemma apply_mul_single (f' : Π i, f i → g i) (hf' : ∀ i, f' i 1 = 1) (i : I) (x : f i) (j : I):
  f' j (mul_single i x j) = mul_single i (f' i x) j :=
by simpa only [pi.one_apply, hf', mul_single] using function.apply_update f' 1 i x j

@[to_additive apply_single₂]
lemma apply_mul_single₂ (f' : Π i, f i → g i → h i) (hf' : ∀ i, f' i 1 1 = 1)
  (i : I) (x : f i) (y : g i) (j : I):
  f' j (mul_single i x j) (mul_single i y j) = mul_single i (f' i x y) j :=
begin
  by_cases h : j = i,
  { subst h, simp only [mul_single_eq_same] },
  { simp only [mul_single_eq_of_ne h, hf'] },
end

@[to_additive]

@[to_additive]
lemma mul_single_op₂ {g₁ g₂ : I → Type*} [Π i, has_one (g₁ i)] [Π i, has_one (g₂ i)]
  (op : Π i, g₁ i → g₂ i → f i) (h : ∀ i, op i 1 1 = 1) (i : I) (x₁ : g₁ i) (x₂ : g₂ i) :
  mul_single i (op i x₁ x₂) = λ j, op j (mul_single i x₁ j) (mul_single i x₂ j) :=
eq.symm $ funext $ apply_mul_single₂ op h i x₁ x₂

variables (f)

@[to_additive]
lemma mul_single_injective (i : I) : function.injective (mul_single i : f i → Π i, f i) :=
function.update_injective _ i

@[simp, to_additive]
lemma mul_single_inj (i : I) {x y : f i} : mul_single i x = mul_single i y ↔ x = y :=
(pi.mul_single_injective _ _).eq_iff

end

/-- The mapping into a product type built from maps into each component. -/
@[simp] protected def prod (f' : Π i, f i) (g' : Π i, g i) (i : I) : f i × g i := (f' i, g' i)

@[simp] lemma prod_fst_snd : pi.prod (prod.fst : α × β → α) (prod.snd : α × β → β) = id :=
funext $ λ _, prod.mk.eta

@[simp] lemma prod_snd_fst : pi.prod (prod.snd : α × β → β) (prod.fst : α × β → α) = prod.swap :=
rfl

end pi

namespace function

section extend
@[to_additive]
lemma extend_one [has_one γ] (f : α → β) :
  function.extend f (1 : α → γ) (1 : β → γ) = 1 :=
funext $ λ _, by apply if_t_t _ _

@[to_additive]
lemma extend_mul [has_mul γ] (f : α → β) (g₁ g₂ : α → γ) (e₁ e₂ : β → γ) :
  function.extend f (g₁ * g₂) (e₁ * e₂) = function.extend f g₁ e₁ * function.extend f g₂ e₂ :=
funext $ λ _, by convert (apply_dite2 (*) _ _ _ _ _).symm

@[to_additive]
lemma extend_inv [has_inv γ] (f : α → β) (g : α → γ) (e : β → γ) :
  function.extend f (g⁻¹) (e⁻¹) = (function.extend f g e)⁻¹ :=
funext $ λ _, by convert (apply_dite has_inv.inv _ _ _).symm

@[to_additive]
lemma extend_div [has_div γ] (f : α → β) (g₁ g₂ : α → γ) (e₁ e₂ : β → γ) :
  function.extend f (g₁ / g₂) (e₁ / e₂) = function.extend f g₁ e₁ / function.extend f g₂ e₂ :=
funext $ λ _, by convert (apply_dite2 (/) _ _ _ _ _).symm

end extend

lemma surjective_pi_map {F : Π i, f i → g i} (hF : ∀ i, surjective (F i)) :
  surjective (λ x : Π i, f i, λ i, F i (x i)) :=
λ y, ⟨λ i, (hF i (y i)).some, funext $ λ i, (hF i (y i)).some_spec⟩

lemma injective_pi_map {F : Π i, f i → g i} (hF : ∀ i, injective (F i)) :
  injective (λ x : Π i, f i, λ i, F i (x i)) :=
λ x y h, funext $ λ i, hF i $ (congr_fun h i : _)

lemma bijective_pi_map {F : Π i, f i → g i} (hF : ∀ i, bijective (F i)) :
  bijective (λ x : Π i, f i, λ i, F i (x i)) :=
⟨injective_pi_map (λ i, (hF i).injective), surjective_pi_map (λ i, (hF i).surjective)⟩

end function

/-- If the one function is surjective, the codomain is trivial. -/
@[to_additive "If the zero function is surjective, the codomain is trivial."]
def unique_of_surjective_one (α : Type*) {β : Type*} [has_one β]
  (h : function.surjective (1 : α → β)) : unique β :=
h.unique_of_surjective_const α (1 : β)

@[to_additive subsingleton.pi_single_eq]
lemma subsingleton.pi_mul_single_eq {α : Type*} [decidable_eq I] [subsingleton I] [has_one α]
  (i : I) (x : α) :
  pi.mul_single i x = λ _, x :=
funext $ λ j, by rw [subsingleton.elim j i, pi.mul_single_eq_same]