/-
Copyright (c) 2020 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Yury Kudryashov
-/
import data.set.finite
import data.nat.modeq
import algebra.big_operators.order

/-!
# Pigeonhole principles

Given pigeons (possibly infinitely many) in pigeonholes, the
pigeonhole principle states that, if there are more pigeons than
pigeonholes, then there is a pigeonhole with two or more pigeons.

There are a few variations on this statement, and the conclusion can
be made stronger depending on how many pigeons you know you might
have.

The basic statements of the pigeonhole principle appear in the
following locations:

* `data.finset.basic` has `finset.exists_ne_map_eq_of_card_lt_of_maps_to`
* `data.fintype.basic` has `fintype.exists_ne_map_eq_of_card_lt`
* `data.fintype.basic` has `fintype.exists_ne_map_eq_of_infinite`
* `data.fintype.basic` has `fintype.exists_infinite_fiber`
* `data.set.finite` has `set.infinite.exists_ne_map_eq_of_maps_to`

This module gives access to these pigeonhole principles along with 20 more.
The versions vary by:

* using a function between `fintype`s or a function between possibly infinite types restricted to
  `finset`s;
* counting pigeons by a general weight function (`∑ x in s, w x`) or by heads (`finset.card s`);
* using strict or non-strict inequalities;
* establishing upper or lower estimate on the number (or the total weight) of the pigeons in one
  pigeonhole;
* in case when we count pigeons by some weight function `w` and consider a function `f` between
  `finset`s `s` and `t`, we can either assume that each pigeon is in one of the pigeonholes
  (`∀ x ∈ s, f x ∈ t`), or assume that for `y ∉ t`, the total weight of the pigeons in this
  pigeonhole `∑ x in s.filter (λ x, f x = y), w x` is nonpositive or nonnegative depending on
  the inequality we are proving.

