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

/-!
# Probability density function

This file defines the probability density function of random variables, by which we mean
measurable functions taking values in a Borel space. In particular, a measurable function `f`
is said to the probability density function of a random variable `X` if for all measurable
sets `S`, `ℙ(X ∈ S) = ∫ x in S, f x dx`. Probability density functions are one way of describing
the distribution of a random variable, and are useful for calculating probabilities and
finding moments (although the latter is better achieved with moment generating functions).

This file also defines the continuous uniform distribution and proves some properties about
random variables with this distribution.

## Main definitions

* `measure_theory.has_pdf` : A random variable `X : α → E` is said to `has_pdf` with
  respect to the measure `ℙ` on `α` and `μ` on `E` if there exists a measurable function `f`
  such that the push-forward measure of `ℙ` along `X` equals `μ.with_density f`.
* `measure_theory.pdf` : If `X` is a random variable that `has_pdf X ℙ μ`, then `pdf X`
  is the measurable function `f` such that the push-forward measure of `ℙ` along `X` equals
  `μ.with_density f`.
* `measure_theory.pdf.uniform` : A random variable `X` is said to follow the uniform
  distribution if it has a constant probability density function with a compact, non-null support.

## Main results

* `measure_theory.pdf.integral_fun_mul_eq_integral` : Law of the unconscious statistician,
  i.e. if a random variable `X : α → E` has pdf `f`, then `𝔼(g(X)) = ∫ x, g x * f x dx` for
  all measurable `g : E → ℝ`.
* `measure_theory.pdf.integral_mul_eq_integral` : A real-valued random variable `X` with
  pdf `f` has expectation `∫ x, x * f x dx`.
* `measure_theory.pdf.uniform.integral_eq` : If `X` follows the uniform distribution with
  its pdf having support `s`, then `X` has expectation `(λ s)⁻¹ * ∫ x in s, x dx` where `λ`
  is the Lebesgue measure.

## TODOs

Ultimately, we would also like to define characteristic functions to describe distributions as
it exists for all random variables. However, to define this, we will need Fourier transforms
which we currently do not have.
-/

noncomputable theory
open_locale classical measure_theory nnreal ennreal

namespace measure_theory

open topological_space measure_theory.measure

variables {α E : Type*} [normed_group E] [measurable_space E] [second_countable_topology E]
  [normed_space ℝ E] [complete_space E] [borel_space E]

/-- A random variable `X : α → E` is said to `has_pdf` with respect to the measure `ℙ` on `α` and
`μ` on `E` if there exists a measurable function `f` such that the push-forward measure of `ℙ`
along `X` equals `μ.with_density f`. -/
class has_pdf {m : measurable_space α} (X : α → E)
  (ℙ : measure α) (μ : measure E . volume_tac) : Prop :=
