/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.measure_theory.content
import Mathlib.measure_theory.prod_group
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Haar measure

In this file we prove the existence of Haar measure for a locally compact Hausdorff topological
group.

For the construction, we follow the write-up by Jonathan Gleason,
*Existence and Uniqueness of Haar Measure*.
This is essentially the same argument as in
https://en.wikipedia.org/wiki/Haar_measure#A_construction_using_compact_subsets.

We construct the Haar measure first on compact sets. For this we define `(K : U)` as the (smallest)
number of left-translates of `U` are needed to cover `K` (`index` in the formalization).
Then we define a function `h` on compact sets as `lim_U (K : U) / (K₀ : U)`,
where `U` becomes a smaller and smaller open neighborhood of `1`, and `K₀` is a fixed compact set
with nonempty interior. This function is `chaar` in the formalization, and we define the limit
formally using Tychonoff's theorem.

This function `h` forms a content, which we can extend to an outer measure `μ`
(`haar_outer_measure`), and obtain the Haar measure from that (`haar_measure`).
We normalize the Haar measure so that the measure of `K₀` is `1`.
We show that for second countable spaces any left invariant Borel measure is a scalar multiple of
the Haar measure.

Note that `μ` need not coincide with `h` on compact sets, according to
[halmos1950measure, ch. X, §53 p.233]. However, we know that `h(K)` lies between `μ(Kᵒ)` and `μ(K)`,
where `ᵒ` denotes the interior.

## Main Declarations

* `haar_measure`: the Haar measure on a locally compact Hausdorff group. This is a left invariant
  regular measure. It takes as argument a compact set of the group (with non-empty interior),
  and is normalized so that the measure of the given set is 1.
* `haar_measure_self`: the Haar measure is normalized.
* `is_left_invariant_haar_measure`: the Haar measure is left invariant.
* `regular_haar_measure`: the Haar measure is a regular measure.

## References
* Paul Halmos (1950), Measure Theory, §53
* Jonathan Gleason, Existence and Uniqueness of Haar Measure
  - Note: step 9, page 8 contains a mistake: the last defined `μ` does not extend the `μ` on compact
    sets, see Halmos (1950) p. 233, bottom of the page. This makes some other steps (like step 11)
    invalid.
* https://en.wikipedia.org/wiki/Haar_measure
-/

namespace measure_theory

namespace measure

/-! We put the internal functions in the construction of the Haar measure in a namespace,
  so that the chosen names don't clash with other declarations.
  We first define a couple of the functions before proving the properties (that require that `G`
  is a topological group). -/

namespace haar

/-- The index or Haar covering number or ratio of `K` w.r.t. `V`, denoted `(K : V)`:
  it is the smallest number of (left) translates of `V` that is necessary to cover `K`.
  It is defined to be 0 if no finite number of translates cover `K`. -/