Lemma names follow `mathlib` convention (e.g.,
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`); "pigeonhole principle" is mentioned in the
docstrings instead of the names.

## See also

* `ordinal.infinite_pigeonhole`: pigeonhole principle for cardinals, formulated using cofinality;

* `measure_theory.exists_nonempty_inter_of_measure_univ_lt_tsum_measure`,
  `measure_theory.exists_nonempty_inter_of_measure_univ_lt_sum_measure`: pigeonhole principle in a
  measure space.

## Tags

pigeonhole principle
-/

universes u v w
variables {α : Type u} {β : Type v} {M : Type w} [linear_ordered_cancel_add_comm_monoid M]
  [decidable_eq β]

open_locale big_operators

namespace finset

variables {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} {n : ℕ}

/-!
### The pigeonhole principles on `finset`s, pigeons counted by weight

In this section we prove the following version of the pigeonhole principle: if the total weight of a
finite set of pigeons is greater than `n • b`, and they are sorted into `n` pigeonholes, then for
some pigeonhole, the total weight of the pigeons in this pigeonhole is greateer than `b`, and a few
variations of this theorem.

The principle is formalized in the following way, see
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`: if `f : α → β` is a function which maps all
elements of `s : finset α` to `t : finset β` and `card t • b < ∑ x in s, w x`, where `w : α → M` is
a weight function taking values in a `linear_ordered_cancel_add_comm_monoid`, then for
some `y ∈ t`, the sum of the weights of all `x ∈ s` such that `f x = y` is greater than `b`.

There are a few bits we can change in this theorem:

* reverse all inequalities, with obvious adjustments to the name;
* replace the assumption `∀ a ∈ s, f a ∈ t` with
  `∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0`,
  and replace `of_maps_to` with `of_sum_fiber_nonpos` in the name;
* use non-strict inequalities assuming `t` is nonempty.

We can do all these variations independently, so we have eight versions of the theorem.
-/

/-!
#### Strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, and they are sorted into
`n` pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is
greater than `b`. -/
lemma exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (hf : ∀ a ∈ s, f a ∈ t)
  (hb : t.card • b < ∑ x in s, w x) :
  ∃ y ∈ t, b < ∑ x in s.filter (λ x, f x = y), w x :=
exists_lt_of_sum_lt $ by simpa only [sum_fiberwise_of_maps_to hf, sum_const]

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, and they are sorted into `n`
pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is less
than `b`. -/
lemma exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul (hf : ∀ a ∈ s, f a ∈ t)
  (hb : (∑ x in s, w x) < t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum α β (order_dual M) _ _ _ _ _ _ _ hf hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonpositive,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is greater than `b`. -/
lemma exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum
  (ht : ∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0) (hb : t.card • b < ∑ x in s, w x) :
  ∃ y ∈ t, b < ∑ x in s.filter (λ x, f x = y), w x :=
exists_lt_of_sum_lt $
calc (∑ y in t, b) < ∑ x in s, w x : by simpa
... ≤ ∑ y in t, ∑ x in s.filter (λ x, f x = y), w x :
  sum_le_sum_fiberwise_of_sum_fiber_nonpos ht

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonnegative,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is less than `b`. -/
lemma exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul
  (ht : ∀ y ∉ t, (0:M) ≤ ∑ x in s.filter (λ x, f x = y), w x) (hb : (∑ x in s, w x) < t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum α β (order_dual M) _ _ _ _ _ _ _ ht hb

/-!
#### Non-strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, and
they are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons
in this pigeonhole is greater than or equal to `b`. -/
lemma exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hb : t.card • b ≤ ∑ x in s, w x) :
  ∃ y ∈ t, b ≤ ∑ x in s.filter (λ x, f x = y), w x :=
exists_le_of_sum_le ht $ by simpa only [sum_fiberwise_of_maps_to hf, sum_const]

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, and they
are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons in
this pigeonhole is less than or equal to `b`. -/
lemma exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hb : (∑ x in s, w x) ≤ t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum α β (order_dual M) _ _ _ _ _ _ _ hf ht hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, they
are sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the
pigeons there is nonpositive, then for at least one of these `n` pigeonholes, the total weight of
the pigeons in this pigeonhole is greater than or equal to `b`. -/
lemma exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum
  (hf : ∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0) (ht : t.nonempty)
  (hb : t.card • b ≤ ∑ x in s, w x) :
  ∃ y ∈ t, b ≤ ∑ x in s.filter (λ x, f x = y), w x :=
exists_le_of_sum_le ht $
calc (∑ y in t, b) ≤ ∑ x in s, w x : by simpa
... ≤ ∑ y in t, ∑ x in s.filter (λ x, f x = y), w x :
  sum_le_sum_fiberwise_of_sum_fiber_nonpos hf

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, they are
sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the pigeons
there is nonnegative, then for at least one of these `n` pigeonholes, the total weight of the
pigeons in this pigeonhole is less than or equal to `b`. -/
lemma exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul
  (hf : ∀ y ∉ t, (0:M) ≤ ∑ x in s.filter (λ x, f x = y), w x) (ht : t.nonempty)
  (hb : (∑ x in s, w x) ≤ t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum α β (order_dual M) _ _ _ _ _ _ _ hf ht hb

/-!
### The pigeonhole principles on `finset`s, pigeons counted by heads

In this section we formalize a few versions of the following pigeonhole principle: there is a
pigeonhole with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes.

First, we can use strict or non-strict inequalities. While the versions with non-strict inequalities
are weaker than those with strict inequalities, sometimes it might be more convenient to apply the
weaker version. Second, we can either state that there exists a pigeonhole with at least `n`
pigeons, or state that there exists a pigeonhole with at most `n` pigeons. In the latter case we do
not need the assumption `∀ a ∈ s, f a ∈ t`.

So, we prove four theorems: `finset.exists_lt_card_fiber_of_maps_to_of_mul_lt_card`,
`finset.exists_le_card_fiber_of_maps_to_of_mul_le_card`,
`finset.exists_card_fiber_lt_of_card_lt_mul`, and `finset.exists_card_fiber_le_of_card_le_mul`. -/

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function between finite sets `s` and `t` and a natural number `n` such that
`card t * n < card s`, there exists `y ∈ t` such that its preimage in `s` has more than `n`
elements. -/
lemma exists_lt_card_fiber_of_mul_lt_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t)
  (hn : t.card * n < s.card) :
  ∃ y ∈ t, n < (s.filter (λ x, f x = y)).card :=
begin
  simp only [card_eq_sum_ones],
  apply exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum hf,
  simpa
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.  ("The
minimum is at most the mean" specialized to integers.)

More formally, given a function `f`, a finite sets `s` in its domain, a finite set `t` in its
codomain, and a natural number `n` such that `card s < card t * n`, there exists `y ∈ t` such that
its preimage in `s` has less than `n` elements. -/
lemma exists_card_fiber_lt_of_card_lt_mul (hn : s.card < t.card * n) :
  ∃ y ∈ t, (s.filter (λ x, f x = y)).card < n:=
begin
  simp only [card_eq_sum_ones],
  apply exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul (λ _ _, nat.zero_le _),
  simpa
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a natural number `n` such that `card t * n ≤ card s`, there exists `y ∈
t` such that its preimage in `s` has at least `n` elements. See also
`finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to` for a stronger statement. -/
lemma exists_le_card_fiber_of_mul_le_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hn : t.card * n ≤ s.card) :
  ∃ y ∈ t, n ≤ (s.filter (λ x, f x = y)).card :=
begin
  simp only [card_eq_sum_ones],
  apply exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum hf ht,
  simpa
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` in its domain, a finite set `t` in its codomain, and a natural number `n` such that
`card s ≤ card t * n`, there exists `y ∈ t` such that its preimage in `s` has no more than `n`
elements. See also `finset.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_mul (ht : t.nonempty) (hn : s.card ≤ t.card * n) :
  ∃ y ∈ t, (s.filter (λ x, f x = y)).card ≤ n:=
begin
  simp only [card_eq_sum_ones],
  apply exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul (λ _ _, nat.zero_le _) ht,
  simpa
end

end finset

namespace fintype
open finset

variables [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} {n : ℕ}

/-!
### The pigeonhole principles on `fintypes`s, pigeons counted by weight

In this section we specialize theorems from the previous section to the special case of functions
between `fintype`s and `s = univ`, `t = univ`. In this case the assumption `∀ x ∈ s, f x ∈ t` always
holds, so we have four theorems instead of eight. -/

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than `b` provided that
the total number of pigeonholes times `b` is less than the total weight of all pigeons. -/
lemma exists_lt_sum_fiber_of_nsmul_lt_sum (hb : card β • b < ∑ x, w x) :
  ∃ y, b < ∑ x in univ.filter (λ x, f x = y), w x :=
let ⟨y, _, hy⟩ := exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (λ _ _, mem_univ _) hb in ⟨y, hy⟩

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than or equal to `b`
provided that the total number of pigeonholes times `b` is less than or equal to the total weight of
all pigeons. -/
lemma exists_le_sum_fiber_of_nsmul_le_sum [nonempty β] (hb : card β • b ≤ ∑ x, w x) :
  ∃ y, b ≤ ∑ x in univ.filter (λ x, f x = y), w x :=
let ⟨y, _, hy⟩ :=
  exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (λ _ _, mem_univ _) univ_nonempty hb
in ⟨y, hy⟩

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than `b` provided that
the total number of pigeonholes times `b` is greater than the total weight of all pigeons. -/
lemma exists_sum_fiber_lt_of_sum_lt_nsmul (hb : (∑ x, w x) < card β • b) :
  ∃ y, (∑ x in univ.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_nsmul_lt_sum α β (order_dual M) _ _ _ _ _ w b hb

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than or equal to `b`
provided that the total number of pigeonholes times `b` is greater than or equal to the total weight
of all pigeons. -/
lemma exists_sum_fiber_le_of_sum_le_nsmul [nonempty β] (hb : (∑ x, w x) ≤ card β • b) :
  ∃ y, (∑ x in univ.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_nsmul_le_sum α β (order_dual M) _ _ _ _ _ w b _ hb

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at least as many pigeons as
the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card β * n < card α`, there exists an element `y : β` such that its preimage has more than `n`
elements. -/
lemma exists_lt_card_fiber_of_mul_lt_card (hn : card β * n < card α) :
  ∃ y : β, n < (univ.filter (λ x, f x = y)).card :=
let ⟨y, _, h⟩ := exists_lt_card_fiber_of_mul_lt_card_of_maps_to (λ _ _, mem_univ _) hn in ⟨y, h⟩

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at most as many pigeons as
the floor of the average number of pigeons across all pigeonholes.
("The minimum is at most the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card α < card β * n`, there exists an element `y : β` such that its preimage has less than `n`
elements. -/
lemma exists_card_fiber_lt_of_card_lt_mul (hn : card α < card β * n) :
  ∃ y : β, (univ.filter (λ x, f x = y)).card < n :=
let ⟨y, _, h⟩ := exists_card_fiber_lt_of_card_lt_mul hn in ⟨y, h⟩

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card β * n ≤ card α`, there exists an
element `y : β` such that its preimage has at least `n` elements. See also
`fintype.exists_lt_card_fiber_of_mul_lt_card` for a stronger statement. -/
lemma exists_le_card_fiber_of_mul_le_card [nonempty β] (hn : card β * n ≤ card α) :
  ∃ y : β, n ≤ (univ.filter (λ x, f x = y)).card :=
let ⟨y, _, h⟩ := exists_le_card_fiber_of_mul_le_card_of_maps_to (λ _ _, mem_univ _) univ_nonempty hn
in ⟨y, h⟩

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card α ≤ card β * n`, there exists an
element `y : β` such that its preimage has at most `n` elements. See also
`fintype.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_mul [nonempty β] (hn : card α ≤ card β * n) :
  ∃ y : β, (univ.filter (λ x, f x = y)).card ≤ n :=
let ⟨y, _, h⟩ := exists_card_fiber_le_of_card_le_mul univ_nonempty hn in ⟨y, h⟩

end fintype

namespace nat

open set

/-- If `s` is an infinite set of natural numbers and `k > 0`, then `s` contains two elements `m < n`
that are equal mod `k`. -/
theorem exists_lt_modeq_of_infinite {s : set ℕ} (hs : s.infinite) {k : ℕ} (hk : 0 < k) :
  ∃ (m ∈ s) (n ∈ s), m < n ∧ m ≡ n [MOD k] :=
hs.exists_lt_map_eq_of_maps_to (λ n _, show n % k ∈ Iio k, from nat.mod_lt n hk) $
  finite_lt_nat k

end nat


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.monoid_algebra.basic
import data.finsupp.order

/-!
# Division of `add_monoid_algebra` by monomials

This file is most important for when `G = ℕ` (polynomials) or `G = σ →₀ ℕ` (multivariate
polynomials).

In order to apply in maximal generality (such as for `laurent_polynomial`s), this uses
`∃ d, g' = g + d` in many places instead of `g ≤ g'`.

## Main definitions

* `add_monoid_algebra.div_of x g`: divides `x` by the monomial `add_monoid_algebra.of k G g`
* `add_monoid_algebra.mod_of x g`: the remainder upon dividing `x` by the monomial
  `add_monoid_algebra.of k G g`.

## Main results

* `add_monoid_algebra.div_of_add_mod_of`, `add_monoid_algebra.mod_of_add_div_of`: `div_of` and
  `mod_of` are well-behaved as quotient and remainder operators.

## Implementation notes

`∃ d, g' = g + d` is used as opposed to some other permutation up to commutativity in order to match
the definition of `semigroup_has_dvd`. The results in this file could be duplicated for
`monoid_algebra` by using `g ∣ g'`, but this can't be done automatically, and in any case is not
likely to be very useful.

-/

variables {k G : Type*} [semiring k]

namespace add_monoid_algebra

section
variables [add_cancel_comm_monoid G]

/-- Divide by `of' k G g`, discarding terms not divisible by this. -/
noncomputable def div_of (x : add_monoid_algebra k G) (g : G) : add_monoid_algebra k G :=
-- note: comapping by `+ g` has the effect of subtracting `g` from every element in the support, and
-- discarding the elements of the support from which `g` can't be subtracted. If `G` is an additive
-- group, such as `ℤ` when used for `laurent_polynomial`, then no discarding occurs.
@finsupp.comap_domain.add_monoid_hom _ _ _ _ ((+) g)
  (add_right_injective g) x

local infix ` /ᵒᶠ `:70 := div_of

@[simp] lemma div_of_apply (g : G) (x : add_monoid_algebra k G) (g' : G) :
  (x /ᵒᶠ g) g' = x (g + g') := rfl

@[simp] lemma support_div_of (g : G) (x : add_monoid_algebra k G)  :
  (x /ᵒᶠ g).support = x.support.preimage ((+) g)
    (function.injective.inj_on
      (add_right_injective g) _) := rfl

@[simp]

@[simp] lemma div_of_zero (x : add_monoid_algebra k G) : x /ᵒᶠ 0 = x :=
by { ext, simp only [add_monoid_algebra.div_of_apply, zero_add] }

lemma add_div_of (x y : add_monoid_algebra k G) (g : G) : (x + y) /ᵒᶠ g = x /ᵒᶠ g + y /ᵒᶠ g :=
map_add _ _ _

lemma div_of_add (x : add_monoid_algebra k G) (a b : G) :
  x /ᵒᶠ (a + b) = (x /ᵒᶠ a) /ᵒᶠ b :=
by { ext, simp only [add_monoid_algebra.div_of_apply, add_assoc] }

/-- A bundled version of `add_monoid_algebra.div_of`. -/
@[simps]
noncomputable def div_of_hom : multiplicative G →* add_monoid.End (add_monoid_algebra k G) :=
{ to_fun := λ g,
  { to_fun := λ x, div_of x g.to_add,
    map_zero' := zero_div_of _,
    map_add' := λ x y, add_div_of x y g.to_add },
  map_one' := add_monoid_hom.ext div_of_zero,
  map_mul' := λ g₁ g₂, add_monoid_hom.ext $ λ x,
    (congr_arg _ (add_comm g₁.to_add g₂.to_add)).trans  (div_of_add _ _ _) }

lemma of'_mul_div_of (a : G) (x : add_monoid_algebra k G) :
  (of' k G a * x) /ᵒᶠ a = x :=
begin
  ext b,
  rw [add_monoid_algebra.div_of_apply, of'_apply, single_mul_apply_aux, one_mul],
  intro c,
  exact add_right_inj _,
end

lemma mul_of'_div_of (x : add_monoid_algebra k G) (a : G) :
  (x * of' k G a) /ᵒᶠ a = x :=
begin
  ext b,
  rw [add_monoid_algebra.div_of_apply, of'_apply, mul_single_apply_aux, mul_one],
  intro c,
  rw add_comm,
  exact add_right_inj _,
end

lemma of'_div_of (a : G) : (of' k G a) /ᵒᶠ a = 1 :=
by simpa only [one_mul] using mul_of'_div_of (1 : add_monoid_algebra k G) a

/-- The remainder upon division by `of' k G g`. -/
noncomputable def mod_of (x : add_monoid_algebra k G) (g : G) : add_monoid_algebra k G :=
x.filter (λ g₁, ¬∃ g₂, g₁ = g + g₂)

local infix ` %ᵒᶠ `:70 := mod_of

@[simp] lemma mod_of_apply_of_not_exists_add (x : add_monoid_algebra k G) (g : G) (g' : G)
  (h : ¬∃ d, g' = g + d) :
  (x %ᵒᶠ g) g' = x g' :=
finsupp.filter_apply_pos _ _ h

@[simp] lemma mod_of_apply_of_exists_add (x : add_monoid_algebra k G) (g : G) (g' : G)
  (h : ∃ d, g' = g + d) :
  (x %ᵒᶠ g) g' = 0 :=
finsupp.filter_apply_neg _ _ $ by rwa [not_not]

@[simp] lemma mod_of_apply_add_self (x : add_monoid_algebra k G) (g : G) (d : G) :
  (x %ᵒᶠ g) (d + g) = 0 :=
mod_of_apply_of_exists_add _ _ _ ⟨_, add_comm _ _⟩

@[simp] lemma mod_of_apply_self_add (x : add_monoid_algebra k G) (g : G) (d : G) :
  (x %ᵒᶠ g) (g + d) = 0 :=
mod_of_apply_of_exists_add _ _ _ ⟨_, rfl⟩

lemma of'_mul_mod_of (g : G) (x : add_monoid_algebra k G) :
  (of' k G g * x) %ᵒᶠ g = 0 :=
begin
  ext g',
  rw finsupp.zero_apply,
  obtain ⟨d, rfl⟩ | h := em (∃ d, g' = g + d),
  { rw mod_of_apply_self_add },
  { rw [mod_of_apply_of_not_exists_add _ _ _ h, of'_apply,
      single_mul_apply_of_not_exists_add _ _ h] },
end

lemma mul_of'_mod_of (x : add_monoid_algebra k G) (g : G) :
  (x * of' k G g) %ᵒᶠ g = 0 :=
begin
  ext g',
  rw finsupp.zero_apply,
  obtain ⟨d, rfl⟩ | h := em (∃ d, g' = g + d),
  { rw mod_of_apply_self_add },
  { rw [mod_of_apply_of_not_exists_add _ _ _ h, of'_apply, mul_single_apply_of_not_exists_add],
    simpa only [add_comm] using h },
end

lemma of'_mod_of (g : G) : of' k G g %ᵒᶠ g = 0 :=
by simpa only [one_mul] using mul_of'_mod_of (1 : add_monoid_algebra k G) g

lemma div_of_add_mod_of (x : add_monoid_algebra k G) (g : G) :
  of' k G g * (x /ᵒᶠ g) + x %ᵒᶠ g = x :=
begin
  ext g',
  simp_rw [finsupp.add_apply],
  obtain ⟨d, rfl⟩ | h := em (∃ d, g' = g + d),
  swap,
  { rw [mod_of_apply_of_not_exists_add _ _ _ h, of'_apply, single_mul_apply_of_not_exists_add _ _ h,
      zero_add] },
  { rw [mod_of_apply_self_add, add_zero],
    rw [of'_apply, single_mul_apply_aux _ _ _, one_mul, div_of_apply],
    intro a,
    exact add_right_inj _ }
end

lemma mod_of_add_div_of (x : add_monoid_algebra k G) (g : G) :
  x %ᵒᶠ g + of' k G g * (x /ᵒᶠ g) = x :=
by rw [add_comm, div_of_add_mod_of]

lemma of'_dvd_iff_mod_of_eq_zero {x : add_monoid_algebra k G} {g : G} :
  of' k G g ∣ x ↔ x %ᵒᶠ g = 0 :=
begin
  split,
  { rintro ⟨x, rfl⟩,
    rw of'_mul_mod_of },
  { intro h,
    rw [←div_of_add_mod_of x g, h, add_zero],
    exact dvd_mul_right _ _ },
end

end

end add_monoid_algebra


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad, Haitao Zhang
-/
-- a port of core Lean `init/function.lean`

/-!
# General operations on functions
-/

namespace Function

variable {α : Sort u₁} {β : Sort u₂} {φ : Sort u₃} {δ : Sort u₄} {ζ : Sort u₁}

@[reducible] def comp_right (f : β → β → β) (g : α → β) : β → α → β :=
λ b a => f b (g a)

@[reducible] def comp_left (f : β → β → β) (g : α → β) : α → β → β :=
λ a b => f (g a) b

/-- Given functions `f : β → β → φ` and `g : α → β`, produce a function `α → α → φ` that evaluates
`g` on each argument, then applies `f` to the results. Can be used, e.g., to transfer a relation
from `β` to `α`. -/
@[reducible] def on_fun (f : β → β → φ) (g : α → β) : α → α → φ :=
λ x y => f (g x) (g y)

@[reducible] def combine (f : α → β → φ) (op : φ → δ → ζ) (g : α → β → δ)
  : α → β → ζ :=
λ x y => op (f x y) (g x y)

@[reducible] def swap {φ : α → β → Sort u₃} (f : ∀ x y, φ x y) : ∀ y x, φ x y :=
λ y x => f x y

@[reducible] def app {β : α → Sort u₂} (f : ∀ x, β x) (x : α) : β x :=
f x

theorem right_id (f : α → β) : f ∘ id = f := rfl

theorem comp.assoc (f : φ → δ) (g : β → φ) (h : α → β) : (f ∘ g) ∘ h = f ∘ (g ∘ h) := rfl

@[simp] theorem comp.left_id (f : α → β) : id ∘ f = f := rfl

@[simp] theorem comp.right_id (f : α → β) : f ∘ id = f := rfl

theorem comp_const_right (f : β → φ) (b : β) : f ∘ (const α b) = const α (f b) := rfl

/-- A function `f : α → β` is called injective if `f x = f y` implies `x = y`. -/
@[reducible] def injective (f : α → β) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂

theorem injective.comp {g : β → φ} {f : α → β} (hg : injective g) (hf : injective f) :
  injective (g ∘ f) :=
fun _ _ h => hf (hg h)

/-- A function `f : α → β` is calles surjective if every `b : β` is equal to `f a`
for some `a : α`. -/
@[reducible] def surjective (f : α → β) : Prop := ∀ b, ∃ a, f a = b

theorem surjective.comp {g : β → φ} {f : α → β} (hg : surjective g) (hf : surjective f) :
  surjective (g ∘ f) :=
λ (c : φ) => Exists.elim (hg c) (λ b hb => Exists.elim (hf b) (λ a ha =>
  Exists.intro a (show g (f a) = c from (Eq.trans (congrArg g ha) hb))))

/-- A function is called bijective if it is both injective and surjective. -/
def bijective (f : α → β) := injective f ∧ surjective f

theorem bijective.comp {g : β → φ} {f : α → β} : bijective g → bijective f → bijective (g ∘ f)
| ⟨h_ginj, h_gsurj⟩, ⟨h_finj, h_fsurj⟩ => ⟨h_ginj.comp h_finj, h_gsurj.comp h_fsurj⟩

/-- `LeftInverse g f` means that g is a left inverse to f. That is, `g ∘ f = id`. -/
def LeftInverse (g : β → α) (f : α → β) : Prop := ∀ x, g (f x) = x

/-- `has_LeftInverse f` means that `f` has an unspecified left inverse. -/
def has_LeftInverse (f : α → β) : Prop := ∃ finv : β → α, LeftInverse finv f

/-- `RightInverse g f` means that g is a right inverse to f. That is, `f ∘ g = id`. -/
def RightInverse (g : β → α) (f : α → β) : Prop := LeftInverse f g

/-- `has_RightInverse f` means that `f` has an unspecified right inverse. -/
def has_RightInverse (f : α → β) : Prop := ∃ finv : β → α, RightInverse finv f

theorem LeftInverse.injective {g : β → α} {f : α → β} : LeftInverse g f → injective f :=
λ h a b hf => h a ▸ h b ▸ hf ▸ rfl

theorem has_LeftInverse.injective {f : α → β} : has_LeftInverse f → injective f :=
λ h => Exists.elim h (λ finv inv => inv.injective)

theorem RightInverse_of_injective_of_LeftInverse {f : α → β} {g : β → α}
    (injf : injective f) (lfg : LeftInverse f g) :
  RightInverse f g :=
λ x => injf $ lfg $ f x

theorem RightInverse.surjective {f : α → β} {g : β → α} (h : RightInverse g f) : surjective f :=
λ y => ⟨g y, h y⟩

theorem has_RightInverse.surjective {f : α → β} : has_RightInverse f → surjective f
| ⟨finv, inv⟩ => inv.surjective

theorem LeftInverse_of_surjective_of_RightInverse {f : α → β} {g : β → α} (surjf : surjective f)
  (rfg : RightInverse f g) : LeftInverse f g :=
λ y =>
  let ⟨x, hx⟩ := surjf y
  by rw [← hx, rfg]

theorem injective_id : injective (@id α) := fun _ _ => id

theorem surjective_id : surjective (@id α) := λ a => ⟨a, rfl⟩

theorem bijective_id : bijective (@id α) := ⟨injective_id, surjective_id⟩

end Function

namespace Function

variable {α : Type u₁} {β : Type u₂} {φ : Type u₃}

/-- Interpret a function on `α × β` as a function with two arguments. -/
@[inline] def curry : (α × β → φ) → α → β → φ :=
λ f a b => f (a, b)

/-- Interpret a function with two arguments as a function on `α × β` -/
@[inline] def uncurry : (α → β → φ) → α × β → φ :=
λ f a => f a.1 a.2

@[simp] theorem curry_uncurry (f : α → β → φ) : curry (uncurry f) = f :=
rfl

@[simp] theorem uncurry_curry (f : α × β → φ) : uncurry (curry f) = f :=
funext (λ ⟨a, b⟩ => rfl)

protected theorem LeftInverse.id {g : β → α} {f : α → β} (h : LeftInverse g f) : g ∘ f = id :=
funext h

protected theorem RightInverse.id {g : β → α} {f : α → β} (h : RightInverse g f) : f ∘ g = id :=
funext h

end Function


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

/-!
# Theory of univariate polynomials

We show that `polynomial A` is an R-algebra when `A` is an R-algebra.
We promote `eval₂` to an algebra hom in `aeval`.
-/

noncomputable theory
open finset
open_locale big_operators

namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {A' B' : Type*} {a b : R} {n : ℕ}
variables [comm_semiring A'] [comm_semiring B']

section comm_semiring
variables [comm_semiring R] {p q r : polynomial R}

variables [semiring A] [algebra R A]

/-- Note that this instance also provides `algebra R (polynomial R)`. -/
instance algebra_of_algebra : algebra R (polynomial A) :=
{ smul_def' := λ r p, begin
    rcases p,
    simp only [C, monomial, monomial_fun, ring_hom.coe_mk, ring_hom.to_fun_eq_coe,
      function.comp_app, ring_hom.coe_comp, smul_to_finsupp, mul_to_finsupp],
    exact algebra.smul_def' _ _,
  end,
  commutes' := λ r p, begin
    rcases p,
    simp only [C, monomial, monomial_fun, ring_hom.coe_mk, ring_hom.to_fun_eq_coe,
      function.comp_app, ring_hom.coe_comp, mul_to_finsupp],
    convert algebra.commutes' r p,
  end,
  .. C.comp (algebra_map R A) }

lemma algebra_map_apply (r : R) :
  algebra_map R (polynomial A) r = C (algebra_map R A r) :=
rfl

/--
When we have `[comm_ring R]`, the function `C` is the same as `algebra_map R (polynomial R)`.

(But note that `C` is defined when `R` is not necessarily commutative, in which case
`algebra_map` is not available.)
-/
lemma C_eq_algebra_map (r : R) :
  C r = algebra_map R (polynomial R) r :=
rfl

variables {R}

/--
  Extensionality lemma for algebra maps out of `polynomial A'` over a smaller base ring than `A'`
-/
@[ext] lemma alg_hom_ext' [algebra R A'] [algebra R B']
  {f g : polynomial A' →ₐ[R] B'}
  (h₁ : f.comp (is_scalar_tower.to_alg_hom R A' (polynomial A')) =
        g.comp (is_scalar_tower.to_alg_hom R A' (polynomial A')))
  (h₂ : f X = g X) : f = g :=
alg_hom.coe_ring_hom_injective (polynomial.ring_hom_ext'
  (congr_arg alg_hom.to_ring_hom h₁) h₂)

variable (R)

/-- Algebra isomorphism between `polynomial R` and `add_monoid_algebra R ℕ`. This is just an
implementation detail, but it can be useful to transfer results from `finsupp` to polynomials. -/
@[simps]
def to_finsupp_iso_alg : polynomial R ≃ₐ[R] add_monoid_algebra R ℕ :=
{ commutes' := λ r,
  begin
    simp only [add_monoid_algebra.coe_algebra_map, algebra.id.map_eq_self, function.comp_app],
    rw [←C_eq_algebra_map, ←monomial_zero_left, ring_equiv.to_fun_eq_coe, to_finsupp_iso_monomial],
  end,
  ..to_finsupp_iso R }

variable {R}

instance [nontrivial A] : nontrivial (subalgebra R (polynomial A)) :=
⟨⟨⊥, ⊤, begin
  rw [ne.def, set_like.ext_iff, not_forall],
  refine ⟨X, _⟩,
  simp only [algebra.mem_bot, not_exists, set.mem_range, iff_true, algebra.mem_top,
    algebra_map_apply, not_forall],
  intro x,
  rw [ext_iff, not_forall],
  refine ⟨1, _⟩,
  simp [coeff_C],
end⟩⟩

@[simp]
lemma alg_hom_eval₂_algebra_map
  {R A B : Type*} [comm_ring R] [ring A] [ring B] [algebra R A] [algebra R B]
  (p : polynomial R) (f : A →ₐ[R] B) (a : A) :
  f (eval₂ (algebra_map R A) a p) = eval₂ (algebra_map R B) (f a) p :=
begin
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, ring_hom.eq_int_cast, ring_hom.map_int_cast,
    alg_hom.commutes],
end

@[simp]
lemma eval₂_algebra_map_X {R A : Type*} [comm_ring R] [ring A] [algebra R A]
  (p : polynomial R) (f : polynomial R →ₐ[R] A) :
  eval₂ (algebra_map R A) (f X) p = f p :=
begin
  conv_rhs { rw [←polynomial.sum_C_mul_X_eq p], },
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, ring_hom.eq_int_cast, ring_hom.map_int_cast],
  simp [polynomial.C_eq_algebra_map],
end

@[simp]
lemma ring_hom_eval₂_algebra_map_int {R S : Type*} [ring R] [ring S]
  (p : polynomial ℤ) (f : R →+* S) (r : R) :
  f (eval₂ (algebra_map ℤ R) r p) = eval₂ (algebra_map ℤ S) (f r) p :=
alg_hom_eval₂_algebra_map p f.to_int_alg_hom r

@[simp]
lemma eval₂_algebra_map_int_X {R : Type*} [ring R] (p : polynomial ℤ) (f : polynomial ℤ →+* R) :
  eval₂ (algebra_map ℤ R) (f X) p = f p :=
-- Unfortunately `f.to_int_alg_hom` doesn't work here, as typeclasses don't match up correctly.
eval₂_algebra_map_X p { commutes' := λ n, by simp, .. f }

end comm_semiring

section aeval
variables [comm_semiring R] {p q : polynomial R}

variables [semiring A] [algebra R A]
variables {B : Type*} [semiring B] [algebra R B]
variables (x : A)

/-- Given a valuation `x` of the variable in an `R`-algebra `A`, `aeval R A x` is
the unique `R`-algebra homomorphism from `R[X]` to `A` sending `X` to `x`.

This is a stronger variant of the linear map `polynomial.leval`. -/
def aeval : polynomial R →ₐ[R] A :=
{ commutes' := λ r, eval₂_C _ _,
  ..eval₂_ring_hom' (algebra_map R A) x (λ a, algebra.commutes _ _) }

variables {R A}

@[ext] lemma alg_hom_ext {f g : polynomial R →ₐ[R] A} (h : f X = g X) : f = g :=
begin
  ext p,
  rw [← sum_monomial_eq p],
  simp [sum, f.map_sum, g.map_sum, monomial_eq_smul_X, h],
end

theorem aeval_def (p : polynomial R) : aeval x p = eval₂ (algebra_map R A) x p := rfl

@[simp] lemma aeval_zero : aeval x (0 : polynomial R) = 0 :=
alg_hom.map_zero (aeval x)

@[simp] lemma aeval_X : aeval x (X : polynomial R) = x := eval₂_X _ x

@[simp] lemma aeval_C (r : R) : aeval x (C r) = algebra_map R A r := eval₂_C _ x

@[simp] lemma aeval_monomial {n : ℕ} {r : R} : aeval x (monomial n r) = (algebra_map _ _ r) * x^n :=
eval₂_monomial _ _

@[simp] lemma aeval_X_pow {n : ℕ} : aeval x ((X : polynomial R)^n) = x^n :=
eval₂_X_pow _ _

@[simp] lemma aeval_add : aeval x (p + q) = aeval x p + aeval x q :=
alg_hom.map_add _ _ _

@[simp] lemma aeval_one : aeval x (1 : polynomial R) = 1 :=
alg_hom.map_one _

@[simp] lemma aeval_bit0 : aeval x (bit0 p) = bit0 (aeval x p) :=
alg_hom.map_bit0 _ _

@[simp] lemma aeval_bit1 : aeval x (bit1 p) = bit1 (aeval x p) :=
alg_hom.map_bit1 _ _

@[simp] lemma aeval_nat_cast (n : ℕ) : aeval x (n : polynomial R) = n :=
alg_hom.map_nat_cast _ _

lemma aeval_mul : aeval x (p * q) = aeval x p * aeval x q :=
alg_hom.map_mul _ _ _

lemma aeval_comp {A : Type*} [comm_semiring A] [algebra R A] (x : A) :
  aeval x (p.comp q) = (aeval (aeval x q) p) :=
eval₂_comp (algebra_map R A)

@[simp] lemma aeval_map {A : Type*} [comm_semiring A] [algebra R A] [algebra A B]
  [is_scalar_tower R A B] (b : B) (p : polynomial R) :
  aeval b (p.map (algebra_map R A)) = aeval b p :=
by rw [aeval_def, eval₂_map, ←is_scalar_tower.algebra_map_eq, ←aeval_def]

theorem eval_unique (φ : polynomial R →ₐ[R] A) (p) :
  φ p = eval₂ (algebra_map R A) (φ X) p :=
begin
  apply polynomial.induction_on p,
  { intro r, rw eval₂_C, exact φ.commutes r },
  { intros f g ih1 ih2,
    rw [φ.map_add, ih1, ih2, eval₂_add] },
  { intros n r ih,
    rw [pow_succ', ← mul_assoc, φ.map_mul,
        eval₂_mul_noncomm (algebra_map R A) _ (λ k, algebra.commutes _ _), eval₂_X, ih] }
end

theorem aeval_alg_hom (f : A →ₐ[R] B) (x : A) : aeval (f x) = f.comp (aeval x) :=
alg_hom.ext $ λ p, by rw [eval_unique (f.comp (aeval x)), alg_hom.comp_apply, aeval_X, aeval_def]

theorem aeval_alg_equiv (f : A ≃ₐ[R] B) (x : A) : aeval (f x) = (f : A →ₐ[R] B).comp (aeval x) :=
aeval_alg_hom (f : A →ₐ[R] B) x

theorem aeval_alg_equiv_apply (f : A ≃ₐ[R] B) (x : A) (p : polynomial R) :
  aeval (f x) p = f (aeval x p) :=
aeval_alg_hom_apply (f : A →ₐ[R] B) x p

lemma aeval_algebra_map_apply (x : R) (p : polynomial R) :
  aeval (algebra_map R A x) p = algebra_map R A (p.eval x) :=
aeval_alg_hom_apply (algebra.of_id R A) x p

@[simp] lemma coe_aeval_eq_eval (r : R) :
  (aeval r : polynomial R → R) = eval r := rfl

@[simp] lemma aeval_fn_apply {X : Type*} (g : polynomial R) (f : X → R) (x : X) :
  ((aeval f) g) x = aeval (f x) g :=
(aeval_alg_hom_apply (pi.eval_alg_hom _ _ x) f g).symm

@[norm_cast] lemma aeval_subalgebra_coe
  (g : polynomial R) {A : Type*} [semiring A] [algebra R A] (s : subalgebra R A) (f : s) :
  (aeval f g : A) = aeval (f : A) g :=
(aeval_alg_hom_apply s.val f g).symm

lemma coeff_zero_eq_aeval_zero (p : polynomial R) : p.coeff 0 = aeval 0 p :=
by simp [coeff_zero_eq_eval_zero]

lemma coeff_zero_eq_aeval_zero' (p : polynomial R) :
  algebra_map R A (p.coeff 0) = aeval (0 : A) p :=
by simp [aeval_def]

section comm_semiring

variables [comm_semiring S] {f : R →+* S}

lemma aeval_eq_sum_range [algebra R S] {p : polynomial R} (x : S) :
  aeval x p = ∑ i in finset.range (p.nat_degree + 1), p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range (algebra_map R S) x }

lemma aeval_eq_sum_range' [algebra R S] {p : polynomial R} {n : ℕ} (hn : p.nat_degree < n) (x : S) :
aeval x p = ∑ i in finset.range n, p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range' (algebra_map R S) hn x }

lemma aeval_sum {ι : Type*} [algebra R S] (s : finset ι) (f : ι → polynomial R)
  (g : S) : aeval g (∑ i in s, f i) = ∑ i in s, aeval g (f i) :=
(polynomial.aeval g : polynomial R →ₐ[_] _).map_sum f s

@[to_additive]
lemma aeval_prod {ι : Type*} [algebra R S] (s : finset ι)
  (f : ι → polynomial R) (g : S) : aeval g (∏ i in s, f i) = ∏ i in s, aeval g (f i) :=
(polynomial.aeval g : polynomial R →ₐ[_] _).map_prod f s

lemma is_root_of_eval₂_map_eq_zero
  (hf : function.injective f) {r : R} : eval₂ f (f r) p = 0 → p.is_root r :=
begin
  intro h,
  apply hf,
  rw [←eval₂_hom, h, f.map_zero],
end

lemma is_root_of_aeval_algebra_map_eq_zero [algebra R S] {p : polynomial R}
  (inj : function.injective (algebra_map R S))
  {r : R} (hr : aeval (algebra_map R S r) p = 0) : p.is_root r :=
is_root_of_eval₂_map_eq_zero inj hr

section aeval_tower

variables [algebra S R] [algebra S A'] [algebra S B']

/-- Version of `aeval` for defining algebra homs out of `polynomial R` over a smaller base ring
  than `R`. -/
def aeval_tower (f : R →ₐ[S] A') (x : A') : polynomial R →ₐ[S] A' :=
{ commutes' := λ r, by simp [algebra_map_apply],
  ..eval₂_ring_hom ↑f x }

variables (g : R →ₐ[S] A') (y : A')

@[simp] lemma aeval_tower_X : aeval_tower g y X = y := eval₂_X _ _

@[simp] lemma aeval_tower_C (x : R) : aeval_tower g y (C x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_C : ((aeval_tower g y : polynomial R →+* A').comp C) = g :=
ring_hom.ext $ aeval_tower_C _ _

@[simp] lemma aeval_tower_algebra_map (x : R) :
  aeval_tower g y (algebra_map R (polynomial R) x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_algebra_map :
  (aeval_tower g y : polynomial R →+* A').comp (algebra_map R (polynomial R)) = g :=
aeval_tower_comp_C _ _

lemma aeval_tower_to_alg_hom (x : R) :
  aeval_tower g y (is_scalar_tower.to_alg_hom S R (polynomial R) x) = g x :=
aeval_tower_algebra_map _ _ _

@[simp] lemma aeval_tower_comp_to_alg_hom :
  (aeval_tower g y).comp (is_scalar_tower.to_alg_hom S R (polynomial R)) = g :=
alg_hom.coe_ring_hom_injective $ aeval_tower_comp_algebra_map _ _

@[simp] lemma aeval_tower_id : aeval_tower (alg_hom.id S S) = aeval :=
by { ext, simp only [eval_X, aeval_tower_X, coe_aeval_eq_eval], }

@[simp] lemma aeval_tower_of_id : aeval_tower (algebra.of_id S A') = aeval :=
by { ext, simp only [aeval_X, aeval_tower_X], }

end aeval_tower

end comm_semiring

section comm_ring

variables [comm_ring S] {f : R →+* S}

lemma dvd_term_of_dvd_eval_of_dvd_terms {z p : S} {f : polynomial S} (i : ℕ)
  (dvd_eval : p ∣ f.eval z) (dvd_terms : ∀ (j ≠ i), p ∣ f.coeff j * z ^ j) :
  p ∣ f.coeff i * z ^ i :=
begin
  by_cases hi : i ∈ f.support,
  { rw [eval, eval₂, sum] at dvd_eval,
    rw [←finset.insert_erase hi, finset.sum_insert (finset.not_mem_erase _ _)] at dvd_eval,
    refine (dvd_add_left _).mp dvd_eval,
    apply finset.dvd_sum,
    intros j hj,
    exact dvd_terms j (finset.ne_of_mem_erase hj) },
  { convert dvd_zero p,
    rw not_mem_support_iff at hi,
    simp [hi] }
end

lemma dvd_term_of_is_root_of_dvd_terms {r p : S} {f : polynomial S} (i : ℕ)
  (hr : f.is_root r) (h : ∀ (j ≠ i), p ∣ f.coeff j * r ^ j) : p ∣ f.coeff i * r ^ i :=
dvd_term_of_dvd_eval_of_dvd_terms i (eq.symm hr ▸ dvd_zero p) h

end comm_ring

end aeval

section ring
variables [ring R]

/--
The evaluation map is not generally multiplicative when the coefficient ring is noncommutative,
but nevertheless any polynomial of the form `p * (X - monomial 0 r)` is sent to zero
when evaluated at `r`.

This is the key step in our proof of the Cayley-Hamilton theorem.
-/
lemma eval_mul_X_sub_C {p : polynomial R} (r : R) :
  (p * (X - C r)).eval r = 0 :=
begin
  simp only [eval, eval₂, ring_hom.id_apply],
  have bound := calc
    (p * (X - C r)).nat_degree
         ≤ p.nat_degree + (X - C r).nat_degree : nat_degree_mul_le
     ... ≤ p.nat_degree + 1 : add_le_add_left nat_degree_X_sub_C_le _
     ... < p.nat_degree + 2 : lt_add_one _,
  rw sum_over_range' _ _ (p.nat_degree + 2) bound,
  swap,
  { simp, },
  rw sum_range_succ',
  conv_lhs
  { congr, apply_congr, skip,
    rw [coeff_mul_X_sub_C, sub_mul, mul_assoc, ←pow_succ], },
  simp [sum_range_sub', coeff_monomial],
end

theorem not_is_unit_X_sub_C [nontrivial R] (r : R) : ¬ is_unit (X - C r) :=
λ ⟨⟨_, g, hfg, hgf⟩, rfl⟩, @zero_ne_one R _ _ $ by erw [← eval_mul_X_sub_C, hgf, eval_one]

end ring

lemma aeval_endomorphism {M : Type*}
  [comm_ring R] [add_comm_group M] [module R M]
  (f : M →ₗ[R] M) (v : M) (p : polynomial R) :
  aeval f p v = p.sum (λ n b, b • (f ^ n) v) :=
begin
  rw [aeval_def, eval₂],
  exact (linear_map.applyₗ v).map_sum ,
end

end polynomial


import ..dual
import linear_algebra.finite_dimensional
import data.matrix.rank
import data.matrix.basic
import data.zmod.basic
import ..constructions.basic
import .field_stuff

noncomputable theory
open_locale classical
open_locale matrix

universes u v w z

open set
open finite_dimensional
open submodule
variables {E ρ R : Type*} [fintype E] [finite ρ] {𝔽 : Type*} [field 𝔽]

section submodule_stuff

variables {M : Type*} [semiring R] [add_comm_monoid M]

/- Linear map from vector in `𝔽^E` to a vector in `𝔽^X` given by forgetting all co-ordinates outside
`X`, where `(X : set E)` -/
def proj_to_set (𝔽 : Type*) [field 𝔽] (X : set E) := linear_map.fun_left 𝔽 𝔽 (coe : X → E)

@[simp] lemma proj_to_set_apply {X : set E} (v : E → 𝔽) (a : X):
  (proj_to_set 𝔽 X v) a = v (coe a) :=
rfl

#check proj_to_set

lemma proj_to_set_range_eq_top (𝔽 : Type*) [field 𝔽] (X : set E):
  (proj_to_set 𝔽 X).range = ⊤ :=
begin
  ext,
  simp only [submodule.mem_top, iff_true, linear_map.mem_range],
  use λ a, dite (a ∈ X) (λ h, x ⟨a,h⟩) (λ _, 0),
  ext a,
  simp,
end

/- Given a subspace of `𝔽^E`, projects it to a subspace of `𝔽^X` where `(X : set E)` by forgetting
all co-ordinates outside `X`-/
def submodule.proj_to_set (V : submodule 𝔽 (E → 𝔽)) (X : set E) : submodule 𝔽 (X → 𝔽)
  := submodule.map (proj_to_set 𝔽 X) V

def submodule.proj_to_singleton (V : submodule 𝔽 (E → 𝔽)) (a : E) : submodule 𝔽 (({a} : set E) → 𝔽)
  := V.proj_to_set {a}
-- want linear_map.apply

/-- An equivalence  -/
def proj_to_univ_equiv (V : submodule 𝔽 (E → 𝔽)) :
   V ≃ₗ[𝔽] V.proj_to_set univ :=
(linear_equiv.fun_congr_left 𝔽 𝔽 (equiv.subtype_univ_equiv mem_univ)).submodule_map V

/- A subspace `R` of `𝔽^E` represents a matroid `M` on `α` if, for every `(X : set α)`, the rank of
`X` in `M` agrees with the dimension of the projection of `R` to the co-ordinates in `X`. -/
def is_subspace_rep (V : submodule 𝔽 ( E → 𝔽 )) (M : matroid E) :=
  ∀ X : set E, finrank 𝔽 (V.proj_to_set X) = M.r X

/- A matroid is representable over `𝔽` if it has a (subspace) representation over `𝔽`. -/
def matroid.is_representable (M : matroid E) (𝔽 : Type*) [h𝔽 : field 𝔽] :=
  ∃ (V : submodule 𝔽 (E → 𝔽)), is_subspace_rep V M

/- The set of rows of a `ρ × E` matrix. -/
def matrix.row_set (P : matrix ρ E R) : set (E → R) :=
  set.range (λ i, (λ a, P i a))

def matrix.column_set (P : matrix ρ E R) : set (ρ → R) :=
  matrix.row_set Pᵀ

-- def matrix.row_set' (P : matroid ρ E R) : set ()

/- The row space of a `ρ × E` matrix over `𝔽`. -/
@[reducible] def matrix.row_space (P : matrix ρ E 𝔽) : submodule 𝔽 (E → 𝔽) :=
  submodule.span 𝔽 P.row_set

/- A matrix represents `M` if its row space is a subspace representation of `M` -/
def is_matrix_rep (P : matrix ρ E 𝔽) (M : matroid E) :=
  is_subspace_rep P.row_space M

/- A matroid is binary if it has a `GF(2)`-representation -/
def matroid.is_binary (M : matroid E) :=
  matroid.is_representable M (zmod 2)

lemma rank_of_rep {V : submodule 𝔽 (E → 𝔽)} {M : matroid E} (h : is_subspace_rep V M) :
  finrank 𝔽 V = M.rk :=
by rw [M.rk_def, ←h univ, (proj_to_univ_equiv V).finrank_eq]

lemma representable_iff_has_matrix_rep (M : matroid E) (𝔽 : Type*) [field 𝔽] {n : ℕ}
(hn : n = M.rk) :
  (M.is_representable 𝔽) ↔ ∃ (P : matrix (fin n) E 𝔽), is_matrix_rep P M :=
begin
  refine ⟨λ h, _, by {rintros ⟨P,hP⟩, exact ⟨P.row_space, hP⟩}⟩,
  obtain ⟨R, hR⟩ := h,
  obtain ⟨B, hB⟩ := finite_dimensional.fin_basis 𝔽 R,
  have h_univ := hR univ,
  suffices h_same : finrank 𝔽 ↥(submodule.proj_to_set R univ) = finrank 𝔽 R,
  { sorry }, --exact ⟨λ i a, (B ⟨i.val, sorry⟩).val a, λ X, sorry⟩, },

  /-apply linear_equiv.findim_eq,
  exact proj_to_univ_equiv _, -/
  sorry,

end

def matrix.col_submatrix (P : matrix ρ E 𝔽) (X : set E) : matrix ρ X 𝔽 :=
  matrix.submatrix P id coe

lemma matrix_rep.apply {M : matroid E} {P : matrix ρ E 𝔽} (h : is_matrix_rep P M) (X : set E) :
  M.r X = (P.col_submatrix X).rank := sorry

-- show that if the submatrices for `{e}`, `{f}` have the same column space, then the
-- submatrix for `{e,f}` has rank `1`, contradicting simplicity.
--lemma col_space {M : matroid E} {P : matrix ρ E 𝔽} (h : is_matrix_rep P M) (e f : E) :
-- span 𝔽 (range Mᵀ) is column space
variables [fintype ρ] [fintype E]
lemma submatrix_rank_one_of_span_eq_span {M : matroid E} {P : matrix ρ E 𝔽} (h : is_matrix_rep P M)
(e f : E) (h_span : span 𝔽 (range (matrix.col_submatrix P {e})ᵀ)
                    = span 𝔽 (range (matrix.col_submatrix P {f})ᵀ)) :
  (matrix.col_submatrix P {e, f}).rank = 1 :=
begin
  rw [matrix.rank],
  -- have := matrix.transpose,
  sorry,
end

variables (h𝔽 : field 𝔽) (V : submodule 𝔽 ( E → 𝔽 ))[fintype V]
variables [fintype {S : subspace 𝔽 V | finrank 𝔽 S = 1}]

--lemma simple_rep_inj
-- define simple to mean every pair has rank 2
def simple (M : matroid E) : Prop := ∀ (e f : E), e ≠ f → M.r {e, f} = 2

#check (λ x : E, submodule.proj_to_set V ({x} : set E))
#check submodule.proj_to_set V

def submodule.proj_to_set2 (x : E) := submodule.proj_to_set V ({x} : set E)

/-lemma inj_of_simple : simple M → is_subspace_rep h𝔽 V M →
  function.injective (submodule.proj_to_set2) :=
begin
  sorry,
end

-- this is true for simple matroids
lemma card_subspaces_eq_ncard_univ :
  simple M → is_subspace_rep h𝔽 V M  →
    (univ : set E).ncard ≤ fintype.card {S : subspace 𝔽 V | finrank 𝔽 S = 1} :=
begin
  intros hs hr,

  sorry,
end
--[_inst_3 : field K] [_inst_4 : add_comm_group V] [_inst_5 : module K V] [_inst_6 : fintype K] [_inst_7 : finite_dimensional K V] [_inst_8 : fintype ↥{S : submodule K V | finrank K ↥S = 1}] [_inst_9 : nontrivial K] [_inst_11 : nontrivial V], fintype.card ↥{S : subspace K V | finrank K ↥S = 1}

lemma U23_binary : (canonical_unif 2 3).is_binary :=
begin
  unfold matroid.is_binary matroid.is_representable,
  sorry,
end

lemma U24_nonbinary : ¬ (canonical_unif 2 4).is_binary :=
begin
  by_contra h2,
  cases h2 with V hV,
  have h1 := @num_subspaces_dim_one (zmod 2) V _ _ _ _ _ sorry _ sorry,
  simp at h1,
  have h3 := hV univ,
  rw canonical_unif_r at h3,
  rw ncard_univ at h3,
  simp at h3,
  have h4 : finrank (zmod 2) ↥V = 2,
  sorry,
  rw h4 at h1,
  have h5 := ncard_univ (fin 4),
  have h6 : univ.ncard ≤ fintype.card ↥{S : subspace (zmod 2) ↥V | finrank (zmod 2) ↥S = 1},

  sorry,
end-/

end submodule_stuff


import Mathlib.Tactic.LinearCombination

-- We deliberately mock R here so that we don't have to import the deps
axiom Real : Type
notation "ℝ" => Real
@[instance] axiom Real.linearOrderedField : LinearOrderedField ℝ

/-! ### Simple Cases with ℤ and two or less equations -/

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) : 3 * x + 2 * y = 10 := by
  linear_combination 1 * h1

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) : 3 * x + 2 * y = 10 := by
  linear_combination h1

example (x y : ℤ) (h1 : x + 2 = -3) (_h2 : y = 10) : 2 * x + 4 = -6 := by
  linear_combination 2 * h1

example (x y : ℤ) (h1 : x * y + 2 * x = 1) (h2 : x = y) : x * y = -2 * y + 1 := by
  linear_combination 1 * h1 - 2 * h2

example (x y : ℤ) (h1 : x * y + 2 * x = 1) (h2 : x = y) : x * y = -2 * y + 1 := by
  linear_combination -2 * h2 + h1

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) : 2 * x + 4 - y = -16 := by
  linear_combination 2 * h1 + -1 * h2

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) : -y + 2 * x + 4 = -16 := by
  linear_combination -h2 + 2 * h1

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : 11 * y = -11 := by
  linear_combination -2 * h1 + 3 * h2

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : -11 * y = 11 := by
  linear_combination 2 * h1 - 3 * h2

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : -11 * y = 11 + 1 - 1 := by
  linear_combination 2 * h1 + -3 * h2

example (x y : ℤ) (h1 : 10 = 3 * x + 2 * y) (h2 : 3 = 2 * x + 5 * y) : 11 + 1 - 1 = -11 * y := by
  linear_combination 2 * h1 - 3 * h2

/-! ### More complicated cases with two equations -/

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) : -y + 2 * x + 4 = -16 := by
  linear_combination 2 * h1 - h2

example (x y : ℚ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : -11 * y + 1 = 11 + 1 := by
  linear_combination 2 * h1 - 3 * h2

-- example (a b : ℝ) (ha : 2 * a = 4) (hab : 2 * b = a - b) : b = 2 / 3 := by
--   linear_combination ha / 6 + hab / 3

/-! ### Cases with more than 2 equations -/

-- example (a b : ℝ) (ha : 2 * a = 4) (hab : 2 * b = a - b) (hignore : 3 = a + b) : b = 2 / 3 := by
--   linear_combination 1 / 6 * ha + 1 / 3 * hab + 0 * hignore

example (x y z : ℝ) (ha : x + 2 * y - z = 4) (hb : 2 * x + y + z = -2) (hc : x + 2 * y + z = 2) :
    -3 * x - 3 * y - 4 * z = 2 := by linear_combination ha - hb - 2 * hc

example (x y z : ℝ) (ha : x + 2 * y - z = 4) (hb : 2 * x + y + z = -2) (hc : x + 2 * y + z = 2) :
    6 * x = -10 := by
  linear_combination 1 * ha + 4 * hb - 3 * hc

example (x y z : ℝ) (ha : x + 2 * y - z = 4) (hb : 2 * x + y + z = -2) (hc : x + 2 * y + z = 2) :
    10 = 6 * -x := by
  linear_combination ha + 4 * hb - 3 * hc

-- example (w x y z : ℝ) (h1 : x + 2.1 * y + 2 * z = 2) (h2 : x + 8 * z + 5 * w = -6.5)
--     (h3 : x + y + 5 * z + 5 * w = 3) : x + 2.2 * y + 2 * z - 5 * w = -8.5 := by
--   linear_combination 2 * h1 + 1 * h2 - 2 * h3

-- example (w x y z : ℝ) (h1 : x + 2.1 * y + 2 * z = 2) (h2 : x + 8 * z + 5 * w = -6.5)
--     (h3 : x + y + 5 * z + 5 * w = 3) : x + 2.2 * y + 2 * z - 5 * w = -8.5 := by
--   linear_combination 2 * h1 + h2 - 2 * h3

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c * 3 = d) (h4 : -d = a) :
    2 * a - 3 + 9 * c + 3 * d = 8 - b + 3 * d - 3 * a := by
  linear_combination 2 * h1 - 1 * h2 + 3 * h3 - 3 * h4

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c * 3 = d) (h4 : -d = a) :
    6 - 3 * c + 3 * a + 3 * d = 2 * b - d + 12 - 3 * a := by
  linear_combination 2 * h2 - h3 + 3 * h1 - 3 * h4

/-! ### Cases with non-hypothesis inputs -/

axiom qc : ℚ
axiom hqc : qc = 2 * qc

example (a b : ℚ) (h : ∀ p q : ℚ, p = q) : 3 * a + qc = 3 * b + 2 * qc := by
  linear_combination 3 * h a b + hqc

axiom bad (q : ℚ) : q = 0

example (a b : ℚ) : a + b ^ 3 = 0 := by linear_combination bad a + b * bad (b * b)

/-! ### Cases with arbitrary coefficients -/

example (a b : ℤ) (h : a = b) : a * a = a * b := by linear_combination a * h

example (a b c : ℤ) (h : a = b) : a * c = b * c := by linear_combination c * h

example (a b c : ℤ) (h1 : a = b) (h2 : b = 1) : c * a + b = c * b + 1 := by
  linear_combination c * h1 + h2

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3 * x = 7) :
    x * x * y + y * x * y + 6 * x = 3 * x * y + 14 := by
  linear_combination x * y * h1 + 2 * h2

example {α} [h : CommRing α] {a b c d e f : α} (h1 : a * d = b * c) (h2 : c * f = e * d) :
    c * (a * f - b * e) = 0 := by linear_combination e * h1 + a * h2

example (x y z w : ℚ) (hzw : z = w) : x * z + 2 * y * z = x * w + 2 * y * w := by
  linear_combination (x + 2 * y) * hzw

/-! ### Cases that explicitly use a config -/

example (x y : ℚ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : -11 * y + 1 = 11 + 1 := by
  linear_combination (norm := ring) 2 * h1 - 3 * h2

example (x y : ℚ) (h1 : 3 * x + 2 * y = 10) (h2 : 2 * x + 5 * y = 3) : -11 * y + 1 = 11 + 1 := by
  linear_combination (norm := ring1) 2 * h1 + -3 * h2

-- example (a b : ℝ) (ha : 2 * a = 4) (hab : 2 * b = a - b) : b = 2 / 3 := by
--   linear_combination (norm := ring_nf) 1 / 6 * ha + 1 / 3 * hab

example (x y : ℤ) (h1 : 3 * x + 2 * y = 10) : 3 * x + 2 * y = 10 := by
  linear_combination (norm := simp) h1

/-! ### Cases that have linear_combination skip normalization -/

-- example (a b : ℝ) (ha : 2 * a = 4) (hab : 2 * b = a - b) : b = 2 / 3 := by
--   linear_combination (norm := skip) 1 / 6 * ha + 1 / 3 * hab
--   linarith

example (x y : ℤ) (h1 : x = -3) (_h2 : y = 10) : 2 * x = -6 := by
  linear_combination (norm := skip) 2 * h1
  simp

/-! ### Cases without any arguments provided -/

-- the corner case is "just apply the normalization procedure".
example {x y z w : ℤ} (_h₁ : 3 * x = 4 + y) (_h₂ : x + 2 * y = 1) : z + w = w + z := by
  linear_combination

-- this interacts as expected with options
example {x y z w : ℤ} (_h₁ : 3 * x = 4 + y) (_h₂ : x + 2 * y = 1) : z + w = w + z := by
  linear_combination (norm := skip)
  guard_target = z + w - (w + z) - (0 - 0) = 0
  simp [add_comm]

example {x y z w : ℤ} (_h₁ : 3 * x = 4 + y) (_h₂ : x + 2 * y = 1) : z + w = w + z := by
  linear_combination (norm := simp [add_comm])

/-! ### Cases where the goal is not closed -/

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3 * x = 7) :
    x * x * y + y * x * y + 6 * x = 3 * x * y + 14 := by
  linear_combination (norm := ring_nf) x * y * h1 + h2
  guard_target = -7 + x * 3 = 0
  linear_combination h2

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c * 3 = d) (h4 : -d = a) :
    6 - 3 * c + 3 * a + 3 * d = 2 * b - d + 12 - 3 * a := by
  linear_combination (norm := ring_nf) 2 * h2
  linear_combination (norm := ring_nf) -h3
  linear_combination (norm := ring_nf) 3 * h1
  linear_combination (norm := ring_nf) -3 * h4

example (x y : ℤ) (h1 : x * y + 2 * x = 1) (h2 : x = y) : x * y = -2 * y + 1 := by
  linear_combination (norm := ring_nf)
  linear_combination h1 - 2 * h2

/-! ### Cases that should fail -/

-- This should fail because the second coefficient has a different type than
--   the equations it is being combined with.  This was a design choice for the
--   sake of simplicity, but the tactic could potentially be modified to allow
--   this behavior.
example (x y : ℤ) (h1 : x * y + 2 * x = 1) (h2 : x = y) : x * y + 2 * x = 1 := by
  fail_if_success linear_combination h1 + (0 : ℝ) * h2
  linear_combination h1

-- This fails because the linear_combination tactic requires the equations
--   and coefficients to use a type that fulfills the add_group condition,
--   and ℕ does not.
example (a _b : ℕ) (h1 : a = 3) : a = 3 := by
  fail_if_success linear_combination h1
  linear_combination2 h1

example (a b : ℤ) (x y : ℝ) (hab : a = b) (hxy : x = y) : 2 * x = 2 * y := by
  fail_if_success linear_combination 2 * hab
  linear_combination 2 * hxy

/-! ### Regression tests -/

def g (a : ℤ) : ℤ := a ^ 2

example (h : g a = g b) : a ^ 4 = b ^ 4 := by
  dsimp [g] at h
  linear_combination (a ^ 2 + b ^ 2) * h

example {r s a b : ℕ} (h₁ : (r : ℤ) = a + 1) (h₂ : (s : ℤ) = b + 1) :
    r * s = (a + 1 : ℤ) * (b + 1) := by
  linear_combination (↑b + 1) * h₁ + ↑r * h₂


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

! This file was ported from Lean 3 source module ring_theory.power_basis
! leanprover-community/mathlib commit d1d69e99ed34c95266668af4e288fc1c598b9a7f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.Minpoly.Field

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
For example, if `x` is algebraic over a ring/field, adjoining `x`
gives a `power_basis` structure generated by `x`.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `finrank (hf : f ≠ 0) : finite_dimensional.finrank K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, `A`, `B` ... are `comm_ring`s, and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

open Polynomial

open Polynomial

variable {R S T : Type _} [CommRing R] [Ring S] [Algebra R S]

variable {A B : Type _} [CommRing A] [CommRing B] [IsDomain B] [Algebra A B]

variable {K : Type _} [Field K]

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
@[nolint has_nonempty_instance]
structure PowerBasis (R S : Type _) [CommRing R] [Ring S] [Algebra R S] where
  gen : S
  dim : ℕ
  Basis : Basis (Fin dim) R S
  basis_eq_pow : ∀ i, Basis i = gen ^ (i : ℕ)
#align power_basis PowerBasis

-- this is usually not needed because of `basis_eq_pow` but can be needed in some cases;
-- in such circumstances, add it manually using `@[simps dim gen basis]`.
initialize_simps_projections PowerBasis (-Basis)

namespace PowerBasis

@[simp]
theorem coe_basis (pb : PowerBasis R S) : ⇑pb.Basis = fun i : Fin pb.dim => pb.gen ^ (i : ℕ) :=
  funext pb.basis_eq_pow
#align power_basis.coe_basis PowerBasis.coe_basis

/-- Cannot be an instance because `power_basis` cannot be a class. -/
theorem finiteDimensional [Algebra K S] (pb : PowerBasis K S) : FiniteDimensional K S :=
  FiniteDimensional.of_fintype_basis pb.Basis
#align power_basis.finite_dimensional PowerBasis.finiteDimensional

theorem finrank [Algebra K S] (pb : PowerBasis K S) : FiniteDimensional.finrank K S = pb.dim := by
  rw [FiniteDimensional.finrank_eq_card_basis pb.basis, Fintype.card_fin]
#align power_basis.finrank PowerBasis.finrank

theorem mem_span_pow' {x y : S} {d : ℕ} :
    y ∈ Submodule.span R (Set.range fun i : Fin d => x ^ (i : ℕ)) ↔
      ∃ f : R[X], f.degree < d ∧ y = aeval x f :=
  by
  have : (Set.range fun i : Fin d => x ^ (i : ℕ)) = (fun i : ℕ => x ^ i) '' ↑(Finset.range d) :=
    by
    ext n
    simp_rw [Set.mem_range, Set.mem_image, Finset.mem_coe, Finset.mem_range]
    exact ⟨fun ⟨⟨i, hi⟩, hy⟩ => ⟨i, hi, hy⟩, fun ⟨i, hi, hy⟩ => ⟨⟨i, hi⟩, hy⟩⟩
  simp only [this, Finsupp.mem_span_image_iff_total, degree_lt_iff_coeff_zero,
    exists_iff_exists_finsupp, coeff, aeval, eval₂_ring_hom', eval₂_eq_sum, Polynomial.sum, support,
    Finsupp.mem_supported', Finsupp.total, Finsupp.sum, Algebra.smul_def, eval₂_zero, exists_prop,
    LinearMap.id_coe, eval₂_one, id.def, not_lt, Finsupp.coe_lsum, LinearMap.coe_smulRight,
    Finset.mem_range, AlgHom.coe_mks, Finset.mem_coe]
  simp_rw [@eq_comm _ y]
  exact Iff.rfl
#align power_basis.mem_span_pow' PowerBasis.mem_span_pow'

theorem mem_span_pow {x y : S} {d : ℕ} (hd : d ≠ 0) :
    y ∈ Submodule.span R (Set.range fun i : Fin d => x ^ (i : ℕ)) ↔
      ∃ f : R[X], f.natDegree < d ∧ y = aeval x f :=
  by
  rw [mem_span_pow']
  constructor <;>
    · rintro ⟨f, h, hy⟩
      refine' ⟨f, _, hy⟩
      by_cases hf : f = 0
      · simp only [hf, nat_degree_zero, degree_zero] at h⊢
        first |exact lt_of_le_of_ne (Nat.zero_le d) hd.symm|exact WithBot.bot_lt_coe d
      simpa only [degree_eq_nat_degree hf, WithBot.coe_lt_coe] using h
#align power_basis.mem_span_pow PowerBasis.mem_span_pow

theorem dim_ne_zero [h : Nontrivial S] (pb : PowerBasis R S) : pb.dim ≠ 0 := fun h =>
  not_nonempty_iff.mpr (h.symm ▸ Fin.isEmpty : IsEmpty (Fin pb.dim)) pb.Basis.index_nonempty
#align power_basis.dim_ne_zero PowerBasis.dim_ne_zero

theorem dim_pos [Nontrivial S] (pb : PowerBasis R S) : 0 < pb.dim :=
  Nat.pos_of_ne_zero pb.dim_ne_zero
#align power_basis.dim_pos PowerBasis.dim_pos

theorem exists_eq_aeval [Nontrivial S] (pb : PowerBasis R S) (y : S) :
    ∃ f : R[X], f.natDegree < pb.dim ∧ y = aeval pb.gen f :=
  (mem_span_pow pb.dim_ne_zero).mp (by simpa using pb.basis.mem_span y)
#align power_basis.exists_eq_aeval PowerBasis.exists_eq_aeval

theorem exists_eq_aeval' (pb : PowerBasis R S) (y : S) : ∃ f : R[X], y = aeval pb.gen f :=
  by
  nontriviality S
  obtain ⟨f, _, hf⟩ := exists_eq_aeval pb y
  exact ⟨f, hf⟩
#align power_basis.exists_eq_aeval' PowerBasis.exists_eq_aeval'

theorem algHom_ext {S' : Type _} [Semiring S'] [Algebra R S'] (pb : PowerBasis R S)
    ⦃f g : S →ₐ[R] S'⦄ (h : f pb.gen = g pb.gen) : f = g :=
  by
  ext x
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x
  rw [← Polynomial.aeval_algHom_apply, ← Polynomial.aeval_algHom_apply, h]
#align power_basis.alg_hom_ext PowerBasis.algHom_ext

section minpoly

open BigOperators

variable [Algebra A S]

/-- `pb.minpoly_gen` is the minimal polynomial for `pb.gen`. -/
noncomputable def minpolyGen (pb : PowerBasis A S) : A[X] :=
  X ^ pb.dim - ∑ i : Fin pb.dim, C (pb.Basis.repr (pb.gen ^ pb.dim) i) * X ^ (i : ℕ)
#align power_basis.minpoly_gen PowerBasis.minpolyGen

theorem aeval_minpolyGen (pb : PowerBasis A S) : aeval pb.gen (minpolyGen pb) = 0 :=
  by
  simp_rw [minpoly_gen, AlgHom.map_sub, AlgHom.map_sum, AlgHom.map_mul, AlgHom.map_pow, aeval_C, ←
    Algebra.smul_def, aeval_X]
  refine' sub_eq_zero.mpr ((pb.basis.total_repr (pb.gen ^ pb.dim)).symm.trans _)
  rw [Finsupp.total_apply, Finsupp.sum_fintype] <;>
    simp only [pb.coe_basis, zero_smul, eq_self_iff_true, imp_true_iff]
#align power_basis.aeval_minpoly_gen PowerBasis.aeval_minpolyGen

theorem minpolyGen_monic (pb : PowerBasis A S) : Monic (minpolyGen pb) :=
  by
  nontriviality A
  apply (monic_X_pow _).sub_of_left _
  rw [degree_X_pow]
  exact degree_sum_fin_lt _
#align power_basis.minpoly_gen_monic PowerBasis.minpolyGen_monic

theorem dim_le_natDegree_of_root (pb : PowerBasis A S) {p : A[X]} (ne_zero : p ≠ 0)
    (root : aeval pb.gen p = 0) : pb.dim ≤ p.natDegree :=
  by
  refine' le_of_not_lt fun hlt => NeZero _
  rw [p.as_sum_range' _ hlt, Finset.sum_range]
  refine' Fintype.sum_eq_zero _ fun i => _
  simp_rw [aeval_eq_sum_range' hlt, Finset.sum_range, ← pb.basis_eq_pow] at root
  have := Fintype.linearIndependent_iff.1 pb.basis.linear_independent _ root
  dsimp only at this
  rw [this, monomial_zero_right]
#align power_basis.dim_le_nat_degree_of_root PowerBasis.dim_le_natDegree_of_root

theorem dim_le_degree_of_root (h : PowerBasis A S) {p : A[X]} (ne_zero : p ≠ 0)
    (root : aeval h.gen p = 0) : ↑h.dim ≤ p.degree :=
  by
  rw [degree_eq_nat_degree NeZero, WithBot.coe_le_coe]
  exact h.dim_le_nat_degree_of_root NeZero root
#align power_basis.dim_le_degree_of_root PowerBasis.dim_le_degree_of_root

theorem degree_minpolyGen [Nontrivial A] (pb : PowerBasis A S) : degree (minpolyGen pb) = pb.dim :=
  by
  unfold minpoly_gen
  rw [degree_sub_eq_left_of_degree_lt] <;> rw [degree_X_pow]
  apply degree_sum_fin_lt
#align power_basis.degree_minpoly_gen PowerBasis.degree_minpolyGen

theorem natDegree_minpolyGen [Nontrivial A] (pb : PowerBasis A S) :
    natDegree (minpolyGen pb) = pb.dim :=
  natDegree_eq_of_degree_eq_some pb.degree_minpolyGen
#align power_basis.nat_degree_minpoly_gen PowerBasis.natDegree_minpolyGen

@[simp]
theorem minpolyGen_eq (pb : PowerBasis A S) : pb.minpolyGen = minpoly A pb.gen :=
  by
  nontriviality A
  refine'
    minpoly.unique' A _ pb.minpoly_gen_monic pb.aeval_minpoly_gen fun q hq =>
      or_iff_not_imp_left.2 fun hn0 h0 => _
  exact (pb.dim_le_degree_of_root hn0 h0).not_lt (pb.degree_minpoly_gen ▸ hq)
#align power_basis.minpoly_gen_eq PowerBasis.minpolyGen_eq

theorem isIntegral_gen (pb : PowerBasis A S) : IsIntegral A pb.gen :=
  ⟨minpolyGen pb, minpolyGen_monic pb, aeval_minpolyGen pb⟩
#align power_basis.is_integral_gen PowerBasis.isIntegral_gen

@[simp]
theorem degree_minpoly [Nontrivial A] (pb : PowerBasis A S) : degree (minpoly A pb.gen) = pb.dim :=
  by rw [← minpoly_gen_eq, degree_minpoly_gen]
#align power_basis.degree_minpoly PowerBasis.degree_minpoly

@[simp]
theorem natDegree_minpoly [Nontrivial A] (pb : PowerBasis A S) :
    (minpoly A pb.gen).natDegree = pb.dim := by rw [← minpoly_gen_eq, nat_degree_minpoly_gen]
#align power_basis.nat_degree_minpoly PowerBasis.natDegree_minpoly

protected theorem leftMulMatrix (pb : PowerBasis A S) :
    Algebra.leftMulMatrix pb.Basis pb.gen =
      Matrix.of fun i j =>
        if ↑j + 1 = pb.dim then -pb.minpolyGen.coeff ↑i else if ↑i = ↑j + 1 then 1 else 0 :=
  by
  cases subsingleton_or_nontrivial A; · apply Subsingleton.elim
  rw [Algebra.leftMulMatrix_apply, ← LinearEquiv.eq_symm_apply, LinearMap.toMatrix_symm]
  refine' pb.basis.ext fun k => _
  simp_rw [Matrix.toLin_self, Matrix.of_apply, pb.basis_eq_pow]
  apply (pow_succ _ _).symm.trans
  split_ifs with h h
  · simp_rw [h, neg_smul, Finset.sum_neg_distrib, eq_neg_iff_add_eq_zero]
    convert pb.aeval_minpoly_gen
    rw [add_comm, aeval_eq_sum_range, Finset.sum_range_succ, ← leading_coeff,
      pb.minpoly_gen_monic.leading_coeff, one_smul, nat_degree_minpoly_gen, Finset.sum_range]
  · rw [Fintype.sum_eq_single (⟨↑k + 1, lt_of_le_of_ne k.2 h⟩ : Fin pb.dim), if_pos, one_smul]
    · rfl
    · rfl
    intro x hx
    rw [if_neg, zero_smul]
    apply mt Fin.ext hx
#align power_basis.left_mul_matrix PowerBasis.leftMulMatrix

end minpoly

section Equiv

variable [Algebra A S] {S' : Type _} [Ring S'] [Algebra A S']

theorem constr_pow_aeval (pb : PowerBasis A S) {y : S'} (hy : aeval y (minpoly A pb.gen) = 0)
    (f : A[X]) : pb.Basis.constr A (fun i => y ^ (i : ℕ)) (aeval pb.gen f) = aeval y f :=
  by
  cases subsingleton_or_nontrivial A
  · rw [(Subsingleton.elim _ _ : f = 0), aeval_zero, map_zero, aeval_zero]
  rw [← aeval_mod_by_monic_eq_self_of_root (minpoly.monic pb.is_integral_gen) (minpoly.aeval _ _), ←
    @aeval_mod_by_monic_eq_self_of_root _ _ _ _ _ f _ (minpoly.monic pb.is_integral_gen) y hy]
  by_cases hf : f %ₘ minpoly A pb.gen = 0
  · simp only [hf, AlgHom.map_zero, LinearMap.map_zero]
  have : (f %ₘ minpoly A pb.gen).natDegree < pb.dim :=
    by
    rw [← pb.nat_degree_minpoly]
    apply nat_degree_lt_nat_degree hf
    exact degree_mod_by_monic_lt _ (minpoly.monic pb.is_integral_gen)
  rw [aeval_eq_sum_range' this, aeval_eq_sum_range' this, LinearMap.map_sum]
  refine' Finset.sum_congr rfl fun i (hi : i ∈ Finset.range pb.dim) => _
  rw [Finset.mem_range] at hi
  rw [LinearMap.map_smul]
  congr
  rw [← Fin.val_mk hi, ← pb.basis_eq_pow ⟨i, hi⟩, Basis.constr_basis]
#align power_basis.constr_pow_aeval PowerBasis.constr_pow_aeval

theorem constr_pow_gen (pb : PowerBasis A S) {y : S'} (hy : aeval y (minpoly A pb.gen) = 0) :
    pb.Basis.constr A (fun i => y ^ (i : ℕ)) pb.gen = y := by
  convert pb.constr_pow_aeval hy X <;> rw [aeval_X]
#align power_basis.constr_pow_gen PowerBasis.constr_pow_gen

theorem constr_pow_algebraMap (pb : PowerBasis A S) {y : S'} (hy : aeval y (minpoly A pb.gen) = 0)
    (x : A) : pb.Basis.constr A (fun i => y ^ (i : ℕ)) (algebraMap A S x) = algebraMap A S' x := by
  convert pb.constr_pow_aeval hy (C x) <;> rw [aeval_C]
#align power_basis.constr_pow_algebra_map PowerBasis.constr_pow_algebraMap

theorem constr_pow_mul (pb : PowerBasis A S) {y : S'} (hy : aeval y (minpoly A pb.gen) = 0)
    (x x' : S) :
    pb.Basis.constr A (fun i => y ^ (i : ℕ)) (x * x') =
      pb.Basis.constr A (fun i => y ^ (i : ℕ)) x * pb.Basis.constr A (fun i => y ^ (i : ℕ)) x' :=
  by
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x
  obtain ⟨g, rfl⟩ := pb.exists_eq_aeval' x'
  simp only [← aeval_mul, pb.constr_pow_aeval hy]
#align power_basis.constr_pow_mul PowerBasis.constr_pow_mul

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`.

See `power_basis.lift_equiv` for a bundled equiv sending `⟨y, hy⟩` to the algebra map.
-/
noncomputable def lift (pb : PowerBasis A S) (y : S') (hy : aeval y (minpoly A pb.gen) = 0) :
    S →ₐ[A] S' :=
  {
    pb.Basis.constr A fun i =>
      y ^
        (i :
          ℕ) with
    map_one' := by convert pb.constr_pow_algebra_map hy 1 using 2 <;> rw [RingHom.map_one]
    map_zero' := by convert pb.constr_pow_algebra_map hy 0 using 2 <;> rw [RingHom.map_zero]
    map_mul' := pb.constr_pow_mul hy
    commutes' := pb.constr_pow_algebraMap hy }
#align power_basis.lift PowerBasis.lift

@[simp]
theorem lift_gen (pb : PowerBasis A S) (y : S') (hy : aeval y (minpoly A pb.gen) = 0) :
    pb.lift y hy pb.gen = y :=
  pb.constr_pow_gen hy
#align power_basis.lift_gen PowerBasis.lift_gen

@[simp]
theorem lift_aeval (pb : PowerBasis A S) (y : S') (hy : aeval y (minpoly A pb.gen) = 0) (f : A[X]) :
    pb.lift y hy (aeval pb.gen f) = aeval y f :=
  pb.constr_pow_aeval hy f
#align power_basis.lift_aeval PowerBasis.lift_aeval

/-- `pb.lift_equiv` states that roots of the minimal polynomial of `pb.gen` correspond to
maps sending `pb.gen` to that root.

This is the bundled equiv version of `power_basis.lift`.
If the codomain of the `alg_hom`s is an integral domain, then the roots form a multiset,
see `lift_equiv'` for the corresponding statement.
-/
@[simps]
noncomputable def liftEquiv (pb : PowerBasis A S) :
    (S →ₐ[A] S') ≃ { y : S' // aeval y (minpoly A pb.gen) = 0 }
    where
  toFun f := ⟨f pb.gen, by rw [aeval_alg_hom_apply, minpoly.aeval, f.map_zero]⟩
  invFun y := pb.lift y y.2
  left_inv f := pb.algHom_ext <| lift_gen _ _ _
  right_inv y := Subtype.ext <| lift_gen _ _ y.Prop
#align power_basis.lift_equiv PowerBasis.liftEquiv

/-- `pb.lift_equiv'` states that elements of the root set of the minimal
polynomial of `pb.gen` correspond to maps sending `pb.gen` to that root. -/
@[simps (config := { fullyApplied := false })]
noncomputable def liftEquiv' (pb : PowerBasis A S) :
    (S →ₐ[A] B) ≃ { y : B // y ∈ ((minpoly A pb.gen).map (algebraMap A B)).roots } :=
  pb.liftEquiv.trans
    ((Equiv.refl _).subtypeEquiv fun x =>
      by
      rw [mem_roots, is_root.def, Equiv.refl_apply, ← eval₂_eq_eval_map, ← aeval_def]
      exact map_monic_ne_zero (minpoly.monic pb.is_integral_gen))
#align power_basis.lift_equiv' PowerBasis.liftEquiv'

/-- There are finitely many algebra homomorphisms `S →ₐ[A] B` if `S` is of the form `A[x]`
and `B` is an integral domain. -/
noncomputable def AlgHom.fintype (pb : PowerBasis A S) : Fintype (S →ₐ[A] B) :=
  letI := Classical.decEq B
  Fintype.ofEquiv _ pb.lift_equiv'.symm
#align power_basis.alg_hom.fintype PowerBasis.AlgHom.fintype

/-- `pb.equiv_of_root pb' h₁ h₂` is an equivalence of algebras with the same power basis,
where "the same" means that `pb` is a root of `pb'`s minimal polynomial and vice versa.

See also `power_basis.equiv_of_minpoly` which takes the hypothesis that the
minimal polynomials are identical.
-/
@[simps (config := { attrs := [] }) apply]
noncomputable def equivOfRoot (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
    S ≃ₐ[A] S' :=
  AlgEquiv.ofAlgHom (pb.lift pb'.gen h₂) (pb'.lift pb.gen h₁)
    (by
      ext x
      obtain ⟨f, hf, rfl⟩ := pb'.exists_eq_aeval' x
      simp)
    (by
      ext x
      obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval' x
      simp)
#align power_basis.equiv_of_root PowerBasis.equivOfRoot

@[simp]
theorem equivOfRoot_aeval (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0)
    (f : A[X]) : pb.equivOfRoot pb' h₁ h₂ (aeval pb.gen f) = aeval pb'.gen f :=
  pb.lift_aeval _ h₂ _
#align power_basis.equiv_of_root_aeval PowerBasis.equivOfRoot_aeval

@[simp]
theorem equivOfRoot_gen (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
    pb.equivOfRoot pb' h₁ h₂ pb.gen = pb'.gen :=
  pb.lift_gen _ h₂
#align power_basis.equiv_of_root_gen PowerBasis.equivOfRoot_gen

@[simp]
theorem equivOfRoot_symm (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
    (pb.equivOfRoot pb' h₁ h₂).symm = pb'.equivOfRoot pb h₂ h₁ :=
  rfl
#align power_basis.equiv_of_root_symm PowerBasis.equivOfRoot_symm

/-- `pb.equiv_of_minpoly pb' h` is an equivalence of algebras with the same power basis,
where "the same" means that they have identical minimal polynomials.

See also `power_basis.equiv_of_root` which takes the hypothesis that each generator is a root of the
other basis' minimal polynomial; `power_basis.equiv_root` is more general if `A` is not a field.
-/
@[simps (config := { attrs := [] }) apply]
noncomputable def equivOfMinpoly (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h : minpoly A pb.gen = minpoly A pb'.gen) : S ≃ₐ[A] S' :=
  pb.equivOfRoot pb' (h ▸ minpoly.aeval _ _) (h.symm ▸ minpoly.aeval _ _)
#align power_basis.equiv_of_minpoly PowerBasis.equivOfMinpoly

@[simp]
theorem equivOfMinpoly_aeval (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h : minpoly A pb.gen = minpoly A pb'.gen) (f : A[X]) :
    pb.equivOfMinpoly pb' h (aeval pb.gen f) = aeval pb'.gen f :=
  pb.equivOfRoot_aeval pb' _ _ _
#align power_basis.equiv_of_minpoly_aeval PowerBasis.equivOfMinpoly_aeval

@[simp]
theorem equivOfMinpoly_gen (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h : minpoly A pb.gen = minpoly A pb'.gen) : pb.equivOfMinpoly pb' h pb.gen = pb'.gen :=
  pb.equivOfRoot_gen pb' _ _
#align power_basis.equiv_of_minpoly_gen PowerBasis.equivOfMinpoly_gen

@[simp]
theorem equivOfMinpoly_symm (pb : PowerBasis A S) (pb' : PowerBasis A S')
    (h : minpoly A pb.gen = minpoly A pb'.gen) :
    (pb.equivOfMinpoly pb' h).symm = pb'.equivOfMinpoly pb h.symm :=
  rfl
#align power_basis.equiv_of_minpoly_symm PowerBasis.equivOfMinpoly_symm

end Equiv

end PowerBasis

open PowerBasis

/-- Useful lemma to show `x` generates a power basis:
the powers of `x` less than the degree of `x`'s minimal polynomial are linearly independent. -/
theorem linearIndependent_pow [Algebra K S] (x : S) :
    LinearIndependent K fun i : Fin (minpoly K x).natDegree => x ^ (i : ℕ) :=
  by
  by_cases IsIntegral K x; swap
  · rw [minpoly.eq_zero h, nat_degree_zero]
    exact linearIndependent_empty_type
  refine' Fintype.linearIndependent_iff.2 fun g hg i => _
  simp only at hg
  simp_rw [Algebra.smul_def, ← aeval_monomial, ← map_sum] at hg
  apply (fun hn0 => (minpoly.degree_le_of_ne_zero K x (mt (fun h0 => _) hn0) hg).not_lt).mtr
  · simp_rw [← C_mul_X_pow_eq_monomial]
    exact (degree_eq_nat_degree <| minpoly.ne_zero h).symm ▸ degree_sum_fin_lt _
  · apply_fun lcoeff K i  at h0
    simp_rw [map_sum, lcoeff_apply, coeff_monomial, Fin.val_eq_val, Finset.sum_ite_eq'] at h0
    exact (if_pos <| Finset.mem_univ _).symm.trans h0
#align linear_independent_pow linearIndependent_pow

theorem IsIntegral.mem_span_pow [Nontrivial R] {x y : S} (hx : IsIntegral R x)
    (hy : ∃ f : R[X], y = aeval x f) :
    y ∈ Submodule.span R (Set.range fun i : Fin (minpoly R x).natDegree => x ^ (i : ℕ)) :=
  by
  obtain ⟨f, rfl⟩ := hy
  apply mem_span_pow'.mpr _
  have := minpoly.monic hx
  refine' ⟨f %ₘ minpoly R x, (degree_mod_by_monic_lt _ this).trans_le degree_le_nat_degree, _⟩
  conv_lhs => rw [← mod_by_monic_add_div f this]
  simp only [add_zero, MulZeroClass.zero_mul, minpoly.aeval, aeval_add, AlgHom.map_mul]
#align is_integral.mem_span_pow IsIntegral.mem_span_pow

namespace PowerBasis

section Map

variable {S' : Type _} [CommRing S'] [Algebra R S']

/-- `power_basis.map pb (e : S ≃ₐ[R] S')` is the power basis for `S'` generated by `e pb.gen`. -/
@[simps dim gen Basis]
noncomputable def map (pb : PowerBasis R S) (e : S ≃ₐ[R] S') : PowerBasis R S'
    where
  dim := pb.dim
  Basis := pb.Basis.map e.toLinearEquiv
  gen := e pb.gen
  basis_eq_pow i := by rw [Basis.map_apply, pb.basis_eq_pow, e.to_linear_equiv_apply, e.map_pow]
#align power_basis.map PowerBasis.map

variable [Algebra A S] [Algebra A S']

@[simp]
theorem minpolyGen_map (pb : PowerBasis A S) (e : S ≃ₐ[A] S') :
    (pb.map e).minpolyGen = pb.minpolyGen :=
  by
  dsimp only [minpoly_gen, map_dim]
  -- Turn `fin (pb.map e).dim` into `fin pb.dim`
  simp only [LinearEquiv.trans_apply, map_basis, Basis.map_repr, map_gen,
    AlgEquiv.toLinearEquiv_apply, e.to_linear_equiv_symm, AlgEquiv.map_pow,
    AlgEquiv.symm_apply_apply, sub_right_inj]
#align power_basis.minpoly_gen_map PowerBasis.minpolyGen_map

@[simp]
theorem equivOfRoot_map (pb : PowerBasis A S) (e : S ≃ₐ[A] S') (h₁ h₂) :
    pb.equivOfRoot (pb.map e) h₁ h₂ = e := by
  ext x
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x
  simp [aeval_alg_equiv]
#align power_basis.equiv_of_root_map PowerBasis.equivOfRoot_map

@[simp]
theorem equivOfMinpoly_map (pb : PowerBasis A S) (e : S ≃ₐ[A] S')
    (h : minpoly A pb.gen = minpoly A (pb.map e).gen) : pb.equivOfMinpoly (pb.map e) h = e :=
  pb.equivOfRoot_map _ _ _
#align power_basis.equiv_of_minpoly_map PowerBasis.equivOfMinpoly_map

end Map

section Adjoin

open Algebra

theorem adjoin_gen_eq_top (B : PowerBasis R S) : adjoin R ({B.gen} : Set S) = ⊤ :=
  by
  rw [← to_submodule_eq_top, _root_.eq_top_iff, ← B.basis.span_eq, Submodule.span_le]
  rintro x ⟨i, rfl⟩
  rw [B.basis_eq_pow i]
  exact Subalgebra.pow_mem _ (subset_adjoin (Set.mem_singleton _)) _
#align power_basis.adjoin_gen_eq_top PowerBasis.adjoin_gen_eq_top

theorem adjoin_eq_top_of_gen_mem_adjoin {B : PowerBasis R S} {x : S}
    (hx : B.gen ∈ adjoin R ({x} : Set S)) : adjoin R ({x} : Set S) = ⊤ :=
  by
  rw [_root_.eq_top_iff, ← B.adjoin_gen_eq_top]
  refine' adjoin_le _
  simp [hx]
#align power_basis.adjoin_eq_top_of_gen_mem_adjoin PowerBasis.adjoin_eq_top_of_gen_mem_adjoin

end Adjoin

end PowerBasis


import Huber_ring.localization
import Spa.rational_open_data

/-!
# Extending continuous valuations on Huber rings

In this file, we extend continuous valuations on Huber rings R
to rational localizations R(T/s) and their completions.

This is an important step in the definition of the structure presheaf on the adic spectrum.
-/

noncomputable theory

local attribute [instance] valued.subgroups_basis valued.uniform_space

local postfix `⁺` : 66 := λ A : Huber_pair, A.plus

variables {A : Huber_pair}
{Γ₀ : Type*} [linear_ordered_comm_group_with_zero Γ₀] {v : valuation A Γ₀}
{rd : spa.rational_open_data A} (hv : valuation.is_continuous v)

namespace Huber_pair
open valuation linear_ordered_structure

local attribute [instance] set.smul_set_action

local notation `A⟮T/s⟯` := spa.rational_open_data.localization rd
local notation `s` := rd.s
local notation `T` := rd.T

/-- An auxilliary definition that constructs s as unit in the valuation field
of a valuation v, under the assumption that v s ≠ 0.-/
def unit_s (hs : v s ≠ 0) : units (valuation_field v) :=
units.mk0 (valuation_field_mk v s) $ valuation_field_mk_ne_zero v s hs

example : (λ r, localization.of (valuation_ID_mk v r)) = valuation_field_mk v := rfl

set_option class.instance_max_depth 64

/--The set T/s (for some rational open subset D(T,s)) considered as subset of the valuation field.-/
def v_T_over_s (hs : v s ≠ 0) : set (valuation_field v) :=
((unit_s hs)⁻¹ : v.valuation_field) • ((valuation_field_mk v) '' rd.T)

lemma v_T_over_s_le_one (hs : v s ≠ 0) (hT2 : ∀ t : A, t ∈ T → v t ≤ v s) :
  v_T_over_s hs ⊆ {x : valuation_field v | valuation_field.canonical_valuation v x ≤ 1} :=
begin
  let v' := valuation_field.canonical_valuation v,
  intros k Hk,
  show v' k ≤ 1,
  let u := unit_s hs,
  have remember_this : valuation_field_mk v s = u.val := rfl,
  unfold v_T_over_s at Hk,
  rcases Hk with ⟨l, ⟨t, ht, rfl⟩, rfl⟩,
  rw [smul_eq_mul, v'.map_mul],
  change v' (↑(unit_s hs)⁻¹) * _ ≤ _,
  rw mul_comm,
  apply le_of_le_mul_right
    (group_with_zero.unit_ne_zero $ units.map (v' : v.valuation_field →* (value_monoid v)) u),
  show v' _ * v' _ * v' u ≤ _,
  rw [mul_assoc, one_mul, ← v'.map_mul, units.inv_mul, v'.map_one, mul_one],
  change canonical_valuation v t ≤ v' u.val,
  rw ← remember_this,
  change _ ≤ canonical_valuation v s,
  rw canonical_valuation_is_equiv v,
  exact hT2 _ ht,
end

lemma v_le_one_is_bounded {R : Type*} [comm_ring R] (v : valuation R Γ₀) :
  is_bounded {x : valuation_field v | valuation_field.canonical_valuation v x ≤ 1} :=
begin
  let v' := valuation_field.canonical_valuation v,
  intros U HU,
  rcases subgroups_basis.mem_nhds_zero.mp HU with ⟨_, ⟨γ, rfl⟩, H⟩,
  let V := {k : valuation_field v | v' k < ↑γ},
  use V,
  existsi _, swap,
  { rw subgroups_basis.mem_nhds_zero,
    use [V, set.mem_range_self _] },
  intros w Hw b Hb,
  change V ⊆ U at H,
  change v' w < γ at Hw,
  change v' b ≤ 1 at Hb,
  apply set.mem_of_mem_of_subset _ H,
  change v' (w * b) < γ,
  rw v'.map_mul,
  exact actual_ordered_comm_monoid.mul_lt_of_lt_of_nongt_one' Hw Hb,
end

lemma v_le_one_is_power_bounded {R : Type*} [comm_ring R] (v : valuation R Γ₀) :
  is_power_bounded_subset {x : valuation_field v | valuation_field.canonical_valuation v x ≤ 1} :=
begin
  let v' := valuation_field.canonical_valuation v,
  refine is_bounded.subset _ (v_le_one_is_bounded v),
  intros x hx,
  induction hx with a ha a b ha' hb' ha hb,
  { assumption },
  { show v' 1 ≤ 1, rw v'.map_one, },
  { show v' (a * b) ≤ 1, rw v'.map_mul,
    exact actual_ordered_comm_monoid.mul_nongt_one' ha hb, }
end

lemma v_T_over_s_is_power_bounded (hs : v s ≠ 0) (hT2 : ∀ t : A, t ∈ T → v t ≤ v s) :
  is_power_bounded_subset (v_T_over_s hs) :=
begin
  apply power_bounded.subset (v_T_over_s_le_one hs hT2),
  exact v_le_one_is_power_bounded v
end

/--The natural map from the localization A⟮T/s⟯ of a Huber pair A
at a rational open subset R(T/s)
to the valuation field of a valuation that does not have s in its support.-/
noncomputable def to_valuation_field (hs : v s ≠ 0) : A⟮T/s⟯ → (valuation_field v) :=
Huber_ring.away.lift T s (valuation_field_mk v) (unit_s hs) rfl

/-- The natural map from A⟮T/s⟯ to the valuation field is a ring homomorphism. -/
instance (hs : v s ≠ 0) : is_ring_hom (to_valuation_field hs) :=
by delta to_valuation_field; apply_instance

local attribute [instance] valued.subgroups_basis

theorem to_valuation_field_cts' (hs : v s ≠ 0)(hT2 : ∀ t : A, t ∈ T → v t ≤ v s) (hv : is_continuous v) :
  continuous (to_valuation_field hs) :=
Huber_ring.away.lift_continuous T s (by convert subgroups_basis.nonarchimedean)
  (continuous_valuation_field_mk_of_continuous v hv) _ rfl (rd.Hopen)
  (v_T_over_s_is_power_bounded hs hT2)

-- now we need that the triangles commute when we fix v but change s.

theorem to_valuation_field_commutes (r1 r2 : spa.rational_open_data A) (h : r1 ≤ r2)
  (hs1 : v r1.s ≠ 0) (hs2 : v r2.s ≠ 0) :
to_valuation_field hs1 = (to_valuation_field hs2) ∘ (spa.rational_open_data.localization_map h) :=
begin
  refine localization.funext
    (to_valuation_field hs1 : localization A (powers r1.s) → valuation_field v)
    ((to_valuation_field hs2) ∘ (spa.rational_open_data.localization_map h) :
      localization A (powers r1.s) → valuation_field v) _,
  intro r,
  delta to_valuation_field spa.rational_open_data.localization_map function.comp,
  erw Huber_ring.away.lift_of,
  erw Huber_ring.away.lift_of,
  change _ = Huber_ring.away.lift (r2.T) (r2.s) _ _ _ (localization.of r),
  rw Huber_ring.away.lift_of,
end

namespace rational_open_data

lemma to_valuation_field_cts_aux {r : spa.rational_open_data A} {v : spa A}
(hv : v ∈ r.open_set) : (Spv.out v.1) (r.s) ≠ 0 := hv.2

/-- The natural map from A(T/s) to the valuation field of a valuation v contained in
the rational open subset R(T/s). -/
def to_valuation_field {r : spa.rational_open_data A} {v : spa A} (hv : v ∈ r.open_set) :
  spa.rational_open_data.localization r → valuation_field (Spv.out (v.val)) :=
(to_valuation_field $ to_valuation_field_cts_aux hv)

/-- The natural map from A(T/s) to the valuation field of a valuation v contained in
the rational open subset R(T/s) is a ring homomorphism. -/
instance {r : spa.rational_open_data A} {v : spa A} (hv : v ∈ r.open_set) :
  is_ring_hom (to_valuation_field hv) := by {delta to_valuation_field, apply_instance}

/-- If v : spa A is in D(T,s) then the map A(T/s) -> K_v is continuous -/
theorem to_valuation_field_cts {r : spa.rational_open_data A} {v : spa A}
  (hv : v ∈ r.open_set) : continuous (to_valuation_field hv) :=
Huber_pair.to_valuation_field_cts' hv.2 hv.1 v.2.1

-- Now we need to show that if r1 <= r2 then these to_valuation_field maps
-- are compatible.

theorem to_valuation_field_commutes {r1 r2 : spa.rational_open_data A} {v : spa A}
  (hv1 : v ∈ r1.open_set) (hv2 : v ∈ r2.open_set) (h : r1 ≤ r2) :
  (to_valuation_field hv1) =
  (to_valuation_field hv2) ∘ (spa.rational_open_data.localization_map h) :=
to_valuation_field_commutes r1 r2 h hv1.2 hv2.2

end rational_open_data

end Huber_pair


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.sheaf
import category_theory.sites.limits
import category_theory.limits.functor_category

/-!
# Presheaves in `C` have limits and colimits when `C` does.
-/

noncomputable theory

universes v u

open category_theory
open category_theory.limits

variables {C : Type u} [category.{v} C] {J : Type v} [small_category J]

namespace Top

instance [has_limits C] (X : Top) : has_limits (presheaf C X) :=
limits.functor_category_has_limits_of_size.{v v}

instance [has_colimits C] (X : Top) : has_colimits_of_size.{v} (presheaf C X) :=
limits.functor_category_has_colimits_of_size

instance [has_limits C] (X : Top) : creates_limits (sheaf.forget C X) :=
Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{u v v}

instance [has_limits C] (X : Top) : has_limits_of_size.{v} (sheaf.{v} C X) :=
has_limits_of_has_limits_creates_limits (sheaf.forget C X)

lemma is_sheaf_of_is_limit [has_limits C] {X : Top} (F : J ⥤ presheaf.{v} C X)
  (H : ∀ j, (F.obj j).is_sheaf) {c : cone F} (hc : is_limit c) : c.X.is_sheaf :=
begin
  let F' : J ⥤ sheaf C X := { obj := λ j, ⟨F.obj j, H j⟩, map := λ X Y f, ⟨F.map f⟩ },
  let e : F' ⋙ sheaf.forget C X ≅ F := nat_iso.of_components (λ _, iso.refl _) (by tidy),
  exact presheaf.is_sheaf_of_iso ((is_limit_of_preserves (sheaf.forget C X)
      (limit.is_limit F')).cone_points_iso_of_nat_iso hc e) (limit F').2
end

lemma limit_is_sheaf [has_limits C] {X : Top} (F : J ⥤ presheaf.{v} C X)
  (H : ∀ j, (F.obj j).is_sheaf) : (limit F).is_sheaf :=
is_sheaf_of_is_limit F H (limit.is_limit F)

end Top