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

import order.conditionally_complete_lattice
import field_theory.adjoin
import field_theory.algebraic_closure
import field_theory.galois
import field_theory.primitive_element
import linear_algebra.bilinear_form
import linear_algebra.char_poly.coeff
import linear_algebra.vandermonde
import ring_theory.algebra_tower
import ring_theory.localization

/-!
# Trace for (finite) ring extensions.

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the trace of the linear map given by multiplying by `s` gives information about
the roots of the minimal polynomial of `s` over `R`.

## Implementation notes

Typically, the trace is defined specifically for finite field extensions.
The definition is as general as possible and the assumption that we have
fields or that the extension is finite is added to the lemmas as needed.

We only define the trace for left multiplication (`algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't matter anyway.

## References

 * https://en.wikipedia.org/wiki/Field_trace

-/

universes u v w

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables {A: Type*} [integral_domain A] [algebra A S]
variables [algebra R S] [algebra R T]
variables {K L : Type*} [field K] [field L] [algebra K L]
variables {ι : Type w} [fintype ι]

open finite_dimensional
open intermediate_field
open linear_map
open matrix

open_locale big_operators
open_locale matrix

namespace algebra

variables {b : ι → S} (hb : is_basis R b)

variables (R S)

/-- The trace of an element `s` of an `R`-algebra is the trace of `(*) s`,
as an `R`-linear map. -/
noncomputable def trace : S →ₗ[R] R :=
(linear_map.trace R S).comp (lmul R S).to_linear_map

variables {S}

@[simp] lemma trace_apply (s : S) : trace R S s = linear_map.trace R S (lmul R S s) := rfl

lemma trace_eq_zero_of_not_exists_basis
  (h : ¬ ∃ s : finset S, is_basis R (λ x, x : (↑s : set S) → S)) : trace R S = 0 :=
by { ext s, simp [linear_map.trace, h] }

lemma findim_eq_zero_of_not_exists_basis
  (h : ¬ ∃ s : finset L, is_basis K (λ x, x : (↑s : set L) → L)) : findim K L = 0 :=
dif_neg (mt (λ h, @exists_is_basis_finset K L _ _ _ (finite_dimensional_iff_dim_lt_omega.mpr h)) h)

include hb

variables {R}

lemma trace_eq_matrix_trace [decidable_eq ι] (hb : is_basis R b) (s : S) :
  trace R S s = matrix.trace _ R _ (matrix.lmul hb s) :=
by rw [trace_apply, linear_map.trace_eq_matrix_trace _ hb, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`. -/
lemma trace_algebra_map_of_basis (x : R) :
  trace R S (algebra_map R S x) = fintype.card ι • x :=
begin
  haveI := classical.dec_eq ι,
  rw [trace_apply, linear_map.trace_eq_matrix_trace R hb, trace_diag],
  convert finset.sum_const _,
  ext i,
  simp,
end
omit hb

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`.

(If `L` is not finite-dimensional over `K`, then `trace` and `findim` return `0`.)
-/
@[simp]
lemma trace_algebra_map (x : K) : trace K L (algebra_map K L x) = findim K L • x :=
begin
  by_cases H : ∃ s : finset L, is_basis K (λ x, x : (↑s : set L) → L),
  { rw [trace_algebra_map_of_basis H.some_spec, findim_eq_card_basis H.some_spec] },
  { simp [trace_eq_zero_of_not_exists_basis K H, findim_eq_zero_of_not_exists_basis H] },
end

section trace_form

variables (R S)

/-- The `trace_form` maps `x y : S` to the trace of `x * y`.
It is a symmetric bilinear form and is nondegenerate if the extension is separable. -/
noncomputable def trace_form : bilin_form R S :=
{ bilin := λ x y, trace R S (x * y),
  bilin_add_left := λ x y z, by rw [add_mul, linear_map.map_add],
  bilin_smul_left := λ x y z, by rw [smul_mul_assoc, linear_map.map_smul, smul_eq_mul],
  bilin_add_right := λ x y z, by rw [mul_add, linear_map.map_add],
  bilin_smul_right := λ x y z, by rw [mul_smul_comm, linear_map.map_smul, smul_eq_mul], }

variables {S}

@[simp] lemma trace_form_apply (x y : S) : trace_form R S x y = trace R S (x * y) := rfl

lemma trace_form_is_sym : sym_bilin_form.is_sym (trace_form R S) :=
λ x y, congr_arg (trace R S) (mul_comm _ _)

lemma trace_form_to_matrix [decidable_eq ι] (i j) :
  bilin_form.to_matrix hb (trace_form R S) i j = trace R S (b i * b j) :=
by rw [bilin_form.to_matrix_apply, trace_form_apply]

lemma trace_form_to_matrix_power_basis (h : power_basis R S) :
  bilin_form.to_matrix h.is_basis (trace_form R S) = λ i j, (trace R S (h.gen ^ (i + j : ℕ))) :=
by { ext, rw [trace_form_to_matrix, pow_add] }

end trace_form

end algebra

section trace_eq_sum_roots

variables {b : ι → S} (hb : is_basis R b)

open intermediate_field.adjoin_simple
open algebra

section

open polynomial

lemma matrix.card_le_card_of_left_inv' {m n : ℕ}
  {M : matrix (fin m) (fin n) A} {M' : matrix (fin n) (fin m) A}
  (hMM' : M ⬝ M' = 1) :
  m ≤ n :=
have function.left_inverse
  ((M.map (algebra_map A (fraction_ring A))).mul_vec)
  ((M'.map (algebra_map A (fraction_ring A))).mul_vec) :=
λ x, by rw [mul_vec_mul_vec, ← matrix.map_mul, hMM', matrix.ring_hom_map_one, mul_vec_one],
have function.injective ((M'.map (algebra_map A (fraction_ring A))).to_lin') :=
function.left_inverse.injective this,
calc m = findim (fraction_ring A) (fin m → fraction_ring A) : (findim_fin_fun _).symm
   ... ≤ findim (fraction_ring A) (fin n → fraction_ring A) : findim_le_findim_of_injective this
   ... = n : findim_fin_fun _

lemma matrix.card_le_card_of_left_inv {m n : Type*}
  [fintype m] [decidable_eq m] [fintype n]
  {M : matrix m n A} {M' : matrix n m A} (hMM' : M ⬝ M' = 1) :
  fintype.card m ≤ fintype.card n :=
begin
  haveI : decidable_eq n := classical.dec_eq n,
  let em := trunc.out (fintype.equiv_fin m),
  let en := trunc.out (fintype.equiv_fin n),
  apply @matrix.card_le_card_of_left_inv' A,
  calc reindex_linear_equiv em en M ⬝ reindex_linear_equiv en em M'
      = reindex_linear_equiv em em (M ⬝ M') : reindex_mul em en em M M'
  ... = reindex_linear_equiv em em 1 : by rw hMM'
  ... = 1 : (reindex_alg_equiv em).map_one
end

/-- If an `m × n` matrix has an inverse, then `m = n`. -/
noncomputable def matrix.equiv_of_inv {m n : Type*}
  [fintype m] [decidable_eq m] [fintype n] [decidable_eq n]
   {M : matrix m n A} {M' : matrix n m A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  m ≃ n :=
classical.choice (fintype.card_eq.mp (le_antisymm
  (matrix.card_le_card_of_left_inv hMM')
  (matrix.card_le_card_of_left_inv hM'M)))

/-- If `A'` is a two-sided inverse for `A` (indexed differently), `det (A ⬝ B ⬝ A') = det B`. -/
lemma det_conjugate_aux {m n : Type*} [fintype m] [decidable_eq m]
  [fintype n] [decidable_eq n] {M : matrix m n A} {M' : matrix n m A} {N : matrix n n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N ⬝ M') = det N :=
begin
  -- Although `m` and `n` are different a priori, we will show they have the same cardinality.
  -- This turns the problem into one for square matrices, which is easy.
  let e : m ≃ n := matrix.equiv_of_inv hMM' hM'M,
  have :
    det (reindex_linear_equiv e (equiv.refl _) M ⬝ N ⬝ reindex_linear_equiv (equiv.refl _) e M')
    = det N,
  { rw [det_mul, det_mul, mul_comm, ← mul_assoc, ← det_mul, reindex_mul,
        reindex_linear_equiv_refl_refl, hM'M, det_one, one_mul] },
  convert this,
  rw [← det_reindex_linear_equiv_self e (M ⬝ N ⬝ M'), ← reindex_mul e (equiv.refl n) e,
      ← reindex_mul e (equiv.refl n) (equiv.refl n), reindex_linear_equiv_refl_refl],
end

/-- If `A'` is a two-sided inverse for `A`, `char_poly (A ⬝ B ⬝ A') = char_poly B`. -/
lemma char_poly_conjugate_aux {m n : Type*} [fintype m] [decidable_eq m]
  [fintype n] [decidable_eq n] {M : matrix m n A} {M' : matrix n m A} {N : matrix n n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  char_poly (M ⬝ N ⬝ M') = char_poly N :=
have hCACA' : M.map C ⬝ M'.map C = 1 := by rw [← matrix.map_mul, hMM', matrix.ring_hom_map_one],
have hCA'CA : M'.map C ⬝ M.map C = 1 := by rw [← matrix.map_mul, hM'M, matrix.ring_hom_map_one],
calc (X • 1 - C.map_matrix (M ⬝ N ⬝ M')).det
    = (M.map C ⬝ (scalar n X - N.map C) ⬝ M'.map C).det :
    by rw [matrix.mul_sub, matrix.sub_mul, ring_hom.map_matrix_apply, matrix.map_mul,
           matrix.map_mul, coe_scalar, matrix.mul_smul, matrix.mul_one,
           matrix.smul_mul, hCACA']
... = (X • 1 - C.map_matrix N).det : det_conjugate_aux hCACA' hCA'CA

lemma char_poly_conjugate {n : Type*} [fintype n] [decidable_eq n] {M B : matrix n n A}
  (hM : is_unit M.det) :
  char_poly (M⁻¹ ⬝ B ⬝ M) = char_poly B :=
char_poly_conjugate_aux (nonsing_inv_mul _ hM) (mul_nonsing_inv _ hM)

end

variables {M M' : Type*} [add_comm_group M] [module R M] [add_comm_group M'] [module R M']

section

variables {ι' κ κ' : Type*} [fintype ι'] [decidable_eq ι']
variables [decidable_eq ι] [fintype κ] [fintype κ']
variables {b' : ι' → M} (hb' : is_basis R b')
variables {c : κ → M'} {c' : κ' → M'} (hc : is_basis R c) (hc' : is_basis R c')
variables (f : M →ₗ[R] M')

lemma to_matrix_basis_change
  {b : ι → M} (hb : is_basis R b) :
  to_matrix hb hc f = hc.to_matrix c' ⬝ to_matrix hb' hc' f ⬝ hb'.to_matrix b :=
by rw [is_basis_to_matrix_mul_linear_map_to_matrix, linear_map_to_matrix_mul_is_basis_to_matrix]

end

lemma char_poly_lmul_matrix_basis_invariant [decidable_eq ι]
  {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (hb : is_basis A b) {b' : ι' → S} (hb' : is_basis A b') (x : S) :
  char_poly (matrix.lmul hb x) = char_poly (matrix.lmul hb' x) :=
begin
  change char_poly (to_matrix hb hb (lmul A S x)) = char_poly (to_matrix hb' hb' (lmul A S x)),
  rw [to_matrix_basis_change hb hb' hb, char_poly_conjugate_aux];
    rw [is_basis.to_matrix_mul_to_matrix, is_basis.to_matrix_self];
    assumption
end

section

/-- `(l : M →ₗ[S] M').restrict_base R` is `l` as an `R`-linear map. -/
def linear_map.restrict_base (R : Type*) [comm_semiring R]
  {S M M' : Type*} [semiring S] [algebra R S]
  [add_comm_monoid M] [semimodule R M] [semimodule S M] [is_scalar_tower R S M]
  [add_comm_monoid M'] [semimodule R M'] [semimodule S M'] [is_scalar_tower R S M']
  (l : M →ₗ[S] M') : M →ₗ[R] M' :=
{ map_smul' := λ c x,
    show l (c • x) = c • l x,
    by rw [← is_scalar_tower.algebra_map_smul S c x, l.map_smul, is_scalar_tower.algebra_map_smul],
  .. (l.to_add_monoid_hom) }

@[simp] lemma linear_map.restrict_base_apply
  (R : Type*) {S M M' : Type*} [comm_semiring R] [semiring S] [algebra R S]
  [add_comm_monoid M] [semimodule R M] [semimodule S M] [is_scalar_tower R S M]
  [add_comm_monoid M'] [semimodule R M'] [semimodule S M'] [is_scalar_tower R S M']
  (l : M →ₗ[S] M') (x : M) : l.restrict_base R x = l x := rfl

instance is_scalar_tower.finsupp {α : Type*} : is_scalar_tower R S (α →₀ S) :=
⟨λ r s t, finsupp.ext (λ x, show ((r • s) • t x) = (r • s • t x), by rw smul_assoc)⟩

end

lemma trace_comp_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ] {b : ι → S} {c : κ → T}
  (hb : is_basis R b) (hc : is_basis S c) (x : T) :
  algebra.trace R T x = trace R S (trace S T x) :=
begin
  haveI := classical.dec_eq ι,
  haveI := classical.dec_eq κ,
  rw [trace_eq_matrix_trace (hb.smul hc), trace_eq_matrix_trace hb, trace_eq_matrix_trace hc,
      matrix.trace_apply, matrix.trace_apply, matrix.trace_apply,
      ← finset.univ_product_univ, finset.sum_product],
  refine finset.sum_congr rfl (λ i _, _),
  rw [alg_hom.map_sum, finset.sum_apply, finset.sum_apply],
      refine finset.sum_congr rfl (λ j _, _),
  apply matrix.smul_lmul
end

lemma trace_comp (L : Type*) [field L]
  [algebra K L] [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] (x : T) :
  algebra.trace K T x = trace K L (trace L T x) :=
trace_comp_of_basis
  (classical.some_spec (exists_is_basis_finset K L))
  (classical.some_spec (exists_is_basis_finset L T))
  x

lemma aeval_lmul_matrix [decidable_eq ι] (p : polynomial R) (x : S) :
  polynomial.aeval (matrix.lmul hb x) p = matrix.lmul hb (polynomial.aeval x p) :=
p.aeval_alg_hom_apply (matrix.lmul hb) x

lemma linear_map.injective_iff {V V' : Type*} [add_comm_group V] [add_comm_monoid V']
  [semimodule R V] [semimodule R V']
  (f : V →ₗ[R] V') : function.injective f ↔ ∀ x, f x = 0 → x = 0 :=
f.to_add_monoid_hom.injective_iff

lemma char_poly_lmul_power_basis [algebra K S] (h : power_basis K S) :
  char_poly (matrix.lmul h.is_basis h.gen) = minpoly K h.gen :=
begin
  apply minpoly.unique,
  { apply char_poly_monic },
  { have := matrix.lmul_injective h.is_basis,
    apply (matrix.lmul _).injective_iff.mp this,
    rw [← aeval_lmul_matrix, aeval_self_char_poly] },
  { intros q q_monic root_q,
    rw [char_poly_degree_eq_dim, fintype.card_fin,
        polynomial.degree_eq_nat_degree q_monic.ne_zero],
    apply with_bot.some_le_some.mpr,
    exact h.dim_le_nat_degree_of_root q_monic.ne_zero root_q }
end

section

open polynomial

lemma multiset.sum_const_one {α R : Type*} [semiring R] (s : multiset α) :
  (s.map (λ _, (1 : R))).sum = s.card :=
begin
  refine multiset.induction_on s _ _,
  { rw [multiset.map_zero, multiset.card_zero, multiset.sum_zero],
    norm_cast },
  { intros a s ih,
    rw [multiset.map_cons, multiset.sum_cons, multiset.card_cons, ih, add_comm],
    norm_cast }
end

lemma coeff_prod_X_sub_C {R : Type*} [comm_ring R] [nontrivial R] (s : multiset R) :
  (s.map (λ x, X - C x)).prod.coeff s.card = 1 :=
begin
  have monic : ∀ p ∈ s.map (λ x, X - C x), p.monic,
  { simp only [multiset.mem_map],
    rintros _ ⟨a, ha, rfl⟩,
    exact monic_X_sub_C a },
  have nat_degree_eq' : (nat_degree ∘ λ (x : R), X - C x) = (λ _, 1),
  { ext a,
    exact nat_degree_X_sub_C a },
  have leading_coeff_eq' : (leading_coeff ∘ λ (x : R), X - C x) = (λ _, 1),
  { ext a,
    exact monic_X_sub_C a },

  convert leading_coeff_multiset_prod' _ _,
  { simp [nat_degree_multiset_prod_of_monic _ monic, nat_degree_eq', multiset.sum_const_one] },
  { rw [multiset.map_map, leading_coeff_eq', multiset.prod_map_one] },
  { convert (one_ne_zero : (1 : R) ≠ 0),
    rw [multiset.map_map, leading_coeff_eq', multiset.prod_map_one] },
end

lemma coeff_prod_X_sub_C_of_succ_eq_aux {R : Type*} [comm_ring R] [nontrivial R]
  (a : R) (s : multiset R) :
  ((a ::ₘ s).map (λ x, X - C x)).prod.coeff s.card = - (a ::ₘ s).sum :=
begin
  refine multiset.induction_on s _ (λ b s ih, _),
  { simp only [multiset.map_cons, multiset.map_zero, multiset.prod_cons, multiset.prod_zero,
        mul_one, multiset.sum_cons, multiset.sum_zero, add_zero, multiset.card_zero,
        coeff_sub, coeff_X_zero, coeff_C_zero, zero_sub] },
  rw [multiset.cons_swap a b s, multiset.map_cons, multiset.prod_cons, multiset.sum_cons,
      multiset.card_cons, coeff_mul, finset.nat.antidiagonal_succ, finset.sum_insert, neg_add],
  congr,
  { simp only [coeff_sub, coeff_X_zero, coeff_C_zero, zero_sub],
    rw [← multiset.card_cons a s, coeff_prod_X_sub_C (a ::ₘ s), mul_one] },
  { rw [finset.sum_eq_single (1, s.card), ih, coeff_sub, coeff_X_one, coeff_C,
        if_neg (one_ne_zero : (1 : ℕ) ≠ 0), sub_zero, one_mul],
    { simp only [finset.mem_map],
      rintros _ ⟨⟨i, j⟩, hij, rfl⟩ ij_ne,
      have one_ne : 1 ≠ nat.succ i,
      { intro hi,
        apply ij_ne,
        cases nat.succ_injective hi,
        simp only [finset.nat.mem_antidiagonal, zero_add] at hij,
        cases hij,
        refl },
      simp only [function.embedding.prod_map, function.embedding.coe_fn_mk, prod.map,
          coeff_sub, coeff_X, if_neg one_ne, coeff_C, if_neg (nat.succ_ne_zero i),
          sub_zero, zero_mul] },
    { simp only [finset.mem_map, not_exists],
      intros hx,
      exfalso,
      simpa using hx ⟨0, multiset.card s⟩ } },
  { simp only [finset.mem_map, not_exists],
    rintros ⟨i, j⟩ hij,
    simp [i.succ_ne_zero] }
end

lemma coeff_prod_X_sub_C_of_succ_eq {R : Type*} [comm_ring R] [nontrivial R]
  (s : multiset R) :
  ∀ {i : ℕ} (hi : i + 1 = s.card), (s.map (λ x, X - C x)).prod.coeff i = - s.sum :=
begin
  refine multiset.induction _ _ s,
  { rintros i ⟨⟩ },
  intros a s ih i hi,
  rw [multiset.card_cons, add_left_inj] at hi,
  cases hi,
  exact coeff_prod_X_sub_C_of_succ_eq_aux a s
end

lemma coeff_sub_one_eq {K L : Type*} [field K] [field L]
  {p : polynomial K} {hp : 0 < p.nat_degree} {f : K →+* L} (h : p.splits f) :
  f (p.coeff (p.nat_degree - 1)) = - f (p.leading_coeff) * multiset.sum (p.map f).roots :=
begin
  conv_lhs { rw [← coeff_map, eq_prod_roots_of_splits h] },
  rw [coeff_C_mul, coeff_prod_X_sub_C_of_succ_eq, neg_mul_eq_neg_mul_symm, mul_neg_eq_neg_mul_symm],
  rw [nat.sub_add_cancel hp, nat_degree_eq_card_roots h],
end

end

lemma fin.nonempty {n : ℕ} (hn : 0 < n) : nonempty (fin n) :=
by { cases n, { cases hn }, { exact has_zero.nonempty } }

lemma power_basis.trace_gen_eq_sum_roots {F : Type*} [field F] [algebra K F]
  (pb : power_basis K L)
  (h : polynomial.splits (algebra_map K F) pb.minpoly_gen) :
  algebra_map _ F (algebra.trace K L pb.gen) =
    (pb.minpoly_gen.map (algebra_map K F)).roots.sum :=
begin
  rw [trace_eq_matrix_trace pb.is_basis,
      trace_eq_neg_char_poly_coeff (matrix.lmul _ (power_basis.gen _)),
      char_poly_lmul_power_basis, ← pb.minpoly_gen_eq,
      fintype.card_fin, ← pb.nat_degree_minpoly_gen,
      ring_hom.map_neg, coeff_sub_one_eq h,
      show pb.minpoly_gen.leading_coeff = 1, from pb.minpoly_gen_monic,
      ring_hom.map_one, neg_mul_eq_neg_mul_symm, one_mul, neg_neg],
   { exact pb.nat_degree_minpoly_gen_pos },
   { apply fin.nonempty,
      rw [← pb.nat_degree_minpoly, polynomial.nat_degree_pos_iff_degree_pos],
     exact minpoly.degree_pos pb.is_integral_gen }
end

section

open intermediate_field

lemma trace_gen_eq_sum_roots {F : Type*} [field F] [algebra K F]
  {x : L} (hx : is_integral K x) (h : polynomial.splits (algebra_map K F) (minpoly K x)) :
  algebra_map _ F (algebra.trace K K⟮x⟯ (gen K x)) =
    ((minpoly K x).map (algebra_map K F)).roots.sum :=
begin
  rw ← adjoin.power_basis.minpoly_gen_eq hx at ⊢ h,
  exact power_basis.trace_gen_eq_sum_roots _ h
end

@[simp] lemma multiset.length_to_list {α : Type*} (m : multiset α) :
  m.to_list.length = m.card :=
calc m.to_list.length = multiset.card ↑m.to_list : (multiset.coe_card _).symm
... = m.card : congr_arg _ m.coe_to_list

section conjugates

open polynomial

/-- `alg_hom_of_root (hx : is_integral K x) (hy : aeval y (minpoly hx) = 0)`
is the algebra homomorphism sending `K` to the image of `K` in `F` and `x` to `y`. -/
noncomputable def alg_hom_of_root {F : Type*} [field F] [algebra K F]
  {x : L} (hx : is_integral K x) {y : F} (hy : aeval y (minpoly K x) = 0) :
  ↥K⟮x⟯ →ₐ[K] F :=
(alg_hom_adjoin_integral_equiv _ hx).symm
⟨y, by simpa [mem_roots_map (minpoly.ne_zero hx)] using hy⟩

noncomputable instance algebra_adjoin_splitting_field {x : L} (hx : is_integral K x) :
  algebra ↥K⟮x⟯ (splitting_field (minpoly K x)) :=
(alg_hom_of_root hx (map_root_of_splits _ (splitting_field.splits _)
  (ne_of_gt (minpoly.degree_pos hx)))).to_ring_hom.to_algebra

variables {F : Type*} [field F] [algebra K F] (pb : power_basis K L)
  (hF : pb.minpoly_gen.splits (algebra_map K F))

lemma power_basis.dim_eq_card_roots
  (hF : pb.minpoly_gen.splits (algebra_map K F)) :
  pb.dim = (pb.minpoly_gen.map (algebra_map K F)).roots.card :=
by rw [← power_basis.nat_degree_minpoly_gen, nat_degree_eq_card_roots hF]

@[simp]
lemma multiset.to_list_nodup {α : Type*} {m : multiset α} :
  m.to_list.nodup ↔ m.nodup :=
by rw [← multiset.coe_nodup, m.coe_to_list]

@[simp]
lemma list.sum_nth_le {α β : Type*} [add_comm_monoid β] (l : list α) (f : α → β)
  {n : ℕ} (hn : n = l.length) :
  ∑ i : fin n, f (l.nth_le i (lt_of_lt_of_le i.2 (le_of_eq hn))) = (l.map f).sum :=
begin
  cases hn,
  induction l with a l ih,
  { rw [list.map_nil, list.sum_nil, ← finset.sum_empty, finset.sum_congr _ (λ _ _, rfl)],
    ext i,
    cases i.2 },
  { rw [list.map_cons, list.sum_cons, ← ih rfl, finset.sum_fin_eq_sum_range,
        finset.sum_fin_eq_sum_range],
    conv in (finset.range (a :: l).length)
    { rw list.length_cons a l},
    rw [finset.sum_range_succ', add_comm],
    dsimp only [list.length_cons],
    refine congr (congr_arg (+) _) _,
    { simp [dif_pos (nat.zero_lt_succ _)] },
    { refine finset.sum_congr rfl _,
      intros i hi,
      rw finset.mem_range at hi,
      rw [dif_pos hi, dif_pos (nat.succ_lt_succ hi)],
      refl } },
end

-- TODO: `@[to_additive]` doesn't work
@[simp]
lemma list.prod_nth_le {α β : Type*} [comm_monoid β] (l : list α) (f : α → β)
  {n : ℕ} (hn : n = l.length) :
  ∏ i : fin n, f (l.nth_le i (lt_of_lt_of_le i.2 (le_of_eq hn))) = (l.map f).prod :=
begin
  cases hn,
  induction l with a l ih,
  { rw [list.map_nil, list.prod_nil, ← finset.prod_empty, finset.prod_congr _ (λ _ _, rfl)],
    ext i,
    cases i.2 },
  { rw [list.map_cons, list.prod_cons, ← ih rfl, finset.prod_fin_eq_prod_range,
        finset.prod_fin_eq_prod_range],
    conv in (finset.range (a :: l).length)
    { rw list.length_cons a l},
    rw [finset.prod_range_succ', mul_comm],
    dsimp only [list.length_cons],
    refine congr (congr_arg (*) _) _,
    { simp [dif_pos (nat.zero_lt_succ _)] },
    { refine finset.prod_congr rfl _,
      intros i hi,
      rw finset.mem_range at hi,
      simp only [dif_pos hi, dif_pos (nat.succ_lt_succ hi)],
      refl } },
end

@[simp, to_additive]
lemma multiset.prod_to_list {α : Type*} [comm_monoid α] (m : multiset α) :
  m.to_list.prod = m.prod :=
by rw [← multiset.coe_prod m.to_list, m.coe_to_list]

include hF
/-- `power_basis.conjugates hF` is the vector of all conjugates to the generator of `L / K`,
in a field `F` where `hF` shows the appropriate minimal polynomial splits.

The order of the conjugates is arbitrary.
-/
noncomputable def power_basis.conjugates :
  fin pb.dim → F :=
λ i, (pb.minpoly_gen.map (algebra_map K F)).roots.to_list.nth_le i
  (by simpa [pb.dim_eq_card_roots hF] using i.2)

/-- `power_basis.conjugate_matrix hF` is a Vandermonde matrix of conjugates to
the generator of `L / K`, in a field `F` where `hF` shows the appropriate minimal polynomial splits.

The order of the conjugates is arbitrary.
-/
noncomputable def power_basis.conjugate_matrix :
  matrix (fin pb.dim) (fin pb.dim) F
| i j := pb.conjugates hF j ^ (i : ℕ)

lemma power_basis.conjugates_injective (hpb : pb.minpoly_gen.separable) :
  function.injective (pb.conjugates hF) :=
λ i j h, fin.coe_injective (list.nodup_iff_nth_le_inj.mp
  (multiset.to_list_nodup.mpr (nodup_roots (separable.map hpb)))
  _ _ _ _ h)

lemma sum_conjugates (f : F → R) :
  ∑ i, f (pb.conjugates hF i) = ((pb.minpoly_gen.map (algebra_map K F)).roots.map f).sum :=
begin
  refine trans (list.sum_nth_le _ _ _) _,
  { rw [pb.dim_eq_card_roots hF, multiset.length_to_list] },
  rw [← multiset.coe_sum, ← multiset.coe_map, multiset.coe_to_list]
end

omit hF

/-- A `S`-algebra structure on `T` given by a map fixing `R` gives a tower of algebras. -/
@[priority(100)] -- See note [lower instance priority]
instance algebra_tower_alg_hom (f : S →ₐ[R] T) :
  @is_scalar_tower R S T _ f.to_ring_hom.to_algebra.to_has_scalar _ :=
{ smul_assoc := λ x y z, show f (x • y) • z = x • (f y • z), by rw [f.map_smul, smul_assoc] }

lemma trace_eq_sum_roots [finite_dimensional K L]
  {x : L} (hx : is_integral K x) (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L x) =
    findim ↥K⟮x⟯ L • ((minpoly K x).map (algebra_map K _)).roots.sum :=
begin
  haveI : finite_dimensional K⟮x⟯ L := finite_dimensional.right K _ L,
  rw trace_comp K⟮x⟯ x,
  conv in x { rw [← algebra_map_gen K x] },
  rw [trace_algebra_map, ← is_scalar_tower.algebra_map_smul K, (algebra.trace K K⟮x⟯).map_smul,
      smul_eq_mul, ring_hom.map_mul, ← is_scalar_tower.algebra_map_apply ℕ K _, ← smul_def,
      trace_gen_eq_sum_roots hx hF],
   all_goals { apply_instance }
end

noncomputable instance multiset.fintype_mem {α : Type*} (m : multiset α) :
  fintype {x // x ∈ m} :=
by classical; exact
fintype.of_injective
  (λ x, (⟨x.1, finset.mem_coe.mpr (multiset.mem_to_finset.mpr x.2)⟩ : (m.to_finset : set α)))
  (λ ⟨x, hx⟩ ⟨y, hy⟩ h, by { ext, simpa using h })

@[simp] lemma multiset.univ_mem_zero {α : Type*} :
  (finset.univ : finset {x // x ∈ (0 : multiset α)}) = ∅ :=
by { ext x, cases x with _ hx, cases hx }

@[to_additive, simp] lemma multiset.prod_mem {α M : Type*} [decidable_eq α]
  [comm_monoid M] (m : multiset α) (f : {x // x ∈ m} → M) (g : α → M)
  (hfg : ∀ x, f x = g x) :
  ∏ (x : {x // x ∈ m}), f x = ∏ x in m.to_finset, g x :=
finset.prod_bij (λ x _, x.1) (λ x _, multiset.mem_to_finset.mpr x.2)
  (λ _ _, hfg _)
  (λ _ _ _ _ h, by { ext, assumption })
  (λ y hy, ⟨⟨y, multiset.mem_to_finset.mp hy⟩, finset.mem_univ _, rfl⟩)

/-- Specialize `finset.sum_bij'` to sums over fintypes with an equiv. -/
lemma finset.sum_equiv {M : Type*} [add_comm_monoid M]
  {m n : Type*} [fintype m] [fintype n] (e : m ≃ n) (f : m → M) :
  ∑ x : m, f x = ∑ y : n, f (e.symm y) :=
finset.sum_bij'
  (λ x _, e x) (λ _ _, finset.mem_univ _) (λ _ _, by rw e.symm_apply_apply)
  (λ y _, e.symm y) (λ _ _, finset.mem_univ _) (λ _ _, by rw e.symm_apply_apply)
  (λ _ _, by rw e.apply_symm_apply)

@[simp] lemma adjoin_root_equiv_adjoin_symm_gen {x : L} (h : is_integral K x) :
  (adjoin_root_equiv_adjoin K h).symm (adjoin_simple.gen K x) =
    adjoin_root.root (minpoly K x) :=
(adjoin_root_equiv_adjoin K h).injective (by simp [adjoin_root_equiv_adjoin_apply_root])

@[simp] lemma adjoin_root_equiv_symm_apply_root {f : polynomial K} (hf : f ≠ 0)
  (x : {x // x ∈ (f.map (algebra_map K L)).roots}) :
  (adjoin_root.equiv K L f hf).symm x (adjoin_root.root _) = x :=
by { simp only [adjoin_root.equiv, equiv.coe_fn_symm_mk],
     exact @adjoin_root.lift_root _ _ _ f _ _ _ ((mem_roots_map hf).mp x.2) }

lemma alg_hom_adjoin_integral_equiv_apply
  {x : L} (hx : is_integral K x)
  (y : {y // y ∈ ((minpoly K x).map (algebra_map K F)).roots}) :
  (alg_hom_adjoin_integral_equiv K hx).symm y (gen K x) = y :=
by simp only [alg_hom_adjoin_integral_equiv, equiv.symm_trans_apply,
  adjoin_root_equiv_adjoin_symm_gen, alg_equiv.coe_alg_hom, equiv.coe_fn_symm_mk,
  alg_equiv.to_alg_hom_eq_coe, adjoin_root_equiv_symm_apply_root, alg_hom.comp_apply]

lemma sum_embeddings_gen {M : Type*} [add_comm_monoid M]
  {x : L} (hx : is_integral K x) (hfx : (minpoly K x).separable)
  (f : F → M) :
  @finset.sum _ _ _ (@finset.univ _ (fintype_of_alg_hom_adjoin_integral _ hx))
      (λ σ : ↥K⟮x⟯ →ₐ[K] F, f (σ (adjoin_simple.gen K x)))
    = (((minpoly K x).map (algebra_map K F)).roots.map f).sum :=
begin
  classical,
  rw [finset.sum_equiv (alg_hom_adjoin_integral_equiv K hx), multiset.sum_mem _ _ f],
  { rw [finset.sum_eq_multiset_sum, multiset.to_finset_val,
        multiset.erase_dup_eq_self.mpr (nodup_roots ((separable_map _).mpr hfx))] },
  { intro x,
    rw alg_hom_adjoin_integral_equiv_apply hx }
end

-- TODO: prove this directly assuming `is_power_basis`
lemma trace_eq_sum_embeddings_gen [finite_dimensional K L]
  {x : L} (hx : is_integral K x) (hfx : (minpoly K x).separable)
  (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L x) =
    findim ↥K⟮x⟯ L • @finset.sum _ _ _ (@finset.univ _ (fintype_of_alg_hom_adjoin_integral _ hx))
      (λ σ : ↥K⟮x⟯ →ₐ[K] F, σ (adjoin_simple.gen K x)) :=
by simp_rw [trace_eq_sum_roots hx hF, sum_embeddings_gen hx hfx (λ x, x), multiset.map_id']

/-- Apply an `alg_equiv` to the left side of an `alg_hom`. -/
def alg_hom_congr_left {S' : Type*} (T : Type*) [comm_semiring S'] [algebra R S']
  [comm_semiring T] [algebra R T]
  (e : S ≃ₐ[R] S') : (S →ₐ[R] T) ≃ (S' →ₐ[R] T) :=
{ to_fun := λ f, f.comp e.symm,
  inv_fun := λ f, f.comp e,
  left_inv := λ x,
    by { ext, simp only [alg_equiv.symm_apply_apply, alg_equiv.coe_alg_hom, alg_hom.comp_apply] },
  right_inv := λ x,
    by { ext, simp only [alg_equiv.apply_symm_apply, alg_equiv.coe_alg_hom, alg_hom.comp_apply] } }

@[simp] lemma alg_hom_congr_left_apply {S' T : Type*} [comm_semiring S'] [algebra R S']
  [comm_semiring T] [algebra R T]
  (e : S ≃ₐ[R] S') (f : S →ₐ[R] T) (x : S') : alg_hom_congr_left T e f x = f (e.symm x) :=
rfl

@[simp] lemma alg_hom_congr_left_symm_apply {S' T : Type*} [comm_semiring S'] [algebra R S']
  [comm_semiring T] [algebra R T]
  (e : S ≃ₐ[R] S') (f : S' →ₐ[R] T) (x : S) : (alg_hom_congr_left T e).symm f x = f (e x) :=
rfl

/-- A rephrasing of the primitive element theorem:
in a finite separable field extension, there is an `x` such that `L ≃ K⟮x⟯`. -/
noncomputable def field.equiv_primitive_element (K L : Type*) [field K] [field L] [algebra K L]
  [is_separable K L] [finite_dimensional K L] :
  Σ x : L, L ≃ₐ[K] K⟮x⟯ :=
let f := (@intermediate_field.top_equiv K _ L _ _).symm in
⟨classical.some (field.exists_primitive_element K L),
 by rwa ← classical.some_spec (field.exists_primitive_element K L) at f⟩

/-- If `L` has a power basis over `K`, there are finitely many maps `L → F` fixing `K`. -/
noncomputable def power_basis.fintype_alg_hom (pb : power_basis K L) :
  fintype (L →ₐ[K] F) :=
@fintype.of_equiv _ (K⟮pb.gen⟯ →ₐ[K] F)
  (fintype_of_alg_hom_adjoin_integral _ pb.is_integral_gen)
  (alg_hom_congr_left F pb.equiv_adjoin_simple)

lemma finite_dimensional.is_integral (K : Type*) [field K] [algebra K L] [finite_dimensional K L]
  (x : L) : is_integral K x :=
((is_algebraic_iff_is_integral K).mp (is_algebraic_of_finite x))

noncomputable instance alg_hom.fintype_of_separable
  [hsep : is_separable K L] [finite_dimensional K L] :
  fintype (L →ₐ[K] F) :=
@fintype.of_equiv _ (K⟮(field.equiv_primitive_element K L).1⟯ →ₐ[K] F)
  (fintype_of_alg_hom_adjoin_integral _ (finite_dimensional.is_integral _ _))
  (alg_hom_congr_left F (field.equiv_primitive_element K L).2.symm)

noncomputable instance adjoin.fintype_alg_hom_of_finite_dimensional (x : L)
  [finite_dimensional K L] :
  fintype (K⟮x⟯ →ₐ[K] F) :=
power_basis.fintype_alg_hom
  (intermediate_field.adjoin.power_basis (finite_dimensional.is_integral _ _))

-- TODO: to_additive this from prod_surj
lemma finset.sum_eq_card_smul {α β : Type*} [decidable_eq β]
  (f : α → β) {M : Type*} [add_comm_monoid M] (gf : α → M) (g : β → M)
  (s : finset α) (t : finset β)
  (hf : ∀ x ∈ s, f x ∈ t) (hgf : ∀ x ∈ s, gf x = g (f x)) (n : ℕ)
  (hcard : ∀ y ∈ t, (s.filter (λ x, f x = y)).card = n) :
  ∑ x in s, gf x = n • (∑ y in t, g y) :=
calc ∑ x in s, gf x = ∑ x in s, g (f x) : finset.sum_congr rfl hgf
... = ∑ y in finset.image f s, (s.filter (λ x, f x = y)).card • g y : finset.sum_comp g f
... = ∑ y in t, (s.filter (λ x, f x = y)).card • g y :
  finset.sum_subset
    (λ y hy, by { rcases finset.mem_image.mp hy with ⟨x, hx, rfl⟩, exact hf x hx })
    (λ y hyt hys, (by { have := mt (finset.fiber_card_ne_zero_iff_mem_image _ _ _).mp hys,
                        rw [ne.def, not_not] at this,
                        rw [this, zero_smul] }))
... = ∑ y in t, n • g y : finset.sum_congr rfl (λ y hy, by rw hcard y hy)
... = n • ∑ y in t, g y : finset.smul_sum.symm

lemma adjoin_root.nontrivial {R : Type*} [integral_domain R]
  {f : polynomial R} (hf : 0 < degree f) :
  nontrivial (adjoin_root f) :=
⟨⟨0, 1, λ h,
  begin
    apply not_le_of_gt (nat_degree_pos_iff_degree_pos.mpr hf),
    simpa using nat_degree_le_of_dvd ((adjoin_root.mk_eq_mk _ _ _).mp h) (by simp),
  end ⟩⟩

/-- Algebra homomorphism `F⟮α⟯ →ₐ[F] K` are in bijection with the set of roots
of `minpoly α` in `K`. -/
noncomputable def power_basis.alg_hom_adjoin_equiv (pb : power_basis K L) :
  (L →ₐ[K] F) ≃ {x // x ∈ (pb.minpoly_gen.map (algebra_map K F)).roots} :=
begin
  haveI : nontrivial (adjoin_root pb.minpoly_gen) :=
    adjoin_root.nontrivial pb.degree_minpoly_gen_pos,
  let ϕ := (adjoin_root.power_basis pb.minpoly_gen_ne_zero).equiv pb _,
  { let swap1 : (L →ₐ[K] F) ≃ (adjoin_root pb.minpoly_gen →ₐ[K] F) :=
      { to_fun := λ f, f.comp ϕ.to_alg_hom,
        inv_fun := λ f, f.comp ϕ.symm.to_alg_hom,
        left_inv := λ _, by { ext, simp only [alg_equiv.coe_alg_hom,
        alg_equiv.to_alg_hom_eq_coe, alg_hom.comp_apply, alg_equiv.apply_symm_apply]},
        right_inv := λ _, by { ext, simp only [alg_equiv.symm_apply_apply,
        alg_equiv.coe_alg_hom, alg_equiv.to_alg_hom_eq_coe, alg_hom.comp_apply] } },
    let swap2 := adjoin_root.equiv K F pb.minpoly_gen pb.minpoly_gen_ne_zero,
    exact swap1.trans swap2 },
  rw [adjoin_root.minpoly_gen_eq _ pb.minpoly_gen_monic],
  { rw pb.minpoly_gen_eq, exact minpoly.irreducible pb.is_integral_gen }
end

-- generalizes card_alg_hom_adjoin_integral
-- TODO: merge this with the field.adjoin version
lemma power_basis.card_alg_hom (pb : power_basis K L)
  (h_sep : pb.minpoly_gen.separable)
  (h_splits : pb.minpoly_gen.splits (algebra_map K F)) :
  @fintype.card (L →ₐ[K] F) pb.fintype_alg_hom = pb.dim :=
begin
  classical,
  let s := (pb.minpoly_gen.map (algebra_map K F)).roots.to_finset,
  have H := λ x, multiset.mem_to_finset,
  rw [fintype.card_congr pb.alg_hom_adjoin_equiv, fintype.card_of_subtype s H,
      multiset.to_finset_card_of_nodup, ← nat_degree_eq_card_roots h_splits,
      pb.nat_degree_minpoly_gen],
  exact polynomial.nodup_roots h_sep.map
end

lemma polynomial.splits_of_is_alg_closed (L : Type*) [field L] [algebra K L]
  [is_alg_closed L] (f : polynomial K) :
  f.splits (algebra_map K L) :=
begin
  convert (splits_map_iff _ (ring_hom.id L)).mp (f.map (algebra_map K L)).splits',
  exact (ring_hom.id_comp _).symm
end

lemma alg_hom.to_linear_map_injective :
  function.injective (alg_hom.to_linear_map : (L →ₐ[K] F) → (L →ₗ[K] F)) :=
λ f g h, alg_hom.ext (λ x, by rw [← f.to_linear_map_apply, h, g.to_linear_map_apply])

lemma power_basis.alg_hom_ext (pb : power_basis K L) (f g : L →ₐ[K] F)
  (h : f pb.gen = g pb.gen) : f = g :=
alg_hom.to_linear_map_injective (pb.is_basis.ext (λ i,
  by rw [f.to_linear_map_apply, g.to_linear_map_apply, alg_hom.map_pow, alg_hom.map_pow, h]))

lemma is_scalar_tower.restrict_base_injective {A B : Type*}
  [semiring A] [semiring B]
  [algebra R A] [algebra S A] [algebra R B] [algebra S B]
  [is_scalar_tower R S A] [is_scalar_tower R S B] :
  function.injective (is_scalar_tower.restrict_base R : (A →ₐ[S] B) → (A →ₐ[R] B)) :=
λ f g h, alg_hom.ext (λ x,
  by rw [← is_scalar_tower.restrict_base_apply R f x, h, is_scalar_tower.restrict_base_apply])

@[simp] lemma intermediate_field.algebra_map_mk (S : intermediate_field K L)
  {x : L} (hx : x ∈ S) : algebra_map S L ⟨x, hx⟩ = x := rfl

@[simp] lemma intermediate_field.algebra_map_algebra_map (S : intermediate_field K L)
  [algebra S F] [is_scalar_tower K S F] (x : K) :
  algebra_map S F ⟨algebra_map K L x, S.algebra_map_mem x⟩ = algebra_map K F x :=
by { rw [is_scalar_tower.algebra_map_apply K S F], refl }

/-- If `f` fixes `K` and `x`, then `f` fixes `K⟮x⟯`. -/
def intermediate_field.adjoin.extend_base (x : L) [algebra K⟮x⟯ F] [is_scalar_tower K K⟮x⟯ F]
  (f : L →ₐ[K] F) (hf : f x = algebra_map _ _ (gen K x)) :
  L →ₐ[K⟮x⟯] F :=
{ commutes' := begin
    rintro ⟨r, hr⟩,
    simp only [intermediate_field.algebra_map_mk, ring_hom.to_fun_eq_coe, alg_hom.coe_to_ring_hom],
    suffices : ∃ hr, f r = algebra_map K⟮x⟯ F ⟨r, hr⟩,
    { obtain ⟨_, h⟩ := this,
      exact h },
    refine intermediate_field.adjoin_induction K hr _ _ _ _ _ _,
    { rintros x' (hx' | hx'), exact ⟨intermediate_field.subset_adjoin K _ H, hf⟩ },
    { rintros c,
      use K⟮x⟯.algebra_map_mem c,
      simp only [f.commutes],
      apply (K⟮x⟯.algebra_map_algebra_map c).symm.trans _, assumption, assumption,
      congr },
    { rintros a b ⟨ha, a_eq⟩ ⟨hb, b_eq⟩,
      use K⟮x⟯.add_mem ha hb,
      simp only [f.map_add, a_eq, b_eq, ← ring_hom.map_add],
      congr },
    { rintros a ⟨ha, a_eq⟩,
      use K⟮x⟯.neg_mem ha,
      simp only [f.map_neg, a_eq, ← ring_hom.map_neg],
      congr },
    { rintros a ⟨ha, a_eq⟩,
      use K⟮x⟯.inv_mem ha,
      simp only [f.map_inv, a_eq, ← ring_hom.map_inv],
      congr },
    { rintros a b ⟨ha, a_eq⟩ ⟨hb, b_eq⟩,
      use K⟮x⟯.mul_mem ha hb,
      simp only [f.map_mul, a_eq, b_eq, ← ring_hom.map_mul],
      congr },
  end,
  .. (f : L →+* F) }

@[simp]
lemma restrict_base_extend_base (x : L) [algebra K⟮x⟯ F] [is_scalar_tower K K⟮x⟯ F]
  (f : L →ₐ[K] F) (hf : f x = algebra_map _ _ (gen K x)) :
  is_scalar_tower.restrict_base K (intermediate_field.adjoin.extend_base x f hf) = f :=
by { ext, refl }

lemma card_filter_apply_eq [decidable_eq F] [is_alg_closed F]
  [is_separable K L] [finite_dimensional K L]
  (x : L) (hx : is_integral K x) (y : F)
  (hy : aeval y ((intermediate_field.adjoin.power_basis hx).minpoly_gen) = 0) :
  (finset.univ.filter (λ (σ : L →ₐ[K] F), σ x = y)).card = findim K⟮x⟯ L :=
begin
  let pb : power_basis K L := field.power_basis_of_finite_of_separable K L,
  let emb_y : K⟮x⟯ →ₐ[K] F := (intermediate_field.adjoin.power_basis hx).lift y hy,
  letI : algebra K⟮x⟯ F := (emb_y : K⟮x⟯ →+* F).to_algebra,
  haveI : is_scalar_tower K K⟮x⟯ F := is_scalar_tower.of_algebra_map_eq
    (λ x, (emb_y.commutes x).symm),

  have emb_y_gen : emb_y (adjoin_simple.gen K x) = y,
  { rw [← adjoin.power_basis.gen_eq hx, (intermediate_field.adjoin.power_basis hx).lift_gen] },
  have algebra_map_gen : algebra_map _ F (adjoin_simple.gen K x) = y := emb_y_gen,

  haveI sep_x : is_separable K⟮x⟯ L :=
    is_separable_tower_top_of_is_separable K K⟮x⟯ L,
  let pb_x : power_basis K⟮x⟯ L := field.power_basis_of_finite_of_separable _ L,
  letI : fintype (L →ₐ[K⟮x⟯] F) := pb_x.fintype_alg_hom,

  calc (finset.univ.filter (λ (σ : L →ₐ[K] F), σ x = y)).card
      = fintype.card (L →ₐ[K⟮x⟯] F) :
        (finset.card_congr (λ f _, is_scalar_tower.restrict_base K f) _ _ _).symm
  ... = pb_x.dim : pb_x.card_alg_hom _ _
  ... = findim ↥K⟮x⟯ L : pb_x.findim.symm,
  { intros f _,
    simp only [finset.mem_filter, finset.mem_univ, true_and, is_scalar_tower.restrict_base_apply,
               ← adjoin_simple.algebra_map_gen K x, f.commutes, algebra_map_gen] },
  { intros f g _ _ h,
    ext x,
    rw is_scalar_tower.restrict_base_injective h },
  { intros f hf,
    simp only [finset.mem_filter, finset.mem_univ, true_and] at hf,
    refine ⟨intermediate_field.adjoin.extend_base _ f (hf.trans algebra_map_gen.symm),
            finset.mem_univ _,
            _⟩,
    simp },
  { rw [pb_x.minpoly_gen_eq], apply is_separable.separable },
  { apply polynomial.splits_of_is_alg_closed },
end

lemma sum_embeddings_eq_findim_mul [is_alg_closed F]
  [finite_dimensional K L] [hsep : is_separable K L]
  {x : L} (hx : is_integral K x) :
  ∑ σ : L →ₐ[K] F, (σ x) = findim K⟮x⟯ L •
    @finset.sum _ _ _ (@finset.univ _ (fintype_of_alg_hom_adjoin_integral _ hx))
      (λ σ : ↥K⟮x⟯ →ₐ[K] F, σ (adjoin_simple.gen K x)) :=
begin
  classical,
  letI : fintype (K⟮x⟯ →ₐ[K] F) := fintype_of_alg_hom_adjoin_integral _ hx,
  apply finset.sum_eq_card_smul (λ σ : L →ₐ[K] F, σ.comp (is_scalar_tower.to_alg_hom K K⟮x⟯ L)),
  { intros, apply finset.mem_univ },
  { intros σ hσ,
    simp only [alg_hom.comp_apply, is_scalar_tower.to_alg_hom_apply, algebra_map_gen] },
  intros σ' _,
  rw ← card_filter_apply_eq x hx (σ' (adjoin_simple.gen K x)),
  apply finset.card_congr (λ σ _, σ),
  { intros σ hσ,
    simp only [finset.mem_filter, finset.mem_univ, true_and] at ⊢ hσ,
    simp only [← hσ, alg_hom.comp_apply, is_scalar_tower.to_alg_hom_apply, algebra_map_gen] },
  { intros σ τ hσ hτ h,
    exact h },
  { intros σ hσ,
    refine ⟨σ, _, rfl⟩,
    simp only [finset.mem_filter, finset.mem_univ, true_and] at ⊢ hσ,
    apply (intermediate_field.adjoin.power_basis hx).alg_hom_ext,
    simp only [← hσ, alg_hom.comp_apply, is_scalar_tower.to_alg_hom_apply,
               intermediate_field.adjoin.power_basis.gen_eq, algebra_map_gen] },
  { rw [aeval_alg_hom, alg_hom.comp_apply, ← intermediate_field.adjoin.power_basis.gen_eq,
        (intermediate_field.adjoin.power_basis hx).aeval_minpoly_gen, σ'.map_zero] }
end

section

lemma power_basis.sum_embeddings_gen [is_separable K L] (f : F → R) :
  ∑ σ in (@finset.univ _ (@alg_hom.fintype_of_separable _ _ _ _ _ _ _ _ _
      pb.finite_dimensional)),
    f (σ pb.gen) =
    ((pb.minpoly_gen.map (algebra_map K F)).roots.map f).sum :=
begin
  haveI := pb.finite_dimensional,
  haveI : fintype (↥K⟮pb.gen⟯ →ₐ[K] F) :=
    fintype_of_alg_hom_adjoin_integral _ pb.is_integral_gen,
  convert sum_embeddings_gen pb.is_integral_gen _ f using 1,
  { rw finset.sum_equiv (alg_hom_congr_left F pb.equiv_adjoin_simple.symm),
    convert finset.sum_congr rfl (λ x _, _),
    rw [alg_hom_congr_left_symm_apply, power_basis.equiv_adjoin_simple_symm_gen] },
  { rw pb.minpoly_gen_eq },
  { apply is_separable.separable }
end

lemma power_basis.trace_gen_eq_sum_embeddings [is_separable K L]
  (hF : pb.minpoly_gen.splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L pb.gen) =
    ∑ σ in (@finset.univ _
        (@alg_hom.fintype_of_separable _ _ _ _ _ F _ _ _ pb.finite_dimensional)),
      σ pb.gen :=
by simp only [pb.trace_gen_eq_sum_roots hF, pb.sum_embeddings_gen (λ x, x), multiset.map_id']

end

section
variables (K)

-- TODO: go via `power_basis` instead of adjoin K x
lemma trace_eq_sum_embeddings
  [is_alg_closed F] [finite_dimensional K L] [is_separable K L]
  {x : L} (hx : is_integral K x) :
  algebra_map K F (algebra.trace K L x) = ∑ σ : L →ₐ[K] F, σ x :=
by { rw trace_eq_sum_embeddings_gen hx (is_separable.separable K x)
          (polynomial.splits_of_is_alg_closed F _),
     exact (sum_embeddings_eq_findim_mul hx).symm }
end

lemma algebraic_closure.splits (f : polynomial K) :
  f.splits (algebra_map K (algebraic_closure K)) :=
f.splits_of_is_alg_closed (algebraic_closure K)

lemma trace_form_gen_pow_gen_pow
  [is_alg_closed F] [is_separable K L] [finite_dimensional K L]
  (i j : ℕ) :
  algebra_map K F (trace_form K L (pb.gen ^ i) (pb.gen ^ j)) =
    ((pb.minpoly_gen.map (algebra_map K F)).roots.map (λ x, x ^ i * x ^ j)).sum :=
calc algebra_map K F (trace_form K L (pb.gen ^ i) (pb.gen ^ j))
    = algebra_map K F (trace K L (pb.gen ^ (i + j))) : by rw [pow_add, trace_form_apply]
... = ∑ (σ : L →ₐ[K] F), σ (pb.gen ^ (i + j)) :
  trace_eq_sum_embeddings _ (is_integral_pow _ pb.is_integral_gen)
... = ∑ (σ : L →ₐ[K] F), (σ pb.gen) ^ i * (σ pb.gen) ^ j :
  by simp only [pow_add, alg_hom.map_mul, alg_hom.map_pow]
... = ((pb.minpoly_gen.map (algebra_map K F)).roots.map (λ x, x ^ i * x ^ j)).sum :
  by rw ← pb.sum_embeddings_gen (λ x, x ^ i * x ^ j)

lemma conjugate_matrix_mul_conjugate_matrix [is_separable K L] :
  (pb.conjugate_matrix (algebraic_closure.splits _)) ⬝
    (pb.conjugate_matrix (algebraic_closure.splits _))ᵀ =
    ((bilin_form.to_matrix pb.is_basis (trace_form K L)).map
      (algebra_map K (algebraic_closure K))) :=
begin
  ext i k,
  simp only [matrix.mul_apply, map_apply, trace_form_to_matrix_power_basis, transpose_apply,
             power_basis.conjugate_matrix],

  haveI := pb.finite_dimensional,
  rw trace_eq_sum_embeddings K (is_integral_pow (i + k) pb.is_integral_gen),
  { simp only [← pow_add, alg_hom.map_pow],
    refine trans (sum_conjugates pb (algebraic_closure.splits _) (λ x, x ^ (i + k : ℕ))) _,
    exact (pb.sum_embeddings_gen (λ x, x ^ (i + k : ℕ))).symm },
  { apply algebraic_closure.is_alg_closed }
end

@[simp] lemma det_conjugate_matrix :
  (pb.conjugate_matrix hF).det = ∏ (i : fin pb.dim),
    ∏ j in finset.univ.filter (λ (j : fin pb.dim), i < j),
      (pb.conjugates hF j - pb.conjugates hF i) :=
matrix.det_vandermonde _

lemma sum_repr (x : S) : ∑ i, hb.repr x i • b i = x :=
begin
  convert hb.total_repr x using 1,
  rw finsupp.total_apply,
  refine (finset.sum_subset (finset.subset_univ _) (λ i _ hi, _)).symm,
  rw [finsupp.not_mem_support_iff.mp hi, zero_smul]
end

lemma lmul_one : lmul R S 1 = linear_map.id :=
by { ext, simp }

@[simp] lemma det_map {R S : Type*} [comm_ring R] [comm_ring S]
  {n : Type*} [fintype n] [decidable_eq n] (f : R →+* S) (M : matrix n n R) :
  (M.map f).det = f M.det :=
by { unfold det, simp only [f.map_sum, f.map_mul, f.map_prod, f.map_int_cast, map_apply] }

lemma det_trace_form_ne_zero' [is_separable K L] :
  det (bilin_form.to_matrix pb.is_basis (trace_form K L)) ≠ 0 :=
begin
  suffices : algebra_map K (algebraic_closure K)
    (det (bilin_form.to_matrix pb.is_basis (trace_form K L))) ≠ 0,
  { refine mt (λ ht, _) this,
    rw [ht, ring_hom.map_zero] },
  have hF := algebraic_closure.splits _,
  calc algebra_map K (algebraic_closure K) (det _)
      = det (pb.conjugate_matrix hF ⬝ (pb.conjugate_matrix hF)ᵀ) : _
  ... = det (pb.conjugate_matrix hF) ^ 2 : by simp [pow_two]
  ... = (∏ (i : fin pb.dim), ∏ j in finset.univ.filter (λ (j : fin pb.dim), i < j),
          (pb.conjugates hF j - pb.conjugates hF i)) ^ 2 : by rw det_conjugate_matrix pb
  ... ≠ 0 : _,
  { rw [← det_map, conjugate_matrix_mul_conjugate_matrix] },
  { simp only [pow_two, ne.def, mul_self_eq_zero, finset.prod_eq_zero_iff, not_exists, sub_eq_zero],
    intros i _ j hj,
    refine mt (λ hij, pb.conjugates_injective hF _ hij) (ne_of_lt (finset.mem_filter.mp hj).2).symm,
    rw pb.minpoly_gen_eq,
    exact is_separable.separable K pb.gen }
end

lemma det_transpose_mul_mul_self {n m : Type*} [fintype m] [fintype n]
  [decidable_eq m] [decidable_eq n]
  {A : matrix n n K} {B : matrix n m K} {C : matrix m n K} (hBC : B ⬝ C = 1) (hCB : C ⬝ B = 1) :
  det (Bᵀ ⬝ A ⬝ B) = det (B ⬝ Bᵀ) * det A :=
begin
  rw ← det_conjugate_aux hBC hCB,
  calc (B ⬝ (Bᵀ ⬝ A ⬝ B) ⬝ C).det = ((B ⬝ Bᵀ) ⬝ (A ⬝ (B ⬝ C))).det : by simp only [matrix.mul_assoc]
                           ... = ((B ⬝ Bᵀ) ⬝ A).det : by rw [hBC, matrix.mul_one]
                           ... = det (B ⬝ Bᵀ) * det A : matrix.det_mul _ _
end

lemma det_trace_form_ne_zero  [is_separable K L] [decidable_eq ι] {b : ι → L} (hb : is_basis K b) :
  det (bilin_form.to_matrix hb (trace_form K L)) ≠ 0 :=
begin
  haveI : finite_dimensional K L := finite_dimensional.of_fintype_basis hb,
  let pb : power_basis K L := field.power_basis_of_finite_of_separable _ _,
  have hph : pb.is_basis.to_matrix b ⬝ hb.to_matrix (λ i : fin pb.dim, pb.gen ^ (i : ℕ)) = 1,
  { apply (matrix.to_lin pb.is_basis pb.is_basis).injective,
    rw [matrix.to_lin_mul pb.is_basis hb pb.is_basis, is_basis.to_lin_to_matrix,
        is_basis.to_lin_to_matrix, id_comp, to_lin_one] },
  have hhp : hb.to_matrix (λ i : fin pb.dim, pb.gen ^ (i : ℕ)) ⬝ pb.is_basis.to_matrix b = 1,
  { apply (matrix.to_lin hb hb).injective,
    rw [matrix.to_lin_mul hb pb.is_basis hb, is_basis.to_lin_to_matrix, is_basis.to_lin_to_matrix,
        id_comp, to_lin_one] },
  rw [← bilin_form.to_matrix_basis_change hb pb.is_basis, det_transpose_mul_mul_self hph hhp],
  apply mul_ne_zero (is_unit.ne_zero _) (det_trace_form_ne_zero' pb),
  apply is_unit_det_of_left_inverse _ (_ᵀ ⬝ _),
  rw [matrix.mul_assoc, ← matrix.mul_assoc _ (pb.is_basis.to_matrix b), hhp, matrix.one_mul,
      ← matrix.transpose_mul, hph, matrix.transpose_one],
end

end conjugates

end

end trace_eq_sum_roots

section dual_basis

open algebra

variables [decidable_eq ι] {b : ι → L} (hb : is_basis K b)

lemma nonsing_inv_det_zero (A : matrix ι ι K) (hA : det A = 0) :
  A⁻¹ = 0 :=
begin
  unfold has_inv.inv nonsing_inv,
  rw [hA, dif_neg not_is_unit_zero],
  apply_instance
end

lemma det_inv_ne_zero {A : matrix ι ι K} :
  det (A⁻¹) ≠ 0 ↔ det A ≠ 0 :=
begin
  by_cases hι : nonempty ι,
  swap,
  { have : fintype.card ι = 0,
    { rw fintype.card_eq_zero_iff, exact λ i, hι ⟨i⟩ },
    simp only [matrix.det_eq_one_of_card_eq_zero, matrix.det_eq_one_of_card_eq_zero this] },

  by_cases hA : det A = 0,
  { simp [hA, nonsing_inv_det_zero A hA, matrix.det_zero hι] },
  simp only [hA, ne.def, not_false_iff, iff_true],
  exact is_unit_iff_ne_zero.mp (is_unit_nonsing_inv_det A (is_unit.mk0 _ hA)),
end

include hb

/-- If `pb` is a power basis for the finite separable field extension `L / K`,
`dual_basis pb` is another basis such that
`trace_form (pb.gen ^ i) (dual_basis pb j) = if i = j then 1 else 0`. -/
noncomputable def dual_basis : ι → L :=
λ i, matrix.to_lin hb hb
  (bilin_form.to_matrix hb (trace_form K L))⁻¹ (b i)

lemma dual_basis_apply (i : ι) :
  dual_basis hb i = matrix.to_lin hb hb
    (bilin_form.to_matrix hb (trace_form K L))⁻¹ (b i) :=
rfl

lemma trace_form_dual_basis_power_basis [is_separable K L] (i j : ι) :
  trace_form K L (b i) (dual_basis hb j) = (1 : matrix _ _ K) i j :=
calc trace_form K L (b i) (dual_basis hb j)
    = ((bilin_form.to_matrix hb (trace_form K L)) ⬝
       (bilin_form.to_matrix hb (trace_form K L))⁻¹) i j :
  by simp_rw [dual_basis, ← bilin_form.comp_right_apply,
              bilin_form.to_matrix_mul hb, bilin_form.to_matrix_apply]
... = (1 : matrix _ _ K) i j :
  by rw matrix.mul_nonsing_inv _ (is_unit.mk0 _ (det_trace_form_ne_zero hb))

lemma trace_dual_basis_mul_power_basis [is_separable K L] (i j : ι) :
  algebra.trace K L (b i * dual_basis hb j) = if i = j then 1 else 0 :=
trace_form_dual_basis_power_basis hb i j

lemma is_basis_dual_basis [is_separable K L] :
  is_basis K (dual_basis hb) :=
  let e : L ≃ₗ[K] L := linear_equiv.of_bijective
    (matrix.to_lin hb hb (bilin_form.to_matrix hb (trace_form K L))⁻¹)
    (matrix.ker_to_lin_eq_bot hb _ (det_inv_ne_zero.mpr (det_trace_form_ne_zero _)))
    (matrix.range_to_lin_eq_top hb _ (det_inv_ne_zero.mpr (det_trace_form_ne_zero _)))
    in
@linear_equiv.is_basis ι _ _ _ _ _ _ _ _ _ hb e

lemma trace_gen_pow_mul [is_separable K L] (x : L) (i : ι) :
  algebra.trace K L (b i * x) = (is_basis_dual_basis hb).repr x i :=
begin
  calc algebra.trace K L (b i * x)
      = algebra.trace K L (b i * (∑ j, (is_basis_dual_basis hb).repr x j • dual_basis hb j)) :
    by rw sum_repr
  ... = algebra.trace K L (∑ j, (is_basis_dual_basis hb).repr x j • (b i * dual_basis hb j)) :
    by simp_rw [finset.mul_sum, mul_smul_comm]
  ... = ∑ j, (is_basis_dual_basis hb).repr x j • algebra.trace K L (b i * dual_basis hb j) :
    by simp_rw [linear_map.map_sum, linear_map.map_smul]
  ... = (is_basis_dual_basis hb).repr x i * algebra.trace K L (b i * dual_basis hb i) :
    finset.sum_eq_single _ _ _
  ... = (is_basis_dual_basis hb).repr x i :
    by rw [trace_dual_basis_mul_power_basis, if_pos rfl, mul_one],

  { intros j _ ne,
    rw [trace_dual_basis_mul_power_basis, if_neg ne.symm, smul_zero] },
  { intro not_mem_univ,
    have := finset.mem_univ i,
    contradiction }
end

end dual_basis

section trace_mem

open polynomial

variables {F : Type*} [field F] [algebra R L] [algebra L F] [algebra R F] [is_scalar_tower R L F]

lemma is_integral.nat_smul (n : ℕ) (x : F) (hx : is_integral R x) : is_integral R (n • x) :=
begin
  rw [algebra.smul_def, is_scalar_tower.algebra_map_apply ℕ R F],
  exact is_integral_mul is_integral_algebra_map hx,
end

lemma is_integral.multiset_sum (m : multiset F) :
  (∀ x ∈ m, is_integral R x) → is_integral R m.sum :=
begin
  refine m.induction _ _,
  { intros, simpa only [multiset.sum_zero] using is_integral_zero },
  { intros x m ih h,
    simpa [multiset.sum_cons] using
      is_integral_add
        (h x (multiset.mem_cons_self x m))
        (ih (λ x hx, h x (multiset.mem_cons.mpr (or.inr hx)))) }
end

lemma eval₂_dvd {R S : Type*} [semiring R] [comm_semiring S]
  {f : R →+* S} {p q : polynomial R} {x : S}
  (hpq : p ∣ q) : eval₂ f x p ∣ eval₂ f x q :=
begin
  rcases hpq with ⟨q, rfl⟩,
  exact ⟨eval₂ f x q, eval₂_mul f x⟩,
end

lemma eval₂_eq_zero_of_dvd_of_eval₂_eq_zero {R S : Type*} [semiring R] [comm_semiring S]
  {f : R →+* S} {p q : polynomial R} {x : S}
  (hpq : p ∣ q) (hxp : eval₂ f x p = 0) : eval₂ f x q = 0 :=
zero_dvd_iff.mp (dvd_trans (zero_dvd_iff.mpr hxp) (eval₂_dvd hpq))

lemma is_integral_trace [finite_dimensional L F] {x : F} (hx : is_integral R x) :
  is_integral R (algebra.trace L F x) :=
begin
  have hx' : is_integral L x := is_integral_of_is_scalar_tower _ hx,
  letI : algebra L (algebraic_closure F) := ((algebra_map F _).comp (algebra_map _ F)).to_algebra,
  letI : algebra R (algebraic_closure F) := ((algebra_map L _).comp (algebra_map _ L)).to_algebra,
  letI : is_scalar_tower L F (algebraic_closure F) := is_scalar_tower.of_algebra_map_eq (λ x, rfl),
  letI : is_scalar_tower R L (algebraic_closure F) := is_scalar_tower.of_algebra_map_eq (λ x, rfl),
  apply (is_integral_algebra_map_iff (algebra_map L (algebraic_closure F)).injective).mp,
  rw trace_eq_sum_roots hx',
  { apply is_integral.nat_smul,
    apply is_integral.multiset_sum,
    intros y hy,
    rw mem_roots_map (minpoly.ne_zero hx') at hy,
    use [minpoly R x, minpoly.monic hx],
    rw [← aeval_def, is_scalar_tower.aeval_apply R L, aeval_def],
    apply eval₂_eq_zero_of_dvd_of_eval₂_eq_zero (minpoly.dvd L x _) hy,
    rw ← is_scalar_tower.aeval_apply R L,
    apply minpoly.aeval },
  { apply splits_of_is_alg_closed },
  { apply_instance }
end

end trace_mem


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

Suppose we have two types α and β with decidable equality, and
an equivalence between them (as defined in
mathlib/data/equiv/basic.lean).  We then get an equivalence
between the associated types (finset α) and (finset β) of finite
subsets, and this equivalence respects membership, inclusion,
intersections and unions and various other kinds of structure.
In this file we prove a variety of facts of that type.

All this should probably be done in some more abstract and
general framework of functors from types to types, or something
like that.  Also, the naming conventions should be changed for
greater compatibility with mathlib.
-/

import data.finset data.fintype.basic

/-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-/

namespace finset
open finset fintype equiv

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

def finset_equiv_of_equiv (f : α ≃ β) :
 (finset α) ≃ (finset β) := {
   to_fun := (finset.image f.to_fun),
   inv_fun := (finset.image f.inv_fun),
   left_inv := begin
    unfold function.left_inverse at ⊢,
    intro x,
    rw[image_image],
    have li : f.inv_fun ∘ f.to_fun = id,
     {ext t,simp[f.left_inv t]},
    rw[li,image_id]
    end,
   right_inv := begin
    unfold function.right_inverse at ⊢,
    intro y,
    rw[image_image],
    have ri : f.to_fun ∘ f.inv_fun = id,
     {ext u,simp[f.right_inv u]},
    rw[ri,image_id]
   end
 }

 lemma finset_equiv_symm : ∀ (f : α ≃ β),
  (finset_equiv_of_equiv f).symm = finset_equiv_of_equiv (f.symm)
| ⟨ft,fi,l,r⟩  :=
 begin
  unfold equiv.symm,
  unfold finset_equiv_of_equiv
 end

 lemma mem_transfer (f : α ≃ β) (a : α) (u : finset α) :
  a ∈ u ↔ f.to_fun a ∈ (finset_equiv_of_equiv f).to_fun u :=
 begin
  split,
  exact mem_image_of_mem f.to_fun,
  intro f_a_in_f_u,
  have : (∃ a0 ∈ u, f.to_fun a0 = f.to_fun a) := (mem_image.mp f_a_in_f_u),
  cases this with a0 Z0,
  cases Z0 with a0_in_u same_image,
  have a0_eq_a : a0 = a :=
  calc a0 = f.inv_fun (f.to_fun a0) : (f.left_inv a0).symm
       ... = f.inv_fun (f.to_fun a) : congr_arg f.inv_fun same_image
       ... = a : f.left_inv a,
  exact eq.subst a0_eq_a a0_in_u
 end

 lemma mem_transfer_inv (f : α ≃ β) (b : β) (u : finset α) :
  b ∈ (finset_equiv_of_equiv f).to_fun u ↔ f.inv_fun b ∈ u :=
 begin
  split,
  {intro b_in_f_u,
  have : (∃ a ∈ u, f.to_fun a = b) := (mem_image.mp b_in_f_u),
  cases this with a a_in_u_f_a_eq_b,
  cases a_in_u_f_a_eq_b with a_in_u f_a_eq_b,
  have f_inv_b_eq_a : f.inv_fun b = a := eq.subst f_a_eq_b (f.left_inv a),
  exact eq.subst f_inv_b_eq_a.symm a_in_u},
  {intro f_inv_b_in_u,
  exact eq.subst (f.right_inv b) (mem_image_of_mem f.to_fun f_inv_b_in_u)
  }
 end

 lemma mem_transfer_alt (f : α ≃ β) (a : α) (v : finset β) :
  a ∈ (finset_equiv_of_equiv f).inv_fun v ↔ f a ∈ v :=
 begin
  let Pf := finset_equiv_of_equiv f,
  let u := Pf.inv_fun v,
  let E := Pf.right_inv v,
  let T := (mem_transfer f a u),
  rw E at T,
  exact T
 end

 lemma empty_transfer (f : α ≃ β) :
  (finset_equiv_of_equiv f) ∅ = ∅ := (image_empty f.to_fun)

 lemma subset_transfer (f : α ≃ β) {u v : finset α} :
  u ⊆ v ↔ (finset_equiv_of_equiv f) u ⊆ (finset_equiv_of_equiv f) v :=
 begin
  split,
  {intro u_sse_v,
   exact image_subset_image u_sse_v},
  {intro f_u_sse_f_v,
   apply subset_iff.mpr,
   intros a a_in_u,
   have f_a_in_f_u : f a ∈ (finset_equiv_of_equiv f) u :=
    mem_image_of_mem f a_in_u,
   have f_a_in_f_v : f a ∈ (finset_equiv_of_equiv f) v :=
    subset_iff.mp f_u_sse_f_v f_a_in_f_u,
   exact (mem_transfer f a v).mpr (f_a_in_f_v)}
 end

 lemma ssubset_transfer (f : α ≃ β ) {u v : finset α} :
  u ⊂ v ↔  (finset_equiv_of_equiv f) u ⊂ (finset_equiv_of_equiv f) v :=
 begin
  let Pf := finset_equiv_of_equiv f,
  have uu_eq_u : image f.inv_fun (Pf u) = u := Pf.left_inv u,
  have vv_eq_v : image f.inv_fun (Pf v) = v := Pf.left_inv v,
  split,
  intro u_ssubset_v,
  have u_subset_v := u_ssubset_v.left,
  have v_not_subset_u := u_ssubset_v.right,
  have f_u_subset_f_v : Pf u ⊆ Pf v :=
      (subset_transfer f).mp u_subset_v,
  have f_v_not_subset_f_u :
    not (Pf v ⊆ Pf u) :=
   begin
    intro f_v_subset_f_u,
    let vv_subset_uu := @image_subset_image β α _ f.inv_fun _ _ f_v_subset_f_u,
    rw[uu_eq_u,vv_eq_v] at vv_subset_uu,
    exact v_not_subset_u vv_subset_uu
   end,
   exact ⟨f_u_subset_f_v,f_v_not_subset_f_u⟩,
  intro f_u_ssubset_f_v,
  have f_u_subset_f_v := f_u_ssubset_f_v.left,
  have f_v_not_subset_f_u := f_u_ssubset_f_v.right,
  have uu_subset_vv := (subset_transfer f).mpr f_u_subset_f_v,
  have not_vv_subset_uu : not (v ⊆ u) :=
   begin
    intro v_subset_u,
    have f_v_subset_f_u := (subset_transfer f).mp v_subset_u,
    exact f_v_not_subset_f_u f_v_subset_f_u,
   end,
  exact ⟨uu_subset_vv,not_vv_subset_uu⟩
 end

 lemma union_transfer (f : α ≃ β) (u v : finset α) :
  (finset_equiv_of_equiv f).to_fun (u ∪ v) =
   (finset_equiv_of_equiv f).to_fun (u) ∪ (finset_equiv_of_equiv f).to_fun (v) :=
    (image_union u v)

 lemma intersect_transfer (f : α ≃ β) (u v : finset α) :
  (finset_equiv_of_equiv f).to_fun (u ∩ v) =
   (finset_equiv_of_equiv f).to_fun (u) ∩ (finset_equiv_of_equiv f).to_fun (v) :=
 begin
  apply finset.ext,
  intro b,
  let P := mem_transfer_inv f b u,
  let Q := mem_transfer_inv f b v,
  let R := mem_transfer_inv f b (u ∩ v),
  split,
  {intro H,apply finset.mem_inter.mpr,
  exact ⟨P.mpr (mem_inter.mp (R.mp H)).left,
         Q.mpr (mem_inter.mp (R.mp H)).right⟩},
  {intro H,rw[finset.mem_inter] at H,
  exact R.mpr (mem_inter.mpr ⟨P.mp H.left,Q.mp H.right⟩)}
 end

 lemma sdiff_transfer (f : α ≃ β) (u v : finset α) :
  (finset_equiv_of_equiv f).to_fun (u \ v) =
   (finset_equiv_of_equiv f).to_fun (u) \ (finset_equiv_of_equiv f).to_fun (v) :=
 begin
  apply finset.ext,
  intro b,
  let P := mem_transfer_inv f b u,
  let Q := mem_transfer_inv f b v,
  let R := mem_transfer_inv f b (u \ v),
  split,
  {intro H,apply finset.mem_sdiff.mpr,
  exact ⟨P.mpr (mem_sdiff.mp (R.mp H)).left,
        λ U,(mem_sdiff.mp (R.mp H)).right (Q.mp U)⟩},
  {intro H,rw[finset.mem_sdiff] at H,
  exact R.mpr (mem_sdiff.mpr ⟨P.mp H.left,λ U,H.right (Q.mpr U)⟩)}
 end

 lemma singleton_transfer (f : α ≃ β) (a : α) :
  (finset_equiv_of_equiv f) (singleton a) = singleton (f a) := rfl

 lemma insert_transfer (f : α ≃ β) (a : α) (u : finset α) :
  (finset_equiv_of_equiv f) (insert a u) =
    insert (f a) ((finset_equiv_of_equiv f) u) :=
    image_insert f a u

 lemma card_transfer (f : α ≃ β) (u : finset α) :
  card ((finset_equiv_of_equiv f) u) = card u :=
  card_image_of_injective u (function.left_inverse.injective f.left_inv)

 lemma erase_transfer (f : α ≃ β) (u : finset α) (a : α) :
  (finset_equiv_of_equiv f) (erase u a) = erase ((finset_equiv_of_equiv f) u) (f a) :=
 begin
  let Pf := (finset_equiv_of_equiv f),
  simp[ext_iff],
  intro b,
  split,
  intro b_in_f_erase,
  have f_inv_b_in_erase := (mem_transfer_inv f b (erase u a)).mp b_in_f_erase,
  have f_inv_b_neq_a : ¬ (f.inv_fun b = a) := (mem_erase.mp f_inv_b_in_erase).left,
  have f_inv_b_in_u : f.inv_fun b ∈ u  := (mem_erase.mp f_inv_b_in_erase).right,
  split,
  intro b_eq_f_a,
  have f_inv_b_eq_a := eq.trans (congr_arg f.inv_fun b_eq_f_a) (f.left_inv a),
  exact f_inv_b_neq_a f_inv_b_eq_a,
  have b_in_f_u := (mem_transfer f (f.inv_fun b) u).mp f_inv_b_in_u,
  rw[f.right_inv b] at b_in_f_u,
  exact b_in_f_u,
  intro H,
  have f_inv_b_in_erase : f.inv_fun b ∈ erase u a :=
  begin
   apply mem_erase.mpr,
   split,
   intro f_inv_b_eq_a,
   exact H.left (eq.trans (f.right_inv b).symm (congr_arg f f_inv_b_eq_a)),
   have f_inv_b_in_uu := mem_image_of_mem f.inv_fun H.right,
   have uu_eq_u : image f.inv_fun (Pf u) = u := Pf.left_inv u,
   rw[uu_eq_u] at f_inv_b_in_uu,
   exact f_inv_b_in_uu
  end,
  have b_in_f_erase := mem_image_of_mem f f_inv_b_in_erase,
  have bb_eq_b : f (f.inv_fun b) = b := f.right_inv b,
  rw[bb_eq_b] at b_in_f_erase,
  exact b_in_f_erase
 end

 lemma filter_transfer
  (f : α ≃ β) (p : α → Prop) [decidable_pred p] (u : finset α) :
   (finset_equiv_of_equiv f) (filter p u) =
    filter (p ∘ f.inv_fun) ((finset_equiv_of_equiv f) u) :=
 begin
  let Pf := (finset_equiv_of_equiv f),
  simp[ext_iff],
  intro b,
  let a := f.inv_fun b,
  split,
  intro b_in_f_filter,
  let a_in_filter : a ∈ filter p u :=
   (mem_transfer_inv f b (filter p u)).mp b_in_f_filter,
  have a_in_u : a ∈ u := (mem_filter.mp a_in_filter).left,
  let p_a : p a := (mem_filter.mp a_in_filter).right,
  {split,
  exact (mem_transfer_inv f b u).mpr a_in_u,
  exact p_a},
  intro H,
  have b_in_f_u := H.left,
  have a_in_u : a ∈ u := (mem_transfer_inv f b u).mp b_in_f_u,
  have p_a : p a := H.right,
  have a_in_filter : a ∈ filter p u := mem_filter.mpr ⟨a_in_u,p_a⟩,
  exact (mem_transfer_inv f b (filter p u)).mpr a_in_filter
 end

 lemma disjoint_transfer
  (f : α ≃ β) (s0 s1 : finset α) :
   (disjoint s0 s1) ↔
    (disjoint ((finset_equiv_of_equiv f) s0) ((finset_equiv_of_equiv f) s1)) :=
 begin
  let Pf := finset_equiv_of_equiv f,
  split,
  {intro s_disjoint,
  by calc
   (Pf s0) ∩ (Pf s1) = Pf (s0 ∩ s1) : (intersect_transfer f s0 s1).symm
    ... ⊆ Pf ∅ : (subset_transfer f).mp s_disjoint
    ... = ∅ : empty_transfer f},
  {intro t_disjoint,
  let t0 := Pf s0,
  let t1 := Pf s1,
  let E := calc
   Pf (s0 ∩ s1) = t0 ∩ t1 : intersect_transfer f s0 s1
   ... ⊆ ∅ : t_disjoint,
  by calc
   s0 ∩ s1 = Pf.inv_fun (Pf (s0 ∩ s1)) : (Pf.left_inv _).symm
    ... ⊆ Pf.inv_fun ∅ : (subset_transfer f.symm).mp E
    ... = ∅ : empty_transfer f.symm
  }
 end
end finset

namespace fintype

open finset fintype equiv

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

lemma fintype_eq_of_elems_eq : ∀ {s t : fintype α}, s.1 = t.1 → s = t
| ⟨s, _⟩ ⟨t, _⟩ rfl := rfl

lemma fintype_unique (u v : fintype α) : u = v :=
begin
 apply fintype_eq_of_elems_eq,
 ext,split,
 intro a_in_u,
 exact (@fintype.complete α v a),
 intro a_in_v,
 exact (@fintype.complete α u a)
end

def fintype_equiv_of_equiv (f : α ≃ β) :
 (fintype α ≃ fintype β ) :=
begin
 let Pf := finset.finset_equiv_of_equiv f,
 exact {
  to_fun := λ u, {
   elems := Pf.to_fun u.elems,
   complete := λ b,
    (mem_transfer_inv f b u.elems).mpr (@fintype.complete α u (f.inv_fun b))
  },
  inv_fun := λ v, {
   elems := Pf.inv_fun v.elems,
   complete := λ a,
    (mem_transfer_alt f a v.elems).mpr (@fintype.complete β v (f.to_fun a))
  },
  left_inv  := λ u,fintype_eq_of_elems_eq (Pf.left_inv  u.elems),
  right_inv := λ v,fintype_eq_of_elems_eq (Pf.right_inv v.elems)
 }
end

lemma univ_transfer [u : fintype α] [v : fintype β] (f : α ≃ β) :
 (finset_equiv_of_equiv f) (@univ α _) = (@univ β _) :=
begin
 ext b,split,
 intro,
 exact (@fintype.complete β v b),
 intro,
 exact (mem_transfer_inv f b (@univ α _)).mpr
  (@fintype.complete α u (f.inv_fun b)),
end

end fintype


import data.list init.algebra.classes
import tactic.norm_num tactic.tauto tactic.rewrite tactic.rewrite_all tactic.omega tactic.tidy
import tactic.hint

variables {α: Type*}
variables [semiring α]

@[simp]
theorem map_id {l: list α}: list.map (λ x, x) l = l := begin
induction l, reflexivity, simp, assumption,
end

theorem map_forall {β: Type*} {l: list α} {f: α -> β} {p: β -> Prop} (h: ∀ b:β, p b):
  (∀ a ∈ l, p (f a)) -> ∀ b ∈ (list.map f l), p b := by tidy

@[simp]
def scalar_l (x: α) (l: list α) := list.map (λ y, x*y) l
infixr `[*]`:1000 := scalar_l

@[simp]
def scalar_add_l (x: α) (l: list α) := list.map (λ y, x+y) l
infixr `[+]`:500 := scalar_add_l

@[simp]
def scalar_r (l: list α) (x: α) := list.map (λ y, y*x) l

@[simp]
def scalar_add_r (l: list α) (x: α) := list.map (λ y, y+x) l

@[simp]
def tensor : list α -> list α -> list α
| [] ys := []
| (x::xs) ys := (x [*] ys) ++ (tensor xs ys)
infixr `<*>` := tensor
infixr ` ⊗`:1000 := tensor

@[simp]
def vec_add: list α -> list α -> list α
| [] ys := ys
| xs [] := xs
| (x::xs) (y::ys) := (x+y)::(vec_add xs ys)
infixr `<+>`:500 := vec_add

@[simp]
theorem scalar_l_sum {x: α} {l: list α}: (x [*] l).sum = x * l.sum := begin
induction l, simp,
case list.cons: hd tl ih {
  rw list.sum_cons,
  simp,
  simp at ih,
  rw ih,
  rw left_distrib,
}
end

@[simp]
theorem scalar_l_cons {x y: α} {l: list α}: (x [*] (y::l)) = (x*y)::(x [*] l) := by simp

@[simp]
theorem add_scalar_l_distrib {x y: α} {l: list α}: (x + y) [*] l = (x[*]l) <+> (y[*]l) := begin
induction l, reflexivity,
case list.cons: hd tl ih {
  repeat {rw scalar_l_cons },
  rw ih,
  simp,
  rw semiring.right_distrib,
  reflexivity,
}
end

@[simp]
theorem tensor_l_id {l: list α}: [1] <*> l = l := begin
induction l, reflexivity,
case list.cons: hd tl ih {
  simp,
}
end

@[simp]
theorem tensor_r_id {l: list α}: l <*> [1] = l := begin
induction l,
  reflexivity,
  simp, assumption,
end

@[simp]
theorem tensor_sum {l1 l2: list α}: (l1 <*> l2).sum = l1.sum * l2.sum := begin
induction l1, {
  rw tensor, simp,
},
case list.cons: hd tl ih {
  rw list.sum_cons,
  rw right_distrib,
  rw tensor,
  rw list.sum_append,
  rw scalar_l_sum,
  rw ih,
}
end

-- geom (n, e) = [n^0, n^1, ..., n^e]
@[simp, reducible]
def geom (p: α × ℕ) := list.map (λ c, (p.1 ^ c)) (list.range (p.2+1))
notation `<|` p `|>` := geom p

@[simp]
theorem geom_zero (e: α): <| (e, 0) |> = [1] := rfl

@[simp]
theorem geom_succ (p: α × ℕ): <| (p.1, p.2+1) |> = 1::(p.1 [*] <| p |>) := begin
simp,
repeat { rw add_comm, rw list.range_succ_eq_map, rw list.map_cons},
simp,
have: (pow p.fst) ∘ nat.succ ∘ nat.succ = (pow p.fst ∘ nat.succ) ∘ nat.succ, by simp,
rw this, clear this,
have: (pow p.fst ∘ nat.succ) = (has_mul.mul p.fst ∘ pow p.fst), {
  apply funext,
  intro,
  simp,
  rw pow_succ,
},
rw this,
end


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis

! This file was ported from Lean 3 source module algebra.order.smul
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Module.Pi
import Mathlib.Algebra.Module.Prod
import Mathlib.Algebra.Order.Monoid.Prod
import Mathlib.Algebra.Order.Pi
import Mathlib.Data.Set.Pointwise.SMul
import Mathlib.Tactic.Positivity

/-!
# Ordered scalar product

In this file we define

* `OrderedSMul R M` : an ordered additive commutative monoid `M` is an `OrderedSMul`
  over an `OrderedSemiring` `R` if the scalar product respects the order relation on the
  monoid and on the ring. There is a correspondence between this structure and convex cones,
  which is proven in `Analysis/Convex/Cone.lean`.

## Implementation notes
* We choose to define `OrderedSMul` as a `Prop`-valued mixin, so that it can be
  used for actions, modules, and algebras
  (the axioms for an "ordered algebra" are exactly that the algebra is ordered as a module).
* To get ordered modules and ordered vector spaces, it suffices to replace the
  `OrderedAddCommMonoid` and the `OrderedSemiring` as desired.

## References

* https://en.wikipedia.org/wiki/Ordered_module

## Tags

ordered module, ordered scalar, ordered smul, ordered action, ordered vector space
-/

open Pointwise

/-- The ordered scalar product property is when an ordered additive commutative monoid
with a partial order has a scalar multiplication which is compatible with the order.
-/
class OrderedSMul (R M : Type _) [OrderedSemiring R] [OrderedAddCommMonoid M] [SMulWithZero R M] :
  Prop where
  /-- Scalar multiplication by positive elements preserves the order. -/
  protected smul_lt_smul_of_pos : ∀ {a b : M}, ∀ {c : R}, a < b → 0 < c → c • a < c • b
  /-- If `c • a < c • b` for some positive `c`, then `a < b`. -/
  protected lt_of_smul_lt_smul_of_pos : ∀ {a b : M}, ∀ {c : R}, c • a < c • b → 0 < c → a < b
#align ordered_smul OrderedSMul

variable {ι 𝕜 R M N : Type _}

namespace OrderDual

instance [Zero R] [AddZeroClass M] [SMulWithZero R M] : SMulWithZero R Mᵒᵈ :=
  { instSMulOrderDual with
    zero_smul := fun m => OrderDual.rec (zero_smul _) m
    smul_zero := fun r => OrderDual.rec (@smul_zero R M _ _) r }

instance [Monoid R] [MulAction R M] : MulAction R Mᵒᵈ :=
  { instSMulOrderDual with
    one_smul := fun m => OrderDual.rec (one_smul _) m
    mul_smul := fun r => OrderDual.rec (@mul_smul R M _ _) r }

instance [MonoidWithZero R] [AddMonoid M] [MulActionWithZero R M] : MulActionWithZero R Mᵒᵈ :=
  { instMulActionOrderDual , instSMulWithZeroOrderDualInstZeroOrderDualToZero with }

instance [MonoidWithZero R] [AddMonoid M] [DistribMulAction R M] : DistribMulAction R Mᵒᵈ where
  smul_add _ a := OrderDual.rec (fun _ b => OrderDual.rec (smul_add _ _) b) a
  smul_zero r := OrderDual.rec (@smul_zero _ M _ _) r

instance [OrderedSemiring R] [OrderedAddCommMonoid M] [SMulWithZero R M] [OrderedSMul R M] :
    OrderedSMul R Mᵒᵈ where
  smul_lt_smul_of_pos {a b} := @OrderedSMul.smul_lt_smul_of_pos R M _ _ _ _ b a
  lt_of_smul_lt_smul_of_pos {a b} := @OrderedSMul.lt_of_smul_lt_smul_of_pos R M _ _ _ _ b a

end OrderDual

section OrderedSMul

variable [OrderedSemiring R] [OrderedAddCommMonoid M] [SMulWithZero R M] [OrderedSMul R M]
  {s : Set M} {a b : M} {c : R}

theorem smul_lt_smul_of_pos : a < b → 0 < c → c • a < c • b :=
  OrderedSMul.smul_lt_smul_of_pos
#align smul_lt_smul_of_pos smul_lt_smul_of_pos

theorem smul_le_smul_of_nonneg (h₁ : a ≤ b) (h₂ : 0 ≤ c) : c • a ≤ c • b := by
  rcases h₁.eq_or_lt with (rfl | hab)
  · rfl
  · rcases h₂.eq_or_lt with (rfl | hc)
    · rw [zero_smul, zero_smul]
    · exact (smul_lt_smul_of_pos hab hc).le
#align smul_le_smul_of_nonneg smul_le_smul_of_nonneg

theorem smul_nonneg (hc : 0 ≤ c) (ha : 0 ≤ a) : 0 ≤ c • a :=
  calc
    (0 : M) = c • (0 : M) := (smul_zero c).symm
    _ ≤ c • a := smul_le_smul_of_nonneg ha hc
#align smul_nonneg smul_nonneg

theorem smul_nonpos_of_nonneg_of_nonpos (hc : 0 ≤ c) (ha : a ≤ 0) : c • a ≤ 0 :=
  @smul_nonneg R Mᵒᵈ _ _ _ _ _ _ hc ha
#align smul_nonpos_of_nonneg_of_nonpos smul_nonpos_of_nonneg_of_nonpos

theorem eq_of_smul_eq_smul_of_pos_of_le (h₁ : c • a = c • b) (hc : 0 < c) (hle : a ≤ b) : a = b :=
  hle.lt_or_eq.resolve_left fun hlt => (smul_lt_smul_of_pos hlt hc).ne h₁
#align eq_of_smul_eq_smul_of_pos_of_le eq_of_smul_eq_smul_of_pos_of_le

theorem lt_of_smul_lt_smul_of_nonneg (h : c • a < c • b) (hc : 0 ≤ c) : a < b :=
  hc.eq_or_lt.elim
    (fun hc => False.elim <| lt_irrefl (0 : M) <| by rwa [← hc, zero_smul, zero_smul] at h)
    (OrderedSMul.lt_of_smul_lt_smul_of_pos h)
#align lt_of_smul_lt_smul_of_nonneg lt_of_smul_lt_smul_of_nonneg

theorem smul_lt_smul_iff_of_pos (hc : 0 < c) : c • a < c • b ↔ a < b :=
  ⟨fun h => lt_of_smul_lt_smul_of_nonneg h hc.le, fun h => smul_lt_smul_of_pos h hc⟩
#align smul_lt_smul_iff_of_pos smul_lt_smul_iff_of_pos

theorem smul_pos_iff_of_pos (hc : 0 < c) : 0 < c • a ↔ 0 < a :=
  calc
    0 < c • a ↔ c • (0 : M) < c • a := by rw [smul_zero]
    _ ↔ 0 < a := smul_lt_smul_iff_of_pos hc
#align smul_pos_iff_of_pos smul_pos_iff_of_pos

alias smul_pos_iff_of_pos ↔ _ smul_pos
#align smul_pos smul_pos

theorem monotone_smul_left (hc : 0 ≤ c) : Monotone (SMul.smul c : M → M) := fun _ _ h =>
  smul_le_smul_of_nonneg h hc
#align monotone_smul_left monotone_smul_left

theorem strictMono_smul_left (hc : 0 < c) : StrictMono (SMul.smul c : M → M) := fun _ _ h =>
  smul_lt_smul_of_pos h hc
#align strict_mono_smul_left strictMono_smul_left

theorem smul_lowerBounds_subset_lowerBounds_smul (hc : 0 ≤ c) :
    c • lowerBounds s ⊆ lowerBounds (c • s) :=
  (monotone_smul_left hc).image_lowerBounds_subset_lowerBounds_image
#align smul_lower_bounds_subset_lower_bounds_smul smul_lowerBounds_subset_lowerBounds_smul

theorem smul_upperBounds_subset_upperBounds_smul (hc : 0 ≤ c) :
    c • upperBounds s ⊆ upperBounds (c • s) :=
  (monotone_smul_left hc).image_upperBounds_subset_upperBounds_image
#align smul_upper_bounds_subset_upper_bounds_smul smul_upperBounds_subset_upperBounds_smul

theorem BddBelow.smul_of_nonneg (hs : BddBelow s) (hc : 0 ≤ c) : BddBelow (c • s) :=
  (monotone_smul_left hc).map_bddBelow hs
#align bdd_below.smul_of_nonneg BddBelow.smul_of_nonneg

theorem BddAbove.smul_of_nonneg (hs : BddAbove s) (hc : 0 ≤ c) : BddAbove (c • s) :=
  (monotone_smul_left hc).map_bddAbove hs
#align bdd_above.smul_of_nonneg BddAbove.smul_of_nonneg

end OrderedSMul

/-- To prove that a linear ordered monoid is an ordered module, it suffices to verify only the first
axiom of `OrderedSMul`. -/
theorem OrderedSMul.mk'' [OrderedSemiring 𝕜] [LinearOrderedAddCommMonoid M] [SMulWithZero 𝕜 M]
    (h : ∀ ⦃c : 𝕜⦄, 0 < c → StrictMono fun a : M => c • a) : OrderedSMul 𝕜 M :=
  { smul_lt_smul_of_pos := fun hab hc => h hc hab
    lt_of_smul_lt_smul_of_pos := fun hab hc => (h hc).lt_iff_lt.1 hab }
#align ordered_smul.mk'' OrderedSMul.mk''

instance Nat.orderedSMul [LinearOrderedCancelAddCommMonoid M] : OrderedSMul ℕ M :=
  OrderedSMul.mk'' fun n hn a b hab => by
    cases n with
    | zero => cases hn
    | succ n =>
      induction n with
      | zero => dsimp; rwa [one_nsmul, one_nsmul]
      | succ n ih => simp only [succ_nsmul _ n.succ, _root_.add_lt_add hab (ih n.succ_pos)]
#align nat.ordered_smul Nat.orderedSMul

instance Int.orderedSMul [LinearOrderedAddCommGroup M] : OrderedSMul ℤ M :=
  OrderedSMul.mk'' fun n hn => by
    cases n
    · simp only [Int.ofNat_eq_coe, Int.coe_nat_pos, coe_nat_zsmul] at hn⊢
      exact strictMono_smul_left hn
    · cases (Int.negSucc_not_pos _).1 hn
#align int.ordered_smul Int.orderedSMul

-- TODO: `LinearOrderedField M → OrderedSMul ℚ M`
instance LinearOrderedSemiring.toOrderedSMul {R : Type _} [LinearOrderedSemiring R] :
    OrderedSMul R R :=
  OrderedSMul.mk'' fun _ => strictMono_mul_left_of_pos
#align linear_ordered_semiring.to_ordered_smul LinearOrderedSemiring.toOrderedSMul

section LinearOrderedSemifield

variable [LinearOrderedSemifield 𝕜] [OrderedAddCommMonoid M] [OrderedAddCommMonoid N]
  [MulActionWithZero 𝕜 M] [MulActionWithZero 𝕜 N]

/-- To prove that a vector space over a linear ordered field is ordered, it suffices to verify only
the first axiom of `OrderedSMul`. -/
theorem OrderedSMul.mk' (h : ∀ ⦃a b : M⦄ ⦃c : 𝕜⦄, a < b → 0 < c → c • a ≤ c • b) :
    OrderedSMul 𝕜 M := by
  have hlt' : ∀ (a b : M) (c : 𝕜), a < b → 0 < c → c • a < c • b := by
    refine' fun a b c hab hc => (h hab hc).lt_of_ne _
    rw [Ne.def, hc.ne'.isUnit.smul_left_cancel]
    exact hab.ne
  refine' { smul_lt_smul_of_pos := fun {a b c} => hlt' a b c..}
  intro a b c hab hc
  obtain ⟨c, rfl⟩ := hc.ne'.isUnit
  rw [← inv_smul_smul c a, ← inv_smul_smul c b]
  refine' hlt' _ _ _ hab (pos_of_mul_pos_right _ hc.le)
  simp only [c.mul_inv, zero_lt_one]
#align ordered_smul.mk' OrderedSMul.mk'

instance [OrderedSMul 𝕜 M] [OrderedSMul 𝕜 N] : OrderedSMul 𝕜 (M × N) :=
  OrderedSMul.mk' fun _ _ _ h hc =>
    ⟨smul_le_smul_of_nonneg h.1.1 hc.le, smul_le_smul_of_nonneg h.1.2 hc.le⟩

instance Pi.orderedSMul {M : ι → Type _} [∀ i, OrderedAddCommMonoid (M i)]
    [∀ i, MulActionWithZero 𝕜 (M i)] [∀ i, OrderedSMul 𝕜 (M i)] : OrderedSMul 𝕜 (∀ i, M i) :=
  OrderedSMul.mk' fun _ _ _ h hc i => smul_le_smul_of_nonneg (h.le i) hc.le
#align pi.ordered_smul Pi.orderedSMul

/- Sometimes Lean fails to apply the dependent version to non-dependent functions, so we define
another instance. -/
instance Pi.orderedSMul' [OrderedSMul 𝕜 M] : OrderedSMul 𝕜 (ι → M) :=
  Pi.orderedSMul
#align pi.ordered_smul' Pi.orderedSMul'

-- Sometimes Lean fails to unify the module with the scalars, so we define another instance.
instance Pi.orderedSMul'' : OrderedSMul 𝕜 (ι → 𝕜) :=
  @Pi.orderedSMul' ι 𝕜 𝕜 _ _ _ _
#align pi.ordered_smul'' Pi.orderedSMul''

variable [OrderedSMul 𝕜 M] {s : Set M} {a b : M} {c : 𝕜}

theorem smul_le_smul_iff_of_pos (hc : 0 < c) : c • a ≤ c • b ↔ a ≤ b :=
  ⟨fun h =>
    inv_smul_smul₀ hc.ne' a ▸
      inv_smul_smul₀ hc.ne' b ▸ smul_le_smul_of_nonneg h (inv_nonneg.2 hc.le),
    fun h => smul_le_smul_of_nonneg h hc.le⟩
#align smul_le_smul_iff_of_pos smul_le_smul_iff_of_pos

theorem inv_smul_le_iff (h : 0 < c) : c⁻¹ • a ≤ b ↔ a ≤ c • b := by
  rw [← smul_le_smul_iff_of_pos h, smul_inv_smul₀ h.ne']
#align inv_smul_le_iff inv_smul_le_iff

theorem inv_smul_lt_iff (h : 0 < c) : c⁻¹ • a < b ↔ a < c • b := by
  rw [← smul_lt_smul_iff_of_pos h, smul_inv_smul₀ h.ne']
#align inv_smul_lt_iff inv_smul_lt_iff

theorem le_inv_smul_iff (h : 0 < c) : a ≤ c⁻¹ • b ↔ c • a ≤ b := by
  rw [← smul_le_smul_iff_of_pos h, smul_inv_smul₀ h.ne']
#align le_inv_smul_iff le_inv_smul_iff

theorem lt_inv_smul_iff (h : 0 < c) : a < c⁻¹ • b ↔ c • a < b := by
  rw [← smul_lt_smul_iff_of_pos h, smul_inv_smul₀ h.ne']
#align lt_inv_smul_iff lt_inv_smul_iff

variable (M)

/-- Left scalar multiplication as an order isomorphism. -/
@[simps]
def OrderIso.smulLeft (hc : 0 < c) : M ≃o M where
  toFun b := c • b
  invFun b := c⁻¹ • b
  left_inv := inv_smul_smul₀ hc.ne'
  right_inv := smul_inv_smul₀ hc.ne'
  map_rel_iff' := smul_le_smul_iff_of_pos hc
#align order_iso.smul_left OrderIso.smulLeft
#align order_iso.smul_left_symm_apply OrderIso.smulLeft_symm_apply
#align order_iso.smul_left_apply OrderIso.smulLeft_apply

variable {M}

@[simp]
theorem lowerBounds_smul_of_pos (hc : 0 < c) : lowerBounds (c • s) = c • lowerBounds s :=
  (OrderIso.smulLeft _ hc).lowerBounds_image
#align lower_bounds_smul_of_pos lowerBounds_smul_of_pos

@[simp]
theorem upperBounds_smul_of_pos (hc : 0 < c) : upperBounds (c • s) = c • upperBounds s :=
  (OrderIso.smulLeft _ hc).upperBounds_image
#align upper_bounds_smul_of_pos upperBounds_smul_of_pos

@[simp]
theorem bddBelow_smul_iff_of_pos (hc : 0 < c) : BddBelow (c • s) ↔ BddBelow s :=
  (OrderIso.smulLeft _ hc).bddBelow_image
#align bdd_below_smul_iff_of_pos bddBelow_smul_iff_of_pos

@[simp]
theorem bddAbove_smul_iff_of_pos (hc : 0 < c) : BddAbove (c • s) ↔ BddAbove s :=
  (OrderIso.smulLeft _ hc).bddAbove_image
#align bdd_above_smul_iff_of_pos bddAbove_smul_iff_of_pos

end LinearOrderedSemifield

namespace Tactic

section OrderedSMul

variable [OrderedSemiring R] [OrderedAddCommMonoid M] [SMulWithZero R M] [OrderedSMul R M] {a : R}
  {b : M}

private theorem smul_nonneg_of_pos_of_nonneg (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a • b :=
  smul_nonneg ha.le hb

private theorem smul_nonneg_of_nonneg_of_pos (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a • b :=
  smul_nonneg ha hb.le

end OrderedSMul

section NoZeroSMulDivisors

variable [Zero R] [Zero M] [SMul R M] [NoZeroSMulDivisors R M] {a : R} {b : M}

private theorem smul_ne_zero_of_pos_of_ne_zero [Preorder R] (ha : 0 < a) (hb : b ≠ 0) : a • b ≠ 0 :=
  smul_ne_zero ha.ne' hb

private theorem smul_ne_zero_of_ne_zero_of_pos [Preorder M] (ha : a ≠ 0) (hb : 0 < b) : a • b ≠ 0 :=
  smul_ne_zero ha hb.ne'

end NoZeroSMulDivisors

-- Porting note: Tactic code not ported yet
-- open Positivity

-- -- failed to format: unknown constant 'term.pseudo.antiquot'
-- /--
--       Extension for the `Positivity` tactic: scalar multiplication is
--       nonnegative/positive/nonzero if both sides are. -/
--     @[ positivity ]
--     unsafe
--   def
--     positivity_smul
--     : expr → tactic strictness
--     |
--         e @ q( $ ( a ) • $ ( b ) )
--         =>
--         do
--           let strictness_a ← core a
--             let strictness_b ← core b
--             match
--               strictness_a , strictness_b
--               with
--               | positive pa , positive pb => positive <$> mk_app ` ` smul_pos [ pa , pb ]
--                 |
--                   positive pa , nonnegative pb
--                   =>
--                   nonnegative <$> mk_app ` ` smul_nonneg_of_pos_of_nonneg [ pa , pb ]
--                 |
--                   nonnegative pa , positive pb
--                   =>
--                   nonnegative <$> mk_app ` ` smul_nonneg_of_nonneg_of_pos [ pa , pb ]
--                 |
--                   nonnegative pa , nonnegative pb
--                   =>
--                   nonnegative <$> mk_app ` ` smul_nonneg [ pa , pb ]
--                 |
--                   positive pa , nonzero pb
--                   =>
--                   nonzero <$> to_expr ` `( smul_ne_zero_of_pos_of_ne_zero $ ( pa ) $ ( pb ) )
--                 |
--                   nonzero pa , positive pb
--                   =>
--                   nonzero <$> to_expr ` `( smul_ne_zero_of_ne_zero_of_pos $ ( pa ) $ ( pb ) )
--                 |
--                   nonzero pa , nonzero pb
--                   =>
--                   nonzero <$> to_expr ` `( smul_ne_zero $ ( pa ) $ ( pb ) )
--                 | sa @ _ , sb @ _ => positivity_fail e a b sa sb
--       | e => pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a • b`"
-- #align tactic.positivity_smul Tactic.positivity_smul

end Tactic


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis

! This file was ported from Lean 3 source module analysis.inner_product_space.dual
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.Projection
import Mathbin.Analysis.NormedSpace.Dual
import Mathbin.Analysis.NormedSpace.Star.Basic

/-!
# The Fréchet-Riesz representation theorem

We consider an inner product space `E` over `𝕜`, which is either `ℝ` or `ℂ`. We define
`to_dual_map`, a conjugate-linear isometric embedding of `E` into its dual, which maps an element
`x` of the space to `λ y, ⟪x, y⟫`.

Under the hypothesis of completeness (i.e., for Hilbert spaces), we upgrade this to `to_dual`, a
conjugate-linear isometric *equivalence* of `E` onto its dual; that is, we establish the
surjectivity of `to_dual_map`.  This is the Fréchet-Riesz representation theorem: every element of
the dual of a Hilbert space `E` has the form `λ u, ⟪x, u⟫` for some `x : E`.

For a bounded sesquilinear form `B : E →L⋆[𝕜] E →L[𝕜] 𝕜`,
we define a map `inner_product_space.continuous_linear_map_of_bilin B : E →L[𝕜] E`,
given by substituting `E →L[𝕜] 𝕜` with `E` using `to_dual`.

## References

* [M. Einsiedler and T. Ward, *Functional Analysis, Spectral Theory, and Applications*]
  [EinsiedlerWard2017]

## Tags

dual, Fréchet-Riesz
-/

noncomputable section

open Classical ComplexConjugate

universe u v

namespace InnerProductSpace

open IsROrC ContinuousLinearMap

variable (𝕜 : Type _)

variable (E : Type _) [IsROrC 𝕜] [NormedAddCommGroup E] [InnerProductSpace 𝕜 E]

-- mathport name: «expr⟪ , ⟫»
local notation "⟪" x ", " y "⟫" => @inner 𝕜 E _ x y

-- mathport name: «expr †»
local postfix:90 "†" => starRingEnd _

/-- An element `x` of an inner product space `E` induces an element of the dual space `dual 𝕜 E`,
the map `λ y, ⟪x, y⟫`; moreover this operation is a conjugate-linear isometric embedding of `E`
into `dual 𝕜 E`.
If `E` is complete, this operation is surjective, hence a conjugate-linear isometric equivalence;
see `to_dual`.
-/
def toDualMap : E →ₗᵢ⋆[𝕜] NormedSpace.Dual 𝕜 E :=
  { innerSL 𝕜 with norm_map' := innerSL_apply_norm _ }
#align inner_product_space.to_dual_map InnerProductSpace.toDualMap

variable {E}

@[simp]
theorem toDualMap_apply {x y : E} : toDualMap 𝕜 E x y = ⟪x, y⟫ :=
  rfl
#align inner_product_space.to_dual_map_apply InnerProductSpace.toDualMap_apply

theorem innerSL_norm [Nontrivial E] : ‖(innerSL 𝕜 : E →L⋆[𝕜] E →L[𝕜] 𝕜)‖ = 1 :=
  show ‖(toDualMap 𝕜 E).toContinuousLinearMap‖ = 1 from LinearIsometry.norm_toContinuousLinearMap _
#align inner_product_space.innerSL_norm InnerProductSpace.innerSL_norm

variable {𝕜}

theorem ext_inner_left_basis {ι : Type _} {x y : E} (b : Basis ι 𝕜 E)
    (h : ∀ i : ι, ⟪b i, x⟫ = ⟪b i, y⟫) : x = y :=
  by
  apply (to_dual_map 𝕜 E).map_eq_iff.mp
  refine' (Function.Injective.eq_iff ContinuousLinearMap.coe_injective).mp (Basis.ext b _)
  intro i
  simp only [to_dual_map_apply, ContinuousLinearMap.coe_coe]
  rw [← inner_conj_symm]
  nth_rw_rhs 1 [← inner_conj_symm]
  exact congr_arg conj (h i)
#align inner_product_space.ext_inner_left_basis InnerProductSpace.ext_inner_left_basis

theorem ext_inner_right_basis {ι : Type _} {x y : E} (b : Basis ι 𝕜 E)
    (h : ∀ i : ι, ⟪x, b i⟫ = ⟪y, b i⟫) : x = y :=
  by
  refine' ext_inner_left_basis b fun i => _
  rw [← inner_conj_symm]
  nth_rw_rhs 1 [← inner_conj_symm]
  exact congr_arg conj (h i)
#align inner_product_space.ext_inner_right_basis InnerProductSpace.ext_inner_right_basis

variable (𝕜) (E) [CompleteSpace E]

/-- Fréchet-Riesz representation: any `ℓ` in the dual of a Hilbert space `E` is of the form
`λ u, ⟪y, u⟫` for some `y : E`, i.e. `to_dual_map` is surjective.
-/
def toDual : E ≃ₗᵢ⋆[𝕜] NormedSpace.Dual 𝕜 E :=
  LinearIsometryEquiv.ofSurjective (toDualMap 𝕜 E)
    (by
      intro ℓ
      set Y := LinearMap.ker ℓ with hY
      by_cases htriv : Y = ⊤
      · have hℓ : ℓ = 0 := by
          have h' := linear_map.ker_eq_top.mp htriv
          rw [← coe_zero] at h'
          apply coe_injective
          exact h'
        exact ⟨0, by simp [hℓ]⟩
      · rw [← Submodule.orthogonal_eq_bot_iff] at htriv
        change Yᗮ ≠ ⊥ at htriv
        rw [Submodule.ne_bot_iff] at htriv
        obtain ⟨z : E, hz : z ∈ Yᗮ, z_ne_0 : z ≠ 0⟩ := htriv
        refine' ⟨(ℓ z† / ⟪z, z⟫) • z, _⟩
        ext x
        have h₁ : ℓ z • x - ℓ x • z ∈ Y :=
          by
          rw [LinearMap.mem_ker, map_sub, ContinuousLinearMap.map_smul,
            ContinuousLinearMap.map_smul, Algebra.id.smul_eq_mul, Algebra.id.smul_eq_mul, mul_comm]
          exact sub_self (ℓ x * ℓ z)
        have h₂ : ℓ z * ⟪z, x⟫ = ℓ x * ⟪z, z⟫ :=
          haveI h₃ :=
            calc
              0 = ⟪z, ℓ z • x - ℓ x • z⟫ :=
                by
                rw [(Y.mem_orthogonal' z).mp hz]
                exact h₁
              _ = ⟪z, ℓ z • x⟫ - ⟪z, ℓ x • z⟫ := by rw [inner_sub_right]
              _ = ℓ z * ⟪z, x⟫ - ℓ x * ⟪z, z⟫ := by simp [inner_smul_right]

          sub_eq_zero.mp (Eq.symm h₃)
        have h₄ :=
          calc
            ⟪(ℓ z† / ⟪z, z⟫) • z, x⟫ = ℓ z / ⟪z, z⟫ * ⟪z, x⟫ := by simp [inner_smul_left, conj_conj]
            _ = ℓ z * ⟪z, x⟫ / ⟪z, z⟫ := by rw [← div_mul_eq_mul_div]
            _ = ℓ x * ⟪z, z⟫ / ⟪z, z⟫ := by rw [h₂]
            _ = ℓ x := by field_simp [inner_self_ne_zero.2 z_ne_0]

        exact h₄)
#align inner_product_space.to_dual InnerProductSpace.toDual

variable {𝕜} {E}

@[simp]
theorem toDual_apply {x y : E} : toDual 𝕜 E x y = ⟪x, y⟫ :=
  rfl
#align inner_product_space.to_dual_apply InnerProductSpace.toDual_apply

@[simp]
theorem toDual_symm_apply {x : E} {y : NormedSpace.Dual 𝕜 E} : ⟪(toDual 𝕜 E).symm y, x⟫ = y x :=
  by
  rw [← to_dual_apply]
  simp only [LinearIsometryEquiv.apply_symm_apply]
#align inner_product_space.to_dual_symm_apply InnerProductSpace.toDual_symm_apply

variable {E 𝕜}

/-- Maps a bounded sesquilinear form to its continuous linear map,
given by interpreting the form as a map `B : E →L⋆[𝕜] normed_space.dual 𝕜 E`
and dualizing the result using `to_dual`.
-/
def continuousLinearMapOfBilin (B : E →L⋆[𝕜] E →L[𝕜] 𝕜) : E →L[𝕜] E :=
  comp (toDual 𝕜 E).symm.toContinuousLinearEquiv.toContinuousLinearMap B
#align inner_product_space.continuous_linear_map_of_bilin InnerProductSpace.continuousLinearMapOfBilin

-- mathport name: «expr ♯»
local postfix:1024 "♯" => continuousLinearMapOfBilin

variable (B : E →L⋆[𝕜] E →L[𝕜] 𝕜)

@[simp]
theorem continuousLinearMapOfBilin_apply (v w : E) : ⟪B♯ v, w⟫ = B v w := by
  simp [continuous_linear_map_of_bilin]
#align inner_product_space.continuous_linear_map_of_bilin_apply InnerProductSpace.continuousLinearMapOfBilin_apply

theorem unique_continuousLinearMapOfBilin {v f : E} (is_lax_milgram : ∀ w, ⟪f, w⟫ = B v w) :
    f = B♯ v := by
  refine' ext_inner_right 𝕜 _
  intro w
  rw [continuous_linear_map_of_bilin_apply]
  exact is_lax_milgram w
#align inner_product_space.unique_continuous_linear_map_of_bilin InnerProductSpace.unique_continuousLinearMapOfBilin

end InnerProductSpace