def index {G : Type u_1} [group G] (K : set G) (V : set G) : ℕ :=
  Inf
    (finset.card ''
      set_of
        fun (t : finset G) =>
          K ⊆ set.Union fun (g : G) => set.Union fun (H : g ∈ t) => (fun (h : G) => g * h) ⁻¹' V)

theorem index_empty {G : Type u_1} [group G] {V : set G} : index ∅ V = 0 := sorry

/-- `prehaar K₀ U K` is a weighted version of the index, defined as `(K : U)/(K₀ : U)`.
  In the applications `K₀` is compact with non-empty interior, `U` is open containing `1`,
  and `K` is any compact set.
  The argument `K` is a (bundled) compact set, so that we can consider `prehaar K₀ U` as an
  element of `haar_product` (below). -/
def prehaar {G : Type u_1} [group G] [topological_space G] (K₀ : set G) (U : set G)
    (K : topological_space.compacts G) : ℝ :=
  ↑(index (subtype.val K) U) / ↑(index K₀ U)

theorem prehaar_empty {G : Type u_1} [group G] [topological_space G]
    (K₀ : topological_space.positive_compacts G) {U : set G} : prehaar (subtype.val K₀) U ⊥ = 0 :=
  sorry

theorem prehaar_nonneg {G : Type u_1} [group G] [topological_space G]
    (K₀ : topological_space.positive_compacts G) {U : set G} (K : topological_space.compacts G) :
    0 ≤ prehaar (subtype.val K₀) U K :=
  sorry

/-- `haar_product K₀` is the product of intervals `[0, (K : K₀)]`, for all compact sets `K`.
  For all `U`, we can show that `prehaar K₀ U ∈ haar_product K₀`. -/
def haar_product {G : Type u_1} [group G] [topological_space G] (K₀ : set G) :
    set (topological_space.compacts G → ℝ) :=
  set.pi set.univ fun (K : topological_space.compacts G) => set.Icc 0 ↑(index (subtype.val K) K₀)

@[simp] theorem mem_prehaar_empty {G : Type u_1} [group G] [topological_space G] {K₀ : set G}
    {f : topological_space.compacts G → ℝ} :
    f ∈ haar_product K₀ ↔
        ∀ (K : topological_space.compacts G), f K ∈ set.Icc 0 ↑(index (subtype.val K) K₀) :=
  sorry

/-- The closure of the collection of elements of the form `prehaar K₀ U`,
  for `U` open neighbourhoods of `1`, contained in `V`. The closure is taken in the space
  `compacts G → ℝ`, with the topology of pointwise convergence.
  We show that the intersection of all these sets is nonempty, and the Haar measure
  on compact sets is defined to be an element in the closure of this intersection. -/
def cl_prehaar {G : Type u_1} [group G] [topological_space G] (K₀ : set G)
    (V : topological_space.open_nhds_of 1) : set (topological_space.compacts G → ℝ) :=
  closure (prehaar K₀ '' set_of fun (U : set G) => U ⊆ subtype.val V ∧ is_open U ∧ 1 ∈ U)

/-!
### Lemmas about `index`
-/

/-- If `K` is compact and `V` has nonempty interior, then the index `(K : V)` is well-defined,
  there is a finite set `t` satisfying the desired properties. -/
theorem index_defined {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K : set G} {V : set G} (hK : is_compact K) (hV : set.nonempty (interior V)) :
    ∃ (n : ℕ),
        n ∈
          finset.card ''
            set_of
              fun (t : finset G) =>
                K ⊆
                  set.Union
                    fun (g : G) => set.Union fun (H : g ∈ t) => (fun (h : G) => g * h) ⁻¹' V :=
  Exists.dcases_on (compact_covered_by_mul_left_translates hK hV)
    fun (t : finset G)
      (ht :
      K ⊆ set.Union fun (g : G) => set.Union fun (H : g ∈ t) => (fun (h : G) => g * h) ⁻¹' V) =>
      Exists.intro (finset.card t) (Exists.intro t { left := ht, right := rfl })

theorem index_elim {G : Type u_1} [group G] [topological_space G] [topological_group G] {K : set G}
    {V : set G} (hK : is_compact K) (hV : set.nonempty (interior V)) :
    ∃ (t : finset G),
        (K ⊆ set.Union fun (g : G) => set.Union fun (H : g ∈ t) => (fun (h : G) => g * h) ⁻¹' V) ∧
          finset.card t = index K V :=
  sorry

theorem le_index_mul {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) (K : topological_space.compacts G) {V : set G}
    (hV : set.nonempty (interior V)) :
    index (subtype.val K) V ≤ index (subtype.val K) (subtype.val K₀) * index (subtype.val K₀) V :=
  sorry

theorem index_pos {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K : topological_space.positive_compacts G) {V : set G} (hV : set.nonempty (interior V)) :
    0 < index (subtype.val K) V :=
  sorry

theorem index_mono {G : Type u_1} [group G] [topological_space G] [topological_group G] {K : set G}
    {K' : set G} {V : set G} (hK' : is_compact K') (h : K ⊆ K') (hV : set.nonempty (interior V)) :
    index K V ≤ index K' V :=
  sorry

theorem index_union_le {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₁ : topological_space.compacts G) (K₂ : topological_space.compacts G) {V : set G}
    (hV : set.nonempty (interior V)) :
    index (subtype.val K₁ ∪ subtype.val K₂) V ≤
        index (subtype.val K₁) V + index (subtype.val K₂) V :=
  sorry

theorem index_union_eq {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₁ : topological_space.compacts G) (K₂ : topological_space.compacts G) {V : set G}
    (hV : set.nonempty (interior V))
    (h : disjoint (subtype.val K₁ * (V⁻¹)) (subtype.val K₂ * (V⁻¹))) :
    index (subtype.val K₁ ∪ subtype.val K₂) V =
        index (subtype.val K₁) V + index (subtype.val K₂) V :=
  sorry

theorem mul_left_index_le {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K : set G} (hK : is_compact K) {V : set G} (hV : set.nonempty (interior V)) (g : G) :
    index ((fun (h : G) => g * h) '' K) V ≤ index K V :=
  sorry

theorem is_left_invariant_index {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K : set G} (hK : is_compact K) (g : G) {V : set G} (hV : set.nonempty (interior V)) :
    index ((fun (h : G) => g * h) '' K) V = index K V :=
  sorry

/-!
### Lemmas about `prehaar`
-/

theorem prehaar_le_index {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) {U : set G} (K : topological_space.compacts G)
    (hU : set.nonempty (interior U)) :
    prehaar (subtype.val K₀) U K ≤ ↑(index (subtype.val K) (subtype.val K₀)) :=
  sorry

theorem prehaar_pos {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) {U : set G} (hU : set.nonempty (interior U))
    {K : set G} (h1K : is_compact K) (h2K : set.nonempty (interior K)) :
    0 < prehaar (subtype.val K₀) U { val := K, property := h1K } :=
  sorry

theorem prehaar_mono {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {U : set G} (hU : set.nonempty (interior U))
    {K₁ : topological_space.compacts G} {K₂ : topological_space.compacts G}
    (h : subtype.val K₁ ⊆ subtype.val K₂) :
    prehaar (subtype.val K₀) U K₁ ≤ prehaar (subtype.val K₀) U K₂ :=
  sorry

theorem prehaar_self {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {U : set G} (hU : set.nonempty (interior U)) :
    prehaar (subtype.val K₀) U
          { val := subtype.val K₀, property := and.left (subtype.property K₀) } =
        1 :=
  sorry

theorem prehaar_sup_le {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {U : set G} (K₁ : topological_space.compacts G)
    (K₂ : topological_space.compacts G) (hU : set.nonempty (interior U)) :
    prehaar (subtype.val K₀) U (K₁ ⊔ K₂) ≤
        prehaar (subtype.val K₀) U K₁ + prehaar (subtype.val K₀) U K₂ :=
  sorry

theorem prehaar_sup_eq {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {U : set G} {K₁ : topological_space.compacts G}
    {K₂ : topological_space.compacts G} (hU : set.nonempty (interior U))
    (h : disjoint (subtype.val K₁ * (U⁻¹)) (subtype.val K₂ * (U⁻¹))) :
    prehaar (subtype.val K₀) U (K₁ ⊔ K₂) =
        prehaar (subtype.val K₀) U K₁ + prehaar (subtype.val K₀) U K₂ :=
  sorry

theorem is_left_invariant_prehaar {G : Type u_1} [group G] [topological_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} {U : set G}
    (hU : set.nonempty (interior U)) (g : G) (K : topological_space.compacts G) :
    prehaar (subtype.val K₀) U
          (topological_space.compacts.map (fun (b : G) => g * b) (continuous_mul_left g) K) =
        prehaar (subtype.val K₀) U K :=
  sorry

/-!
### Lemmas about `haar_product`
-/

theorem prehaar_mem_haar_product {G : Type u_1} [group G] [topological_space G]
    [topological_group G] (K₀ : topological_space.positive_compacts G) {U : set G}
    (hU : set.nonempty (interior U)) : prehaar (subtype.val K₀) U ∈ haar_product (subtype.val K₀) :=
  sorry

theorem nonempty_Inter_cl_prehaar {G : Type u_1} [group G] [topological_space G]
    [topological_group G] (K₀ : topological_space.positive_compacts G) :
    set.nonempty
        (haar_product (subtype.val K₀) ∩
          set.Inter fun (V : topological_space.open_nhds_of 1) => cl_prehaar (subtype.val K₀) V) :=
  sorry

/-!
### The Haar measure on compact sets
-/

/-- The Haar measure on compact sets, defined to be an arbitrary element in the intersection of
  all the sets `cl_prehaar K₀ V` in `haar_product K₀`. -/
def chaar {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) (K : topological_space.compacts G) : ℝ :=
  classical.some (nonempty_Inter_cl_prehaar K₀) K

theorem chaar_mem_haar_product {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) : chaar K₀ ∈ haar_product (subtype.val K₀) :=
  and.left (classical.some_spec (nonempty_Inter_cl_prehaar K₀))

theorem chaar_mem_cl_prehaar {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) (V : topological_space.open_nhds_of 1) :
    chaar K₀ ∈ cl_prehaar (subtype.val K₀) V :=
  sorry

theorem chaar_nonneg {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) (K : topological_space.compacts G) :
    0 ≤ chaar K₀ K :=
  sorry

theorem chaar_empty {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) : chaar K₀ ⊥ = 0 :=
  sorry

theorem chaar_self {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) :
    chaar K₀ { val := subtype.val K₀, property := and.left (subtype.property K₀) } = 1 :=
  sorry

theorem chaar_mono {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {K₁ : topological_space.compacts G}
    {K₂ : topological_space.compacts G} (h : subtype.val K₁ ⊆ subtype.val K₂) :
    chaar K₀ K₁ ≤ chaar K₀ K₂ :=
  sorry

theorem chaar_sup_le {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} (K₁ : topological_space.compacts G)
    (K₂ : topological_space.compacts G) : chaar K₀ (K₁ ⊔ K₂) ≤ chaar K₀ K₁ + chaar K₀ K₂ :=
  sorry

theorem chaar_sup_eq {G : Type u_1} [group G] [topological_space G] [topological_group G]
    [t2_space G] {K₀ : topological_space.positive_compacts G} {K₁ : topological_space.compacts G}
    {K₂ : topological_space.compacts G} (h : disjoint (subtype.val K₁) (subtype.val K₂)) :
    chaar K₀ (K₁ ⊔ K₂) = chaar K₀ K₁ + chaar K₀ K₂ :=
  sorry

theorem is_left_invariant_chaar {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} (g : G) (K : topological_space.compacts G) :
    chaar K₀ (topological_space.compacts.map (fun (b : G) => g * b) (continuous_mul_left g) K) =
        chaar K₀ K :=
  sorry

/-- The function `chaar` interpreted in `ennreal` -/
def echaar {G : Type u_1} [group G] [topological_space G] [topological_group G]
    (K₀ : topological_space.positive_compacts G) (K : topological_space.compacts G) : ennreal :=
  ↑((fun (this : nnreal) => this) { val := chaar K₀ K, property := chaar_nonneg K₀ K })

/-! We only prove the properties for `echaar` that we use at least twice below. -/

/-- The variant of `chaar_sup_le` for `echaar` -/
theorem echaar_sup_le {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} (K₁ : topological_space.compacts G)
    (K₂ : topological_space.compacts G) : echaar K₀ (K₁ ⊔ K₂) ≤ echaar K₀ K₁ + echaar K₀ K₂ :=
  sorry

/-- The variant of `chaar_mono` for `echaar` -/
theorem echaar_mono {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} {K₁ : topological_space.compacts G}
    {K₂ : topological_space.compacts G} (h : subtype.val K₁ ⊆ subtype.val K₂) :
    echaar K₀ K₁ ≤ echaar K₀ K₂ :=
  sorry

/-- The variant of `chaar_self` for `echaar` -/
theorem echaar_self {G : Type u_1} [group G] [topological_space G] [topological_group G]
    {K₀ : topological_space.positive_compacts G} :
    echaar K₀ { val := subtype.val K₀, property := and.left (subtype.property K₀) } = 1 :=
  sorry

/-- The variant of `is_left_invariant_chaar` for `echaar` -/
theorem is_left_invariant_echaar {G : Type u_1} [group G] [topological_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} (g : G)
    (K : topological_space.compacts G) :
    echaar K₀ (topological_space.compacts.map (fun (b : G) => g * b) (continuous_mul_left g) K) =
        echaar K₀ K :=
  eq.mpr (id (Eq.trans (propext ennreal.coe_eq_coe) (propext (iff.symm nnreal.coe_eq))))
    (eq.mp
      (Eq.refl
        (chaar K₀ (topological_space.compacts.map (Mul.mul g) (continuous_mul_left g) K) =
          chaar K₀ K))
      (is_left_invariant_chaar g K))

end haar

/-!
### The Haar outer measure
-/

/-- The Haar outer measure on `G`. It is not normalized, and is mainly used to construct
  `haar_measure`, which is a normalized measure. -/
def haar_outer_measure {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] (K₀ : topological_space.positive_compacts G) : outer_measure G :=
  outer_measure.of_content (haar.echaar K₀) sorry

theorem haar_outer_measure_eq_infi {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] (K₀ : topological_space.positive_compacts G) (A : set G) :
    coe_fn (haar_outer_measure K₀) A =
        infi
          fun (U : set G) =>
            infi
              fun (hU : is_open U) =>
                infi
                  fun (h : A ⊆ U) => inner_content (haar.echaar K₀) { val := U, property := hU } :=
  outer_measure.of_content_eq_infi haar.echaar_sup_le A

theorem echaar_le_haar_outer_measure {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G}
    (K : topological_space.compacts G) :
    haar.echaar K₀ K ≤ coe_fn (haar_outer_measure K₀) (subtype.val K) :=
  outer_measure.le_of_content_compacts haar.echaar_sup_le K

theorem haar_outer_measure_of_is_open {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} (U : set G)
    (hU : is_open U) :
    coe_fn (haar_outer_measure K₀) U =
        inner_content (haar.echaar K₀) { val := U, property := hU } :=
  outer_measure.of_content_opens haar.echaar_sup_le { val := U, property := hU }

theorem haar_outer_measure_le_echaar {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} {U : set G} (hU : is_open U)
    (K : topological_space.compacts G) (h : U ⊆ subtype.val K) :
    coe_fn (haar_outer_measure K₀) U ≤ haar.echaar K₀ K :=
  outer_measure.of_content_le haar.echaar_sup_le haar.echaar_mono { val := U, property := hU } K h

theorem haar_outer_measure_exists_open {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} {A : set G}
    (hA : coe_fn (haar_outer_measure K₀) A < ⊤) {ε : nnreal} (hε : 0 < ε) :
    ∃ (U : topological_space.opens G),
        A ⊆ ↑U ∧ coe_fn (haar_outer_measure K₀) ↑U ≤ coe_fn (haar_outer_measure K₀) A + ↑ε :=
  outer_measure.of_content_exists_open haar.echaar_sup_le hA hε

theorem haar_outer_measure_exists_compact {G : Type u_1} [group G] [topological_space G]
    [t2_space G] [topological_group G] {K₀ : topological_space.positive_compacts G}
    {U : topological_space.opens G} (hU : coe_fn (haar_outer_measure K₀) ↑U < ⊤) {ε : nnreal}
    (hε : 0 < ε) :
    ∃ (K : topological_space.compacts G),
        subtype.val K ⊆ ↑U ∧
          coe_fn (haar_outer_measure K₀) ↑U ≤ coe_fn (haar_outer_measure K₀) (subtype.val K) + ↑ε :=
  outer_measure.of_content_exists_compact haar.echaar_sup_le hU hε

theorem haar_outer_measure_caratheodory {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} (A : set G) :
    measurable_space.is_measurable' (outer_measure.caratheodory (haar_outer_measure K₀)) A ↔
        ∀ (U : topological_space.opens G),
          coe_fn (haar_outer_measure K₀) (↑U ∩ A) + coe_fn (haar_outer_measure K₀) (↑U \ A) ≤
            coe_fn (haar_outer_measure K₀) ↑U :=
  outer_measure.of_content_caratheodory haar.echaar_sup_le A

theorem one_le_haar_outer_measure_self {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} :
    1 ≤ coe_fn (haar_outer_measure K₀) (subtype.val K₀) :=
  sorry

theorem haar_outer_measure_pos_of_is_open {G : Type u_1} [group G] [topological_space G]
    [t2_space G] [topological_group G] {K₀ : topological_space.positive_compacts G} {U : set G}
    (hU : is_open U) (h2U : set.nonempty U) : 0 < coe_fn (haar_outer_measure K₀) U :=
  sorry

theorem haar_outer_measure_self_pos {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] {K₀ : topological_space.positive_compacts G} :
    0 < coe_fn (haar_outer_measure K₀) (subtype.val K₀) :=
  has_lt.lt.trans_le
    (haar_outer_measure_pos_of_is_open is_open_interior (and.right (subtype.property K₀)))
    (outer_measure.mono (haar_outer_measure K₀) interior_subset)

theorem haar_outer_measure_lt_top_of_is_compact {G : Type u_1} [group G] [topological_space G]
    [t2_space G] [topological_group G] [locally_compact_space G]
    {K₀ : topological_space.positive_compacts G} {K : set G} (hK : is_compact K) :
    coe_fn (haar_outer_measure K₀) K < ⊤ :=
  sorry

theorem haar_caratheodory_measurable {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G]
    (K₀ : topological_space.positive_compacts G) :
    S ≤ outer_measure.caratheodory (haar_outer_measure K₀) :=
  sorry

/-!
### The Haar measure
-/

/-- the Haar measure on `G`, scaled so that `haar_measure K₀ K₀ = 1`. -/
def haar_measure {G : Type u_1} [group G] [topological_space G] [t2_space G] [topological_group G]
    [S : measurable_space G] [borel_space G] (K₀ : topological_space.positive_compacts G) :
    measure G :=
  coe_fn (haar_outer_measure K₀) (subtype.val K₀)⁻¹ •
    outer_measure.to_measure (haar_outer_measure K₀) (haar_caratheodory_measurable K₀)

theorem haar_measure_apply {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G]
    {K₀ : topological_space.positive_compacts G} {s : set G} (hs : is_measurable s) :
    coe_fn (haar_measure K₀) s =
        coe_fn (haar_outer_measure K₀) s / coe_fn (haar_outer_measure K₀) (subtype.val K₀) :=
  sorry

theorem is_mul_left_invariant_haar_measure {G : Type u_1} [group G] [topological_space G]
    [t2_space G] [topological_group G] [S : measurable_space G] [borel_space G]
    (K₀ : topological_space.positive_compacts G) : is_mul_left_invariant ⇑(haar_measure K₀) :=
  sorry

theorem haar_measure_self {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G] [locally_compact_space G]
    {K₀ : topological_space.positive_compacts G} : coe_fn (haar_measure K₀) (subtype.val K₀) = 1 :=
  sorry

theorem haar_measure_pos_of_is_open {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G] [locally_compact_space G]
    {K₀ : topological_space.positive_compacts G} {U : set G} (hU : is_open U)
    (h2U : set.nonempty U) : 0 < coe_fn (haar_measure K₀) U :=
  sorry

theorem regular_haar_measure {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G] [locally_compact_space G]
    {K₀ : topological_space.positive_compacts G} : regular (haar_measure K₀) :=
  sorry

protected instance haar_measure.measure_theory.sigma_finite {G : Type u_1} [group G]
    [topological_space G] [t2_space G] [topological_group G] [S : measurable_space G]
    [borel_space G] [locally_compact_space G] [topological_space.separable_space G]
    (K₀ : topological_space.positive_compacts G) : sigma_finite (haar_measure K₀) :=
  regular.sigma_finite regular_haar_measure

/-- The Haar measure is unique up to scaling. More precisely: every σ-finite left invariant measure
  is a scalar multiple of the Haar measure. -/
theorem haar_measure_unique {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G] [locally_compact_space G]
    [topological_space.second_countable_topology G] {μ : measure G} [sigma_finite μ]
    (hμ : is_mul_left_invariant ⇑μ) (K₀ : topological_space.positive_compacts G) :
    μ = coe_fn μ (subtype.val K₀) • haar_measure K₀ :=
  sorry

theorem regular_of_left_invariant {G : Type u_1} [group G] [topological_space G] [t2_space G]
    [topological_group G] [S : measurable_space G] [borel_space G] [locally_compact_space G]
    [topological_space.second_countable_topology G] {μ : measure G} [sigma_finite μ]
    (hμ : is_mul_left_invariant ⇑μ) {K : set G} (hK : is_compact K)
    (h2K : set.nonempty (interior K)) (hμK : coe_fn μ K < ⊤) : regular μ :=
  sorry

end Mathlib


import ..fglib
import ..basic
import ..linear_space
import ..matrix_representation

namespace FG

/- ## Example: S₃

  The **permutation group** (or **symmetric group**) of 3 objects.

  A common notation of its elements is:
  - a₁ = (1, 2, 3)
  - a₂ = (3, 2, 1)
  - a₃ = (1, 2)
  - a₄ = (2, 3)
  - a₅ = (3, 1)

    \  | e  | a₁ | a₂ | a₃ | a₄ | a₅
  ------------------------------------
    e  | e  | a₁ | a₂ | a₃ | a₄ | a₅
    a₁ | a₁ | a₂ | e  | a₅ | a₃ | a₄
    a₂ | a₂ | e  | a₁ | a₄ | a₅ | a₃
    a₃ | a₃ | a₄ | a₅ | e  | a₁ | a₂
    a₄ | a₄ | a₅ | a₃ | a₂ | e  | a₁
    a₅ | a₅ | a₃ | a₄ | a₁ | a₂ | e
-/
namespace example_S₃

inductive S₃ : Type
| e  : S₃
| a₁ : S₃
| a₂ : S₃
| a₃ : S₃
| a₄ : S₃
| a₅ : S₃

namespace S₃

open square_matrix

@[simp] def mul : S₃ → S₃ → S₃
| x  e  := x
| e  y  := y
| a₁ a₁ := a₂
| a₁ a₂ := e
| a₁ a₃ := a₅
| a₁ a₄ := a₃
| a₁ a₅ := a₄
| a₂ a₁ := e
| a₂ a₂ := a₁
| a₂ a₃ := a₄
| a₂ a₄ := a₅
| a₂ a₅ := a₃
| a₃ a₁ := a₄
| a₃ a₂ := a₅
| a₃ a₃ := e
| a₃ a₄ := a₁
| a₃ a₅ := a₂
| a₄ a₁ := a₅
| a₄ a₂ := a₃
| a₄ a₃ := a₂
| a₄ a₄ := e
| a₄ a₅ := a₁
| a₅ a₁ := a₃
| a₅ a₂ := a₄
| a₅ a₃ := a₁
| a₅ a₄ := a₂
| a₅ a₅ := e

@[simp] def inv : S₃ → S₃
| e  := e
| a₁ := a₂
| a₂ := a₁
| a₃ := a₃
| a₄ := a₄
| a₅ := a₅

/- S₃ is a **finite group**. -/

@[simps] instance : finite_group S₃ :=
{ one       := e,
  mul       := mul,
  mul_one   := by intro a; cases' a; refl,
  one_mul   := by intro a; cases' a; refl,
  mul_assoc :=
    by intros a b c; cases' a; cases' b; cases' c; refl,
  inv          := inv,
  mul_left_inv := by intro a; cases' a; refl,
  elems := ⟨⟦[e, a₁, a₂, a₃, a₄, a₅]⟧, by simp⟩,
  complete := by intro x; cases' x; simp }

/- S₃ is a **transformation group** on a physical system. -/

/- S₃ is **non-Abelian**. i.e., the multiplication law is not commutative. -/
lemma is_non_abelian :
  ¬∀ a b : S₃, a * b = b * a :=
begin
  intro h,
  have h₂ : a₁ * a₃ ≠ a₃ * a₁ := by simp,
  apply h₂,
  apply h
end

/-
  A representation on a 2-dimensional vector space.
-/
@[simp] noncomputable def rep_func : S₃ → invertible_matrix 1
| e  := ⟨![
    ![1, 0],
    ![0, 1]
  ], by invertible_det2⟩
| a₁ := ⟨![
    ![         -1 / 2, -real.sqrt 3 / 2],
    ![real.sqrt 3 / 2, -1 / 2]
  ], by sorry⟩
| a₂ := ⟨![
    ![          -1 / 2, real.sqrt 3 / 2],
    ![-real.sqrt 3 / 2, -1 / 2]
  ], by sorry⟩
| a₃ := ⟨![
    ![-1, 0],
    ![ 0, 1]
], by invertible_det2⟩
| a₄ := ⟨![
    ![          1 / 2, real.sqrt 3 / 2],
    ![real.sqrt 3 / 2, -1 / 2]
  ], by sorry⟩
| a₅ := ⟨![
    ![           1 / 2, -real.sqrt 3 / 2],
    ![-real.sqrt 3 / 2, -1 / 2]
  ], by sorry⟩

@[simps] noncomputable def rep : matrix_representation 1 S₃ :=
{ f := rep_func,
  id_mapped := begin
    apply invertible_matrix.ext,
    simp [rep_func],
    rw ←matrix.diagonal_one,
    funext i j,
    fin_cases i,
    repeat { fin_cases j, repeat { refl } }
  end,
  mul_mapped := sorry }

/- It is a unitary irreducible representation. -/
example : rep.is_unitary :=
begin
  simp,
  intro z,
  cases' z,
  { unfold rep,
    funext i j,
    fin_cases i,
    repeat { fin_cases j,
      repeat { simp [matrix.conj_transpose] } } },
  repeat { sorry }
end

example : rep.is_irreducible :=
begin
  sorry
end

end S₃

end example_S₃

end FG


/-
# The Category Theory Game, version 0.1

## By Alena Gusakov

# What is this game?

Welcome to the category theory game -- a game to help undergraduates learn category theory
through Lean, a formal proof verification system. Starting from the definition of categories,
we develop the theory of functors, natural transformations, equivalence of categories,
representable functors and the Yoneda lemma. We develop the theory through problem-solving,
getting students to formalise proofs in the theory.

This game is a sequel to
the natural number game.
The levels in the Category Theory Game need to be solved using tactics. To learn how to use these tactics, I would
recommend that you first play the Natural Number Game up to at least "Advanced Proposition world". I will
not go through a careful explanation of the tactics taught by the natural number game here.

Blue nodes on the graph are ones that you are ready to enter. Grey nodes you should stay away
from -- try blue ones higher up the chain first. Green nodes are completed.

# Thanks

Many thanks to Mohammad Pedramfar, without whom this game would not exist.

# Questions?

You can ask questions on the Lean Zulip chat,
where I am often to be found.

The Category Theory Game is brought to you by the Xena project, a project based at Imperial College London
whose aim is to get mathematics undergraduates using computer theorem provers.
Lean is a computer theorem prover being developed at Microsoft Research.

Prove a theorem. Write a function. @XenaProject.
-/


/-
Copyright (c) 2020 Kyle Miller All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Kyle Miller.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.basic
import Mathlib.data.vector2
import Mathlib.tactic.tidy
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Symmetric powers

This file defines symmetric powers of a type.  The nth symmetric power
consists of homogeneous n-tuples modulo permutations by the symmetric
group.

The special case of 2-tuples is called the symmetric square, which is
addressed in more detail in `data.sym2`.

TODO: This was created as supporting material for `data.sym2`; it
needs a fleshed-out interface.

## Tags

symmetric powers

-/

/--
The nth symmetric power is n-tuples up to permutation.  We define it
as a subtype of `multiset` since these are well developed in the
library.  We also give a definition `sym.sym'` in terms of vectors, and we
show these are equivalent in `sym.sym_equiv_sym'`.
-/
def sym (α : Type u) (n : ℕ) :=
  Subtype fun (s : multiset α) => coe_fn multiset.card s = n

/--
This is the `list.perm` setoid lifted to `vector`.
-/
def vector.perm.is_setoid (α : Type u) (n : ℕ) : setoid (vector α n) :=
  setoid.mk (fun (a b : vector α n) => subtype.val a ~ subtype.val b) sorry

namespace sym

/--
This is the quotient map that takes a list of n elements as an n-tuple and produces an nth
symmetric power.
-/
def of_vector {α : Type u} {n : ℕ} (x : vector α n) : sym α n :=
  { val := ↑(subtype.val x), property := sorry }

protected instance has_lift {α : Type u} {n : ℕ} : has_lift (vector α n) (sym α n) :=
  has_lift.mk of_vector

/--
The unique element in `sym α 0`.
-/
def nil {α : Type u} : sym α 0 :=
  { val := 0, property := sorry }

/--
Inserts an element into the term of `sym α n`, increasing the length by one.
-/
def cons {α : Type u} {n : ℕ} : α → sym α n → sym α (Nat.succ n) :=
  sorry

infixr:67 " :: " => Mathlib.sym.cons

@[simp] theorem cons_inj_right {α : Type u} {n : ℕ} (a : α) (s : sym α n) (s' : sym α n) : a :: s = a :: s' ↔ s = s' := sorry

@[simp] theorem cons_inj_left {α : Type u} {n : ℕ} (a : α) (a' : α) (s : sym α n) : a :: s = a' :: s ↔ a = a' := sorry

theorem cons_swap {α : Type u} {n : ℕ} (a : α) (b : α) (s : sym α n) : a :: b :: s = b :: a :: s := sorry

/--
`α ∈ s` means that `a` appears as one of the factors in `s`.
-/
def mem {α : Type u} {n : ℕ} (a : α) (s : sym α n) :=
  a ∈ subtype.val s

protected instance has_mem {α : Type u} {n : ℕ} : has_mem α (sym α n) :=
  has_mem.mk mem

protected instance decidable_mem {α : Type u} {n : ℕ} [DecidableEq α] (a : α) (s : sym α n) : Decidable (a ∈ s) :=
  subtype.cases_on s
    fun (s_val : multiset α) (s_property : coe_fn multiset.card s_val = n) => id (multiset.decidable_mem a s_val)

@[simp] theorem mem_cons {α : Type u} {n : ℕ} {a : α} {b : α} {s : sym α n} : a ∈ b :: s ↔ a = b ∨ a ∈ s := sorry

theorem mem_cons_of_mem {α : Type u} {n : ℕ} {a : α} {b : α} {s : sym α n} (h : a ∈ s) : a ∈ b :: s :=
  iff.mpr mem_cons (Or.inr h)

@[simp] theorem mem_cons_self {α : Type u} {n : ℕ} (a : α) (s : sym α n) : a ∈ a :: s :=
  iff.mpr mem_cons (Or.inl rfl)

theorem cons_of_coe_eq {α : Type u} {n : ℕ} (a : α) (v : vector α n) : a :: ↑v = ↑(a::ᵥv) := sorry

theorem sound {α : Type u} {n : ℕ} {a : vector α n} {b : vector α n} (h : subtype.val a ~ subtype.val b) : ↑a = ↑b := sorry

/--
Another definition of the nth symmetric power, using vectors modulo permutations. (See `sym`.)
-/
def sym' (α : Type u) (n : ℕ) :=
  quotient (vector.perm.is_setoid α n)

/--
This is `cons` but for the alternative `sym'` definition.
-/
def cons' {α : Type u} {n : ℕ} : α → sym' α n → sym' α (Nat.succ n) :=
  fun (a : α) => quotient.map (vector.cons a) sorry

infixr:67 " :: " => Mathlib.sym.cons'

/--
Multisets of cardinality n are equivalent to length-n vectors up to permutations.
-/
def sym_equiv_sym' {α : Type u} {n : ℕ} : sym α n ≃ sym' α n :=
  equiv.subtype_quotient_equiv_quotient_subtype (fun (l : List α) => list.length l = n)
    (fun (s : multiset α) => coe_fn multiset.card s = n) sorry sorry

theorem cons_equiv_eq_equiv_cons (α : Type u) (n : ℕ) (a : α) (s : sym α n) : a :: coe_fn sym_equiv_sym' s = coe_fn sym_equiv_sym' (a :: s) := sorry

-- Instances to make the linter happy

protected instance inhabited_sym {α : Type u} [Inhabited α] (n : ℕ) : Inhabited (sym α n) :=
  { default := { val := multiset.repeat Inhabited.default n, property := sorry } }

protected instance inhabited_sym' {α : Type u} [Inhabited α] (n : ℕ) : Inhabited (sym' α n) :=
  { default := quotient.mk' (vector.repeat Inhabited.default n) }


/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import field_theory.adjoin
import field_theory.is_alg_closed.basic
import field_theory.separable
import ring_theory.integral_domain

/-!
# Primitive Element Theorem

In this file we prove the primitive element theorem.

## Main results

- `exists_primitive_element`: a finite separable extension `E / F` has a primitive element, i.e.
  there is an `α : E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.

## Implementation notes

In declaration names, `primitive_element` abbreviates `adjoin_simple_eq_top`:
it stands for the statement `F⟮α⟯ = (⊤ : subalgebra F E)`. We did not add an extra
declaration `is_primitive_element F α := F⟮α⟯ = (⊤ : subalgebra F E)` because this
requires more unfolding without much obvious benefit.

## Tags

primitive element, separable field extension, separable extension, intermediate field, adjoin,
exists_adjoin_simple_eq_top

-/

noncomputable theory
open_locale classical polynomial

open finite_dimensional polynomial intermediate_field

namespace field

section primitive_element_finite
variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

/-! ### Primitive element theorem for finite fields -/

/-- **Primitive element theorem** assuming E is finite. -/
lemma exists_primitive_element_of_fintype_top [fintype E] : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  obtain ⟨α, hα⟩ := is_cyclic.exists_generator (units E),
  use α,
  apply eq_top_iff.mpr,
  rintros x -,
  by_cases hx : x = 0,
  { rw hx,
    exact F⟮α.val⟯.zero_mem },
  { obtain ⟨n, hn⟩ := set.mem_range.mp (hα (units.mk0 x hx)),
    rw (show x = α^n, by { norm_cast, rw [hn, units.coe_mk0] }),
    exact pow_mem F⟮↑α⟯ (mem_adjoin_simple_self F ↑α) n, },
end

/-- Primitive element theorem for finite dimensional extension of a finite field. -/
theorem exists_primitive_element_of_fintype_bot [fintype F] [finite_dimensional F E] :
  ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  haveI : fintype E := fintype_of_fintype F E,
  exact exists_primitive_element_of_fintype_top F E,
end

end primitive_element_finite

/-! ### Primitive element theorem for infinite fields -/

section primitive_element_inf

variables {F : Type*} [field F] [infinite F] {E : Type*} [field E] (ϕ : F →+* E) (α β : E)

lemma primitive_element_inf_aux_exists_c (f g : F[X]) :
  ∃ c : F, ∀ (α' ∈ (f.map ϕ).roots) (β' ∈ (g.map ϕ).roots), -(α' - α)/(β' - β) ≠ ϕ c :=
begin
  let sf := (f.map ϕ).roots,
  let sg := (g.map ϕ).roots,
  let s := (sf.bind (λ α', sg.map (λ β', -(α' - α) / (β' - β)))).to_finset,
  let s' := s.preimage ϕ (λ x hx y hy h, ϕ.injective h),
  obtain ⟨c, hc⟩ := infinite.exists_not_mem_finset s',
  simp_rw [finset.mem_preimage, multiset.mem_to_finset, multiset.mem_bind, multiset.mem_map] at hc,
  push_neg at hc,
  exact ⟨c, hc⟩,
end

variables (F) [algebra F E]

-- This is the heart of the proof of the primitive element theorem. It shows that if `F` is
-- infinite and `α` and `β` are separable over `F` then `F⟮α, β⟯` is generated by a single element.
lemma primitive_element_inf_aux [is_separable F E] :
  ∃ γ : E, F⟮α, β⟯ = F⟮γ⟯ :=
begin
  have hα := is_separable.is_integral F α,
  have hβ := is_separable.is_integral F β,
  let f := minpoly F α,
  let g := minpoly F β,
  let ιFE := algebra_map F E,
  let ιEE' := algebra_map E (splitting_field (g.map ιFE)),
  obtain ⟨c, hc⟩ := primitive_element_inf_aux_exists_c (ιEE'.comp ιFE) (ιEE' α) (ιEE' β) f g,
  let γ := α + c • β,
  suffices β_in_Fγ : β ∈ F⟮γ⟯,
  { use γ,
    apply le_antisymm,
    { rw adjoin_le_iff,
      have α_in_Fγ : α ∈ F⟮γ⟯,
      { rw ← add_sub_cancel α (c • β),
        exact F⟮γ⟯.sub_mem (mem_adjoin_simple_self F γ) (F⟮γ⟯.to_subalgebra.smul_mem β_in_Fγ c) },
      exact λ x hx, by cases hx; cases hx; cases hx; assumption },
    { rw adjoin_le_iff,
      change {γ} ⊆ _,
      rw set.singleton_subset_iff,
      have α_in_Fαβ : α ∈ F⟮α, β⟯ := subset_adjoin F {α, β} (set.mem_insert α {β}),
      have β_in_Fαβ : β ∈ F⟮α, β⟯ := subset_adjoin F {α, β} (set.mem_insert_of_mem α rfl),
      exact F⟮α,β⟯.add_mem α_in_Fαβ (F⟮α, β⟯.smul_mem β_in_Fαβ) } },
  let p := euclidean_domain.gcd ((f.map (algebra_map F F⟮γ⟯)).comp
    (C (adjoin_simple.gen F γ) - (C ↑c * X))) (g.map (algebra_map F F⟮γ⟯)),
  let h := euclidean_domain.gcd ((f.map ιFE).comp (C γ - (C (ιFE c) * X))) (g.map ιFE),
  have map_g_ne_zero : g.map ιFE ≠ 0 := map_ne_zero (minpoly.ne_zero hβ),
  have h_ne_zero : h ≠ 0 :=  mt euclidean_domain.gcd_eq_zero_iff.mp
    (not_and.mpr (λ _, map_g_ne_zero)),
  suffices p_linear : p.map (algebra_map F⟮γ⟯ E) = (C h.leading_coeff) * (X - C β),
  { have finale : β = algebra_map F⟮γ⟯ E (-p.coeff 0 / p.coeff 1),
    { rw [ring_hom.map_div, ring_hom.map_neg, ←coeff_map, ←coeff_map, p_linear],
      simp [mul_sub, coeff_C, mul_div_cancel_left β (mt leading_coeff_eq_zero.mp h_ne_zero)] },
    rw finale,
    exact subtype.mem (-p.coeff 0 / p.coeff 1) },
  have h_sep : h.separable := separable_gcd_right _ (is_separable.separable F β).map,
  have h_root : h.eval β = 0,
  { apply eval_gcd_eq_zero,
    { rw [eval_comp, eval_sub, eval_mul, eval_C, eval_C, eval_X, eval_map, ←aeval_def,
          ←algebra.smul_def, add_sub_cancel, minpoly.aeval] },
    { rw [eval_map, ←aeval_def, minpoly.aeval] } },
  have h_splits : splits ιEE' h := splits_of_splits_gcd_right ιEE' map_g_ne_zero
    (splitting_field.splits _),
  have h_roots : ∀ x ∈ (h.map ιEE').roots, x = ιEE' β,
  { intros x hx,
    rw mem_roots_map h_ne_zero at hx,
    specialize hc ((ιEE' γ) - (ιEE' (ιFE c)) * x) (begin
      have f_root := root_left_of_root_gcd hx,
      rw [eval₂_comp, eval₂_sub, eval₂_mul,eval₂_C, eval₂_C, eval₂_X, eval₂_map] at f_root,
      exact (mem_roots_map (minpoly.ne_zero hα)).mpr f_root,
    end),
    specialize hc x (begin
      rw [mem_roots_map (minpoly.ne_zero hβ), ←eval₂_map],
      exact root_right_of_root_gcd hx,
    end),
    by_contradiction a,
    apply hc,
    apply (div_eq_iff (sub_ne_zero.mpr a)).mpr,
    simp only [algebra.smul_def, ring_hom.map_add, ring_hom.map_mul, ring_hom.comp_apply],
    ring },
  rw ← eq_X_sub_C_of_separable_of_root_eq h_sep h_root h_splits h_roots,
  transitivity euclidean_domain.gcd (_ : E[X]) (_ : E[X]),
  { dsimp only [p],
    convert (gcd_map (algebra_map F⟮γ⟯ E)).symm },
  { simpa [map_comp, polynomial.map_map, ←is_scalar_tower.algebra_map_eq, h] },
end

end primitive_element_inf

variables (F E : Type*) [field F] [field E]
variables [algebra F E] [finite_dimensional F E] [is_separable F E]

/-- Primitive element theorem: a finite separable field extension `E` of `F` has a
  primitive element, i.e. there is an `α ∈ E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.-/
theorem exists_primitive_element : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  rcases is_empty_or_nonempty (fintype F) with F_inf|⟨⟨F_finite⟩⟩,
  { let P : intermediate_field F E → Prop := λ K, ∃ α : E, F⟮α⟯ = K,
    have base : P ⊥ := ⟨0, adjoin_zero⟩,
    have ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑K⟮x⟯,
    { intros K β hK,
      cases hK with α hK,
      rw [←hK, adjoin_simple_adjoin_simple],
      haveI : infinite F := is_empty_fintype.mp F_inf,
      cases primitive_element_inf_aux F α β with γ hγ,
      exact ⟨γ, hγ.symm⟩ },
    exact induction_on_adjoin P base ih ⊤ },
  { exactI exists_primitive_element_of_fintype_bot F E }
end

/-- Alternative phrasing of primitive element theorem:
a finite separable field extension has a basis `1, α, α^2, ..., α^n`.

See also `exists_primitive_element`. -/
noncomputable def power_basis_of_finite_of_separable : power_basis F E :=
let α := (exists_primitive_element F E).some,
    pb := (adjoin.power_basis (is_separable.is_integral F α)) in
have e : F⟮α⟯ = ⊤ := (exists_primitive_element F E).some_spec,
pb.map ((intermediate_field.equiv_of_eq e).trans intermediate_field.top_equiv)

/-- If `E / F` is a finite separable extension, then there are finitely many
embeddings from `E` into `K` that fix `F`, corresponding to the number of
conjugate roots of the primitive element generating `F`. -/
instance {K : Type*} [field K] [algebra F K] : fintype (E →ₐ[F] K) :=
power_basis.alg_hom.fintype (power_basis_of_finite_of_separable F E)

end field

@[simp] lemma alg_hom.card (F E K : Type*) [field F] [field E] [field K] [is_alg_closed K]
  [algebra F E] [finite_dimensional F E] [is_separable F E] [algebra F K] :
  fintype.card (E →ₐ[F] K) = finrank F E :=
(alg_hom.card_of_power_basis (field.power_basis_of_finite_of_separable F E)
    (is_separable.separable _ _) (is_alg_closed.splits_codomain _)).trans
  (power_basis.finrank _).symm


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.W
import data.qpf.multivariate.basic

/-!
# The initial algebra of a multivariate qpf is again a qpf.

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

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `fix.mk`     - constructor
 * `fix.dest    - destructor
 * `fix.rec`    - recursor: basis for defining functions by structural recursion on `fix F α`
 * `fix.drec`   - dependent recursor: generalization of `fix.rec` where
                  the result type of the function is allowed to depend on the `fix F α` value
 * `fix.rec_eq` - defining equation for `recursor`
 * `fix.ind`    - induction principle for `fix F α`

## Implementation notes

For `F` a QPF`, we define `fix F α` in terms of the W-type of the polynomial functor `P` of `F`.
We define the relation `Wequiv` and take its quotient as the definition of `fix F α`.

```lean
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w
```

See [avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universes u v

namespace mvqpf
open typevec
open mvfunctor (liftp liftr)
open_locale mvfunctor

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

/-- `recF` is used as a basis for defining the recursor on `fix F α`. `recF`
traverses recursively the W-type generated by `q.P` using a function on `F`
as a recursive step -/
def recF {α : typevec n} {β : Type*} (g : F (α.append1 β) → β) : q.P.W α → β :=
q.P.W_rec (λ a f' f rec, g (abs ⟨a, split_fun f' rec⟩))

theorem recF_eq {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  recF g (q.P.W_mk a f' f) =  g (abs ⟨a, split_fun f' (recF g ∘ f)⟩) :=
by rw [recF, mvpfunctor.W_rec_eq]; refl

theorem recF_eq' {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (x : q.P.W α) :
  recF g x = g (abs ((append_fun id (recF g)) <$$> q.P.W_dest' x)) :=
begin
  apply q.P.W_cases _ x,
  intros a f' f,
  rw [recF_eq, q.P.W_dest'_W_mk, mvpfunctor.map_eq, append_fun_comp_split_fun,
    typevec.id_comp]
end

/-- Equivalence relation on W-types that represent the same `fix F`
value -/
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w

theorem recF_eq_of_Wequiv (α : typevec n) {β : Type*} (u : F (α.append1 β) → β)
    (x y : q.P.W α) :
  Wequiv x y → recF u x = recF u y :=
begin
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih { simp only [recF_eq, function.comp, ih] },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { simp only [recF_eq', abs_map, mvpfunctor.W_dest'_W_mk, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact eq.trans ih₁ ih₂ }
end

theorem Wequiv.abs' {α : typevec n} (x y : q.P.W α)
    (h : abs (q.P.W_dest' x) = abs (q.P.W_dest' y)) :
  Wequiv x y :=
begin
  revert h,
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  apply Wequiv.abs
end

theorem Wequiv.refl {α : typevec n} (x : q.P.W α) : Wequiv x x :=
by apply q.P.W_cases _ x; intros a f' f; exact Wequiv.abs a f' f a f' f rfl

theorem Wequiv.symm {α : typevec n} (x y : q.P.W α) : Wequiv x y → Wequiv y x :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { exact Wequiv.ind _ _ _ _ ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { exact Wequiv.abs _ _ _ _ _ _ h.symm },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact mvqpf.Wequiv.trans _ _ _ ih₂ ih₁}
end

/-- maps every element of the W type to a canonical representative -/
def Wrepr {α : typevec n} : q.P.W α → q.P.W α := recF (q.P.W_mk' ∘ repr)

theorem Wrepr_W_mk  {α : typevec n}
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  Wrepr (q.P.W_mk a f' f) =
    q.P.W_mk' (repr (abs ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩))) :=
by rw [Wrepr, recF_eq', q.P.W_dest'_W_mk]; refl

theorem Wrepr_equiv {α : typevec n} (x : q.P.W α) : Wequiv (Wrepr x) x :=
begin
  apply q.P.W_ind _ x, intros a f' f ih,
  apply Wequiv.trans _ (q.P.W_mk' ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩)),
  { apply Wequiv.abs',
    rw [Wrepr_W_mk, q.P.W_dest'_W_mk', q.P.W_dest'_W_mk', abs_repr] },
  rw [q.P.map_eq, mvpfunctor.W_mk', append_fun_comp_split_fun, id_comp],
  apply Wequiv.ind, exact ih
end

theorem Wequiv_map {α β : typevec n} (g : α ⟹ β) (x y : q.P.W α) :
  Wequiv x y → Wequiv (g <$$> x) (g <$$> y) :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.ind, apply ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.abs,
      show abs (q.P.obj_append1 a₀ (g ⊚ f'₀) (λ x, q.P.W_map g (f₀ x))) =
           abs (q.P.obj_append1 a₁ (g ⊚ f'₁) (λ x, q.P.W_map g (f₁ x))),
      rw [←q.P.map_obj_append1, ←q.P.map_obj_append1, abs_map, abs_map, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { apply mvqpf.Wequiv.trans, apply ih₁, apply ih₂ }
end

/--
Define the fixed point as the quotient of trees under the equivalence relation.
-/
def W_setoid (α : typevec n) : setoid (q.P.W α) :=
⟨Wequiv, @Wequiv.refl _ _ _ _ _, @Wequiv.symm _ _ _ _ _, @Wequiv.trans _ _ _ _ _⟩

local attribute [instance] W_setoid

/-- Least fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
fix F a b = F a b (fix F a b)
```
-/
def fix {n : ℕ} (F : typevec (n+1) → Type*) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
quotient (W_setoid α : setoid (q.P.W α))

attribute [nolint has_nonempty_instance] fix

/-- `fix F` is a functor -/
def fix.map {α β : typevec n} (g : α ⟹ β) : fix F α → fix F β :=
quotient.lift (λ x : q.P.W α, ⟦q.P.W_map g x⟧)
  (λ a b h, quot.sound (Wequiv_map _ _ _ h))

instance fix.mvfunctor : mvfunctor (fix F) :=
{ map := @fix.map _ _ _ _}

variable {α : typevec.{u} n}

/-- Recursor for `fix F` -/
def fix.rec {β : Type u} (g : F (α ::: β) → β) : fix F α → β :=
quot.lift (recF g) (recF_eq_of_Wequiv α g)

/-- Access W-type underlying `fix F`  -/
def fix_to_W : fix F α → q.P.W α :=
quotient.lift Wrepr (recF_eq_of_Wequiv α (λ x, q.P.W_mk' (repr x)))

/-- Constructor for `fix F` -/
def fix.mk (x : F (append1 α (fix F α))) : fix F α :=
  quot.mk _ (q.P.W_mk' (append_fun id fix_to_W <$$> repr x))

/-- Destructor for `fix F` -/
def fix.dest : fix F α → F (append1 α (fix F α)) :=
fix.rec (mvfunctor.map (append_fun id fix.mk))

theorem fix.rec_eq {β : Type u} (g : F (append1 α β) → β) (x : F (append1 α (fix F α))) :
  fix.rec g (fix.mk x) = g (append_fun id (fix.rec g) <$$> x) :=
have recF g ∘ fix_to_W = fix.rec g,
  by { apply funext, apply quotient.ind, intro x, apply recF_eq_of_Wequiv,
       apply Wrepr_equiv },
begin
  conv { to_lhs, rw [fix.rec, fix.mk], dsimp },
  cases h : repr x with a f,
  rw [mvpfunctor.map_eq, recF_eq', ←mvpfunctor.map_eq, mvpfunctor.W_dest'_W_mk'],
  rw [←mvpfunctor.comp_map, abs_map, ←h, abs_repr, ←append_fun_comp, id_comp, this]
end

theorem fix.ind_aux (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦q.P.W_mk a f' f⟧ :=
have fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦Wrepr (q.P.W_mk a f' f)⟧,
  begin
    apply quot.sound, apply Wequiv.abs',
    rw [mvpfunctor.W_dest'_W_mk', abs_map, abs_repr, ←abs_map, mvpfunctor.map_eq],
    conv { to_rhs, rw [Wrepr_W_mk, q.P.W_dest'_W_mk', abs_repr, mvpfunctor.map_eq] },
    congr' 2, rw [mvpfunctor.append_contents, mvpfunctor.append_contents],
    rw [append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
    reflexivity
  end,
by { rw this, apply quot.sound, apply Wrepr_equiv }

theorem fix.ind_rec {β : Type*} (g₁ g₂ : fix F α → β)
    (h : ∀ x : F (append1 α (fix F α)),
      (append_fun id g₁) <$$> x = (append_fun id g₂) <$$> x → g₁ (fix.mk x) = g₂ (fix.mk x)) :
  ∀ x, g₁ x = g₂ x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  show g₁ ⟦q.P.W_mk a f' f⟧ = g₂ ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f], apply h,
  rw [←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  congr' 2,
  rw [mvpfunctor.append_contents, append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
  have : g₁ ∘ (λ x, ⟦f x⟧) = g₂ ∘ (λ x, ⟦f x⟧),
  { ext x, exact ih x },
  rw this
end

theorem fix.rec_unique {β : Type*} (g : F (append1 α β) → β) (h : fix F α → β)
    (hyp : ∀ x, h (fix.mk x) = g (append_fun id h <$$> x)) :
  fix.rec g = h :=
begin
  ext x,
  apply fix.ind_rec,
  intros x hyp',
  rw [hyp, ←hyp', fix.rec_eq]
end

theorem fix.mk_dest (x : fix F α) : fix.mk (fix.dest x) = x :=
begin
  change (fix.mk ∘ fix.dest) x = x,
  apply fix.ind_rec,
  intro x, dsimp,
  rw [fix.dest, fix.rec_eq, ←comp_map, ←append_fun_comp, id_comp],
  intro h, rw h,
  show fix.mk (append_fun id id <$$> x) = fix.mk x,
  rw [append_fun_id_id, mvfunctor.id_map]
end

theorem fix.dest_mk (x : F (append1 α (fix F α))) : fix.dest (fix.mk x) = x :=
begin
  unfold fix.dest, rw [fix.rec_eq, ←fix.dest, ←comp_map],
  conv { to_rhs, rw ←(mvfunctor.id_map x) },
  rw [←append_fun_comp, id_comp],
  have : fix.mk ∘ fix.dest = id, {ext x, apply fix.mk_dest },
  rw [this, append_fun_id_id]
end

theorem fix.ind {α : typevec n} (p : fix F α → Prop)
    (h : ∀ x : F (α.append1 (fix F α)), liftp (pred_last α p) x → p (fix.mk x)) :
  ∀ x, p x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  change p ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f],
  apply h,
  rw mvqpf.liftp_iff,
  refine ⟨_, _, rfl, _⟩,
  intros i j,
  cases i,
  { apply ih },
  { trivial },
end

instance mvqpf_fix : mvqpf (fix F) :=
{ P         := q.P.Wp,
  abs       := λ α, quot.mk Wequiv,
  repr      := λ α, fix_to_W,
  abs_repr  := by { intros α, apply quot.ind, intro a, apply quot.sound, apply Wrepr_equiv },
  abs_map   :=
    begin
      intros α β g x, conv { to_rhs, dsimp [mvfunctor.map]},
      rw fix.map, apply quot.sound,
      apply Wequiv.refl
    end }

/-- Dependent recursor for `fix F` -/
def fix.drec {β : fix F α → Type u}
  (g : Π x : F (α ::: sigma β), β (fix.mk $ (id ::: sigma.fst) <$$> x)) (x : fix F α) : β x :=
let y := @fix.rec _ F _ _ α (sigma β) (λ i, ⟨_,g i⟩) x in
have x = y.1,
  by { symmetry, dsimp [y], apply fix.ind_rec _ id _ x, intros x' ih,
       rw fix.rec_eq, dsimp, simp [append_fun_id_id] at ih,
       congr, conv { to_rhs, rw [← ih] }, rw [mvfunctor.map_map,← append_fun_comp,id_comp], },
cast (by rw this) y.2

end mvqpf


/- Justin cai, jc5pz-/
/-
POINTS: Welcome to the first CS2102 exam. The exam has 12
questions. Points for each question are as indicated, for a
total of 100 points.

READ CAREFULLY: If you are unable to answer a question in
a way that Lean accepts as syntactically correct, *comment
out your malformed answer*. Otherwise an error in your answer
can cause Lean not to recognize correct answers to other
questions. If you are sure an answer is correct but Lean is
not accepting it, look for problems in the preceding logic.

Do not change or delete any of the questions.

WHAT TO DO: Complete the exam by following the instructions
for each question. Save your file then upload the completed
and saved file to Collab. You have 75 minutes from the start
of the exam to the time where it must be uploaded to Collab.

OPEN NOTES: You may use the class notes for this exam, whether
provided to you by the instructors or taken by you (or for you).

STRICTLY INDIVIDUAL EFFORT: This is a strictly individual exam,
taken under the honor system. Do not communicate with anyone except
for the instructor about the content of this exam, by any means,
until you are sure that each person you are communicating with
has already completed the test.
-/

/- 1. (5 points)
What is the type of function1 (just below)? Give you answer by
replacing the hole (underscore) in the subsequent definition
with your answer.
-/

def function1 (f: ℕ → ℕ) (g: ℕ → ℕ) :=
  λ (x: ℕ), 3
#check function1

def function1_type : Type :=
  (ℕ → ℕ ) → (ℕ → ℕ ) → ℕ → ℕ

/- 2. (10 points)
Define three equivalent functions, called product1,
product2, and product3. Each must take two natural
numbers as its arguments and return their product.
Define the first version using C-style notation,
the second using a lambda abstraction, and the third
using a tactic script.
-/

-- Answer below:

-- ANSWER

-- C-style here
def product1 (a b: ℕ ) : ℕ := a * b

-- Lambda abstraction here
def product2: ℕ → ℕ → ℕ :=
  λ a b : ℕ,
    a * b

-- Tactic script here
def product3 (a b : ℕ ) : ℕ :=
begin
  exact a * b
end

/- 3. (5 points)

Given the definition of product1, what function
is (product1 5)? Answer by replacing the hole in
the following definition with a lambda abstraction.
-/

def product1_5 := λ a : ℕ, product1 5 a

/- 4. (5 points)
Which of the following properties does "product1_5" have?
Answer by placing a Y (for yes, it has this property), or
N (for no, it doesn't have this property), BEFORE the name
of each property, just after the dash.

-- ANSWER

- Y injective
- N surjective
- N one-to-many
- N strictly partial
- N bijective
-/

/- 5. (5 points)
Complete the  proof of the following conjecture, that
(product1 4 6) = 24. Fill in the proposition to be
proved in the first hole (underscore) and a proof in
the second hole.
-/

-- ANSWER
example : (product1 4 6) = 24 := rfl

/- 6. (10 points)
Prove the proposition that, for any natural
numbers, a, b, and c, if b = a, then if c = b, then a = c.
Fill in the hole in the following example accordingly,
replacing the underscore with a proof.
-/

-- Complete  by replacing the hole with a proof:
example: ∀ a b c: ℕ, b = a → c = b → a = c :=
    λ a b c,
      λ ba : b = a,
        λ cb : c = b,
          eq.trans (eq.symm ba) (eq.symm cb)

/- 7. (10 points)
In the context of the following assumptions, use
"example" to formally state and prove the proposition
that "Jane is nice."
-/

axiom Person : Type
axioms Jill Jane : Person
axiom IsNice : Person → Prop
axiom JillIsNice : IsNice Jill
axiom JillIsJane : Jill = Jane

-- Fill in the holes with your proposition and proof
example : IsNice Jane :=
  eq.subst JillIsJane JillIsNice

/- 8. (10 points)
Use "example" to prove that true ∧ true implies
true. Give two proofs, the first using a term-style
proof (e.g., a lambda expression term), and the
second, using a tactic script.
-/

-- Your answers here
example : true ∧ true → true := and.elim_left

example : true ∧ true → true :=
begin
  exact and.elim_left
end

/- 9. (10 points)
Define a function, called exfalso, that takes a proof
of false as an argument, and that returns a proof of
3 = 7 as a result.
-/

-- ANSWER
def exfalso (f: false) : 3 = 7 :=
begin
  exact false.elim f
end

/- 10. (10 points)
Formally state and prove the proposition,
that, for any propositions, A, B, and C,
A ∧ B ∧ C → C ∧ A ∧ B. You may write the
proof in any style you wish. One way to do it
would be to define a function that takes the
propositions, A, B, and C, and a proof of the
premise as its arguments and that returns a
proof of the conclusion as a result. You
might also use a tactic script.
-/

-- ANSWER

example:  ∀ (A B C : Prop ) , A ∧ B ∧ C → C ∧ A ∧ B :=
begin
  intros A B C,
  assume abc,
  have c := abc.2.2,
  have a := abc.1,
  have b:= abc.2.1,
  exact and.intro c (and.intro a b),
end

/- 11. (10 points)
Formally (in Lean), prove that if A, B, and C
are any propositions, and if C is true, then
A ∧ B ∧ C → B ∧ A.
-/

-- Complete the following by replacing _ with a proof:
theorem temp :  ∀(A B C: Prop), C → (A ∧ B ∧ C → B ∧ A) :=
begin
  assume A B C,
  assume c,
  assume abc,
  have a := abc.1,
  have bc := abc.2,
  have b := bc.1,
  have ba := and.intro b a,
  exact ba,
end

/- 12. (10 points)

Define a predicate, gt5, that is true for all and only for
natural numbers greater than 5. You may use the expression,
n > 5, in your answer. Then fill in the hole in the following
definition with the type of the term (gt5 4).
-/

-- ANSWER
def gt5 : ℕ → Prop :=
  λ n : ℕ ,
    if n > 5 then tt else ff

-- ANSWER
def type_of_gt5_4 := (5 > 4 : Prop)

/- 13. EXTRA CREDIT 5 points

Give brief natural-language (in English) rendition
of the following formal proposition.

∃ n, m : ℕ, isPrime n ∧ isPrime m ∧ m = n + 2

Answer: There exists an n and m, both Nats,
n is prime and m is prime, and m is equal to n + 2

If by isPrime we mean the ordinary concept of primeness
from basic arithmetic, then this proposition is true.
Prove it by giving values for n and m that satisfy the
predicate along with a very brief argument that the two
numbers do actually satisfy the predicate.

Answer:

n = 1
m = 3

Argument:
1 is prime and 3 is prime, and 1 + 2 = 3, thus n=1 and m=3
satisfies this predicate

-/


import SciLean
open SciLean

/-!
Running queries
===============
Alectryon captures the results of `#check`, `#eval`, and the like:
-/

variable (f : ℝ → ℝ) [IsSmooth f]

def x : Nat := 5
#reduce 5 + x

#check differential

#check (∂ f)  -- ℝ → ℝ → ℝ

#check (differential f)  -- ℝ → ℝ → ℝ

set_option pp.notation false in
#check (differential f)  -- ℝ → ℝ → ℝ

set_option pp.notation false in
#check (∂ f)  -- ℝ → ℝ → ℝ

set_option trace.Meta.Tactic.simp.rewrite true in
example : (ⅆ x, Math.sin x) = λ x => Math.cos x :=
by
  conv =>
    lhs                    -- focus on lhs
    simp only[derivative]  -- unfold derivative
    simp (config := {singlePass := true}) -- run simplifier
  done

/-!
By default, these results are folded and are displayed upon hovering or clicking.  We can unfold them by default using annotations or directives:
-/

def foo (x : ℝ) (y : ℝ) : ℝ := x*x*y + y
argument x
  isSmooth,
  diff?
argument y
  isSmooth,
  diff?

#check Nat /- .unfold -/

/-!
.. lean4:: unfold
-/

#check Bool
#eval 1 + 1

/-!
..

Hohoho

 -/

variable (f : ℝ → ℝ)

#check ∂ f /- .unfold -/

/-!
..

Euler Lagrange equations
========================

The Euler-Lagrange equations are usually written in the following way:
[asdf](www.google.com)

.. math:: \frac{d}{dt} \frac{\partial}{\partial \dot x} L(x(t),\dot x(t)) - \frac{\partial}{\partial x} L(x(t),\dot x(t))

..

The usual partial derivative notation is really confusing. To make it
a bit more clear, we can add vertical bars indicating what you should
pass after derivative:

.. math:: \frac{d}{ds}\bigg\rvert_{s=t} \frac{\partial}{\partial v}\bigg\rvert_{v=\dot y(s)} L(y(s),v) - \frac{\partial}{\partial x}\bigg\rvert_{x=y(t)} L(x, \dot y(t))

-/

section EulerLagrange

/-!

Let's introduce few variable, first Lagrangian

 -/

  variable {X ι} [Enumtype ι] [FinVec X ι]
  variable (L : X → X → ℝ)                     -- Lagrangian
  variable [IsSmooth L] [∀ x, IsSmooth (L x)]  -- It is smooth
  -- variable [∀ v, HasAdjDiff (λ x => L x v)]
  -- variable [∀ x, HasAdjDiff (λ v => L x v)]    -- It has gradients

#check Nat × Nat × Nat

theorem invert_first  {X₁ X₂ Y₁ Y₂ : Type}
  [Nonempty X₁] [Nonempty Y₁] [Nonempty X₂] [Nonempty Y₂]
  (f : X₁×X₂ → Y₁×Y₂) [IsInv f]
  : f⁻¹ = λ (y₁,y₂) =>
      let g₁ := λ x₂ => (λ x₁ => (f (x₁, x₂)).1)⁻¹ y₁
      let x₂ := (λ x₂ => (f (g₁ x₂, x₂)).2)⁻¹ y₂
      (g₁ x₂, x₂) := sorry

theorem invert_second  {X₁ X₂ Y₁ Y₂ : Type}
  [Nonempty X₁] [Nonempty Y₁] [Nonempty X₂] [Nonempty Y₂]
  (f : X₁×X₂ → Y₁×Y₂) [IsInv f]
  : f⁻¹ = λ (y₁,y₂) =>
      let g₂ := λ x₁ => (λ x₂ => (f (x₁, x₂)).2)⁻¹ y₂
      let x₁ := (λ x₁ => (f (x₁, g₂ x₁)).1)⁻¹ y₁
      (x₁, g₂ x₁) := sorry

/-!

and a trajectory of our system

 -/

  notation "⦃" x ", " y "⦄[" Ω "]" => SemiInner.semiInner x y Ω

#check@SemiHilbert.semi_inner_add--⦃x + y, z⦄[Ω]=⦃x, z⦄[Ω]+⦃y, z⦄[Ω]
  #check @SemiHilbert.semi_inner_mul
  #check @SemiHilbert.semi_inner_sym
  #check @SemiHilbert.semi_inner_pos

  variable (y : ℝ → X)  -- trajectory
  variable [IsSmooth y] -- it is smooth

/-!

..

With all this setup, let's have a look a the second term:

.. math:: \frac{\partial}{\partial x}\bigg\rvert_{x=y(t)} L(x, \dot y(t))

 -/

  #check λ t => ∇ (x:=y t), L x (ⅆ y t)

/-!
..

The first term is a bit more complicated:

.. math::  \frac{d}{ds}\bigg\rvert_{s=t} \frac{\partial}{\partial v}\bigg\rvert_{v=\dot y(s)} L(y(s),v)

 -/

  #check λ t => ⅆ (s:=t), ∇ (v:=ⅆ y s), L (y s) v

end EulerLagrange

/-!

..

Multiline equation

.. raw:: html

  \begin{align}
    y &= \int_\Omega e^{-x^2} dx \\
      &= \pi ...
  \end{align}

-/

/-!

..

  Here is a video

.. raw:: html

 -/

/-!

..

  Here is a picture

.. raw:: html

 -/

/-!
Documenting proofs
==================
Alectryon also captures goals and hypotheses as proofs progress:
-/

theorem test (p q : Prop) (hp : p) (hq : q): p ∧ q ↔ q ∧ p := by
  apply Iff.intro
  . intro h
    apply And.intro
    . exact hq   -- hoho
    . exact hp   /- hihi -/
  . intro h
    apply And.intro
    . exact hp
    . exact hq


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

! This file was ported from Lean 3 source module number_theory.class_number.finite
! leanprover-community/mathlib commit d0259b01c82eed3f50390a60404c63faf9e60b1f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.Pow
import Mathbin.LinearAlgebra.FreeModule.Pid
import Mathbin.LinearAlgebra.Matrix.AbsoluteValue
import Mathbin.NumberTheory.ClassNumber.AdmissibleAbsoluteValue
import Mathbin.RingTheory.ClassGroup
import Mathbin.RingTheory.DedekindDomain.IntegralClosure
import Mathbin.RingTheory.Norm

/-!
# Class numbers of global fields
In this file, we use the notion of "admissible absolute value" to prove
finiteness of the class group for number fields and function fields,
and define `class_number` as the order of this group.
## Main definitions
 - `class_group.fintype_of_admissible`: if `R` has an admissible absolute value,
   its integral closure has a finite class group
-/

open BigOperators

open nonZeroDivisors

namespace ClassGroup

open Ring

open BigOperators

section EuclideanDomain

variable (R S K L : Type _) [EuclideanDomain R] [CommRing S] [IsDomain S]

variable [Field K] [Field L]

variable [Algebra R K] [IsFractionRing R K]

variable [Algebra K L] [FiniteDimensional K L] [IsSeparable K L]

variable [algRL : Algebra R L] [IsScalarTower R K L]

variable [Algebra R S] [Algebra S L]

variable [ist : IsScalarTower R S L] [iic : IsIntegralClosure S R L]

variable {R S} (abv : AbsoluteValue R ℤ)

variable {ι : Type _} [DecidableEq ι] [Fintype ι] (bS : Basis ι R S)

/-- If `b` is an `R`-basis of `S` of cardinality `n`, then `norm_bound abv b` is an integer
such that for every `R`-integral element `a : S` with coordinates `≤ y`,
we have algebra.norm a ≤ norm_bound abv b * y ^ n`. (See also `norm_le` and `norm_lt`). -/
noncomputable def normBound : ℤ :=
  let n := Fintype.card ι
  let i : ι := Nonempty.some bS.index_nonempty
  let m : ℤ :=
    Finset.max'
      (Finset.univ.image fun ijk : ι × ι × ι =>
        abv (Algebra.leftMulMatrix bS (bS ijk.1) ijk.2.1 ijk.2.2))
      ⟨_, Finset.mem_image.mpr ⟨⟨i, i, i⟩, Finset.mem_univ _, rfl⟩⟩
  Nat.factorial n • (n • m) ^ n
#align class_group.norm_bound ClassGroup.normBound

theorem normBound_pos : 0 < normBound abv bS :=
  by
  obtain ⟨i, j, k, hijk⟩ : ∃ i j k, Algebra.leftMulMatrix bS (bS i) j k ≠ 0 :=
    by
    by_contra' h
    obtain ⟨i⟩ := bS.index_nonempty
    apply bS.ne_zero i
    apply
      (injective_iff_map_eq_zero (Algebra.leftMulMatrix bS)).mp (Algebra.leftMulMatrix_injective bS)
    ext (j k)
    simp [h, DMatrix.zero_apply]
  simp only [norm_bound, Algebra.smul_def, eq_natCast]
  refine' mul_pos (int.coe_nat_pos.mpr (Nat.factorial_pos _)) _
  refine' pow_pos (mul_pos (int.coe_nat_pos.mpr (fintype.card_pos_iff.mpr ⟨i⟩)) _) _
  refine' lt_of_lt_of_le (abv.pos hijk) (Finset.le_max' _ _ _)
  exact finset.mem_image.mpr ⟨⟨i, j, k⟩, Finset.mem_univ _, rfl⟩
#align class_group.norm_bound_pos ClassGroup.normBound_pos

/-- If the `R`-integral element `a : S` has coordinates `≤ y` with respect to some basis `b`,
its norm is less than `norm_bound abv b * y ^ dim S`. -/
theorem norm_le (a : S) {y : ℤ} (hy : ∀ k, abv (bS.repr a k) ≤ y) :
    abv (Algebra.norm R a) ≤ normBound abv bS * y ^ Fintype.card ι :=
  by
  conv_lhs => rw [← bS.sum_repr a]
  rw [Algebra.norm_apply, ← LinearMap.det_toMatrix bS]
  simp only [Algebra.norm_apply, AlgHom.map_sum, AlgHom.map_smul, LinearEquiv.map_sum,
    LinearEquiv.map_smul, Algebra.toMatrix_lmul_eq, norm_bound, smul_mul_assoc, ← mul_pow]
  convert Matrix.det_sum_smul_le Finset.univ _ hy using 3
  · rw [Finset.card_univ, smul_mul_assoc, mul_comm]
  · intro i j k
    apply Finset.le_max'
    exact finset.mem_image.mpr ⟨⟨i, j, k⟩, Finset.mem_univ _, rfl⟩
#align class_group.norm_le ClassGroup.norm_le

/-- If the `R`-integral element `a : S` has coordinates `< y` with respect to some basis `b`,
its norm is strictly less than `norm_bound abv b * y ^ dim S`. -/
theorem norm_lt {T : Type _} [LinearOrderedRing T] (a : S) {y : T}
    (hy : ∀ k, (abv (bS.repr a k) : T) < y) :
    (abv (Algebra.norm R a) : T) < normBound abv bS * y ^ Fintype.card ι :=
  by
  obtain ⟨i⟩ := bS.index_nonempty
  have him : (finset.univ.image fun k => abv (bS.repr a k)).Nonempty :=
    ⟨_, finset.mem_image.mpr ⟨i, Finset.mem_univ _, rfl⟩⟩
  set y' : ℤ := Finset.max' _ him with y'_def
  have hy' : ∀ k, abv (bS.repr a k) ≤ y' := by
    intro k
    exact Finset.le_max' _ _ (finset.mem_image.mpr ⟨k, Finset.mem_univ _, rfl⟩)
  have : (y' : T) < y :=
    by
    rw [y'_def, ←
      Finset.max'_image (show Monotone (coe : ℤ → T) from fun x y h => int.cast_le.mpr h)]
    apply (Finset.max'_lt_iff _ (him.image _)).mpr
    simp only [Finset.mem_image, exists_prop]
    rintro _ ⟨x, ⟨k, -, rfl⟩, rfl⟩
    exact hy k
  have y'_nonneg : 0 ≤ y' := le_trans (abv.nonneg _) (hy' i)
  apply (int.cast_le.mpr (norm_le abv bS a hy')).trans_lt
  simp only [Int.cast_mul, Int.cast_pow]
  apply mul_lt_mul' le_rfl
  · exact pow_lt_pow_of_lt_left this (int.cast_nonneg.mpr y'_nonneg) (fintype.card_pos_iff.mpr ⟨i⟩)
  · exact pow_nonneg (int.cast_nonneg.mpr y'_nonneg) _
  · exact int.cast_pos.mpr (norm_bound_pos abv bS)
  · infer_instance
#align class_group.norm_lt ClassGroup.norm_lt

/-- A nonzero ideal has an element of minimal norm. -/
theorem exists_min (I : (Ideal S)⁰) :
    ∃ b ∈ (I : Ideal S),
      b ≠ 0 ∧ ∀ c ∈ (I : Ideal S), abv (Algebra.norm R c) < abv (Algebra.norm R b) → c = (0 : S) :=
  by
  obtain ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩, min⟩ :=
    @Int.exists_least_of_bdd
      (fun a => ∃ b ∈ (I : Ideal S), b ≠ (0 : S) ∧ abv (Algebra.norm R b) = a) _ _
  · refine' ⟨b, b_mem, b_ne_zero, _⟩
    intro c hc lt
    contrapose! lt with c_ne_zero
    exact min _ ⟨c, hc, c_ne_zero, rfl⟩
  · use 0
    rintro _ ⟨b, b_mem, b_ne_zero, rfl⟩
    apply abv.nonneg
  · obtain ⟨b, b_mem, b_ne_zero⟩ := (I : Ideal S).ne_bot_iff.mp (nonZeroDivisors.coe_ne_zero I)
    exact ⟨_, ⟨b, b_mem, b_ne_zero, rfl⟩⟩
#align class_group.exists_min ClassGroup.exists_min

section IsAdmissible

variable (L) {abv} (adm : abv.IsAdmissible)

include adm

/-- If we have a large enough set of elements in `R^ι`, then there will be a pair
whose remainders are close together. We'll show that all sets of cardinality
at least `cardM bS adm` elements satisfy this condition.

The value of `cardM` is not at all optimal: for specific choices of `R`,
the minimum cardinality can be exponentially smaller.
-/
noncomputable def cardM : ℕ :=
  adm.card (normBound abv bS ^ (-1 / Fintype.card ι : ℝ)) ^ Fintype.card ι
#align class_group.cardM ClassGroup.cardM

variable [Infinite R]

/-- In the following results, we need a large set of distinct elements of `R`. -/
noncomputable def distinctElems : Fin (cardM bS adm).succ ↪ R :=
  Fin.valEmbedding.trans (Infinite.natEmbedding R)
#align class_group.distinct_elems ClassGroup.distinctElems

variable [DecidableEq R]

/-- `finset_approx` is a finite set such that each fractional ideal in the integral closure
contains an element close to `finset_approx`. -/
noncomputable def finsetApprox : Finset R :=
  (Finset.univ.image fun xy : _ × _ => distinctElems bS adm xy.1 - distinctElems bS adm xy.2).eraseₓ
    0
#align class_group.finset_approx ClassGroup.finsetApprox

theorem finsetApprox.zero_not_mem : (0 : R) ∉ finsetApprox bS adm :=
  Finset.not_mem_erase _ _
#align class_group.finset_approx.zero_not_mem ClassGroup.finsetApprox.zero_not_mem

@[simp]
theorem mem_finsetApprox {x : R} :
    x ∈ finsetApprox bS adm ↔ ∃ i j, i ≠ j ∧ distinctElems bS adm i - distinctElems bS adm j = x :=
  by
  simp only [finset_approx, Finset.mem_erase, Finset.mem_image]
  constructor
  · rintro ⟨hx, ⟨i, j⟩, _, rfl⟩
    refine' ⟨i, j, _, rfl⟩
    rintro rfl
    simpa using hx
  · rintro ⟨i, j, hij, rfl⟩
    refine' ⟨_, ⟨i, j⟩, Finset.mem_univ _, rfl⟩
    rw [Ne.def, sub_eq_zero]
    exact fun h => hij ((distinct_elems bS adm).Injective h)
#align class_group.mem_finset_approx ClassGroup.mem_finsetApprox

section Real

open Real

attribute [-instance] Real.decidableEq

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finsetApprox (a : S) {b} (hb : b ≠ (0 : R)) :
    ∃ q : S,
      ∃ r ∈ finsetApprox bS adm,
        abv (Algebra.norm R (r • a - b • q)) < abv (Algebra.norm R (algebraMap R S b)) :=
  by
  have dim_pos := fintype.card_pos_iff.mpr bS.index_nonempty
  set ε : ℝ := norm_bound abv bS ^ (-1 / Fintype.card ι : ℝ) with ε_eq
  have hε : 0 < ε := Real.rpow_pos_of_pos (int.cast_pos.mpr (norm_bound_pos abv bS)) _
  have ε_le : (norm_bound abv bS : ℝ) * (abv b • ε) ^ Fintype.card ι ≤ abv b ^ Fintype.card ι :=
    by
    have := norm_bound_pos abv bS
    have := abv.nonneg b
    rw [ε_eq, Algebra.smul_def, eq_intCast, ← rpow_nat_cast, mul_rpow, ← rpow_mul, div_mul_cancel,
        rpow_neg_one, mul_left_comm, mul_inv_cancel, mul_one, rpow_nat_cast] <;>
      try norm_cast; linarith
    · apply rpow_nonneg_of_nonneg
      norm_cast
      linarith
  let μ : Fin (cardM bS adm).succ ↪ R := distinct_elems bS adm
  set s := bS.repr a
  have s_eq : ∀ i, s i = bS.repr a i := fun i => rfl
  set qs := fun j i => μ j * s i / b
  have q_eq : ∀ j i, qs j i = μ j * s i / b := fun i j => rfl
  set rs := fun j i => μ j * s i % b with r_eq
  have r_eq : ∀ j i, rs j i = μ j * s i % b := fun i j => rfl
  have μ_eq : ∀ i j, μ j * s i = b * qs j i + rs j i :=
    by
    intro i j
    rw [q_eq, r_eq, EuclideanDomain.div_add_mod]
  have μ_mul_a_eq : ∀ j, μ j • a = (b • ∑ i, qs j i • bS i) + ∑ i, rs j i • bS i :=
    by
    intro j
    rw [← bS.sum_repr a]
    simp only [Finset.smul_sum, ← Finset.sum_add_distrib]
    refine' Finset.sum_congr rfl fun i _ => _
    rw [← s_eq, ← mul_smul, μ_eq, add_smul, mul_smul]
  obtain ⟨j, k, j_ne_k, hjk⟩ := adm.exists_approx hε hb fun j i => μ j * s i
  have hjk' : ∀ i, (abv (rs k i - rs j i) : ℝ) < abv b • ε := by simpa only [r_eq] using hjk
  set q := ∑ i, (qs k i - qs j i) • bS i with q_eq
  set r := μ k - μ j with r_eq
  refine' ⟨q, r, (mem_finset_approx bS adm).mpr _, _⟩
  · exact ⟨k, j, j_ne_k.symm, rfl⟩
  have : r • a - b • q = ∑ x : ι, rs k x • bS x - rs j x • bS x :=
    by
    simp only [r_eq, sub_smul, μ_mul_a_eq, q_eq, Finset.smul_sum, ← Finset.sum_add_distrib, ←
      Finset.sum_sub_distrib, smul_sub]
    refine' Finset.sum_congr rfl fun x _ => _
    ring
  rw [this, Algebra.norm_algebraMap_of_basis bS, abv.map_pow]
  refine' int.cast_lt.mp ((norm_lt abv bS _ fun i => lt_of_le_of_lt _ (hjk' i)).trans_le _)
  · apply le_of_eq
    congr
    simp_rw [LinearEquiv.map_sum, LinearEquiv.map_sub, LinearEquiv.map_smul, Finset.sum_apply',
      Finsupp.sub_apply, Finsupp.smul_apply, Finset.sum_sub_distrib, Basis.repr_self_apply,
      smul_eq_mul, mul_boole, Finset.sum_ite_eq', Finset.mem_univ, if_true]
  · exact_mod_cast ε_le
#align class_group.exists_mem_finset_approx ClassGroup.exists_mem_finsetApprox

include ist iic

/-- We can approximate `a / b : L` with `q / r`, where `r` has finitely many options for `L`. -/
theorem exists_mem_finset_approx' (h : Algebra.IsAlgebraic R L) (a : S) {b : S} (hb : b ≠ 0) :
    ∃ q : S,
      ∃ r ∈ finsetApprox bS adm, abv (Algebra.norm R (r • a - q * b)) < abv (Algebra.norm R b) :=
  by
  have inj : Function.Injective (algebraMap R L) :=
    by
    rw [IsScalarTower.algebraMap_eq R S L]
    exact (IsIntegralClosure.algebraMap_injective S R L).comp bS.algebra_map_injective
  obtain ⟨a', b', hb', h⟩ := IsIntegralClosure.exists_smul_eq_mul h inj a hb
  obtain ⟨q, r, hr, hqr⟩ := exists_mem_finset_approx bS adm a' hb'
  refine' ⟨q, r, hr, _⟩
  refine'
    lt_of_mul_lt_mul_left _ (show 0 ≤ abv (Algebra.norm R (algebraMap R S b')) from abv.nonneg _)
  refine'
    lt_of_le_of_lt (le_of_eq _)
      (mul_lt_mul hqr le_rfl (abv.pos ((Algebra.norm_ne_zero_iff_of_basis bS).mpr hb))
        (abv.nonneg _))
  rw [← abv.map_mul, ← MonoidHom.map_mul, ← abv.map_mul, ← MonoidHom.map_mul, ← Algebra.smul_def,
    smul_sub b', sub_mul, smul_comm, h, mul_comm b a', Algebra.smul_mul_assoc r a' b,
    Algebra.smul_mul_assoc b' q b]
#align class_group.exists_mem_finset_approx' ClassGroup.exists_mem_finset_approx'

end Real

theorem prod_finsetApprox_ne_zero : algebraMap R S (∏ m in finsetApprox bS adm, m) ≠ 0 :=
  by
  refine' mt ((injective_iff_map_eq_zero _).mp bS.algebra_map_injective _) _
  simp only [Finset.prod_eq_zero_iff, not_exists]
  rintro x hx rfl
  exact finset_approx.zero_not_mem bS adm hx
#align class_group.prod_finset_approx_ne_zero ClassGroup.prod_finsetApprox_ne_zero

theorem ne_bot_of_prod_finsetApprox_mem (J : Ideal S)
    (h : algebraMap _ _ (∏ m in finsetApprox bS adm, m) ∈ J) : J ≠ ⊥ :=
  (Submodule.ne_bot_iff _).mpr ⟨_, h, prod_finsetApprox_ne_zero _ _⟩
#align class_group.ne_bot_of_prod_finset_approx_mem ClassGroup.ne_bot_of_prod_finsetApprox_mem

include ist iic

/-- Each class in the class group contains an ideal `J`
such that `M := Π m ∈ finset_approx` is in `J`. -/
theorem exists_mk0_eq_mk0 [IsDedekindDomain S] (h : Algebra.IsAlgebraic R L) (I : (Ideal S)⁰) :
    ∃ J : (Ideal S)⁰,
      ClassGroup.mk0 I = ClassGroup.mk0 J ∧
        algebraMap _ _ (∏ m in finsetApprox bS adm, m) ∈ (J : Ideal S) :=
  by
  set M := ∏ m in finset_approx bS adm, m with M_eq
  have hM : algebraMap R S M ≠ 0 := prod_finset_approx_ne_zero bS adm
  obtain ⟨b, b_mem, b_ne_zero, b_min⟩ := exists_min abv I
  suffices Ideal.span {b} ∣ Ideal.span {algebraMap _ _ M} * I.1
    by
    obtain ⟨J, hJ⟩ := this
    refine' ⟨⟨J, _⟩, _, _⟩
    · rw [mem_nonZeroDivisors_iff_ne_zero]
      rintro rfl
      rw [Ideal.zero_eq_bot, Ideal.mul_bot] at hJ
      exact hM (ideal.span_singleton_eq_bot.mp (I.2 _ hJ))
    · rw [ClassGroup.mk0_eq_mk0_iff]
      exact ⟨algebraMap _ _ M, b, hM, b_ne_zero, hJ⟩
    rw [← SetLike.mem_coe, ← Set.singleton_subset_iff, ← Ideal.span_le, ← Ideal.dvd_iff_le]
    refine' (mul_dvd_mul_iff_left _).mp _
    swap
    · exact mt ideal.span_singleton_eq_bot.mp b_ne_zero
    rw [Subtype.coe_mk, Ideal.dvd_iff_le, ← hJ, mul_comm]
    apply Ideal.mul_mono le_rfl
    rw [Ideal.span_le, Set.singleton_subset_iff]
    exact b_mem
  rw [Ideal.dvd_iff_le, Ideal.mul_le]
  intro r' hr' a ha
  rw [Ideal.mem_span_singleton] at hr'⊢
  obtain ⟨q, r, r_mem, lt⟩ := exists_mem_finset_approx' L bS adm h a b_ne_zero
  apply @dvd_of_mul_left_dvd _ _ q
  simp only [Algebra.smul_def] at lt
  rw [←
    sub_eq_zero.mp (b_min _ (I.1.sub_mem (I.1.mul_mem_left _ ha) (I.1.mul_mem_left _ b_mem)) lt)]
  refine' mul_dvd_mul_right (dvd_trans (RingHom.map_dvd _ _) hr') _
  exact Multiset.dvd_prod (multiset.mem_map.mpr ⟨_, r_mem, rfl⟩)
#align class_group.exists_mk0_eq_mk0 ClassGroup.exists_mk0_eq_mk0

omit iic ist

/-- `class_group.mk_M_mem` is a specialization of `class_group.mk0` to (the finite set of)
ideals that contain `M := ∏ m in finset_approx L f abs, m`.
By showing this function is surjective, we prove that the class group is finite. -/
noncomputable def mkMMem [IsDedekindDomain S]
    (J : { J : Ideal S // algebraMap _ _ (∏ m in finsetApprox bS adm, m) ∈ J }) : ClassGroup S :=
  ClassGroup.mk0
    ⟨J.1, mem_nonZeroDivisors_iff_ne_zero.mpr (ne_bot_of_prod_finsetApprox_mem bS adm J.1 J.2)⟩
#align class_group.mk_M_mem ClassGroup.mkMMem

include iic ist

theorem mkMMem_surjective [IsDedekindDomain S] (h : Algebra.IsAlgebraic R L) :
    Function.Surjective (ClassGroup.mkMMem bS adm) :=
  by
  intro I'
  obtain ⟨⟨I, hI⟩, rfl⟩ := ClassGroup.mk0_surjective I'
  obtain ⟨J, mk0_eq_mk0, J_dvd⟩ := exists_mk0_eq_mk0 L bS adm h ⟨I, hI⟩
  exact ⟨⟨J, J_dvd⟩, mk0_eq_mk0.symm⟩
#align class_group.mk_M_mem_surjective ClassGroup.mkMMem_surjective

open Classical

/-- The main theorem: the class group of an integral closure `S` of `R` in an
algebraic extension `L` is finite if there is an admissible absolute value.

See also `class_group.fintype_of_admissible_of_finite` where `L` is a finite
extension of `K = Frac(R)`, supplying most of the required assumptions automatically.
-/
noncomputable def fintypeOfAdmissibleOfAlgebraic [IsDedekindDomain S]
    (h : Algebra.IsAlgebraic R L) : Fintype (ClassGroup S) :=
  @Fintype.ofSurjective _ _ _
    (@Fintype.ofEquiv _
      { J // J ∣ Ideal.span ({algebraMap R S (∏ m : R in finsetApprox bS adm, m)} : Set S) }
      (UniqueFactorizationMonoid.fintypeSubtypeDvd _
        (by
          rw [Ne.def, Ideal.zero_eq_bot, Ideal.span_singleton_eq_bot]
          exact prod_finset_approx_ne_zero bS adm))
      ((Equiv.refl _).subtypeEquiv fun I =>
        Ideal.dvd_iff_le.trans (by rw [Equiv.refl_apply, Ideal.span_le, Set.singleton_subset_iff])))
    (ClassGroup.mkMMem bS adm) (ClassGroup.mkMMem_surjective L bS adm h)
#align class_group.fintype_of_admissible_of_algebraic ClassGroup.fintypeOfAdmissibleOfAlgebraic

include K

/-- The main theorem: the class group of an integral closure `S` of `R` in a
finite extension `L` of `K = Frac(R)` is finite if there is an admissible
absolute value.

See also `class_group.fintype_of_admissible_of_algebraic` where `L` is an
algebraic extension of `R`, that includes some extra assumptions.
-/
noncomputable def fintypeOfAdmissibleOfFinite [IsDedekindDomain R] : Fintype (ClassGroup S) :=
  by
  letI := Classical.decEq L
  letI := IsIntegralClosure.isFractionRing_of_finite_extension R K L S
  letI := IsIntegralClosure.isDedekindDomain R K L S
  choose s b hb_int using FiniteDimensional.exists_is_basis_integral R K L
  obtain ⟨n, b⟩ :=
    Submodule.basisOfPidOfLeSpan _ (IsIntegralClosure.range_le_span_dualBasis S b hb_int)
  let bS := b.map ((LinearMap.quotKerEquivRange _).symm ≪≫ₗ _)
  refine'
    fintype_of_admissible_of_algebraic L bS adm fun x =>
      (IsFractionRing.isAlgebraic_iff R K L).mpr (Algebra.isAlgebraic_of_finite _ _ x)
  · rw [linear_map.ker_eq_bot.mpr]
    · exact Submodule.quotEquivOfEqBot _ rfl
    · exact IsIntegralClosure.algebraMap_injective _ R _
  · refine' (Basis.linearIndependent _).restrictScalars _
    simp only [Algebra.smul_def, mul_one]
    apply IsFractionRing.injective
#align class_group.fintype_of_admissible_of_finite ClassGroup.fintypeOfAdmissibleOfFinite

end IsAdmissible

end EuclideanDomain

end ClassGroup


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

! This file was ported from Lean 3 source module algebraic_topology.dold_kan.faces
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicTopology.DoldKan.Homotopies
import Mathbin.Tactic.RingExp

/-!

# Study of face maps for the Dold-Kan correspondence

TODO (@joelriou) continue adding the various files referenced below

In this file, we obtain the technical lemmas that are used in the file
`projections.lean` in order to get basic properties of the endomorphisms
`P q : K[X] ⟶ K[X]` with respect to face maps (see `homotopies.lean` for the
role of these endomorphisms in the overall strategy of proof).

The main lemma in this file is `higher_faces_vanish.induction`. It is based
on two technical lemmas `higher_faces_vanish.comp_Hσ_eq` and
`higher_faces_vanish.comp_Hσ_eq_zero`.

-/

open Nat

open CategoryTheory

open CategoryTheory.Limits

open CategoryTheory.Category

open CategoryTheory.Preadditive

open CategoryTheory.SimplicialObject

open Simplicial DoldKan

namespace AlgebraicTopology

namespace DoldKan

variable {C : Type _} [Category C] [Preadditive C]

variable {X : SimplicialObject C}

/-- A morphism `φ : Y ⟶ X _[n+1]` satisfies `higher_faces_vanish q φ`
when the compositions `φ ≫ X.δ j` are `0` for `j ≥ max 1 (n+2-q)`. When `q ≤ n+1`,
it basically means that the composition `φ ≫ X.δ j` are `0` for the `q` highest
possible values of a nonzero `j`. Otherwise, when `q ≥ n+2`, all the compositions
`φ ≫ X.δ j` for nonzero `j` vanish. See also the lemma `comp_P_eq_self_iff` in
`projections.lean` which states that `higher_faces_vanish q φ` is equivalent to
the identity `φ ≫ (P q).f (n+1) = φ`. -/
def HigherFacesVanish {Y : C} {n : ℕ} (q : ℕ) (φ : Y ⟶ X _[n + 1]) : Prop :=
  ∀ j : Fin (n + 1), n + 1 ≤ (j : ℕ) + q → φ ≫ X.δ j.succ = 0
#align algebraic_topology.dold_kan.higher_faces_vanish AlgebraicTopology.DoldKan.HigherFacesVanish

namespace HigherFacesVanish

@[reassoc.1]
theorem comp_δ_eq_zero {Y : C} {n : ℕ} {q : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish q φ)
    (j : Fin (n + 2)) (hj₁ : j ≠ 0) (hj₂ : n + 2 ≤ (j : ℕ) + q) : φ ≫ X.δ j = 0 :=
  by
  obtain ⟨i, hi⟩ := Fin.eq_succ_of_ne_zero hj₁
  subst hi
  apply v i
  rw [← @Nat.add_le_add_iff_right 1, add_assoc]
  simpa only [Fin.val_succ, add_assoc, add_comm 1] using hj₂
#align algebraic_topology.dold_kan.higher_faces_vanish.comp_δ_eq_zero AlgebraicTopology.DoldKan.HigherFacesVanish.comp_δ_eq_zero

theorem of_succ {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish (q + 1) φ) :
    HigherFacesVanish q φ := fun j hj => v j (by simpa only [← add_assoc] using le_add_right hj)
#align algebraic_topology.dold_kan.higher_faces_vanish.of_succ AlgebraicTopology.DoldKan.HigherFacesVanish.of_succ

theorem of_comp {Y Z : C} {q n : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish q φ) (f : Z ⟶ Y) :
    HigherFacesVanish q (f ≫ φ) := fun j hj => by rw [assoc, v j hj, comp_zero]
#align algebraic_topology.dold_kan.higher_faces_vanish.of_comp AlgebraicTopology.DoldKan.HigherFacesVanish.of_comp

theorem comp_hσ_eq {Y : C} {n a q : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish q φ)
    (hnaq : n = a + q) :
    φ ≫ (hσ q).f (n + 1) =
      -φ ≫
          X.δ ⟨a + 1, Nat.succ_lt_succ (Nat.lt_succ_iff.mpr (Nat.le.intro hnaq.symm))⟩ ≫
            X.σ ⟨a, Nat.lt_succ_iff.mpr (Nat.le.intro hnaq.symm)⟩ :=
  by
  have hnaq_shift : ∀ d : ℕ, n + d = a + d + q :=
    by
    intro d
    rw [add_assoc, add_comm d, ← add_assoc, hnaq]
  rw [Hσ, Homotopy.nullHomotopicMap'_f (c_mk (n + 2) (n + 1) rfl) (c_mk (n + 1) n rfl),
    hσ'_eq hnaq (c_mk (n + 1) n rfl), hσ'_eq (hnaq_shift 1) (c_mk (n + 2) (n + 1) rfl)]
  simp only [alternating_face_map_complex.obj_d_eq, eq_to_hom_refl, comp_id, comp_sum, sum_comp,
    comp_add]
  simp only [comp_zsmul, zsmul_comp, ← assoc, ← mul_zsmul]
  -- cleaning up the first sum
  rw [← Fin.sum_congr' _ (hnaq_shift 2).symm, Fin.sum_trunc]
  swap
  · rintro ⟨k, hk⟩
    suffices φ ≫ X.δ (⟨a + 2 + k, by linarith⟩ : Fin (n + 2)) = 0 by
      simp only [this, Fin.natAdd_mk, Fin.cast_mk, zero_comp, smul_zero]
    convert v ⟨a + k + 1, by linarith⟩
        (by
          rw [Fin.val_mk]
          linarith)
    rw [Nat.succ_eq_add_one]
    linarith
  -- cleaning up the second sum
  rw [← Fin.sum_congr' _ (hnaq_shift 3).symm, @Fin.sum_trunc _ _ (a + 3)]
  swap
  · rintro ⟨k, hk⟩
    rw [assoc, X.δ_comp_σ_of_gt', v.comp_δ_eq_zero_assoc, zero_comp, zsmul_zero]
    · intro h
      rw [Fin.pred_eq_iff_eq_succ, Fin.ext_iff] at h
      dsimp at h
      linarith
    · dsimp
      simp only [Fin.coe_pred, Fin.val_mk, succ_add_sub_one]
      linarith
    · dsimp
      linarith
  -- leaving out three specific terms
  conv_lhs =>
    congr
    skip
    rw [Fin.sum_univ_castSucc, Fin.sum_univ_castSucc]
  rw [Fin.sum_univ_castSucc]
  simp only [Fin.last, Fin.castLe_mk, Fin.coe_cast, Fin.cast_mk, Fin.coe_castLe, Fin.val_mk,
    Fin.castSucc_mk, Fin.coe_castSucc]
  /- the purpose of the following `simplif` is to create three subgoals in order
      to finish the proof -/
  have simplif :
    ∀ a b c d e f : Y ⟶ X _[n + 1], b = f → d + e = 0 → c + a = 0 → a + b + (c + d + e) = f :=
    by
    intro a b c d e f h1 h2 h3
    rw [add_assoc c d e, h2, add_zero, add_comm a b, add_assoc, add_comm a c, h3, add_zero, h1]
  apply simplif
  · -- b=f
    rw [← pow_add, Odd.neg_one_pow, neg_smul, one_zsmul]
    use a
    linarith
  · -- d+e = 0
    rw [assoc, assoc, X.δ_comp_σ_self' (Fin.castSucc_mk _ _ _).symm,
      X.δ_comp_σ_succ' (Fin.succ_mk _ _ _).symm]
    simp only [comp_id, pow_add _ (a + 1) 1, pow_one, mul_neg, mul_one, neg_smul, add_right_neg]
  · -- c+a = 0
    rw [← Finset.sum_add_distrib]
    apply Finset.sum_eq_zero
    rintro ⟨i, hi⟩ h₀
    have hia : (⟨i, by linarith⟩ : Fin (n + 2)) ≤ Fin.castSucc (⟨a, by linarith⟩ : Fin (n + 1)) :=
      by simpa only [Fin.le_iff_val_le_val, Fin.val_mk, Fin.castSucc_mk, ← lt_succ_iff] using hi
    simp only [Fin.val_mk, Fin.castLe_mk, Fin.castSucc_mk, Fin.succ_mk, assoc, Fin.cast_mk, ←
      δ_comp_σ_of_le X hia, add_eq_zero_iff_eq_neg, ← neg_zsmul]
    congr
    ring
#align algebraic_topology.dold_kan.higher_faces_vanish.comp_Hσ_eq AlgebraicTopology.DoldKan.HigherFacesVanish.comp_hσ_eq

theorem comp_hσ_eq_zero {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish q φ)
    (hqn : n < q) : φ ≫ (hσ q).f (n + 1) = 0 :=
  by
  simp only [Hσ, Homotopy.nullHomotopicMap'_f (c_mk (n + 2) (n + 1) rfl) (c_mk (n + 1) n rfl)]
  rw [hσ'_eq_zero hqn (c_mk (n + 1) n rfl), comp_zero, zero_add]
  by_cases hqn' : n + 1 < q
  · rw [hσ'_eq_zero hqn' (c_mk (n + 2) (n + 1) rfl), zero_comp, comp_zero]
  · simp only [hσ'_eq (show n + 1 = 0 + q by linarith) (c_mk (n + 2) (n + 1) rfl), pow_zero,
      Fin.mk_zero, one_zsmul, eq_to_hom_refl, comp_id, comp_sum,
      alternating_face_map_complex.obj_d_eq]
    rw [← Fin.sum_congr' _ (show 2 + (n + 1) = n + 1 + 2 by linarith), Fin.sum_trunc]
    · simp only [Fin.sum_univ_castSucc, Fin.sum_univ_zero, zero_add, Fin.last, Fin.castLe_mk,
        Fin.cast_mk, Fin.castSucc_mk]
      simp only [Fin.mk_zero, Fin.val_zero, pow_zero, one_zsmul, Fin.mk_one, Fin.val_one, pow_one,
        neg_smul, comp_neg]
      erw [δ_comp_σ_self, δ_comp_σ_succ, add_right_neg]
    · intro j
      rw [comp_zsmul, comp_zsmul, δ_comp_σ_of_gt', v.comp_δ_eq_zero_assoc, zero_comp, zsmul_zero]
      · intro h
        rw [Fin.pred_eq_iff_eq_succ, Fin.ext_iff] at h
        dsimp at h
        linarith
      · dsimp
        simp only [Fin.cast_natAdd, Fin.coe_pred, Fin.coe_addNat, add_succ_sub_one]
        linarith
      · rw [Fin.lt_iff_val_lt_val]
        dsimp
        linarith
#align algebraic_topology.dold_kan.higher_faces_vanish.comp_Hσ_eq_zero AlgebraicTopology.DoldKan.HigherFacesVanish.comp_hσ_eq_zero

theorem induction {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n + 1]} (v : HigherFacesVanish q φ) :
    HigherFacesVanish (q + 1) (φ ≫ (𝟙 _ + hσ q).f (n + 1)) :=
  by
  intro j hj₁
  dsimp
  simp only [comp_add, add_comp, comp_id]
  -- when n < q, the result follows immediately from the assumption
  by_cases hqn : n < q
  · rw [v.comp_Hσ_eq_zero hqn, zero_comp, add_zero, v j (by linarith)]
  -- we now assume that n≥q, and write n=a+q
  cases' Nat.le.dest (not_lt.mp hqn) with a ha
  rw [v.comp_Hσ_eq (show n = a + q by linarith), neg_comp, add_neg_eq_zero, assoc, assoc]
  cases' n with m hm
  -- the boundary case n=0
  ·
    simpa only [Nat.eq_zero_of_add_eq_zero_left ha, Fin.eq_zero j, Fin.mk_zero, Fin.mk_one,
      δ_comp_σ_succ, comp_id]
  -- in the other case, we need to write n as m+1
  -- then, we first consider the particular case j = a
  by_cases hj₂ : a = (j : ℕ)
  · simp only [hj₂, Fin.eta, δ_comp_σ_succ, comp_id]
    congr
    ext
    simp only [Fin.val_succ, Fin.val_mk]
  -- now, we assume j ≠ a (i.e. a < j)
  have haj : a < j := (Ne.le_iff_lt hj₂).mp (by linarith)
  have hj₃ := j.is_lt
  have ham : a ≤ m := by
    by_contra
    rw [not_le, ← Nat.succ_le_iff] at h
    linarith
  rw [X.δ_comp_σ_of_gt', j.pred_succ]
  swap
  · rw [Fin.lt_iff_val_lt_val]
    simpa only [Fin.val_mk, Fin.val_succ, add_lt_add_iff_right] using haj
  obtain ham' | ham'' := ham.lt_or_eq
  · -- case where `a<m`
    rw [← X.δ_comp_δ''_assoc]
    swap
    · rw [Fin.le_iff_val_le_val]
      dsimp
      linarith
    simp only [← assoc, v j (by linarith), zero_comp]
  · -- in the last case, a=m, q=1 and j=a+1
    rw [X.δ_comp_δ_self'_assoc]
    swap
    · ext
      dsimp
      have hq : q = 1 := by rw [← add_left_inj a, ha, ham'', add_comm]
      linarith
    simp only [← assoc, v j (by linarith), zero_comp]
#align algebraic_topology.dold_kan.higher_faces_vanish.induction AlgebraicTopology.DoldKan.HigherFacesVanish.induction

end HigherFacesVanish

end DoldKan

end AlgebraicTopology