(pdf' : measurable X ∧ ∃ (f : E → ℝ≥0∞), measurable f ∧ map X ℙ = μ.with_density f)

@[measurability]
lemma has_pdf.measurable {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : has_pdf X ℙ μ] :
  measurable X :=
hX.pdf'.1

/-- If `X` is a random variable that `has_pdf X ℙ μ`, then `pdf X` is the measurable function `f`
such that the push-forward measure of `ℙ` along `X` equals `μ.with_density f`. -/
def pdf {m : measurable_space α} (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) :=
if hX : has_pdf X ℙ μ then classical.some hX.pdf'.2 else 0

lemma pdf_undef {m : measurable_space α} {ℙ : measure α} {μ : measure E} {X : α → E}
  (h : ¬ has_pdf X ℙ μ) :
  pdf X ℙ μ = 0 :=
by simp only [pdf, dif_neg h]

lemma has_pdf_of_pdf_ne_zero {m : measurable_space α} {ℙ : measure α} {μ : measure E} {X : α → E}
  (h : pdf X ℙ μ ≠ 0) : has_pdf X ℙ μ :=
begin
  by_contra hpdf,
  rw [pdf, dif_neg hpdf] at h,
  exact hpdf (false.rec (has_pdf X ℙ μ) (h rfl))
end

lemma pdf_eq_zero_of_not_measurable {m : measurable_space α}
  {ℙ : measure α} {μ : measure E} {X : α → E} (hX : ¬ measurable X) :
  pdf X ℙ μ = 0 :=
pdf_undef (λ hpdf, hX hpdf.pdf'.1)

lemma measurable_of_pdf_ne_zero {m : measurable_space α}
  {ℙ : measure α} {μ : measure E} (X : α → E) (h : pdf X ℙ μ ≠ 0) :
  measurable X :=
by { by_contra hX, exact h (pdf_eq_zero_of_not_measurable hX) }

@[measurability]
lemma measurable_pdf {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) :
  measurable (pdf X ℙ μ) :=
begin
  by_cases hX : has_pdf X ℙ μ,
  { rw [pdf, dif_pos hX],
    exact (classical.some_spec hX.pdf'.2).1 },
  { rw [pdf, dif_neg hX],
    exact measurable_zero }
end

lemma map_eq_with_density_pdf {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : has_pdf X ℙ μ] :
  measure.map X ℙ = μ.with_density (pdf X ℙ μ) :=
begin
  rw [pdf, dif_pos hX],
  exact (classical.some_spec hX.pdf'.2).2
end

lemma map_eq_set_lintegral_pdf {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : has_pdf X ℙ μ]
  {s : set E} (hs : measurable_set s) :
  measure.map X ℙ s = ∫⁻ x in s, pdf X ℙ μ x ∂μ :=
by rw [← with_density_apply _ hs, map_eq_with_density_pdf X ℙ μ]

namespace pdf

variables {m : measurable_space α} {ℙ : measure α} {μ : measure E}

lemma lintegral_eq_measure_univ {X : α → E} [has_pdf X ℙ μ] :
  ∫⁻ x, pdf X ℙ μ x ∂μ = ℙ set.univ :=
begin
  rw [← set_lintegral_univ, ← map_eq_set_lintegral_pdf X ℙ μ measurable_set.univ,
      measure.map_apply (has_pdf.measurable X ℙ μ) measurable_set.univ, set.preimage_univ],
end

lemma ae_lt_top [is_finite_measure ℙ] {μ : measure E} {X : α → E} :
  ∀ᵐ x ∂μ, pdf X ℙ μ x < ∞ :=
begin
  by_cases hpdf : has_pdf X ℙ μ,
  { haveI := hpdf,
    refine ae_lt_top (measurable_pdf X ℙ μ) _,
    rw lintegral_eq_measure_univ,
    exact (measure_lt_top _ _).ne },
  { rw [pdf, dif_neg hpdf],
    exact filter.eventually_of_forall (λ x, with_top.zero_lt_top) }
end

lemma of_real_to_real_ae_eq [is_finite_measure ℙ] {X : α → E} :
  (λ x, ennreal.of_real (pdf X ℙ μ x).to_real) =ᵐ[μ] pdf X ℙ μ :=
of_real_to_real_ae_eq ae_lt_top

lemma integrable_iff_integrable_mul_pdf [is_finite_measure ℙ] {X : α → E} [has_pdf X ℙ μ]
  {f : E → ℝ} (hf : measurable f) :
  integrable (λ x, f (X x)) ℙ ↔ integrable (λ x, f x * (pdf X ℙ μ x).to_real) μ :=
begin
  rw [← integrable_map_measure hf.ae_measurable (has_pdf.measurable X ℙ μ),
      map_eq_with_density_pdf X ℙ μ,
      integrable_with_density_iff (measurable_pdf _ _ _) ae_lt_top hf],
  apply_instance
end

/-- **The Law of the Unconscious Statistician**: Given a random variable `X` and a measurable
function `f`, `f ∘ X` is a random variable with expectation `∫ x, f x * pdf X ∂μ`
where `μ` is a measure on the codomain of `X`. -/
lemma integral_fun_mul_eq_integral [is_finite_measure ℙ]
  {X : α → E} [has_pdf X ℙ μ] {f : E → ℝ} (hf : measurable f) :
  ∫ x, f x * (pdf X ℙ μ x).to_real ∂μ = ∫ x, f (X x) ∂ℙ :=
begin
  by_cases hpdf : integrable (λ x, f x * (pdf X ℙ μ x).to_real) μ,
  { rw [← integral_map (has_pdf.measurable X ℙ μ) hf.ae_measurable,
        map_eq_with_density_pdf X ℙ μ,
        integral_eq_lintegral_pos_part_sub_lintegral_neg_part hpdf,
        integral_eq_lintegral_pos_part_sub_lintegral_neg_part,
        lintegral_with_density_eq_lintegral_mul _ (measurable_pdf X ℙ μ) hf.neg.ennreal_of_real,
        lintegral_with_density_eq_lintegral_mul _ (measurable_pdf X ℙ μ) hf.ennreal_of_real],
    { congr' 2,
      { have : ∀ x, ennreal.of_real (f x * (pdf X ℙ μ x).to_real) =
          ennreal.of_real (pdf X ℙ μ x).to_real * ennreal.of_real (f x),
        { intro x,
          rw [mul_comm, ennreal.of_real_mul ennreal.to_real_nonneg] },
        simp_rw [this],
        exact lintegral_congr_ae (filter.eventually_eq.mul of_real_to_real_ae_eq (ae_eq_refl _)) },
      { have : ∀ x, ennreal.of_real (- (f x * (pdf X ℙ μ x).to_real)) =
          ennreal.of_real (pdf X ℙ μ x).to_real * ennreal.of_real (-f x),
        { intro x,
          rw [neg_mul_eq_neg_mul, mul_comm, ennreal.of_real_mul ennreal.to_real_nonneg] },
        simp_rw [this],
        exact lintegral_congr_ae (filter.eventually_eq.mul of_real_to_real_ae_eq
          (ae_eq_refl _)) } },
    { refine ⟨hf.ae_measurable, _⟩,
      rw [has_finite_integral, lintegral_with_density_eq_lintegral_mul _
            (measurable_pdf _ _ _) hf.nnnorm.coe_nnreal_ennreal],
      have : (λ x, (pdf X ℙ μ * λ x, ↑∥f x∥₊) x) =ᵐ[μ] (λ x, ∥f x * (pdf X ℙ μ x).to_real∥₊),
      { simp_rw [← smul_eq_mul, nnnorm_smul, ennreal.coe_mul],
        rw [smul_eq_mul, mul_comm],
        refine filter.eventually_eq.mul (ae_eq_refl _) (ae_eq_trans of_real_to_real_ae_eq.symm _),
        convert ae_eq_refl _,
        ext1 x,
        exact real.ennnorm_eq_of_real ennreal.to_real_nonneg },
      rw lintegral_congr_ae this,
      exact hpdf.2 } },
  { rw [integral_undef hpdf, integral_undef],
    rwa ← integrable_iff_integrable_mul_pdf hf at hpdf,
    all_goals { apply_instance } }
end

lemma map_absolutely_continuous {X : α → E} [has_pdf X ℙ μ] : map X ℙ ≪ μ :=
by { rw map_eq_with_density_pdf X ℙ μ, exact with_density_absolutely_continuous _ _, }

/-- A random variable that `has_pdf` is quasi-measure preserving. -/
lemma to_quasi_measure_preserving {X : α → E} [has_pdf X ℙ μ] : quasi_measure_preserving X ℙ μ :=
{ measurable := has_pdf.measurable X ℙ μ,
  absolutely_continuous := map_absolutely_continuous, }

lemma have_lebesgue_decomposition_of_has_pdf {X : α → E} [hX' : has_pdf X ℙ μ] :
  (map X ℙ).have_lebesgue_decomposition μ :=
⟨⟨⟨0, pdf X ℙ μ⟩,
  by simp only [zero_add, measurable_pdf X ℙ μ, true_and, mutually_singular.zero_left,
    map_eq_with_density_pdf X ℙ μ] ⟩⟩

lemma has_pdf_iff {X : α → E} :
  has_pdf X ℙ μ ↔ measurable X ∧ (map X ℙ).have_lebesgue_decomposition μ ∧ map X ℙ ≪ μ :=
begin
  split,
  { intro hX',
    exactI ⟨hX'.pdf'.1, have_lebesgue_decomposition_of_has_pdf, map_absolutely_continuous⟩ },
  { rintros ⟨hX, h_decomp, h⟩,
    haveI := h_decomp,
    refine ⟨⟨hX, (measure.map X ℙ).rn_deriv μ, measurable_rn_deriv _ _, _⟩⟩,
    rwa with_density_rn_deriv_eq }
end

lemma has_pdf_iff_of_measurable {X : α → E} (hX : measurable X) :
  has_pdf X ℙ μ ↔ (map X ℙ).have_lebesgue_decomposition μ ∧ map X ℙ ≪ μ :=
by { rw has_pdf_iff, simp only [hX, true_and], }

section

variables {F : Type*} [normed_group F] [measurable_space F] [second_countable_topology F]
  [normed_space ℝ F] [complete_space F] [borel_space F] {ν : measure F}

/-- A random variable that `has_pdf` transformed under a `quasi_measure_preserving`
map also `has_pdf` if `(map g (map X ℙ)).have_lebesgue_decomposition μ`.

`quasi_measure_preserving_has_pdf'` is more useful in the case we are working with a
probability measure and a real-valued random variable. -/
lemma quasi_measure_preserving_has_pdf {X : α → E} [has_pdf X ℙ μ]
  {g : E → F} (hg : quasi_measure_preserving g μ ν)
  (hmap : (map g (map X ℙ)).have_lebesgue_decomposition ν) :
  has_pdf (g ∘ X) ℙ ν :=
begin
  rw [has_pdf_iff, ← map_map hg.measurable (has_pdf.measurable X ℙ μ)],
  refine ⟨hg.measurable.comp (has_pdf.measurable X ℙ μ), hmap, _⟩,
  rw [map_eq_with_density_pdf X ℙ μ],
  refine absolutely_continuous.mk (λ s hsm hs, _),
  rw [map_apply hg.measurable hsm, with_density_apply _ (hg.measurable hsm)],
  have := hg.absolutely_continuous hs,
  rw map_apply hg.measurable hsm at this,
  exact set_lintegral_measure_zero _ _ this,
end

lemma quasi_measure_preserving_has_pdf' [is_finite_measure ℙ] [sigma_finite ν]
  {X : α → E} [has_pdf X ℙ μ] {g : E → F} (hg : quasi_measure_preserving g μ ν) :
  has_pdf (g ∘ X) ℙ ν :=
quasi_measure_preserving_has_pdf hg infer_instance

end

section real

variables [is_finite_measure ℙ] {X : α → ℝ}

/-- A real-valued random variable `X` `has_pdf X ℙ λ` (where `λ` is the Lebesgue measure) if and
only if the push-forward measure of `ℙ` along `X` is absolutely continuous with respect to `λ`. -/
lemma real.has_pdf_iff_of_measurable (hX : measurable X) : has_pdf X ℙ ↔ map X ℙ ≪ volume :=
begin
  rw [has_pdf_iff_of_measurable hX, and_iff_right_iff_imp],
  exact λ h, infer_instance,
end

lemma real.has_pdf_iff : has_pdf X ℙ ↔ measurable X ∧ map X ℙ ≪ volume :=
begin
  by_cases hX : measurable X,
  { rw [real.has_pdf_iff_of_measurable hX, iff_and_self],
    exact λ h, hX,
    apply_instance },
  { exact ⟨λ h, false.elim (hX h.pdf'.1), λ h, false.elim (hX h.1)⟩, }
end

/-- If `X` is a real-valued random variable that has pdf `f`, then the expectation of `X` equals
`∫ x, x * f x ∂λ` where `λ` is the Lebesgue measure. -/
lemma integral_mul_eq_integral [has_pdf X ℙ] :
  ∫ x, x * (pdf X ℙ volume x).to_real = ∫ x, X x ∂ℙ :=
integral_fun_mul_eq_integral measurable_id

lemma has_finite_integral_mul {f : ℝ → ℝ} {g : ℝ → ℝ≥0∞}
  (hg : pdf X ℙ =ᵐ[volume] g) (hgi : ∫⁻ x, ∥f x∥₊ * g x ≠ ∞) :
  has_finite_integral (λ x, f x * (pdf X ℙ volume x).to_real) :=
begin
  rw has_finite_integral,
  have : (λ x, ↑∥f x∥₊ * g x) =ᵐ[volume] (λ x, ∥f x * (pdf X ℙ volume x).to_real∥₊),
  { refine ae_eq_trans (filter.eventually_eq.mul (ae_eq_refl (λ x, ∥f x∥₊))
      (ae_eq_trans hg.symm of_real_to_real_ae_eq.symm)) _,
    simp_rw [← smul_eq_mul, nnnorm_smul, ennreal.coe_mul, smul_eq_mul],
    refine filter.eventually_eq.mul (ae_eq_refl _) _,
    convert ae_eq_refl _,
    ext1 x,
    exact real.ennnorm_eq_of_real ennreal.to_real_nonneg },
  rwa [lt_top_iff_ne_top, ← lintegral_congr_ae this],
end

end real

section

/-! **Uniform Distribution** -/

/-- A random variable `X` has uniform distribution if it has a probability density function `f`
with support `s` such that `f = (μ s)⁻¹ 1ₛ` a.e. where `1ₛ` is the indicator function for `s`. -/
def is_uniform {m : measurable_space α} (X : α → E) (support : set E)
  (ℙ : measure α) (μ : measure E . volume_tac) :=
pdf X ℙ μ =ᵐ[μ] support.indicator ((μ support)⁻¹ • 1)

namespace is_uniform

lemma has_pdf {m : measurable_space α} {X : α → E} {ℙ : measure α} {μ : measure E}
  {support : set E} (hns : μ support ≠ 0) (hnt : μ support ≠ ⊤) (hu : is_uniform X support ℙ μ) :
  has_pdf X ℙ μ :=
has_pdf_of_pdf_ne_zero
begin
  intro hpdf,
  rw [is_uniform, hpdf] at hu,
  suffices : μ (support ∩ function.support ((μ support)⁻¹ • 1)) = 0,
  { have heq : function.support ((μ support)⁻¹ • (1 : E → ℝ≥0∞)) = set.univ,
    { ext x,
      rw [function.mem_support],
      simp [hnt] },
    rw [heq, set.inter_univ] at this,
    exact hns this },
  exact set.indicator_ae_eq_zero hu.symm,
end

lemma pdf_to_real_ae_eq {m : measurable_space α}
  {X : α → E} {ℙ : measure α} {μ : measure E} {s : set E} (hX : is_uniform X s ℙ μ) :
  (λ x, (pdf X ℙ μ x).to_real) =ᵐ[μ]
  (λ x, (s.indicator ((μ s)⁻¹ • (1 : E → ℝ≥0∞)) x).to_real) :=
filter.eventually_eq.fun_comp hX ennreal.to_real

variables [is_finite_measure ℙ] {X : α → ℝ}
variables {s : set ℝ} (hms : measurable_set s) (hns : volume s ≠ 0)

include hms hns

lemma mul_pdf_integrable (hcs : is_compact s) (huX : is_uniform X s ℙ) :
  integrable (λ x : ℝ, x * (pdf X ℙ volume x).to_real) :=
begin
  by_cases hsupp : volume s = ∞,
  { have : pdf X ℙ =ᵐ[volume] 0,
    { refine ae_eq_trans huX _,
      simp [hsupp] },
    refine integrable.congr (integrable_zero _ _ _) _,
    rw [(by simp : (λ x, 0 : ℝ → ℝ) = (λ x, x * (0 : ℝ≥0∞).to_real))],
    refine filter.eventually_eq.mul (ae_eq_refl _)
      (filter.eventually_eq.fun_comp this.symm ennreal.to_real) },
  refine ⟨ae_measurable_id'.mul (measurable_pdf X ℙ).ae_measurable.ennreal_to_real, _⟩,
  refine has_finite_integral_mul huX _,
  set ind := (volume s)⁻¹ • (1 : ℝ → ℝ≥0∞) with hind,
  have : ∀ x, ↑∥x∥₊ * s.indicator ind x = s.indicator (λ x, ∥x∥₊ * ind x) x :=
      λ x, (s.indicator_mul_right (λ x, ↑∥x∥₊) ind).symm,
  simp only [this, lintegral_indicator _ hms, hind, mul_one,
             algebra.id.smul_eq_mul, pi.one_apply, pi.smul_apply],
  rw lintegral_mul_const _ measurable_nnnorm.coe_nnreal_ennreal,
  { refine (ennreal.mul_lt_top (set_lintegral_lt_top_of_is_compact
      hsupp hcs continuous_nnnorm).ne (ennreal.inv_lt_top.2 (pos_iff_ne_zero.mpr hns)).ne).ne },
  { apply_instance }
end

/-- A real uniform random variable `X` with support `s` has expectation
`(λ s)⁻¹ * ∫ x in s, x ∂λ` where `λ` is the Lebesgue measure. -/
lemma integral_eq (hnt : volume s ≠ ⊤) (huX : is_uniform X s ℙ) :
  ∫ x, X x ∂ℙ = (volume s)⁻¹.to_real * ∫ x in s, x :=
begin
  haveI := has_pdf hns hnt huX,
  rw ← integral_mul_eq_integral,
  all_goals { try { apply_instance } },
  rw integral_congr_ae (filter.eventually_eq.mul (ae_eq_refl _) (pdf_to_real_ae_eq huX)),
  have : ∀ x, x * (s.indicator ((volume s)⁻¹ • (1 : ℝ → ℝ≥0∞)) x).to_real =
    x * (s.indicator ((volume s)⁻¹.to_real • (1 : ℝ → ℝ)) x),
  { refine λ x, congr_arg ((*) x) _,
    by_cases hx : x ∈ s,
    { simp [set.indicator_of_mem hx] },
    { simp [set.indicator_of_not_mem hx] }},
  simp_rw [this, ← s.indicator_mul_right (λ x, x),  integral_indicator hms],
  change ∫ x in s, x * ((volume s)⁻¹.to_real • 1) ∂(volume) = _,
  rw [integral_mul_right, mul_comm, algebra.id.smul_eq_mul, mul_one],
end .

end is_uniform

end

end pdf

end measure_theory


import ..lectures.love13_rational_and_real_numbers_demo
import data.nat.parity

/-! # LoVe Homework 9: Rationals, Reals, Quotients -/

namespace LoVe

/-!

## Question 1 (4 points): Cauchy sequences

1,1 (4 points). In the demo, we sorry'ed the proof that the sum of two Cauchy sequences is Cauchy.
Prove this!

Hint: depending on how you approach this, you might want to do a long calc-mode proof.
It can be nice to structure this as

```
    begin
      <other tactics here>
      calc
        t1 = t2 : _
       ... ≤ t3 : _
       ... < t4 : _
    end
```
leaving the placeholders _ in the calc block.
At the end of the calc block, you will be left with one goal for each step of the calculation.

example:
-/

lemma quarter_pos {x : ℚ} (hx : 0 < x) : 0 < x / 4 :=
begin
  have hx2 : 0 < x / 2 := half_pos hx,
  calc 0 < (x / 2) / 2 : _
     ... = x / 4 : _,
  { apply half_pos,
    exact hx2 },
  { ring }
end

lemma sum_is_cauchy (f g : ℕ → ℚ) (hf : is_cau_seq f) (hg : is_cau_seq g) :
  is_cau_seq (λ n, f n + g n) :=
sorry

/-!
## Question 2 (4 points): Operations on the reals

2.1 (3 points). In the demo, we proved `add_comm` on the reals by first proving it for
Cauchy sequences and then lifting this proof. Follow this same procedure
to prove `zero_add : ∀ x : real, 0 + x = x`. State the lemma yourself
(along with any helper lemmas you may need)!
-/

open LoVe.cau_seq

/-!
2.2 (1 point). Every rational number corresponds to a real number.
Define this coercion.
-/

instance rat_real_coe : has_coe ℚ real :=
{ coe := sorry }

/-!

## Question 3 (6 points): Quotients in general

In this problem we'll take a weird quotient of ℕ.

The following lemmas may be useful:
-/

#check even_zero
#check nat.not_even_one

/-!

3.1 (2 points). Define a setoid structure on ℕ using the equivalence relation
where `x ≈ y` if and only if `x` and `y` are both even or both odd.
E.g. 0 ≈ 2, 1 ≈ 5, but ¬ 4 ≈ 5.
-/
instance eqv : setoid ℕ :=
{ r := sorry,
  iseqv := sorry
}

/-!
Now we'll define the quotient of ℕ by this relation.
There are two elements of the quotient:
-/
def eonat := quotient LoVe.eqv

def e : eonat := ⟦0⟧
def o : eonat := ⟦1⟧

/-!
3.2 (2 points). Prove that these are the only two elements of `eonat`.
-/
lemma e_or_o (x : eonat) : x = e ∨ x = o :=
sorry

/-!
3.3 (2 points). Lift the addition function on ℕ to `eonat`.

What does the "addition table" for `eonat` look like?
That is, what are e+e, o+o, e+o, and o+e?
State and prove two of these identities.
-/

def add : eonat → eonat → eonat :=
sorry

end LoVe


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.algebra.structures
import geometry.manifold.times_cont_mdiff_map

/-!
# Algebraic structures over smooth functions

In this file, we define instances of algebraic structures over smooth functions.
-/

noncomputable theory

open_locale manifold

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{H : Type*} [topological_space H] {I : model_with_corners 𝕜 E H}
{H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
{N : Type*} [topological_space N] [charted_space H N]

namespace smooth_map

@[to_additive]
instance has_mul {G : Type*} [has_mul G] [topological_space G] [charted_space H' G]
  [has_smooth_mul I' G] :
  has_mul C^∞⟮I, N; I', G⟯ :=
⟨λ f g, ⟨f * g, f.smooth.mul g.smooth⟩⟩

@[simp, to_additive]
lemma coe_mul {G : Type*} [has_mul G] [topological_space G] [charted_space H' G]
  [has_smooth_mul I' G] (f g : C^∞⟮I, N; I', G⟯) :
  ⇑(f * g) = f * g := rfl

@[to_additive]
instance has_one {G : Type*} [monoid G] [topological_space G] [charted_space H' G] :
  has_one C^∞⟮I, N; I', G⟯ :=
⟨times_cont_mdiff_map.const (1 : G)⟩

@[simp, to_additive]
lemma coe_one {G : Type*} [monoid G] [topological_space G] [charted_space H' G] :
  ⇑(1 : C^∞⟮I, N; I', G⟯) = 1 := rfl

end smooth_map

section group_structure

/-!
### Group structure

In this section we show that smooth functions valued in a Lie group inherit a group structure
under pointwise multiplication.
-/

@[to_additive]
instance smooth_map_semigroup {G : Type*} [semigroup G] [topological_space G]
  [charted_space H' G] [has_smooth_mul I' G] :
  semigroup C^∞⟮I, N; I', G⟯ :=
{ mul_assoc := λ a b c, by ext; exact mul_assoc _ _ _,
  ..smooth_map.has_mul}

@[to_additive]
instance smooth_map_monoid {G : Type*} [monoid G] [topological_space G]
  [charted_space H' G] [has_smooth_mul I' G] :
  monoid C^∞⟮I, N; I', G⟯ :=
{ one_mul := λ a, by ext; exact one_mul _,
  mul_one := λ a, by ext; exact mul_one _,
  ..smooth_map_semigroup,
  ..smooth_map.has_one }

@[to_additive]
instance smooth_map_comm_monoid {G : Type*} [comm_monoid G] [topological_space G]
  [charted_space H' G] [has_smooth_mul I' G] :
  comm_monoid C^∞⟮I, N; I', G⟯ :=
{ mul_comm := λ a b, by ext; exact mul_comm _ _,
  ..smooth_map_monoid,
  ..smooth_map.has_one }

@[to_additive]
instance smooth_map_group {G : Type*} [group G] [topological_space G]
  [charted_space H' G] [lie_group I' G] :
  group C^∞⟮I, N; I', G⟯ :=
{ inv := λ f, ⟨λ x, (f x)⁻¹, f.smooth.inv⟩,
  mul_left_inv := λ a, by ext; exact mul_left_inv _,
  div := λ f g, ⟨f / g, f.smooth.div g.smooth⟩,
  div_eq_mul_inv := λ f g, by ext; exact div_eq_mul_inv _ _,
  .. smooth_map_monoid }

@[simp, to_additive]
lemma smooth_map.coe_inv {G : Type*} [group G] [topological_space G]
  [charted_space H' G] [lie_group I' G] (f : C^∞⟮I, N; I', G⟯) :
  ⇑f⁻¹ = f⁻¹ := rfl

@[simp, to_additive]
lemma smooth_map.coe_div {G : Type*} [group G] [topological_space G]
  [charted_space H' G] [lie_group I' G] (f g : C^∞⟮I, N; I', G⟯) :
  ⇑(f / g) = f / g :=
rfl

@[to_additive]
instance smooth_map_comm_group {G : Type*} [comm_group G] [topological_space G]
  [charted_space H' G] [lie_group I' G] :
  comm_group C^∞⟮I, N; I', G⟯ :=
{ ..smooth_map_group,
  ..smooth_map_comm_monoid }

end group_structure

section ring_structure

/-!
### Ring stucture

In this section we show that smooth functions valued in a smooth ring `R` inherit a ring structure
under pointwise multiplication.
-/

instance smooth_map_semiring {R : Type*} [semiring R] [topological_space R]
  [charted_space H' R] [smooth_semiring I' R] :
  semiring C^∞⟮I, N; I', R⟯ :=
{ left_distrib := λ a b c, by ext; exact left_distrib _ _ _,
  right_distrib := λ a b c, by ext; exact right_distrib _ _ _,
  zero_mul := λ a, by ext; exact zero_mul _,
  mul_zero := λ a, by ext; exact mul_zero _,
  ..smooth_map_add_comm_monoid,
  ..smooth_map_monoid }

instance smooth_map_ring {R : Type*} [ring R] [topological_space R]
  [charted_space H' R] [smooth_ring I' R] :
  ring C^∞⟮I, N; I', R⟯ :=
{ ..smooth_map_semiring,
  ..smooth_map_add_comm_group, }

instance smooth_map_comm_ring {R : Type*} [comm_ring R] [topological_space R]
  [charted_space H' R] [smooth_ring I' R] :
  comm_ring C^∞⟮I, N; I', R⟯ :=
{ ..smooth_map_semiring,
  ..smooth_map_add_comm_group,
  ..smooth_map_comm_monoid,}

end ring_structure

section module_structure

/-!
### Semiodule stucture

In this section we show that smooth functions valued in a vector space `M` over a normed
field `𝕜` inherit a vector space structure.
-/

instance smooth_map_has_scalar
  {V : Type*} [normed_group V] [normed_space 𝕜 V] :
  has_scalar 𝕜 C^∞⟮I, N; 𝓘(𝕜, V), V⟯ :=
⟨λ r f, ⟨r • f, smooth_const.smul f.smooth⟩⟩

@[simp]
lemma smooth_map.coe_smul
  {V : Type*} [normed_group V] [normed_space 𝕜 V] (r : 𝕜) (f : C^∞⟮I, N; 𝓘(𝕜, V), V⟯) :
  ⇑(r • f) = r • f := rfl

instance smooth_map_module
  {V : Type*} [normed_group V] [normed_space 𝕜 V] :
  module 𝕜 C^∞⟮I, N; 𝓘(𝕜, V), V⟯ :=
module.of_core $
{ smul     := (•),
  smul_add := λ c f g, by ext x; exact smul_add c (f x) (g x),
  add_smul := λ c₁ c₂ f, by ext x; exact add_smul c₁ c₂ (f x),
  mul_smul := λ c₁ c₂ f, by ext x; exact mul_smul c₁ c₂ (f x),
  one_smul := λ f, by ext x; exact one_smul 𝕜 (f x), }

end module_structure

section algebra_structure

/-!
### Algebra structure

In this section we show that smooth functions valued in a normed algebra `A` over a normed field `𝕜`
inherit an algebra structure.
-/

variables {A : Type*} [normed_ring A] [normed_algebra 𝕜 A] [smooth_ring 𝓘(𝕜, A) A]

/-- Smooth constant functions as a `ring_hom`. -/
def smooth_map.C : 𝕜 →+* C^∞⟮I, N; 𝓘(𝕜, A), A⟯ :=
{ to_fun    := λ c : 𝕜, ⟨λ x, ((algebra_map 𝕜 A) c), smooth_const⟩,
  map_one'  := by ext x; exact (algebra_map 𝕜 A).map_one,
  map_mul'  := λ c₁ c₂, by ext x; exact (algebra_map 𝕜 A).map_mul _ _,
  map_zero' := by ext x; exact (algebra_map 𝕜 A).map_zero,
  map_add'  := λ c₁ c₂, by ext x; exact (algebra_map 𝕜 A).map_add _ _ }

instance : algebra 𝕜 C^∞⟮I, N; 𝓘(𝕜, A), A⟯ :=
{ smul := λ r f,
  ⟨r • f, smooth_const.smul f.smooth⟩,
  to_ring_hom := smooth_map.C,
  commutes' := λ c f, by ext x; exact algebra.commutes' _ _,
  smul_def' := λ c f, by ext x; exact algebra.smul_def' _ _,
  ..smooth_map_semiring }

end algebra_structure

section module_over_continuous_functions

/-!
### Structure as module over scalar functions

If `V` is a module over `𝕜`, then we show that the space of smooth functions from `N` to `V`
is naturally a vector space over the ring of smooth functions from `N` to `𝕜`. -/

instance smooth_map_has_scalar'
  {V : Type*} [normed_group V] [normed_space 𝕜 V] :
  has_scalar C^∞⟮I, N; 𝓘(𝕜), 𝕜⟯ C^∞⟮I, N; 𝓘(𝕜, V), V⟯ :=
⟨λ f g, ⟨λ x, (f x) • (g x), (smooth.smul f.2 g.2)⟩⟩

instance smooth_map_module'
  {V : Type*} [normed_group V] [normed_space 𝕜 V] :
  module C^∞⟮I, N; 𝓘(𝕜), 𝕜⟯ C^∞⟮I, N; 𝓘(𝕜, V), V⟯ :=
{ smul     := (•),
  smul_add := λ c f g, by ext x; exact smul_add (c x) (f x) (g x),
  add_smul := λ c₁ c₂ f, by ext x; exact add_smul (c₁ x) (c₂ x) (f x),
  mul_smul := λ c₁ c₂ f, by ext x; exact mul_smul (c₁ x) (c₂ x) (f x),
  one_smul := λ f, by ext x; exact one_smul 𝕜 (f x),
  zero_smul := λ f, by ext x; exact zero_smul _ _,
  smul_zero := λ r, by ext x; exact smul_zero _, }

end module_over_continuous_functions


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

import topology.algebra.group
import logic.function.iterate

/-!
# Flows and invariant sets

This file defines a flow on a topological space `α` by a topological
monoid `τ` as a continuous monoid-act of `τ` on `α`. Anticipating the
cases where `τ` is one of `ℕ`, `ℤ`, `ℝ⁺`, or `ℝ`, we use additive
notation for the monoids, though the definition does not require
commutativity.

A subset `s` of `α` is invariant under a family of maps `ϕₜ : α → α`
if `ϕₜ s ⊆ s` for all `t`. In many cases `ϕ` will be a flow on
`α`. For the cases where `ϕ` is a flow by an ordered (additive,
commutative) monoid, we additionally define forward invariance, where
`t` ranges over those elements which are nonnegative.

Additionally, we define such constructions as the restriction of a
flow onto an invariant subset, and the time-reveral of a flow by a
group.
-/

open set function filter

/-!
### Invariant sets
-/

section invariant

variables {τ  : Type*} {α : Type*}

/-- A set `s ⊆ α` is invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t` in `τ`. -/
def is_invariant (ϕ : τ → α → α) (s : set α): Prop := ∀ t, maps_to (ϕ t) s s

variables (ϕ : τ → α → α) (s : set α)

lemma is_invariant_iff_image : is_invariant ϕ s ↔ ∀ t, ϕ t '' s ⊆ s :=
by simp_rw [is_invariant, maps_to']

/-- A set `s ⊆ α` is forward-invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t ≥ 0`. -/
def is_fw_invariant [preorder τ] [has_zero τ] (ϕ : τ → α → α) (s : set α): Prop :=
∀ ⦃t⦄, 0 ≤ t → maps_to (ϕ t) s s

lemma is_invariant.is_fw_invariant [preorder τ] [has_zero τ] {ϕ : τ → α → α} {s : set α}
  (h : is_invariant ϕ s) : is_fw_invariant ϕ s :=
λ t ht, h t

/-- If `τ` is a `canonically_ordered_add_monoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`is_fw_invariant` and `is_invariant` are equivalent. -/
lemma is_fw_invariant.is_invariant [canonically_ordered_add_monoid τ] {ϕ : τ → α → α} {s : set α}
  (h : is_fw_invariant ϕ s) : is_invariant ϕ s :=
λ t, h (zero_le t)

/-- If `τ` is a `canonically_ordered_add_monoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`is_fw_invariant` and `is_invariant` are equivalent. -/
lemma is_fw_invariant_iff_is_invariant [canonically_ordered_add_monoid τ]
  {ϕ : τ → α → α} {s : set α} :
  is_fw_invariant ϕ s ↔ is_invariant ϕ s :=
⟨is_fw_invariant.is_invariant, is_invariant.is_fw_invariant⟩

end invariant

/-!
### Flows
-/

/-- A flow on a topological space `α` by an a additive topological
    monoid `τ` is a continuous monoid action of `τ` on `α`.-/
structure flow
  (τ : Type*) [topological_space τ] [add_monoid τ] [has_continuous_add τ]
  (α : Type*) [topological_space α] :=
(to_fun    : τ → α → α)
(cont'     : continuous (uncurry to_fun))
(map_add'  : ∀ t₁ t₂ x, to_fun (t₁ + t₂) x = to_fun t₁ (to_fun t₂ x))
(map_zero' : ∀ x, to_fun 0 x = x)

namespace flow

variables
{τ : Type*} [add_monoid τ] [topological_space τ] [has_continuous_add τ]
{α : Type*} [topological_space α]
(ϕ : flow τ α)

instance : inhabited (flow τ α) :=
⟨{ to_fun    := λ _ x, x,
   cont'     := continuous_snd,
   map_add'  := λ _ _ _, rfl,
   map_zero' := λ _, rfl }⟩

instance : has_coe_to_fun (flow τ α) := ⟨_, flow.to_fun⟩

@[ext]

@[continuity]
protected lemma continuous {β : Type*} [topological_space β]
  {t : β → τ} (ht : continuous t) {f : β → α} (hf : continuous f) :
  continuous (λ x, ϕ (t x) (f x)) :=
ϕ.cont'.comp (ht.prod_mk hf)

alias flow.continuous ← continuous.flow

lemma map_add (t₁ t₂ : τ) (x : α) : ϕ (t₁ + t₂) x = ϕ t₁ (ϕ t₂ x) :=
ϕ.map_add' _ _ _

@[simp] lemma map_zero : ϕ 0 = id := funext ϕ.map_zero'

lemma map_zero_apply (x : α) : ϕ 0 x = x := ϕ.map_zero' x

/-- Iterations of a continuous function from a topological space `α`
    to itself defines a semiflow by `ℕ` on `α`. -/
def from_iter {g : α → α} (h : continuous g) : flow ℕ α :=
{ to_fun    := λ n x, g^[n] x,
  cont'     := continuous_uncurry_of_discrete_topology_left (continuous.iterate h),
  map_add'  := iterate_add_apply _,
  map_zero' := λ x, rfl }

/-- Restriction of a flow onto an invariant set. -/
def restrict {s : set α} (h : is_invariant ϕ s) : flow τ ↥s :=
{ to_fun    := λ t, (h t).restrict _ _ _,
  cont'     := continuous_subtype_mk _ (ϕ.continuous continuous_fst
    (continuous_subtype_coe.comp continuous_snd)),
  map_add'  := λ _ _ _, subtype.ext (map_add _ _ _ _),
  map_zero' := λ _, subtype.ext (map_zero_apply _ _)}

end flow

namespace flow

variables
{τ : Type*} [add_comm_group τ] [topological_space τ] [topological_add_group τ]
{α : Type*} [topological_space α]
(ϕ : flow τ α)

lemma is_invariant_iff_image_eq (s : set α) :
  is_invariant ϕ s ↔ ∀ t, ϕ t '' s = s :=
(is_invariant_iff_image _ _).trans (iff.intro
  (λ h t, subset.antisymm (h t) (λ _ hx, ⟨_, h (-t) ⟨_, hx, rfl⟩, by simp [← map_add]⟩))
  (λ h t, by rw h t))

/-- The time-reversal of a flow `ϕ` by a (commutative, additive) group
    is defined `ϕ.reverse t x = ϕ (-t) x`. -/
def reverse : flow τ α :=
{ to_fun    := λ t, ϕ (-t),
  cont'     := ϕ.continuous continuous_fst.neg continuous_snd,
  map_add'  := λ _ _ _, by rw [neg_add, map_add],
  map_zero' := λ _, by rw [neg_zero, map_zero_apply] }

/-- The map `ϕ t` as a homeomorphism. -/
def to_homeomorph (t : τ) : α ≃ₜ α :=
{ to_fun := ϕ t,
  inv_fun := ϕ (-t),
  left_inv := λ x, by rw [← map_add, neg_add_self, map_zero_apply],
  right_inv := λ x, by rw [← map_add, add_neg_self, map_zero_apply] }

lemma image_eq_preimage (t : τ) (s : set α) : ϕ t '' s = ϕ (-t) ⁻¹' s :=
(ϕ.to_homeomorph t).to_equiv.image_eq_preimage s

end flow


/-
Copyright (c) 2020 James Arthur. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: James Arthur, Chris Hughes, Shing Tak Lam
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.special_functions.trigonometric
import Mathlib.PostPort

namespace Mathlib

/-!
# Inverse of the sinh function

In this file we prove that sinh is bijective and hence has an
inverse, arsinh.

## Main Results

- `sinh_injective`: The proof that `sinh` is injective
- `sinh_surjective`: The proof that `sinh` is surjective
- `sinh_bijective`: The proof `sinh` is bijective
- `arsinh`: The inverse function of `sinh`

## Tags

arsinh, arcsinh, argsinh, asinh, sinh injective, sinh bijective, sinh surjective
-/

namespace real

/-- `arsinh` is defined using a logarithm, `arsinh x = log (x + sqrt(1 + x^2))`. -/
def arsinh (x : ℝ) : ℝ := log (x + sqrt (1 + x ^ bit0 1))

/-- `sinh` is injective, `∀ a b, sinh a = sinh b → a = b`. -/
theorem sinh_injective : function.injective sinh := strict_mono.injective sinh_strict_mono

/-- `arsinh` is the right inverse of `sinh`. -/
theorem sinh_arsinh (x : ℝ) : sinh (arsinh x) = x := sorry

/-- `sinh` is surjective, `∀ b, ∃ a, sinh a = b`. In this case, we use `a = arsinh b`. -/
theorem sinh_surjective : function.surjective sinh := function.left_inverse.surjective sinh_arsinh

/-- `sinh` is bijective, both injective and surjective. -/
theorem sinh_bijective : function.bijective sinh :=
  { left := sinh_injective, right := sinh_surjective }

/-- A rearrangement and `sqrt` of `real.cosh_sq_sub_sinh_sq`. -/
theorem sqrt_one_add_sinh_sq (x : ℝ) : sqrt (1 + sinh x ^ bit0 1) = cosh x := sorry

/-- `arsinh` is the left inverse of `sinh`. -/
theorem arsinh_sinh (x : ℝ) : arsinh (sinh x) = x :=
  function.right_inverse_of_injective_of_left_inverse sinh_injective sinh_arsinh x

end Mathlib


import .love01_definitions_and_statements_demo

/-! # LoVe Demo 2: Backward Proofs

A __tactic__ operates on a proof goal and either proves it or creates new
subgoals. Tactics are a __backward__ proof mechanism: They start from the goal
and work towards the available hypotheses and lemmas. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

namespace backward_proofs

/-! ## Tactic Mode

Syntax of tactical proofs:

    begin
      _tactic₁_,
      …,
      _tacticN_
    end -/

lemma fst_of_two_props :
  ∀a b : Prop, a → b → a :=
begin
  intros a b,
  intros ha hb,
  apply ha
end

/-! ## Basic Tactics

`intro`(`s`) moves `∀`-quantified variables, or the assumptions of
implications `→`, from the goal's conclusion (after `⊢`) into the goal's
hypotheses (before `⊢`).

`apply` matches the goal's conclusion with the conclusion of the specified lemma
and adds the lemma's hypotheses as new goals. -/

lemma fst_of_two_props₂ (a b : Prop) (ha : a) (hb : b) :
  a :=
begin
  apply ha
end

/-! Terminal tactic syntax:

    by _tactic_

abbreviates

    begin
      _tactic_
    end -/

lemma fst_of_two_props₃ (a b : Prop) (ha : a) (hb : b) :
  a :=
by apply ha

lemma prop_comp (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
begin
  intro ha,
  apply hbc,
  apply hab,
  apply ha
end

/-! `exact` matches the goal's conclusion with the specified lemma, closing the
goal. We can often use `apply` in such situations, but `exact` communicates our
intentions better. -/

lemma fst_of_two_props₄ (a b : Prop) (ha : a) (hb : b) :
  a :=
by exact ha

/-! `assumption` finds a hypothesis from the local context that matches the
goal's conclusion and applies it to prove the goal. -/

lemma fst_of_two_props₅ (a b : Prop) (ha : a) (hb : b) :
  a :=
by assumption

/-! `refl` proves `l = r`, where the two sides are syntactically equal up to
computation. Computation means unfolding of definitions, β-reduction
(application of λ to an argument), `let`, and more. -/

lemma α_example {α β : Type} (f : α → β) :
  (λx, f x) = (λy, f y) :=
begin
  refl
end

lemma α_example₂ {α β : Type} (f : α → β) :
  (λx, f x) = (λy, f y) :=
by refl

lemma β_example {α β : Type} (f : α → β) (a : α) :
  (λx, f x) a = f a :=
by refl

def double (n : ℕ) : ℕ :=
n + n

lemma δ_example :
  double 5 = 5 + 5 :=
by refl

lemma ζ_example :
  (let n : ℕ := 2 in n + n) = 4 :=
by refl

lemma η_example {α β : Type} (f : α → β) :
  (λx, f x) = f :=
by refl

lemma ι_example {α β : Type} (a : α) (b : β) :
  prod.fst (a, b) = a :=
by refl

/-! ## Reasoning about Logical Connectives and Quantifiers

Introduction rules: -/

#check true.intro
#check not.intro
#check and.intro
#check or.intro_left
#check or.intro_right
#check iff.intro
#check exists.intro

/-! Elimination rules: -/

#check false.elim
#check and.elim_left
#check and.elim_right
#check or.elim
#check iff.elim_left
#check iff.elim_right
#check exists.elim

/-! Definition of `¬` and related lemmas: -/

#print not
#check not_def
#check classical.em
#check classical.by_contradiction

lemma and_swap (a b : Prop) :
  a ∧ b → b ∧ a :=
begin
  intro hab,
  apply and.intro,
  apply and.elim_right,
  exact hab,
  apply and.elim_left,
  exact hab
end

/-! The `{ … }` combinator focuses on the first subgoal. The tactic inside must
fully prove it. -/

lemma and_swap₂ :
  ∀a b : Prop, a ∧ b → b ∧ a :=
begin
  intros a b hab,
  apply and.intro,
  { exact and.elim_right hab },
  { exact and.elim_left hab }
end

/-! Notice above how we pass the hypothesis `hab` directly to the lemmas
`and.elim_right` and `and.elim_left`, instead of waiting for the lemmas's
assumptions to appear as new subgoals. This is a small forward step in an
otherwise backward proof. -/

lemma or_swap (a b : Prop) :
  a ∨ b → b ∨ a :=
begin
  intros hab,
  apply or.elim hab,
  { intro ha,
    exact or.intro_right _ ha },
  { intro hb,
    exact or.intro_left _ hb }
end

lemma modus_ponens (a b : Prop) :
  (a → b) → a → b :=
begin
  intros hab ha,
  apply hab,
  exact ha
end

lemma not_not_intro (a : Prop) :
  a → ¬¬ a :=
begin
  intro ha,
  apply not.intro,
  intro hna,
  apply hna,
  exact ha
end

lemma not_not_intro₂ (a : Prop) :
  a → ¬¬ a :=
begin
  intros ha hna,
  apply hna,
  exact ha
end

lemma nat_exists_double_iden :
  ∃n : ℕ, double n = n :=
begin
  apply exists.intro 0,
  refl
end

/-! ## Reasoning about Equality -/

#check eq.refl
#check eq.symm
#check eq.trans
#check eq.subst

/-! The above rules can be used directly: -/

lemma cong_fst_arg {α : Type} (a a' b : α)
    (f : α → α → α) (ha : a = a') :
  f a b = f a' b :=
begin
  apply eq.subst ha,
  apply eq.refl
end

lemma cong_two_args {α : Type} (a a' b b' : α)
    (f : α → α → α) (ha : a = a') (hb : b = b') :
  f a b = f a' b' :=
begin
  apply eq.subst ha,
  apply eq.subst hb,
  apply eq.refl
end

/-! `rw` applies a single equation as a left-to-right rewrite rule, once. To
apply an equation right-to-left, prefix its name with `←`. -/

lemma cong_two_args₂ {α : Type} (a a' b b' : α)
    (f : α → α → α) (ha : a = a') (hb : b = b') :
  f a b = f a' b' :=
begin
  rw ha,
  rw hb
end

lemma a_proof_of_negation₃ (a : Prop) :
  a → ¬¬ a :=
begin
  rw not_def,
  rw not_def,
  intro ha,
  intro hna,
  apply hna,
  exact ha
end

/-! `simp` applies a standard set of rewrite rules (the __simp set__)
exhaustively. The set can be extended using the `@[simp]` attribute. Lemmas can
be temporarily added to the simp set with the syntax
`simp [_lemma₁_, …, _lemmaN_]`. -/

lemma cong_two_args_etc {α : Type} (a a' b b' : α)
    (g : α → α → ℕ → α) (ha : a = a') (hb : b = b') :
  g a b (1 + 1) = g a' b' 2 :=
by simp [ha, hb]

/-! `cc` applies __congruence closure__ to derive new equalities. -/

lemma cong_two_args₃ {α : Type} (a a' b b' : α)
    (f : α → α → α) (ha : a = a') (hb : b = b') :
  f a b = f a' b' :=
by cc

/-! `cc` can also reason up to associativity and commutativity of `+`, `*`,
and other binary operators. -/

lemma cong_assoc_comm (a a' b c : ℝ) (f : ℝ → ℝ)
    (ha : a = a') :
  f (a + b + c) = f (c + b + a') :=
by cc

/-! ## Proofs by Mathematical Induction

`induction'` performs induction on the specified variable. It gives rise to one
subgoal per constructor. -/

lemma add_zero (n : ℕ) :
  add 0 n = n :=
begin
  induction' n,
  { refl },
  { simp [add, ih] }
end

/-! We use `induction'`, a variant of Lean's built-in `induction` tactic. The
two tactics are similar, but `induction'` is more user-friendly. -/

lemma add_succ (m n : ℕ) :
  add (nat.succ m) n = nat.succ (add m n) :=
begin
  induction' n,
  { refl },
  { simp [add, ih] }
end

lemma add_comm (m n : ℕ) :
  add m n = add n m :=
begin
  induction' n,
  { simp [add, add_zero] },
  { simp [add, add_succ, ih] }
end

lemma add_assoc (l m n : ℕ) :
  add (add l m) n = add l (add m n) :=
begin
  induction' n,
  { refl },
  { simp [add, ih] }
end

/-! `cc` is extensible. We can register `add` as a commutative and associative
operator using the type class instance mechanism (explained in lecture 4). This
is useful for the `cc` invocation below. -/

@[instance] def add.is_commutative : is_commutative ℕ add :=
{ comm := add_comm }

@[instance] def add.is_associative : is_associative ℕ add :=
{ assoc := add_assoc }

lemma mul_add (l m n : ℕ) :
  mul l (add m n) = add (mul l m) (mul l n) :=
begin
  induction' n,
  { refl },
  { simp [add, mul, ih],
    cc }
end

/-! ## Cleanup Tactics

`rename` changes the name of a variable or hypothesis.

`clear` removes unused variables or hypotheses. -/

lemma cleanup_example (a b c : Prop) (ha : a) (hb : b)
    (hab : a → b) (hbc : b → c) :
  c :=
begin
  clear ha hab a,
  apply hbc,
  clear hbc c,
  rename hb h,
  exact h
end

end backward_proofs

end LoVe


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.finsupp.basic
import algebra.ordered_group

/-!
# Lattice structure on finsupps

This file provides instances of ordered structures on finsupps.

-/

open_locale classical
noncomputable theory
variables {α : Type*} {β : Type*} [has_zero β] {μ : Type*} [canonically_ordered_add_monoid μ]
variables {γ : Type*} [canonically_linear_ordered_add_monoid γ]

namespace finsupp

instance : order_bot (α →₀ μ) :=
{ bot := 0, bot_le := by simp [finsupp.le_def, ← bot_eq_zero], .. finsupp.partial_order}

instance [semilattice_inf β] : semilattice_inf (α →₀ β) :=
{ inf := zip_with (⊓) inf_idem,
  inf_le_left := λ a b c, inf_le_left,
  inf_le_right := λ a b c, inf_le_right,
  le_inf := λ a b c h1 h2 s, le_inf (h1 s) (h2 s),
  ..finsupp.partial_order, }

@[simp]
lemma inf_apply [semilattice_inf β] {a : α} {f g : α →₀ β} : (f ⊓ g) a = f a ⊓ g a := rfl

@[simp]
lemma support_inf {f g : α →₀ γ} : (f ⊓ g).support = f.support ∩ g.support :=
begin
  ext, simp only [inf_apply, mem_support_iff,  ne.def,
    finset.mem_union, finset.mem_filter, finset.mem_inter],
  rw [← decidable.not_or_iff_and_not, ← not_congr],
  rw inf_eq_min, unfold min, split_ifs;
  { try {apply or_iff_left_of_imp}, try {apply or_iff_right_of_imp}, intro con, rw con at h,
    revert h, simp, }
end

instance [semilattice_sup β] : semilattice_sup (α →₀ β) :=
{ sup := zip_with (⊔) sup_idem,
  le_sup_left := λ a b c, le_sup_left,
  le_sup_right := λ a b c, le_sup_right,
  sup_le := λ a b c h1 h2 s, sup_le (h1 s) (h2 s),
  ..finsupp.partial_order, }

@[simp]
lemma sup_apply [semilattice_sup β] {a : α} {f g : α →₀ β} : (f ⊔ g) a = f a ⊔ g a := rfl

@[simp]
lemma support_sup
  {f g : α →₀ γ} : (f ⊔ g).support = f.support ∪ g.support :=
begin
  ext, simp only [finset.mem_union, mem_support_iff, sup_apply, ne.def, ← bot_eq_zero],
  rw sup_eq_bot_iff, tauto,
end

instance lattice [lattice β] : lattice (α →₀ β) :=
{ .. finsupp.semilattice_inf, .. finsupp.semilattice_sup}

instance semilattice_inf_bot : semilattice_inf_bot (α →₀ γ) :=
{ ..finsupp.order_bot, ..finsupp.lattice}

lemma bot_eq_zero : (⊥ : α →₀ γ) = 0 := rfl

lemma disjoint_iff {x y : α →₀ γ} : disjoint x y ↔ disjoint x.support y.support :=
begin
  unfold disjoint, repeat {rw le_bot_iff},
  rw [finsupp.bot_eq_zero, ← finsupp.support_eq_empty, finsupp.support_inf], refl,
end

variable [partial_order β]

/-- The order on `finsupp`s over a partial order embeds into the order on functions -/
def order_embedding_to_fun :
  (α →₀ β) ↪o (α → β) :=
⟨⟨λ (f : α →₀ β) (a : α), f a,  λ f g h, finsupp.ext (λ a, by { dsimp at h, rw h,} )⟩,
  λ a b, (@le_def _ _ _ _ a b).symm⟩

@[simp] lemma order_embedding_to_fun_apply {f : α →₀ β} {a : α} :
  order_embedding_to_fun f a = f a := rfl

lemma monotone_to_fun : monotone (finsupp.to_fun : (α →₀ β) → (α → β)) := λ f g h a, le_def.1 h a

end finsupp


import .definitions
import .nat_extra
import .decidable_relations

def plist : list ℕ → bool
| []       := tt
| (h :: t) := nt.irreducible h && plist t

namespace list

/-
Basic lemmas concerning products and prime lists
-/

lemma product_concat (l1 l2 : list ℕ) : product (l1 ++ l2) = (product l1) * (product l2) :=
begin
induction l1,
{ by simp [product] },
{ by simp [product, ih_1] }
end

lemma plist_concat (l1 l2 : list ℕ) : plist l1 = tt → plist l2 = tt → plist (l1 ++ l2) = tt :=
begin
induction l1,
{ intros, by simp [a_1] },
{ intros, simp [plist] at a_2, simp [plist], apply and.intro,
  { exact a_2.right },
  { exact ih_1 a_2.left a_3 }
}
end

lemma lmax_head {x y : ℕ} {t : list ℕ} (h : sorted (x :: y :: t) = tt) : y ≤ x :=
begin
  simp [sorted] at h,
  have : max x (lmax (y :: t)) = x, exact nat.eq_eq h.right.right,
  have hx : max y (lmax t) ≤ x, by rw [←this]; exact le_max_right x (lmax (y :: t)),
  have hy : y ≤ max y (lmax t), by simp [le_max_left],
  exact nat.le_trans hy hx
end

lemma plist_prod_nonzero {l : list ℕ} (h : plist l = tt) : product l ≠ 0 :=
begin
  induction l with p t ih,
  { simp [product] },
  { simp [product],
    have ht : plist t = tt, by simp [plist] at h; exact h.left,
    by_cases p = 0 with hp,
    { simp [plist] at h,
      have : nt.irreducible p, from of_to_bool_true h.right,
      exact absurd hp this.left },
    { have hpg0 : product t ≠ 0, from ih ht,
      --this was incredibly annoying; any ideas how we could make this easier?
      have hp : nat.succ (nat.pred p) = p, from nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hp),
      have ht : nat.succ (nat.pred (product t)) = product t, from nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hpg0),
      have : p*(product t) = 1 + (nat.pred p) + (nat.pred (product t)) + (nat.pred p)*(nat.pred (product t)),
        by rw [←hp,←ht]; apply nat.foil,
      have : p*(product t) = nat.succ((nat.pred p) + (nat.pred (product t)) + (nat.pred p)*(nat.pred (product t))),
        by rw [←nat.one_add]; simp [this],
      rw [this], exact nat.succ_ne_zero ((nat.pred p) + (nat.pred (product t)) + (nat.pred p)*(nat.pred (product t)))
    }
  }
end

lemma plist_prod_one {l : list ℕ} (h : plist l = tt) : product l = 1 → l = [] :=
begin
  cases l with p t,
  { simp },
  { intro, simp [product] at a,
    have : p = 1, from (nat.unique_unit a).left,
    simp [plist, nt.computable_irreducible] at h,
    have : p ≠ 1, from (of_to_bool_true h.right).right.left,
    contradiction
  }
end

/-
We'll need some machinery about permutations to talk about unique prime lists.
This stuff is ripped from mathlib.
-/

variable {α : Type}
open perm

@[refl] protected theorem perm.refl : ∀ (l : list α), l ~ l
| []      := perm.nil
| (x::xs) := skip x (perm.refl xs)

@[symm] protected theorem perm.symm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₂ ~ l₁ :=
perm.rec_on p
  perm.nil
  (λ x l₁ l₂ p₁ r₁, skip x r₁)
  (λ x y l, swap y x l)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₂ r₁)

attribute [trans] perm.trans

/-
Interactions of permutations with our other list definitions
-/

lemma perm_product {l₁ l₂ : list ℕ} (h : l₁ ~ l₂) : product l₁ = product l₂ :=
begin
induction h,
{ simp },
{ simp [product,ih_1] },
{ simp [product] },
{ simp [ih_1,ih_2] }
end

lemma perm_lmax {l₁ l₂ : list ℕ} (h : l₁ ~ l₂) : lmax l₁ = lmax l₂ :=
begin
induction h,
{ simp },
{ simp [lmax,ih_1] },
{ simp [lmax,max_left_comm] },
{ simp [ih_1,ih_2] }
end

lemma perm_plist {l₁ l₂ : list ℕ} (h : l₁ ~ l₂) (hp : plist l₁ = tt) : plist l₂ = tt :=
begin
-- is there a way to clean up this induction re: term introduction?
-- check out perm_induction_on in perm.lean in mathlib?
induction h with x l₁ l₂ l₃ ih x y l l₁ l₂,
{ exact hp },
{ have : plist l₁ = tt, by simp [plist] at hp; exact hp.left,
  have hp2 : plist l₂ = tt, by simp [this] at ih; exact ih,
  have : nt.irreducible x, by simp [plist] at hp; exact of_to_bool_true hp.right,
  simp [plist], exact and.intro hp2 (to_bool_true this)
},
{ have hpx : to_bool (nt.irreducible x) = tt, by simp [plist] at hp; exact hp.right.left,
  have hpy : to_bool (nt.irreducible y) = tt, by simp [plist,plist] at hp; exact hp.right.right,
  have hpl : plist l = tt, by simp [plist, plist] at hp; exact hp.left,
  have hpyl : plist (y :: l) = tt, by simp [plist]; exact and.intro hpl hpy,
  simp [plist], exact and.intro hpl (and.intro hpx hpy)
},
{ apply ih_2, apply ih_1, assumption }
end

/-
We need to prove the existence of sorted lists. To do this, we introduce a
sorting algorithm and show that it spits out a sorted permutation.
-/

lemma perm_ordered_insert (x : ℕ) (l : list ℕ) : ordered_insert x l ~ x :: l :=
begin
induction l with y l ih,
{ simp [ordered_insert] },
{ by_cases y ≤ x with h,
  { simp [ordered_insert, h] },
  { simp [ordered_insert, h],
    have hxy : y :: x :: l ~ x :: y :: l, by simp [perm.swap],
    suffices : y :: ordered_insert x l ~ y :: x :: l,
    { transitivity, apply this, apply hxy },
    { apply perm.skip, simp [ih] }
  }
}
end

lemma perm_insertion_sort (l : list ℕ) : insertion_sort l ~ l :=
begin
induction l with y l ih,
{ simp [insertion_sort] },
{ simp [insertion_sort],
  have h : ordered_insert y (insertion_sort l) ~ y :: insertion_sort l,
    by apply perm_ordered_insert,
  transitivity, assumption, apply perm.skip, apply ih
}
end

lemma sorted_singleton (x : ℕ) : sorted [x] = tt :=
begin
  simp [sorted, lmax, max],
  by_cases x ≤ 0,
  { simp [nat.eq_zero_of_le_zero h, nat.eq] },
  { simp [h, nat.eq] }
end

lemma sorted_head (x : ℕ) (l : list ℕ)
  : sorted (x :: l) = tt ↔ lmax l ≤ x ∧ sorted l = tt :=
begin
split,
{ intro h, simp [sorted] at h,
  have hx : max x (lmax l) = x, from nat.eq_eq h.right,
  split,
  { rw [←hx], simp [le_max_right] },
  { exact h.left }
},
{ intro h, simp [sorted],
  have : max x (lmax l) = x, by simp [max_eq_left h.left],
  apply and.intro,
  { exact h.right },
  { exact nat.eq_of_eq this }
}
end

lemma sorted_ordered_insert {x : ℕ} {l : list ℕ}
 : sorted l = tt → sorted (ordered_insert x l) = tt :=
begin
intro h, induction l with y l ih,
{ simp [sorted_singleton] },
{ by_cases y ≤ x with hxy,
  { simp [hxy], simp [sorted],
    apply and.intro,
    { simp [sorted] at h, exact h.left },
    { simp [sorted] at h, apply and.intro,
      { exact h.right },
      { have : lmax (y :: l) ≤ x,
        begin
          simp [lmax],
          have : max y (lmax l) = y, from nat.eq_eq h.right,
          rw [←this] at hxy, exact hxy
        end,
        have : max x (lmax (y :: l)) = x, from max_eq_left this,
        exact nat.eq_of_eq this
      }
    }
  },
  { have : x ≤ y ∨ y ≤ x, from le_total x y,
    have hyx : x ≤ y, by simp [hxy] at this; assumption,
    have hyl : lmax l ≤ y, by simp [sorted_head] at h; exact h.right,
    have : ordered_insert x l ~ x :: l, by simp [perm_ordered_insert],
    have hyxl : lmax (ordered_insert x l) ≤ y, by
      simp [perm_lmax this, lmax]; simp [max_le hyx hyl],

    have : sorted l = tt, by simp [sorted] at h; exact h.left,
    have hxl : sorted (ordered_insert x l) = tt, from ih this,

    simp [hxy,sorted_head], apply and.intro,
    { exact hxl },
    { exact hyxl }
  }
}
end

lemma sorted_insertion_sort (l : list ℕ) : (sorted $ insertion_sort l) = tt :=
begin
induction l with x l ih,
{ simp [insertion_sort, sorted] },
{ simp [sorted_ordered_insert ih] }
end

/-
Sorting a sorted list is idempotent: idem_insertion_sort.

We conceptually might want the following lemma:

lemma perm_sorted {l₁ l₂ : list ℕ} (h : l₁ ~ l₂) (hs1 : sorted l₁) (hs2 : sorted l₂) : l₁ = l₂

But this seems very hard to prove given our definition of perm_sorted. So
instead we'll get the needed result from less general principles.
-/

lemma idem_insertion_sort {l : list ℕ} (h : sorted l = tt) : insertion_sort l = l :=
--perm_sorted (perm_insertion_sort l) (sorted_insertion_sort l) h
begin
induction l with x t ih,
{ simp },
{ have : sorted t = tt, by simp [sorted] at h; exact h.left,
  simp [insertion_sort], rw [ih this],
  induction t, { simp }, { simp [ordered_insert, list.lmax_head h] }
}
end

end list


/-
  Absolute values on Principal Ideal Domains.
-/

import data.real.cau_seq

import for_mathlib.exp_log

import abvs_equiv

import valuations.basic
import valuations.bounded
import valuations.multiplicative_hom

open is_absolute_value
open_locale classical

def associated_ideal {α} [integral_domain α] [is_principal_ideal_ring α]
    [normalization_monoid α]
    (abv: α → ℝ) [is_absolute_value abv]
    (bounded: ∀ a: α, abv a ≤ 1): ideal α :=
{
  carrier := { a: α | abv a < 1 },
  zero_mem' := by simp [abv_zero abv, zero_lt_one],
  add_mem' := by {
    intros a b ha hb,
    have nonarchimedian := (nonarchimedian_iff_integers_bounded abv).1
      ⟨ 1, zero_lt_one, λ n, bounded n ⟩,
    calc abv (a + b) ≤ max (abv a) (abv b) : nonarchimedian a b
      ... < max 1 1 : max_lt_max ha hb
      ... = 1 : by simp,
  },
  smul_mem' := by {
    intros c x hx,
    rw [algebra.id.smul_eq_mul, set.mem_set_of_eq],
    rw abv_mul abv,
    rw ← mul_one (1: ℝ),
    exact mul_lt_mul' (bounded c) hx (abv_nonneg abv x) zero_lt_one,
  },
}

theorem associated_ideal_prime {α} [integral_domain α] [is_principal_ideal_ring α]
    [normalization_monoid α]
    (abv: α → ℝ) [is_absolute_value abv]
    (bounded: ∀ a: α, abv a ≤ 1): (associated_ideal abv bounded).is_prime :=
begin
  split,
  {
    rw ideal.ne_top_iff_one,
    by_contra,
    have: abv 1 < 1 := h,
    rw abv_one abv at this,
    linarith only [this],
  },
  {
    intros x y,
    contrapose!,
    intro h,
    have: abv x ≥ 1 ∧ abv y ≥ 1,
    { split; by_contra h'; push_neg at h', exact h.1 h', exact h.2 h', },
    suffices: abv (x * y) ≥ 1,
    { intro h, linarith only [this, show abv (x * y) < 1, from h], },
    rw abv_mul abv,
    rw ← mul_one (1: ℝ),
    rw ge_iff_le,
    exact mul_le_mul this.1 this.2 zero_le_one (abv_nonneg abv x),
  },
end

theorem absolute_value_on_primes {α} [integral_domain α] [is_principal_ideal_ring α]
    [normalization_monoid α]
    (abv: α → ℝ) [is_absolute_value abv]
    (bounded: ∀ a: α, abv a ≤ 1)
    (nontrivial: ∃ a: α, a ≠ 0 ∧ abv a ≠ 1):
      ∃ c, 0 < c ∧ c < 1 ∧
      ∃ p: α, prime p ∧ ∀ q: α, prime q → abv q = if associated q p then c else 1 :=
begin
  set I := associated_ideal abv bounded,

  have ideal_prime: I.is_prime,
  from associated_ideal_prime abv bounded,

  obtain ⟨ p, p_prime, abvp_lt_one, p_prop ⟩: ∃ p: α, prime p ∧ abv p < 1 ∧
    ∀ a: α, abv a < 1 → p ∣ a,
  {
    have := _inst_2.principal,
    haveI principal: I.is_principal := this I,
    use submodule.is_principal.generator I,

    have ne_bot: I ≠ ⊥,
    {
      intro h,
      rw submodule.eq_bot_iff at h,
      rcases nontrivial with ⟨ a, ha ⟩,
      have abva_lt_one: abv a < 1,
      from lt_of_le_of_ne (bounded a) ha.2,
      specialize h a abva_lt_one,
      exact ha.1 h,
    },

    refine ⟨ submodule.is_principal.prime_generator_of_prime I ne_bot,
      submodule.is_principal.generator_mem I, _ ⟩,
    intros a ha,
    have a_in_ideal: a ∈ I := ha,
    rw submodule.is_principal.mem_iff_eq_smul_generator I at a_in_ideal,
    cases a_in_ideal with c hc,
    use c,
    rw mul_comm,
    exact hc,
  },

  use [abv p, ((abv_pos abv).2 p_prime.1), abvp_lt_one,
    p, p_prime],
  intros q q_prime,
  exact if hpq: associated q p
    then by {
      simp [hpq],
      cases hpq with c hc,
      rw [← hc, abv_mul abv],
      simp [show abv c = 1, from absolute_value_units_bounded abv bounded c],
    }
    else by {
      simp [hpq],
      by_contra h,
      exact hpq (associated.symm $ primes_associated_of_dvd p_prime q_prime $
        p_prop q $ lt_of_le_of_ne (bounded q) h),
    },
end

theorem abv_bounded_padic {α} [integral_domain α] [is_principal_ideal_ring α]
    [normalization_monoid α]
    (abv: α → ℝ) [is_absolute_value abv]
    (bounded: ∀ a: α, abv a ≤ 1)
    (nontrivial: ∃ a: α, a ≠ 0 ∧ abv a ≠ 1):
      ∃ (p: α) [p_prime: fact (prime p)], abvs_equiv abv (@sample_padic_abv _ _ _ _ p p_prime) :=
begin
  obtain ⟨ c, c_pos, c_lt_one, p, p_prime, prime_vals ⟩ :=
    absolute_value_on_primes abv bounded nontrivial,
  use [p, p_prime],

  set a := - real.log 2 / real.log c with a_def,
  have a_pos: 0 < a,
  {
    refine div_pos_of_neg_of_neg (neg_of_neg_pos _) (real.log_neg c_pos c_lt_one),
    rw neg_neg,
    exact real.log_pos one_lt_two,
  },
  use [a, a_pos],
  set φ₁ := hom_of_equiv (hom_of_abv abv) a a_pos
    (λ a, (show abv = (hom_of_abv abv), from rfl) ▸ abv_nonneg abv a) with φ₁_def,
  haveI : fact (prime p) := fact_iff.2 p_prime,
  set φ₂ := hom_of_abv (sample_padic_abv p) with φ₂_def,
  have φ₁_f: (λ x, abv x ^ a) = φ₁ := rfl,
  have φ₂_f: sample_padic_abv p = φ₂ := rfl,
  rw [φ₁_f, φ₂_f],
  suffices: φ₁ = φ₂, by { rw this, },
  apply ext_hom_primes,
  by simp [← φ₁_f, ← φ₂_f,
    absolute_value_units_bounded abv bounded,
    absolute_value_units_bounded (sample_padic_abv p)
      (sample_padic_abv_bounded p)],
  {
    rw [← φ₁_f, ← φ₂_f],
    intros q hq,
    have q_prime := principal_ideal_ring.irreducible_iff_prime.1 hq,
    dsimp,
    rw prime_vals q q_prime,
    rw sample_padic_abv_on_primes p q q_prime,
    rw a_def,
    exact if hpq: associated q p
      then by {
        simp only [hpq, if_true],
        apply log_inj_pos (real.rpow_pos_of_pos c_pos _) one_half_pos,
        rw real.log_rpow c_pos,
        calc -real.log 2 / real.log c * real.log c
          = -real.log 2 * (real.log c / real.log c) : by ring
          ... = - real.log 2 : by { rw [div_self (real.log_ne_zero_of_ne_one c c_pos $
            ne_of_lt c_lt_one), mul_one], }
          ... = real.log (1/2) : by rw [← real.log_inv, inv_eq_one_div],
      }
      else by simp [hpq],
  },
end


import phase1.basic

/-!
# f-maps

Consider a code `(β, γ, G)`. We are interested in the alternative extensions of this object at
different proper type indices `δ : Λ`. We will define the function `A_δ` which will map the code
`(β, γ, G)` to a new code `(α, δ, D)`. The elements of `D` are produced by the so-called f-maps.
In particular, elements of `D` are of the form `typed_near_litter M` where `M` is a near-litter to
some litter `N`, which in turn is given by an f-map.
-/

open cardinal function set with_bot
open_locale cardinal

universe u

namespace con_nf

section choose_wf

/-!
We construct the f-maps by first defining the auxiliary function `choose_wf`.

Suppose we wish to construct a function `f : α → β` with the constraint that for each `α`,
there is a predefined set of "denied" `β` values that it cannot take. Under some restrictions
based on the cardinalities of the denied set, we can construct such a function.
We can in addition require that `f` be injective if `α` has a well-order, which we will assume here.

The f-maps that we will construct indeed satisfy these conditions.
-/

variables {α β : Type u} {r : α → α → Prop}

/-- Noncomputably chooses an element of `β \ s`, given `#s < #β`. -/
noncomputable def some_of_mk_lt (s : set β) (h : #s < #β) : β :=
(nonempty_compl_of_mk_lt_mk h).some

lemma some_of_mk_lt_spec {s : set β} {h : #s < #β} : some_of_mk_lt s h ∉ s :=
(nonempty_compl_of_mk_lt_mk h).some_spec

lemma mk_image₂_le {p : α → Prop} (f : Π x, p x → β) : #{y // ∃ z h, f z h = y} ≤ #{x // p x} :=
⟨⟨λ y, ⟨y.prop.some, y.prop.some_spec.some⟩, begin
  intros y₁ y₂ h,
  simp only at h,
  have := y₁.prop.some_spec.some_spec,
  simp_rw h at this,
  rw y₂.prop.some_spec.some_spec at this,
  simp only [subtype.coe_inj] at this,
  exact this.symm,
end⟩⟩

noncomputable def choose_wf_core (deny : α → set β)
  (h : ∀ x, #{y // r y x} + #(deny x) < #β) (x : α) (f : Π (y : α), r y x → β) : β :=
begin
  refine some_of_mk_lt ({z | ∃ y h, f y h = z} ∪ deny x) _,
  refine lt_of_le_of_lt (mk_union_le _ _) _,
  exact lt_of_le_of_lt (add_le_add_right (mk_image₂_le _) _) (h x),
end

lemma choose_wf_core_spec {deny : α → set β}
  {h : ∀ x, #{y // r y x} + #(deny x) < #β} (x : α) (f : Π (y : α), r y x → β) :
  choose_wf_core deny h x f ∉ {z | ∃ y h, f y h = z} ∪ deny x :=
some_of_mk_lt_spec

/-- Constructs an injective function `f` such that `f x ∉ deny x`. -/
noncomputable def choose_wf [hwf : is_well_order α r] (deny : α → set β)
  (h : ∀ x, #{y // r y x} + #(deny x) < #β) : α → β :=
hwf.to_is_well_founded.wf.fix (choose_wf_core deny h)

lemma choose_wf_spec [hwf : is_well_order α r] {deny : α → set β}
  {h : ∀ x, #{y // r y x} + #(deny x) < #β} (x : α) :
  choose_wf deny h x ∉ ({z | ∃ y (hy : r y x), choose_wf deny h y = z} ∪ deny x) :=
begin
  rw [choose_wf, well_founded.fix_eq],
  exact choose_wf_core_spec x _,
end

lemma choose_wf_not_mem_deny [is_well_order α r] {deny : α → set β}
  {h : ∀ x, #{y // r y x} + #(deny x) < #β} (x : α) : choose_wf deny h x ∉ deny x :=
λ h', choose_wf_spec x (mem_union_right _ h')

lemma choose_wf_ne_of_r [is_well_order α r] {deny : α → set β}
  {h : ∀ x, #{y // r y x} + #(deny x) < #β} (x₁ x₂ : α) (hx : r x₁ x₂) :
    choose_wf deny h x₁ ≠ choose_wf deny h x₂ :=
λ hx', not_mem_subset (subset_union_left _ _) (choose_wf_spec x₂) ⟨x₁, hx, hx'⟩

lemma choose_wf_injective [is_well_order α r] {deny : α → set β}
  {h : ∀ x, #{y // r y x} + #(deny x) < #β} : injective (choose_wf deny h) :=
begin
  intros x₁ x₂ h,
  obtain hx | hx | hx := (is_well_order.is_trichotomous r).trichotomous x₁ x₂,
  { cases choose_wf_ne_of_r x₁ x₂ hx h },
  { exact hx },
  { cases choose_wf_ne_of_r x₂ x₁ hx h.symm },
end

end choose_wf

/-!
We construct the f-maps by constructing a set of image values to deny, and then choosing
arbitrarily from the remaining set. This uses the `choose_wf` results.
The majority of this section is spent proving that the set of values to deny isn't "too large",
such that we could run out of available values for the function.
-/

variables [params.{u}] {β : type_index} {γ : Λ}
  [core_tangle_data β] [positioned_tangle_data β]
  [position_data.{}] [core_tangle_data γ]
  [positioned_tangle_data γ] [almost_tangle_data γ]
  (hβγ : β ≠ γ)

/-- The requirements to be satisfied by the f-maps.
If `f_map_condition` applied to a litter indexed by `i` is true,
then `i` is *not* a valid output to `f_map x`. -/
inductive f_map_condition (x : tangle β) (i : μ) : Prop
| any (N : set atom) (hN : is_near_litter ⟨i, β, γ, hβγ⟩ N) :
  position (typed_near_litter ⟨⟨i, β, γ, hβγ⟩, N, hN⟩ : tangle γ) ≤ position x →
  f_map_condition
| bot (a : atom) :
  β = ⊥ → -- this condition should only trigger for type `-1`
  a == x → -- using `heq` instead of induction on `β` or the instance deals with many annoyances
  position (typed_near_litter (litter.to_near_litter ⟨i, ⊥, γ, bot_ne_coe⟩) : tangle γ) ≤
    typed_atom_position a →
  f_map_condition

instance : is_well_order (tangle β) (inv_image (<) position) :=
begin
  refine { .. },
  { intros x y,
    have := lt_trichotomy (position x) (position y),
    rw embedding_like.apply_eq_iff_eq at this,
    exact this },
  { intros x y z,
    exact lt_trans },
  { exact inv_image.wf _ μwf.wf },
end

variable (γ)

lemma mk_inv_image_lt (x : tangle β) : #{y // inv_image (<) position y x} < #μ :=
begin
  refine lt_of_le_of_lt _ (show #{y // y < position x} < #μ, from card_Iio_lt _),
  refine ⟨⟨λ y, ⟨_, y.prop⟩, _⟩⟩,
  intros y₁ y₂ h,
  simp only [embedding_like.apply_eq_iff_eq, subtype.coe_inj] at h,
  exact h,
end

lemma mk_inv_image_le (x : tangle β) : #{y : tangle γ // position y ≤ position x} < #μ :=
begin
  refine lt_of_le_of_lt _ (show #{y // y ≤ position x} < #μ, from card_Iic_lt _),
  refine ⟨⟨λ y, ⟨_, y.prop⟩, _⟩⟩,
  intros y₁ y₂ h,
  simp only [embedding_like.apply_eq_iff_eq, subtype.coe_inj] at h,
  exact h,
end

variable {γ}

lemma mk_f_map_deny (hβγ : β ≠ γ) (x : tangle β) :
  #{y // inv_image (<) position y x} + #{i // f_map_condition hβγ x i} < #μ :=
begin
  have h₁ := mk_inv_image_lt x,
  have h₂ : #{i // f_map_condition hβγ x i} < #μ,
  { have : ∀ i, f_map_condition hβγ x i →
      (∃ (N : set atom) (hN : is_near_litter ⟨i, β, γ, hβγ⟩ N),
        position (typed_near_litter ⟨_, N, hN⟩ : tangle γ) ≤ position x) ∨
      β = ⊥ ∧ ∃ (a : atom), a == x ∧
        position (typed_near_litter (litter.to_near_litter ⟨i, β, γ, hβγ⟩) : tangle γ) ≤
          typed_atom_position a,
    { intros i hi,
      obtain ⟨N, hN₁, hN₂⟩ | ⟨a, h₁, h₂, h₃⟩ := hi,
      { left, exact ⟨N, hN₁, hN₂⟩ },
      { right, refine ⟨h₁, a, h₂, _⟩, simp_rw h₁, exact h₃ } },
    refine lt_of_le_of_lt (mk_subtype_mono this) _,
    refine lt_of_le_of_lt (mk_union_le _ _) _,
    refine add_lt_of_lt μ_strong_limit.is_limit.aleph_0_le _ _,
    { refine lt_of_le_of_lt _ (mk_inv_image_le γ x),
      refine ⟨⟨λ i, ⟨_, i.prop.some_spec.some_spec⟩, _⟩⟩,
      intros i j h,
      simp only [embedding_like.apply_eq_iff_eq] at h,
      exact subtype.coe_inj.mp h.1.1 },
    { by_cases β = ⊥ ∧ ∃ (a : atom), a == x,
      { obtain ⟨hβ, a, hax⟩ := h,
        refine lt_of_le_of_lt _ (card_Iic_lt (typed_atom_position a)),
        refine ⟨⟨λ i, ⟨position
          (typed_near_litter (litter.to_near_litter ⟨i, β, γ, hβγ⟩) : tangle γ), _⟩, _⟩⟩,
        { obtain ⟨i, _, b, hb, _⟩ := i,
          rw eq_of_heq (hax.trans hb.symm),
          assumption },
        { intros i j h,
          simp only [subtype.mk_eq_mk, embedding_like.apply_eq_iff_eq,
            litter.to_near_litter_injective.eq_iff] at h,
          exact subtype.coe_inj.mp h.1 } },
      { refine lt_of_eq_of_lt _ (lt_of_lt_of_le aleph_0_pos μ_strong_limit.is_limit.aleph_0_le),
        rw [mk_eq_zero_iff, is_empty_coe_sort, set.eq_empty_iff_forall_not_mem],
        rintros i ⟨hb, a, ha, _⟩,
        exact h ⟨hb, a, ha⟩ } } },
  exact add_lt_of_lt μ_strong_limit.is_limit.aleph_0_le h₁ h₂,
end

/-!
We're done with proving technical results, now we can define the f-maps.
-/

/-- The f-maps. -/
noncomputable def f_map (x : tangle β) : litter :=
⟨choose_wf (f_map_condition hβγ) (mk_f_map_deny hβγ) x, β, γ, hβγ⟩

@[simp] lemma f_map_β (x : tangle β) : (f_map hβγ x).β = β := rfl
@[simp] lemma f_map_γ (x : tangle β) : (f_map hβγ x).γ = γ := rfl

lemma f_map_injective : injective (f_map hβγ) :=
begin
  intros x y h,
  simp only [f_map, choose_wf_injective.eq_iff, eq_self_iff_true, and_true] at h,
  exact h,
end

lemma f_map_not_mem_deny (x : tangle β) : (f_map hβγ x).ν ∉ {i | f_map_condition hβγ x i} :=
choose_wf_not_mem_deny x

lemma f_map_position (x : tangle β) (N : set atom) (h : is_near_litter (f_map hβγ x) N) :
  position x < position (typed_near_litter ⟨_, N, h⟩ : tangle γ) :=
begin
  have := f_map_not_mem_deny hβγ x,
  contrapose! this,
  unfreezingI { induction β using with_bot.rec_bot_coe };
  exact f_map_condition.any _ h this,
end

lemma typed_atom_position_lt_f_map (x : tangle ⊥) :
  typed_atom_position x <
  position (typed_near_litter
    (f_map (bot_ne_coe : (⊥ : type_index) ≠ γ) x).to_near_litter : tangle γ) :=
begin
  have := f_map_not_mem_deny (bot_ne_coe : (⊥ : type_index) ≠ γ) x,
  contrapose! this,
  exact f_map_condition.bot x rfl heq.rfl this,
end

end con_nf


import MyNat.Definition
import MyNat.Addition
import AdditionWorld.Level6
namespace MyNat
open MyNat

axiom succ_inj {a b : MyNat} : succ a = succ b → a = b

/-!

# Advanced Addition World

## Level 1: `succ_inj`. A function.

Let's learn how to use `succ_inj`. You should know a couple of ways to prove the below -- one
directly using an `exact`, and one which uses an `apply` first. But either way you'll need to use
`succ_inj`.

## Theorem
For all naturals `a` and `b`, if we assume `succ a = succ b`, then we can
deduce `a = b`.
-/
theorem succ_inj' {a b : MyNat} (hs : succ a = succ b) :  a = b := by
  exact succ_inj hs

/-!
## Important thing.

You can rewrite proofs of *equalities*. If `h : A = B` then `rw [h]` changes `A`s to `B`s.
But you *cannot rewrite proofs of implications*. `rw [succ_inj]` will *never work*
because `succ_inj` isn't of the form `A = B`, it's of the form `A⟹ B`. This is one
of the most common mistakes I see from beginners. `⟹` and `=` are *two different things*
and you need to be clear about which one you are using.

Next up [Level 2](./Level2.lean.md)
-/


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

import field_theory.primitive_element
import linear_algebra.determinant
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.matrix.to_linear_equiv
import ring_theory.power_basis

/-!
# Norm for (finite) ring extensions

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the determinant 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 norm is defined specifically for finite field extensions.
The current 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 norm for left multiplication (`algebra.left_mul_matrix`,
i.e. `algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't
matter anyway.

See also `algebra.trace`, which is defined similarly as the trace of
`algebra.left_mul_matrix`.

## References

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

-/

universes u v w

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

open finite_dimensional
open linear_map
open matrix

open_locale big_operators
open_locale matrix

namespace algebra

variables (R)

/-- The norm of an element `s` of an `R`-algebra is the determinant of `(*) s`. -/
noncomputable def norm : S →* R :=
linear_map.det.comp (lmul R S).to_ring_hom.to_monoid_hom

lemma norm_apply (x : S) : norm R x = linear_map.det (lmul R S x) := rfl

lemma norm_eq_one_of_not_exists_basis
  (h : ¬ ∃ (s : finset S), nonempty (basis s R S)) (x : S) : norm R x = 1 :=
by { rw [norm_apply, linear_map.det], split_ifs with h, refl }

variables {R}

-- Can't be a `simp` lemma because it depends on a choice of basis
lemma norm_eq_matrix_det [decidable_eq ι] (b : basis ι R S) (s : S) :
  norm R s = matrix.det (algebra.left_mul_matrix b s) :=
by rw [norm_apply, ← linear_map.det_to_matrix b, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the norm is `x ^ [L : K]`. -/
lemma norm_algebra_map_of_basis (b : basis ι R S) (x : R) :
  norm R (algebra_map R S x) = x ^ fintype.card ι :=
begin
  haveI := classical.dec_eq ι,
  rw [norm_apply, ← det_to_matrix b, lmul_algebra_map],
  convert @det_diagonal _ _ _ _ _ (λ (i : ι), x),
  { ext i j, rw [to_matrix_lsmul, matrix.diagonal] },
  { rw [finset.prod_const, finset.card_univ] }
end

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

(If `L` is not finite-dimensional over `K`, then `norm = 1 = x ^ 0 = x ^ (finrank L K)`.)
-/
@[simp]
lemma norm_algebra_map (x : K) : norm K (algebra_map K L x) = x ^ finrank K L :=
begin
  by_cases H : ∃ (s : finset L), nonempty (basis s K L),
  { rw [norm_algebra_map_of_basis H.some_spec.some, finrank_eq_card_basis H.some_spec.some] },
  { rw [norm_eq_one_of_not_exists_basis K H, finrank_eq_zero_of_not_exists_basis, pow_zero],
    rintros ⟨s, ⟨b⟩⟩,
    exact H ⟨s, ⟨b⟩⟩ },
end

section eq_prod_roots

lemma norm_gen_eq_prod_roots [algebra K S] (pb : power_basis K S)
  (hf : (minpoly K pb.gen).splits (algebra_map K F)) :
  algebra_map K F (norm K pb.gen) =
    ((minpoly K pb.gen).map (algebra_map K F)).roots.prod :=
begin
  -- Write the LHS as the 0'th coefficient of `minpoly K pb.gen`
  rw [norm_eq_matrix_det pb.basis, det_eq_sign_charpoly_coeff, charpoly_left_mul_matrix,
      ring_hom.map_mul, ring_hom.map_pow, ring_hom.map_neg, ring_hom.map_one,
      ← polynomial.coeff_map, fintype.card_fin],
  -- Rewrite `minpoly K pb.gen` as a product over the roots.
  conv_lhs { rw polynomial.eq_prod_roots_of_splits hf },
  rw [polynomial.coeff_C_mul, polynomial.coeff_zero_multiset_prod, multiset.map_map,
      (minpoly.monic pb.is_integral_gen).leading_coeff, ring_hom.map_one, one_mul],
  -- Incorporate the `-1` from the `charpoly` back into the product.
  rw [← multiset.prod_repeat (-1 : F), ← pb.nat_degree_minpoly,
      polynomial.nat_degree_eq_card_roots hf, ← multiset.map_const, ← multiset.prod_map_mul],
  -- And conclude that both sides are the same.
  congr, convert multiset.map_id _, ext f, simp
end

end eq_prod_roots

section eq_zero_iff

lemma norm_eq_zero_iff_of_basis [is_domain S] (b : basis ι R S) {x : S} :
  algebra.norm R x = 0 ↔ x = 0 :=
begin
  have hι : nonempty ι := b.index_nonempty,
  letI := classical.dec_eq ι,
  rw algebra.norm_eq_matrix_det b,
  split,
  { rw ← matrix.exists_mul_vec_eq_zero_iff,
    rintros ⟨v, v_ne, hv⟩,
    rw [← b.equiv_fun.apply_symm_apply v, b.equiv_fun_symm_apply, b.equiv_fun_apply,
        algebra.left_mul_matrix_mul_vec_repr] at hv,
    refine (mul_eq_zero.mp (b.ext_elem $ λ i, _)).resolve_right (show ∑ i, v i • b i ≠ 0, from _),
    { simpa only [linear_equiv.map_zero, pi.zero_apply] using congr_fun hv i },
    { contrapose! v_ne with sum_eq,
      apply b.equiv_fun.symm.injective,
      rw [b.equiv_fun_symm_apply, sum_eq, linear_equiv.map_zero] } },
  { rintro rfl,
    rw [alg_hom.map_zero, matrix.det_zero hι] },
end

lemma norm_ne_zero_iff_of_basis [is_domain S] (b : basis ι R S) {x : S} :
  algebra.norm R x ≠ 0 ↔ x ≠ 0 :=
not_iff_not.mpr (algebra.norm_eq_zero_iff_of_basis b)

/-- See also `algebra.norm_eq_zero_iff'` if you already have rewritten with `algebra.norm_apply`. -/
@[simp]
lemma norm_eq_zero_iff [finite_dimensional K L] {x : L} :
  algebra.norm K x = 0 ↔ x = 0 :=
algebra.norm_eq_zero_iff_of_basis (basis.of_vector_space K L)

/-- This is `algebra.norm_eq_zero_iff` composed with `algebra.norm_apply`. -/
@[simp]
lemma norm_eq_zero_iff' [finite_dimensional K L] {x : L} :
  linear_map.det (algebra.lmul K L x) = 0 ↔ x = 0 :=
algebra.norm_eq_zero_iff_of_basis (basis.of_vector_space K L)

end eq_zero_iff

open intermediate_field

variable (K)

lemma norm_eq_norm_adjoin [finite_dimensional K L] [is_separable K L] (x : L) :
  norm K x = norm K (adjoin_simple.gen K x) ^ finrank K⟮x⟯ L :=
begin
  letI := is_separable_tower_top_of_is_separable K K⟮x⟯ L,
  let pbL := field.power_basis_of_finite_of_separable K⟮x⟯ L,
  let pbx := intermediate_field.adjoin.power_basis (is_separable.is_integral K x),
  rw [← adjoin_simple.algebra_map_gen K x, norm_eq_matrix_det (pbx.basis.smul pbL.basis) _,
    smul_left_mul_matrix_algebra_map, det_block_diagonal, norm_eq_matrix_det pbx.basis],
  simp only [finset.card_fin, finset.prod_const, adjoin.power_basis_basis],
  congr,
  rw [← power_basis.finrank, adjoin_simple.algebra_map_gen K x],
end

section eq_prod_embeddings

variable {K}

open intermediate_field intermediate_field.adjoin_simple polynomial

variables (E : Type*) [field E] [algebra K E] [is_scalar_tower K L F]

lemma norm_eq_prod_embeddings_gen
  (pb : power_basis K L)
  (hE : (minpoly K pb.gen).splits (algebra_map K E)) (hfx : (minpoly K pb.gen).separable) :
  algebra_map K E (norm K pb.gen) =
    (@@finset.univ (power_basis.alg_hom.fintype pb)).prod (λ σ, σ pb.gen) :=
begin
  letI := classical.dec_eq E,
  rw [norm_gen_eq_prod_roots pb hE, fintype.prod_equiv pb.lift_equiv', finset.prod_mem_multiset,
    finset.prod_eq_multiset_prod, multiset.to_finset_val,
    multiset.erase_dup_eq_self.mpr, multiset.map_id],
  { exact nodup_roots ((separable_map _).mpr hfx) },
  { intro x, refl },
  { intro σ, rw [power_basis.lift_equiv'_apply_coe, id.def] }
end

variable (F)

lemma prod_embeddings_eq_finrank_pow [is_alg_closed E] [is_separable K F] [finite_dimensional K F]
  (pb : power_basis K L) : ∏ σ : F →ₐ[K] E, σ (algebra_map L F pb.gen) =
  ((@@finset.univ (power_basis.alg_hom.fintype pb)).prod
    (λ σ : L →ₐ[K] E, σ pb.gen)) ^ finrank L F :=
begin
  haveI : finite_dimensional L F := finite_dimensional.right K L F,
  haveI : is_separable L F := is_separable_tower_top_of_is_separable K L F,
  letI : fintype (L →ₐ[K] E) := power_basis.alg_hom.fintype pb,
  letI : ∀ (f : L →ₐ[K] E), fintype (@@alg_hom L F E _ _ _ _ f.to_ring_hom.to_algebra) := _,
  rw [fintype.prod_equiv alg_hom_equiv_sigma (λ (σ : F →ₐ[K] E), _) (λ σ, σ.1 pb.gen),
     ← finset.univ_sigma_univ, finset.prod_sigma, ← finset.prod_pow],
  refine finset.prod_congr rfl (λ σ _, _),
  { letI : algebra L E := σ.to_ring_hom.to_algebra,
    simp only [finset.prod_const, finset.card_univ],
    congr,
    rw alg_hom.card L F E },
  { intros σ,
    simp only [alg_hom_equiv_sigma, equiv.coe_fn_mk, alg_hom.restrict_domain, alg_hom.comp_apply,
         is_scalar_tower.coe_to_alg_hom'] }
end

variable (K)

/-- For `L/K` a finite separable extension of fields and `E` an algebraically closed extension
of `K`, the norm (down to `K`) of an element `x` of `L` is equal to the product of the images
of `x` over all the `K`-embeddings `σ`  of `L` into `E`. -/
lemma norm_eq_prod_embeddings [finite_dimensional K L] [is_separable K L] [is_alg_closed E]
  {x : L} : algebra_map K E (norm K x) = ∏ σ : L →ₐ[K] E, σ x :=
begin
  have hx := is_separable.is_integral K x,
  rw [norm_eq_norm_adjoin K x, ring_hom.map_pow, ← adjoin.power_basis_gen hx,
    norm_eq_prod_embeddings_gen E (adjoin.power_basis hx) (is_alg_closed.splits_codomain _)],
  { exact (prod_embeddings_eq_finrank_pow L E (adjoin.power_basis hx)).symm },
  { haveI := is_separable_tower_bot_of_is_separable K K⟮x⟯ L,
    exact is_separable.separable K _ }
end

end eq_prod_embeddings

end algebra