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

! This file was ported from Lean 3 source module linear_algebra.free_module.pid
! leanprover-community/mathlib commit f62c15c01a5409b31b97a82d79a12980be4eff35
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Dimension
import Mathbin.LinearAlgebra.FreeModule.Basic
import Mathbin.RingTheory.PrincipalIdealDomain
import Mathbin.RingTheory.Finiteness

/-! # Free modules over PID

A free `R`-module `M` is a module with a basis over `R`,
equivalently it is an `R`-module linearly equivalent to `ι →₀ R` for some `ι`.

This file proves a submodule of a free `R`-module of finite rank is also
a free `R`-module of finite rank, if `R` is a principal ideal domain (PID),
i.e. we have instances `[is_domain R] [is_principal_ideal_ring R]`.
We express "free `R`-module of finite rank" as a module `M` which has a basis
`b : ι → R`, where `ι` is a `fintype`.
We call the cardinality of `ι` the rank of `M` in this file;
it would be equal to `finrank R M` if `R` is a field and `M` is a vector space.

## Main results

In this section, `M` is a free and finitely generated `R`-module, and
`N` is a submodule of `M`.

 - `submodule.induction_on_rank`: if `P` holds for `⊥ : submodule R M` and if
  `P N` follows from `P N'` for all `N'` that are of lower rank, then `P` holds
   on all submodules

 - `submodule.exists_basis_of_pid`: if `R` is a PID, then `N : submodule R M` is
   free and finitely generated. This is the first part of the structure theorem
   for modules.

- `submodule.smith_normal_form`: if `R` is a PID, then `M` has a basis
  `bM` and `N` has a basis `bN` such that `bN i = a i • bM i`.
  Equivalently, a linear map `f : M →ₗ M` with `range f = N` can be written as
  a matrix in Smith normal form, a diagonal matrix with the coefficients `a i`
  along the diagonal.

## Tags

free module, finitely generated module, rank, structure theorem

-/

open BigOperators

universe u v

section Ring

variable {R : Type u} {M : Type v} [Ring R] [AddCommGroup M] [Module R M]

variable {ι : Type _} (b : Basis ι R M)

open Submodule.IsPrincipal Submodule

theorem eq_bot_of_generator_maximal_map_eq_zero (b : Basis ι R M) {N : Submodule R M}
    {ϕ : M →ₗ[R] R} (hϕ : ∀ ψ : M →ₗ[R] R, N.map ϕ ≤ N.map ψ → N.map ψ = N.map ϕ)
    [(N.map ϕ).IsPrincipal] (hgen : generator (N.map ϕ) = (0 : R)) : N = ⊥ :=
  by
  rw [Submodule.eq_bot_iff]
  intro x hx
  refine' b.ext_elem fun i => _
  rw [(eq_bot_iff_generator_eq_zero _).mpr hgen] at hϕ
  rw [LinearEquiv.map_zero, Finsupp.zero_apply]
  exact (Submodule.eq_bot_iff _).mp (hϕ (Finsupp.lapply i ∘ₗ ↑b.repr) bot_le) _ ⟨x, hx, rfl⟩
#align eq_bot_of_generator_maximal_map_eq_zero eq_bot_of_generator_maximal_map_eq_zero

theorem eq_bot_of_generator_maximal_submoduleImage_eq_zero {N O : Submodule R M} (b : Basis ι R O)
    (hNO : N ≤ O) {ϕ : O →ₗ[R] R}
    (hϕ :
      ∀ ψ : O →ₗ[R] R,
        ϕ.submoduleImage N ≤ ψ.submoduleImage N → ψ.submoduleImage N = ϕ.submoduleImage N)
    [(ϕ.submoduleImage N).IsPrincipal] (hgen : generator (ϕ.submoduleImage N) = 0) : N = ⊥ :=
  by
  rw [Submodule.eq_bot_iff]
  intro x hx
  refine' congr_arg coe (show (⟨x, hNO hx⟩ : O) = 0 from b.ext_elem fun i => _)
  rw [(eq_bot_iff_generator_eq_zero _).mpr hgen] at hϕ
  rw [LinearEquiv.map_zero, Finsupp.zero_apply]
  refine' (Submodule.eq_bot_iff _).mp (hϕ (Finsupp.lapply i ∘ₗ ↑b.repr) bot_le) _ _
  exact (LinearMap.mem_submoduleImage_of_le hNO).mpr ⟨x, hx, rfl⟩
#align eq_bot_of_generator_maximal_submodule_image_eq_zero eq_bot_of_generator_maximal_submoduleImage_eq_zero

end Ring

section IsDomain

variable {ι : Type _} {R : Type _} [CommRing R] [IsDomain R]

variable {M : Type _} [AddCommGroup M] [Module R M] {b : ι → M}

open Submodule.IsPrincipal Set Submodule

theorem dvd_generator_iff {I : Ideal R} [I.IsPrincipal] {x : R} (hx : x ∈ I) :
    x ∣ generator I ↔ I = Ideal.span {x} :=
  by
  conv_rhs => rw [← span_singleton_generator I]
  erw [Ideal.span_singleton_eq_span_singleton, ← dvd_dvd_iff_associated, ← mem_iff_generator_dvd]
  exact ⟨fun h => ⟨hx, h⟩, fun h => h.2⟩
#align dvd_generator_iff dvd_generator_iff

end IsDomain

section PrincipalIdealDomain

open Submodule.IsPrincipal Set Submodule

variable {ι : Type _} {R : Type _} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R]

variable {M : Type _} [AddCommGroup M] [Module R M] {b : ι → M}

open Submodule.IsPrincipal

theorem generator_maximal_submoduleImage_dvd {N O : Submodule R M} (hNO : N ≤ O) {ϕ : O →ₗ[R] R}
    (hϕ :
      ∀ ψ : O →ₗ[R] R,
        ϕ.submoduleImage N ≤ ψ.submoduleImage N → ψ.submoduleImage N = ϕ.submoduleImage N)
    [(ϕ.submoduleImage N).IsPrincipal] (y : M) (yN : y ∈ N)
    (ϕy_eq : ϕ ⟨y, hNO yN⟩ = generator (ϕ.submoduleImage N)) (ψ : O →ₗ[R] R) :
    generator (ϕ.submoduleImage N) ∣ ψ ⟨y, hNO yN⟩ :=
  by
  let a : R := generator (ϕ.submodule_image N)
  let d : R := is_principal.generator (Submodule.span R {a, ψ ⟨y, hNO yN⟩})
  have d_dvd_left : d ∣ a := (mem_iff_generator_dvd _).mp (subset_span (mem_insert _ _))
  have d_dvd_right : d ∣ ψ ⟨y, hNO yN⟩ :=
    (mem_iff_generator_dvd _).mp (subset_span (mem_insert_of_mem _ (mem_singleton _)))
  refine' dvd_trans _ d_dvd_right
  rw [dvd_generator_iff, Ideal.span, ←
    span_singleton_generator (Submodule.span R {a, ψ ⟨y, hNO yN⟩})]
  obtain ⟨r₁, r₂, d_eq⟩ : ∃ r₁ r₂ : R, d = r₁ * a + r₂ * ψ ⟨y, hNO yN⟩ :=
    by
    obtain ⟨r₁, r₂', hr₂', hr₁⟩ :=
      mem_span_insert.mp (is_principal.generator_mem (Submodule.span R {a, ψ ⟨y, hNO yN⟩}))
    obtain ⟨r₂, rfl⟩ := mem_span_singleton.mp hr₂'
    exact ⟨r₁, r₂, hr₁⟩
  let ψ' : O →ₗ[R] R := r₁ • ϕ + r₂ • ψ
  have : span R {d} ≤ ψ'.submodule_image N :=
    by
    rw [span_le, singleton_subset_iff, SetLike.mem_coe, LinearMap.mem_submoduleImage_of_le hNO]
    refine' ⟨y, yN, _⟩
    change r₁ * ϕ ⟨y, hNO yN⟩ + r₂ * ψ ⟨y, hNO yN⟩ = d
    rw [d_eq, ϕy_eq]
  refine'
    le_antisymm (this.trans (le_of_eq _)) (ideal.span_singleton_le_span_singleton.mpr d_dvd_left)
  rw [span_singleton_generator]
  refine' hϕ ψ' (le_trans _ this)
  rw [← span_singleton_generator (ϕ.submodule_image N)]
  exact ideal.span_singleton_le_span_singleton.mpr d_dvd_left
  · exact subset_span (mem_insert _ _)
#align generator_maximal_submodule_image_dvd generator_maximal_submoduleImage_dvd

/-- The induction hypothesis of `submodule.basis_of_pid` and `submodule.smith_normal_form`.

Basically, it says: let `N ≤ M` be a pair of submodules, then we can find a pair of
submodules `N' ≤ M'` of strictly smaller rank, whose basis we can extend to get a basis
of `N` and `M`. Moreover, if the basis for `M'` is up to scalars a basis for `N'`,
then the basis we find for `M` is up to scalars a basis for `N`.

For `basis_of_pid` we only need the first half and can fix `M = ⊤`,
for `smith_normal_form` we need the full statement,
but must also feed in a basis for `M` using `basis_of_pid` to keep the induction going.
-/
theorem Submodule.basis_of_pid_aux [Finite ι] {O : Type _} [AddCommGroup O] [Module R O]
    (M N : Submodule R O) (b'M : Basis ι R M) (N_bot : N ≠ ⊥) (N_le_M : N ≤ M) :
    ∃ y ∈ M,
      ∃ (a : R)(hay : a • y ∈ N),
        ∃ M' ≤ M,
          ∃ N' ≤ N,
            ∃ (N'_le_M' : N' ≤ M')(y_ortho_M' :
              ∀ (c : R) (z : O), z ∈ M' → c • y + z = 0 → c = 0)(ay_ortho_N' :
              ∀ (c : R) (z : O), z ∈ N' → c • a • y + z = 0 → c = 0),
              ∀ (n') (bN' : Basis (Fin n') R N'),
                ∃ bN : Basis (Fin (n' + 1)) R N,
                  ∀ (m') (hn'm' : n' ≤ m') (bM' : Basis (Fin m') R M'),
                    ∃ (hnm : n' + 1 ≤ m' + 1)(bM : Basis (Fin (m' + 1)) R M),
                      ∀ (as : Fin n' → R)
                        (h : ∀ i : Fin n', (bN' i : O) = as i • (bM' (Fin.castLe hn'm' i) : O)),
                        ∃ as' : Fin (n' + 1) → R,
                          ∀ i : Fin (n' + 1), (bN i : O) = as' i • (bM (Fin.castLe hnm i) : O) :=
  by
  -- Let `ϕ` be a maximal projection of `M` onto `R`, in the sense that there is
  -- no `ψ` whose image of `N` is larger than `ϕ`'s image of `N`.
  have :
    ∃ ϕ : M →ₗ[R] R,
      ∀ ψ : M →ₗ[R] R,
        ϕ.submoduleImage N ≤ ψ.submoduleImage N → ψ.submoduleImage N = ϕ.submoduleImage N :=
    by
    obtain ⟨P, P_eq, P_max⟩ :=
      set_has_maximal_iff_noetherian.mpr (inferInstance : IsNoetherian R R) _
        (show (Set.range fun ψ : M →ₗ[R] R => ψ.submoduleImage N).Nonempty from
          ⟨_, set.mem_range.mpr ⟨0, rfl⟩⟩)
    obtain ⟨ϕ, rfl⟩ := set.mem_range.mp P_eq
    exact ⟨ϕ, fun ψ hψ => P_max _ ⟨_, rfl⟩ hψ⟩
  let ϕ := this.some
  have ϕ_max := this.some_spec
  -- Since `ϕ(N)` is a `R`-submodule of the PID `R`,
  -- it is principal and generated by some `a`.
  let a := generator (ϕ.submodule_image N)
  have a_mem : a ∈ ϕ.submodule_image N := generator_mem _
  -- If `a` is zero, then the submodule is trivial. So let's assume `a ≠ 0`, `N ≠ ⊥`.
  by_cases a_zero : a = 0
  · have := eq_bot_of_generator_maximal_submoduleImage_eq_zero b'M N_le_M ϕ_max a_zero
    contradiction
  -- We claim that `ϕ⁻¹ a = y` can be taken as basis element of `N`.
  obtain ⟨y, yN, ϕy_eq⟩ := (LinearMap.mem_submoduleImage_of_le N_le_M).mp a_mem
  have ϕy_ne_zero : ϕ ⟨y, N_le_M yN⟩ ≠ 0 := fun h => a_zero (ϕy_eq.symm.trans h)
  -- Write `y` as `a • y'` for some `y'`.
  have hdvd : ∀ i, a ∣ b'M.coord i ⟨y, N_le_M yN⟩ := fun i =>
    generator_maximal_submoduleImage_dvd N_le_M ϕ_max y yN ϕy_eq (b'M.coord i)
  choose c hc using hdvd
  cases nonempty_fintype ι
  let y' : O := ∑ i, c i • b'M i
  have y'M : y' ∈ M := M.sum_mem fun i _ => M.smul_mem (c i) (b'M i).2
  have mk_y' : (⟨y', y'M⟩ : M) = ∑ i, c i • b'M i :=
    Subtype.ext
      (show y' = M.subtype _
        by
        simp only [LinearMap.map_sum, LinearMap.map_smul]
        rfl)
  have a_smul_y' : a • y' = y :=
    by
    refine' congr_arg coe (show (a • ⟨y', y'M⟩ : M) = ⟨y, N_le_M yN⟩ from _)
    rw [← b'M.sum_repr ⟨y, N_le_M yN⟩, mk_y', Finset.smul_sum]
    refine' Finset.sum_congr rfl fun i _ => _
    rw [← mul_smul, ← hc]
    rfl
  -- We found an `y` and an `a`!
  refine' ⟨y', y'M, a, a_smul_y'.symm ▸ yN, _⟩
  have ϕy'_eq : ϕ ⟨y', y'M⟩ = 1 :=
    mul_left_cancel₀ a_zero
      (calc
        a • ϕ ⟨y', y'M⟩ = ϕ ⟨a • y', _⟩ := (ϕ.map_smul a ⟨y', y'M⟩).symm
        _ = ϕ ⟨y, N_le_M yN⟩ := by simp only [a_smul_y']
        _ = a := ϕy_eq
        _ = a * 1 := (mul_one a).symm
        )
  have ϕy'_ne_zero : ϕ ⟨y', y'M⟩ ≠ 0 := by simpa only [ϕy'_eq] using one_ne_zero
  -- `M' := ker (ϕ : M → R)` is smaller than `M` and `N' := ker (ϕ : N → R)` is smaller than `N`.
  let M' : Submodule R O := ϕ.ker.map M.subtype
  let N' : Submodule R O := (ϕ.comp (of_le N_le_M)).ker.map N.subtype
  have M'_le_M : M' ≤ M := M.map_subtype_le ϕ.ker
  have N'_le_M' : N' ≤ M' := by
    intro x hx
    simp only [mem_map, LinearMap.mem_ker] at hx⊢
    obtain ⟨⟨x, xN⟩, hx, rfl⟩ := hx
    exact ⟨⟨x, N_le_M xN⟩, hx, rfl⟩
  have N'_le_N : N' ≤ N := N.map_subtype_le (ϕ.comp (of_le N_le_M)).ker
  -- So fill in those results as well.
  refine' ⟨M', M'_le_M, N', N'_le_N, N'_le_M', _⟩
  -- Note that `y'` is orthogonal to `M'`.
  have y'_ortho_M' : ∀ (c : R), ∀ z ∈ M', c • y' + z = 0 → c = 0 :=
    by
    intro c x xM' hc
    obtain ⟨⟨x, xM⟩, hx', rfl⟩ := submodule.mem_map.mp xM'
    rw [LinearMap.mem_ker] at hx'
    have hc' : (c • ⟨y', y'M⟩ + ⟨x, xM⟩ : M) = 0 := Subtype.coe_injective hc
    simpa only [LinearMap.map_add, LinearMap.map_zero, LinearMap.map_smul, smul_eq_mul, add_zero,
      mul_eq_zero, ϕy'_ne_zero, hx', or_false_iff] using congr_arg ϕ hc'
  -- And `a • y'` is orthogonal to `N'`.
  have ay'_ortho_N' : ∀ (c : R), ∀ z ∈ N', c • a • y' + z = 0 → c = 0 :=
    by
    intro c z zN' hc
    refine' (mul_eq_zero.mp (y'_ortho_M' (a * c) z (N'_le_M' zN') _)).resolve_left a_zero
    rw [mul_comm, mul_smul, hc]
  -- So we can extend a basis for `N'` with `y`
  refine' ⟨y'_ortho_M', ay'_ortho_N', fun n' bN' => ⟨_, _⟩⟩
  · refine' Basis.mkFinConsOfLe y yN bN' N'_le_N _ _
    · intro c z zN' hc
      refine' ay'_ortho_N' c z zN' _
      rwa [← a_smul_y'] at hc
    · intro z zN
      obtain ⟨b, hb⟩ : _ ∣ ϕ ⟨z, N_le_M zN⟩ := generator_submodule_image_dvd_of_mem N_le_M ϕ zN
      refine' ⟨-b, submodule.mem_map.mpr ⟨⟨_, N.sub_mem zN (N.smul_mem b yN)⟩, _, _⟩⟩
      · refine' linear_map.mem_ker.mpr (show ϕ (⟨z, N_le_M zN⟩ - b • ⟨y, N_le_M yN⟩) = 0 from _)
        rw [LinearMap.map_sub, LinearMap.map_smul, hb, ϕy_eq, smul_eq_mul, mul_comm, sub_self]
      · simp only [sub_eq_add_neg, neg_smul]
        rfl
  -- And extend a basis for `M'` with `y'`
  intro m' hn'm' bM'
  refine' ⟨Nat.succ_le_succ hn'm', _, _⟩
  · refine' Basis.mkFinConsOfLe y' y'M bM' M'_le_M y'_ortho_M' _
    intro z zM
    refine' ⟨-ϕ ⟨z, zM⟩, ⟨⟨z, zM⟩ - ϕ ⟨z, zM⟩ • ⟨y', y'M⟩, linear_map.mem_ker.mpr _, _⟩⟩
    · rw [LinearMap.map_sub, LinearMap.map_smul, ϕy'_eq, smul_eq_mul, mul_one, sub_self]
    · rw [LinearMap.map_sub, LinearMap.map_smul, sub_eq_add_neg, neg_smul]
      rfl
  -- It remains to show the extended bases are compatible with each other.
  intro as h
  refine' ⟨Fin.cons a as, _⟩
  intro i
  rw [Basis.coe_mkFinConsOfLe, Basis.coe_mkFinConsOfLe]
  refine' Fin.cases _ (fun i => _) i
  · simp only [Fin.cons_zero, Fin.castLe_zero]
    exact a_smul_y'.symm
  · rw [Fin.castLe_succ]
    simp only [Fin.cons_succ, coe_of_le, h i]
#align submodule.basis_of_pid_aux Submodule.basis_of_pid_aux

/-- A submodule of a free `R`-module of finite rank is also a free `R`-module of finite rank,
if `R` is a principal ideal domain.

This is a `lemma` to make the induction a bit easier. To actually access the basis,
see `submodule.basis_of_pid`.

See also the stronger version `submodule.smith_normal_form`.
-/
theorem Submodule.nonempty_basis_of_pid {ι : Type _} [Finite ι] (b : Basis ι R M)
    (N : Submodule R M) : ∃ n : ℕ, Nonempty (Basis (Fin n) R N) :=
  by
  haveI := Classical.decEq M
  cases nonempty_fintype ι
  refine' N.induction_on_rank b _ _
  intro N ih
  let b' := (b.reindex (Fintype.equivFin ι)).map (LinearEquiv.ofTop _ rfl).symm
  by_cases N_bot : N = ⊥
  · subst N_bot
    exact ⟨0, ⟨Basis.empty _⟩⟩
  obtain ⟨y, -, a, hay, M', -, N', N'_le_N, -, -, ay_ortho, h'⟩ :=
    Submodule.basis_of_pid_aux ⊤ N b' N_bot le_top
  obtain ⟨n', ⟨bN'⟩⟩ := ih N' N'_le_N _ hay ay_ortho
  obtain ⟨bN, hbN⟩ := h' n' bN'
  exact ⟨n' + 1, ⟨bN⟩⟩
#align submodule.nonempty_basis_of_pid Submodule.nonempty_basis_of_pid

/-- A submodule of a free `R`-module of finite rank is also a free `R`-module of finite rank,
if `R` is a principal ideal domain.

See also the stronger version `submodule.smith_normal_form`.
-/
noncomputable def Submodule.basisOfPid {ι : Type _} [Finite ι] (b : Basis ι R M)
    (N : Submodule R M) : Σn : ℕ, Basis (Fin n) R N :=
  ⟨_, (N.nonempty_basis_of_pid b).choose_spec.some⟩
#align submodule.basis_of_pid Submodule.basisOfPid

theorem Submodule.basisOfPid_bot {ι : Type _} [Finite ι] (b : Basis ι R M) :
    Submodule.basisOfPid b ⊥ = ⟨0, Basis.empty _⟩ :=
  by
  obtain ⟨n, b'⟩ := Submodule.basisOfPid b ⊥
  let e : Fin n ≃ Fin 0 := b'.index_equiv (Basis.empty _ : Basis (Fin 0) R (⊥ : Submodule R M))
  obtain rfl : n = 0 := by simpa using fintype.card_eq.mpr ⟨e⟩
  exact Sigma.eq rfl (Basis.eq_of_apply_eq <| finZeroElim)
#align submodule.basis_of_pid_bot Submodule.basisOfPid_bot

/-- A submodule inside a free `R`-submodule of finite rank is also a free `R`-module of finite rank,
if `R` is a principal ideal domain.

See also the stronger version `submodule.smith_normal_form_of_le`.
-/
noncomputable def Submodule.basisOfPidOfLe {ι : Type _} [Finite ι] {N O : Submodule R M}
    (hNO : N ≤ O) (b : Basis ι R O) : Σn : ℕ, Basis (Fin n) R N :=
  let ⟨n, bN'⟩ := Submodule.basisOfPid b (N.comap O.Subtype)
  ⟨n, bN'.map (Submodule.comapSubtypeEquivOfLe hNO)⟩
#align submodule.basis_of_pid_of_le Submodule.basisOfPidOfLe

/-- A submodule inside the span of a linear independent family is a free `R`-module of finite rank,
if `R` is a principal ideal domain. -/
noncomputable def Submodule.basisOfPidOfLeSpan {ι : Type _} [Finite ι] {b : ι → M}
    (hb : LinearIndependent R b) {N : Submodule R M} (le : N ≤ Submodule.span R (Set.range b)) :
    Σn : ℕ, Basis (Fin n) R N :=
  Submodule.basisOfPidOfLe le (Basis.span hb)
#align submodule.basis_of_pid_of_le_span Submodule.basisOfPidOfLeSpan

variable {M}

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (i «expr ∉ » I) -/
/-- A finite type torsion free module over a PID admits a basis. -/
noncomputable def Module.basisOfFiniteTypeTorsionFree [Fintype ι] {s : ι → M}
    (hs : span R (range s) = ⊤) [NoZeroSMulDivisors R M] : Σn : ℕ, Basis (Fin n) R M := by
  classical
    -- We define `N` as the submodule spanned by a maximal linear independent subfamily of `s`
    have := exists_maximal_independent R s
    let I : Set ι := this.some
    obtain
      ⟨indepI : LinearIndependent R (s ∘ coe : I → M), hI :
        ∀ (i) (_ : i ∉ I), ∃ a : R, a ≠ 0 ∧ a • s i ∈ span R (s '' I)⟩ :=
      this.some_spec
    let N := span R (range <| (s ∘ coe : I → M))
    -- same as `span R (s '' I)` but more convenient
    let sI : I → N := fun i => ⟨s i.1, subset_span (mem_range_self i)⟩
    -- `s` restricted to `I`
    let sI_basis : Basis I R N
    -- `s` restricted to `I` is a basis of `N`
    exact Basis.span indepI
    -- Our first goal is to build `A ≠ 0` such that `A • M ⊆ N`
    have exists_a : ∀ i : ι, ∃ a : R, a ≠ 0 ∧ a • s i ∈ N :=
      by
      intro i
      by_cases hi : i ∈ I
      · use 1, zero_ne_one.symm
        rw [one_smul]
        exact subset_span (mem_range_self (⟨i, hi⟩ : I))
      · simpa [image_eq_range s I] using hI i hi
    choose a ha ha' using exists_a
    let A := ∏ i, a i
    have hA : A ≠ 0 := by
      rw [Finset.prod_ne_zero_iff]
      simpa using ha
    -- `M ≃ A • M` because `M` is torsion free and `A ≠ 0`
    let φ : M →ₗ[R] M := LinearMap.lsmul R M A
    have : φ.ker = ⊥ := LinearMap.ker_lsmul hA
    let ψ : M ≃ₗ[R] φ.range := LinearEquiv.ofInjective φ (linear_map.ker_eq_bot.mp this)
    have : φ.range ≤ N :=
      by
      -- as announced, `A • M ⊆ N`
      suffices ∀ i, φ (s i) ∈ N
        by
        rw [LinearMap.range_eq_map, ← hs, φ.map_span_le]
        rintro _ ⟨i, rfl⟩
        apply this
      intro i
      calc
        (∏ j, a j) • s i = (∏ j in {i}ᶜ, a j) • a i • s i := by
          rw [Fintype.prod_eq_prod_compl_mul i, mul_smul]
        _ ∈ N := N.smul_mem _ (ha' i)

    -- Since a submodule of a free `R`-module is free, we get that `A • M` is free
    obtain ⟨n, b : Basis (Fin n) R φ.range⟩ := Submodule.basisOfPidOfLe this sI_basis
    -- hence `M` is free.
    exact ⟨n, b.map ψ.symm⟩
#align module.basis_of_finite_type_torsion_free Module.basisOfFiniteTypeTorsionFree

theorem Module.free_of_finite_type_torsion_free [Finite ι] {s : ι → M} (hs : span R (range s) = ⊤)
    [NoZeroSMulDivisors R M] : Module.Free R M :=
  by
  cases nonempty_fintype ι
  obtain ⟨n, b⟩ : Σn, Basis (Fin n) R M := Module.basisOfFiniteTypeTorsionFree hs
  exact Module.Free.of_basis b
#align module.free_of_finite_type_torsion_free Module.free_of_finite_type_torsion_free

/-- A finite type torsion free module over a PID admits a basis. -/
noncomputable def Module.basisOfFiniteTypeTorsionFree' [Module.Finite R M]
    [NoZeroSMulDivisors R M] : Σn : ℕ, Basis (Fin n) R M :=
  Module.basisOfFiniteTypeTorsionFree Module.Finite.exists_fin.choose_spec.choose_spec
#align module.basis_of_finite_type_torsion_free' Module.basisOfFiniteTypeTorsionFree'

theorem Module.free_of_finite_type_torsion_free' [Module.Finite R M] [NoZeroSMulDivisors R M] :
    Module.Free R M :=
  by
  obtain ⟨n, b⟩ : Σn, Basis (Fin n) R M := Module.basisOfFiniteTypeTorsionFree'
  exact Module.Free.of_basis b
#align module.free_of_finite_type_torsion_free' Module.free_of_finite_type_torsion_free'

section SmithNormal

/-- A Smith normal form basis for a submodule `N` of a module `M` consists of
bases for `M` and `N` such that the inclusion map `N → M` can be written as a
(rectangular) matrix with `a` along the diagonal: in Smith normal form. -/
@[nolint has_nonempty_instance]
structure Basis.SmithNormalForm (N : Submodule R M) (ι : Type _) (n : ℕ) where
  bM : Basis ι R M
  bN : Basis (Fin n) R N
  f : Fin n ↪ ι
  a : Fin n → R
  snf : ∀ i, (bN i : M) = a i • bM (f i)
#align basis.smith_normal_form Basis.SmithNormalForm

/-- If `M` is finite free over a PID `R`, then any submodule `N` is free
and we can find a basis for `M` and `N` such that the inclusion map is a diagonal matrix
in Smith normal form.

See `submodule.smith_normal_form_of_le` for a version of this theorem that returns
a `basis.smith_normal_form`.

This is a strengthening of `submodule.basis_of_pid_of_le`.
-/
theorem Submodule.exists_smith_normal_form_of_le [Finite ι] (b : Basis ι R M) (N O : Submodule R M)
    (N_le_O : N ≤ O) :
    ∃ (n o : ℕ)(hno : n ≤ o)(bO : Basis (Fin o) R O)(bN : Basis (Fin n) R N)(a : Fin n → R),
      ∀ i, (bN i : M) = a i • bO (Fin.castLe hno i) :=
  by
  cases nonempty_fintype ι
  revert N
  refine' induction_on_rank b _ _ O
  intro M ih N N_le_M
  obtain ⟨m, b'M⟩ := M.basis_of_pid b
  by_cases N_bot : N = ⊥
  · subst N_bot
    exact ⟨0, m, Nat.zero_le _, b'M, Basis.empty _, finZeroElim, finZeroElim⟩
  obtain ⟨y, hy, a, hay, M', M'_le_M, N', N'_le_N, N'_le_M', y_ortho, ay_ortho, h⟩ :=
    Submodule.basis_of_pid_aux M N b'M N_bot N_le_M
  obtain ⟨n', m', hn'm', bM', bN', as', has'⟩ := ih M' M'_le_M y hy y_ortho N' N'_le_M'
  obtain ⟨bN, h'⟩ := h n' bN'
  obtain ⟨hmn, bM, h''⟩ := h' m' hn'm' bM'
  obtain ⟨as, has⟩ := h'' as' has'
  exact ⟨_, _, hmn, bM, bN, as, has⟩
#align submodule.exists_smith_normal_form_of_le Submodule.exists_smith_normal_form_of_le

/-- If `M` is finite free over a PID `R`, then any submodule `N` is free
and we can find a basis for `M` and `N` such that the inclusion map is a diagonal matrix
in Smith normal form.

See `submodule.exists_smith_normal_form_of_le` for a version of this theorem that doesn't
need to map `N` into a submodule of `O`.

This is a strengthening of `submodule.basis_of_pid_of_le`.
-/
noncomputable def Submodule.smithNormalFormOfLe [Finite ι] (b : Basis ι R M) (N O : Submodule R M)
    (N_le_O : N ≤ O) : Σo n : ℕ, Basis.SmithNormalForm (N.comap O.Subtype) (Fin o) n :=
  by
  choose n o hno bO bN a snf using N.exists_smith_normal_form_of_le b O N_le_O
  refine'
    ⟨o, n, bO, bN.map (comap_subtype_equiv_of_le N_le_O).symm, (Fin.castLe hno).toEmbedding, a,
      fun i => _⟩
  ext
  simp only [snf, Basis.map_apply, Submodule.comapSubtypeEquivOfLe_symm_apply,
    Submodule.coe_smul_of_tower, RelEmbedding.coeFn_toEmbedding]
#align submodule.smith_normal_form_of_le Submodule.smithNormalFormOfLe

/-- If `M` is finite free over a PID `R`, then any submodule `N` is free
and we can find a basis for `M` and `N` such that the inclusion map is a diagonal matrix
in Smith normal form.

This is a strengthening of `submodule.basis_of_pid`.

See also `ideal.smith_normal_form`, which moreover proves that the dimension of
an ideal is the same as the dimension of the whole ring.
-/
noncomputable def Submodule.smithNormalForm [Finite ι] (b : Basis ι R M) (N : Submodule R M) :
    Σn : ℕ, Basis.SmithNormalForm N ι n :=
  let ⟨m, n, bM, bN, f, a, snf⟩ := N.smithNormalFormOfLe b ⊤ le_top
  let bM' := bM.map (LinearEquiv.ofTop _ rfl)
  let e := bM'.indexEquiv b
  ⟨n, bM'.reindex e, bN.map (comapSubtypeEquivOfLe le_top), f.trans e.toEmbedding, a, fun i => by
    simp only [snf, Basis.map_apply, LinearEquiv.ofTop_apply, Submodule.coe_smul_of_tower,
      Submodule.comapSubtypeEquivOfLe_apply_coe, coe_coe, Basis.reindex_apply,
      Equiv.toEmbedding_apply, Function.Embedding.trans_apply, Equiv.symm_apply_apply]⟩
#align submodule.smith_normal_form Submodule.smithNormalForm

section Ideal

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

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix.

See `ideal.exists_smith_normal_form` for a version of this theorem that doesn't
need to map `I` into a submodule of `R`.

This is a strengthening of `submodule.basis_of_pid`.
-/
noncomputable def Ideal.smithNormalForm [Fintype ι] (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) :
    Basis.SmithNormalForm (I.restrictScalars R) ι (Fintype.card ι) :=
  let ⟨n, bS, bI, f, a, snf⟩ := (I.restrictScalars R).SmithNormalForm b
  have eq := Ideal.rank_eq bS hI (bI.map ((restrictScalarsEquiv R S S I).restrictScalars _))
  let e : Fin n ≃ Fin (Fintype.card ι) := Fintype.equivOfCardEq (by rw [Eq, Fintype.card_fin])
  ⟨bS, bI.reindex e, e.symm.toEmbedding.trans f, a ∘ e.symm, fun i => by
    simp only [snf, Basis.coe_reindex, Function.Embedding.trans_apply, Equiv.toEmbedding_apply]⟩
#align ideal.smith_normal_form Ideal.smithNormalForm

variable [Finite ι]

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix.

See also `ideal.smith_normal_form` for a version of this theorem that returns
a `basis.smith_normal_form`.

The definitions `ideal.ring_basis`, `ideal.self_basis`, `ideal.smith_coeffs` are (noncomputable)
choices of values for this existential quantifier.
-/
theorem Ideal.exists_smith_normal_form (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) :
    ∃ (b' : Basis ι R S)(a : ι → R)(ab' : Basis ι R I), ∀ i, (ab' i : S) = a i • b' i := by
  cases nonempty_fintype ι <;>
    exact
      let ⟨bS, bI, f, a, snf⟩ := I.smith_normal_form b hI
      let e : Fin (Fintype.card ι) ≃ ι :=
        Equiv.ofBijective f
          ((Fintype.bijective_iff_injective_and_card f).mpr ⟨f.Injective, Fintype.card_fin _⟩)
      have fe : ∀ i, f (e.symm i) = i := e.apply_symm_apply
      ⟨bS, a ∘ e.symm, (bI.reindex e).map ((restrict_scalars_equiv _ _ _ _).restrictScalars R),
        fun i => by
        simp only [snf, fe, Basis.map_apply, LinearEquiv.restrictScalars_apply,
          Submodule.restrictScalarsEquiv_apply, Basis.coe_reindex]⟩
#align ideal.exists_smith_normal_form Ideal.exists_smith_normal_form

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix; this is the basis for `S`.
See `ideal.self_basis` for the basis on `I`,
see `ideal.smith_coeffs` for the entries of the diagonal matrix
and `ideal.self_basis_def` for the proof that the inclusion map forms a square diagonal matrix.
-/
noncomputable def Ideal.ringBasis (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) : Basis ι R S :=
  (Ideal.exists_smith_normal_form b I hI).some
#align ideal.ring_basis Ideal.ringBasis

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix; this is the basis for `I`.
See `ideal.ring_basis` for the basis on `S`,
see `ideal.smith_coeffs` for the entries of the diagonal matrix
and `ideal.self_basis_def` for the proof that the inclusion map forms a square diagonal matrix.
-/
noncomputable def Ideal.selfBasis (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) : Basis ι R I :=
  (Ideal.exists_smith_normal_form b I hI).choose_spec.choose_spec.some
#align ideal.self_basis Ideal.selfBasis

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix; these are the entries of the diagonal matrix.
See `ideal.ring_basis` for the basis on `S`,
see `ideal.self_basis` for the basis on `I`,
and `ideal.self_basis_def` for the proof that the inclusion map forms a square diagonal matrix.
-/
noncomputable def Ideal.smithCoeffs (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) : ι → R :=
  (Ideal.exists_smith_normal_form b I hI).choose_spec.some
#align ideal.smith_coeffs Ideal.smithCoeffs

/-- If `S` a finite-dimensional ring extension of a PID `R` which is free as an `R`-module,
then any nonzero `S`-ideal `I` is free as an `R`-submodule of `S`, and we can
find a basis for `S` and `I` such that the inclusion map is a square diagonal
matrix.
-/
@[simp]
theorem Ideal.selfBasis_def (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) :
    ∀ i, (Ideal.selfBasis b I hI i : S) = Ideal.smithCoeffs b I hI i • Ideal.ringBasis b I hI i :=
  (Ideal.exists_smith_normal_form b I hI).choose_spec.choose_spec.choose_spec
#align ideal.self_basis_def Ideal.selfBasis_def

@[simp]
theorem Ideal.smithCoeffs_ne_zero (b : Basis ι R S) (I : Ideal S) (hI : I ≠ ⊥) (i) :
    Ideal.smithCoeffs b I hI i ≠ 0 := by
  intro hi
  apply Basis.ne_zero (Ideal.selfBasis b I hI) i
  refine' Subtype.coe_injective _
  simp [hi]
#align ideal.smith_coeffs_ne_zero Ideal.smithCoeffs_ne_zero

end Ideal

end SmithNormal

end PrincipalIdealDomain

/-- A set of linearly independent vectors in a module `M` over a semiring `S` is also linearly
independent over a subring `R` of `K`. -/
theorem LinearIndependent.restrict_scalars_algebras {R S M ι : Type _} [CommSemiring R] [Semiring S]
    [AddCommMonoid M] [Algebra R S] [Module R M] [Module S M] [IsScalarTower R S M]
    (hinj : Function.Injective (algebraMap R S)) {v : ι → M} (li : LinearIndependent S v) :
    LinearIndependent R v :=
  LinearIndependent.restrict_scalars (by rwa [Algebra.algebraMap_eq_smul_one'] at hinj) li
#align linear_independent.restrict_scalars_algebras LinearIndependent.restrict_scalars_algebras


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import Init.SimpLemmas
import Init.Data.Nat.Basic
open Decidable List

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

namespace List

theorem length_add_eq_lengthTRAux (as : List α) (n : Nat) : as.length + n = as.lengthTRAux n := by
  induction as generalizing n with
  | nil  => simp [length, lengthTRAux]
  | cons a as ih =>
    simp [length, lengthTRAux, ← ih, Nat.succ_add]
    rfl

@[csimp] theorem length_eq_lengthTR : @List.length = @List.lengthTR := by
  apply funext; intro α; apply funext; intro as
  simp [lengthTR, ← length_add_eq_lengthTRAux]

@[simp] theorem length_nil : length ([] : List α) = 0 :=
  rfl

def reverseAux : List α → List α → List α
  | [],   r => r
  | a::l, r => reverseAux l (a::r)

def reverse (as : List α) :List α :=
  reverseAux as []

theorem reverseAux_reverseAux_nil (as bs : List α) : reverseAux (reverseAux as bs) [] = reverseAux bs as := by
  induction as generalizing bs with
  | nil => rfl
  | cons a as ih => simp [reverseAux, ih]

theorem reverseAux_reverseAux (as bs cs : List α) : reverseAux (reverseAux as bs) cs = reverseAux bs (reverseAux (reverseAux as []) cs) := by
  induction as generalizing bs cs with
  | nil => rfl
  | cons a as ih => simp [reverseAux, ih (a::bs), ih [a]]

@[simp] theorem reverse_reverse (as : List α) : as.reverse.reverse = as := by
  simp [reverse]; rw [reverseAux_reverseAux_nil]; rfl

protected def append : List α → List α → List α
  | [],    bs => bs
  | a::as, bs => a :: List.append as bs

def appendTR (as bs : List α) : List α :=
  reverseAux as.reverse bs

@[csimp] theorem append_eq_appendTR : @List.append = @appendTR := by
  apply funext; intro α; apply funext; intro as; apply funext; intro bs
  simp [appendTR, reverse]
  induction as with
  | nil  => rfl
  | cons a as ih =>
    simp [reverseAux, List.append, ih, reverseAux_reverseAux]

instance : Append (List α) := ⟨List.append⟩

@[simp] theorem nil_append (as : List α) : [] ++ as = as := rfl
@[simp] theorem append_nil (as : List α) : as ++ [] = as := by
  induction as with
  | nil => rfl
  | cons a as ih =>
    simp_all [HAppend.hAppend, Append.append, List.append]

@[simp] theorem cons_append (a : α) (as bs : List α) : (a::as) ++ bs = a::(as ++ bs) := rfl

theorem append_assoc (as bs cs : List α) : (as ++ bs) ++ cs = as ++ (bs ++ cs) := by
  induction as with
  | nil => rfl
  | cons a as ih => simp [ih]

instance : EmptyCollection (List α) := ⟨List.nil⟩

protected def erase {α} [BEq α] : List α → α → List α
  | [],    b => []
  | a::as, b => match a == b with
    | true  => as
    | false => a :: List.erase as b

def eraseIdx : List α → Nat → List α
  | [],    _   => []
  | a::as, 0   => as
  | a::as, n+1 => a :: eraseIdx as n

def isEmpty : List α → Bool
  | []     => true
  | _ :: _ => false

@[specialize] def map (f : α → β) : List α → List β
  | []    => []
  | a::as => f a :: map f as

@[specialize] def mapTRAux (f : α → β) : List α → List β → List β
  | [],    bs => bs.reverse
  | a::as, bs => mapTRAux f as (f a :: bs)

@[inline] def mapTR (f : α → β) (as : List α) : List β :=
  mapTRAux f as []

theorem reverseAux_eq_append (as bs : List α) : reverseAux as bs = reverseAux as [] ++ bs := by
  induction as generalizing bs with
  | nil => simp [reverseAux]
  | cons a as ih =>
    simp [reverseAux]
    rw [ih (a :: bs), ih [a], append_assoc]
    rfl

@[simp] theorem reverse_nil : reverse ([] : List α) = [] :=
  rfl

@[simp] theorem reverse_cons (a : α) (as : List α) : reverse (a :: as) = reverse as ++ [a] := by
  simp [reverse, reverseAux]
  rw [← reverseAux_eq_append]

@[simp] theorem reverse_append (as bs : List α) : (as ++ bs).reverse = bs.reverse ++ as.reverse := by
  induction as generalizing bs with
  | nil => simp
  | cons a as ih => simp [ih]; rw [append_assoc]

theorem mapTRAux_eq (f : α → β) (as : List α) (bs : List β) : mapTRAux f as bs =  bs.reverse ++ map f as := by
  induction as generalizing bs with
  | nil => simp [mapTRAux, map]
  | cons a as ih =>
    simp [mapTRAux, map]
    rw [ih (f a :: bs), reverse_cons, append_assoc]
    rfl

@[csimp] theorem map_eq_mapTR : @map = @mapTR := by
  apply funext; intro α; apply funext; intro β; apply funext; intro f; apply funext; intro as
  simp [mapTR, mapTRAux_eq]

@[specialize] def map₂ (f : α → β → γ) : List α → List β → List γ
  | [],    _     => []
  | _,     []    => []
  | a::as, b::bs => f a b :: map₂ f as bs

def join : List (List α) → List α
  | []      => []
  | a :: as => a ++ join as

@[specialize] def filterMap (f : α → Option β) : List α → List β
  | []   => []
  | a::as =>
    match f a with
    | none   => filterMap f as
    | some b => b :: filterMap f as

@[specialize] def filterAux (p : α → Bool) : List α → List α → List α
  | [],    rs => rs.reverse
  | a::as, rs => match p a with
     | true  => filterAux p as (a::rs)
     | false => filterAux p as rs

@[inline] def filter (p : α → Bool) (as : List α) : List α :=
  filterAux p as []

@[specialize] def partitionAux (p : α → Bool) : List α → List α × List α → List α × List α
  | [],    (bs, cs) => (bs.reverse, cs.reverse)
  | a::as, (bs, cs) =>
    match p a with
    | true  => partitionAux p as (a::bs, cs)
    | false => partitionAux p as (bs, a::cs)

@[inline] def partition (p : α → Bool) (as : List α) : List α × List α :=
  partitionAux p as ([], [])

def dropWhile (p : α → Bool) : List α → List α
  | []   => []
  | a::l => match p a with
    | true  => dropWhile p l
    | false =>  a::l

def find? (p : α → Bool) : List α → Option α
  | []    => none
  | a::as => match p a with
    | true  => some a
    | false => find? p as

def findSome? (f : α → Option β) : List α → Option β
  | []    => none
  | a::as => match f a with
    | some b => some b
    | none   => findSome? f as

def replace [BEq α] : List α → α → α → List α
  | [],    _, _ => []
  | a::as, b, c => match a == b with
    | true  => c::as
    | false => a :: (replace as b c)

def elem [BEq α] (a : α) : List α → Bool
  | []    => false
  | b::bs => match a == b with
    | true  => true
    | false => elem a bs

def notElem [BEq α] (a : α) (as : List α) : Bool :=
  !(as.elem a)

abbrev contains [BEq α] (as : List α) (a : α) : Bool :=
  elem a as

def eraseDupsAux {α} [BEq α] : List α → List α → List α
  | [],    bs => bs.reverse
  | a::as, bs => match bs.elem a with
    | true  => eraseDupsAux as bs
    | false => eraseDupsAux as (a::bs)

def eraseDups {α} [BEq α] (as : List α) : List α :=
  eraseDupsAux as []

def eraseRepsAux {α} [BEq α] : α → List α → List α → List α
  | a, [], rs => (a::rs).reverse
  | a, a'::as, rs => match a == a' with
    | true  => eraseRepsAux a as rs
    | false => eraseRepsAux a' as (a::rs)

/-- Erase repeated adjacent elements. -/
def eraseReps {α} [BEq α] : List α → List α
  | []    => []
  | a::as => eraseRepsAux a as []

@[specialize] def spanAux (p : α → Bool) : List α → List α → List α × List α
  | [],    rs => (rs.reverse, [])
  | a::as, rs => match p a with
    | true  => spanAux p as (a::rs)
    | false => (rs.reverse, a::as)

@[inline] def span (p : α → Bool) (as : List α) : List α × List α :=
  spanAux p as []

@[specialize] def groupByAux (eq : α → α → Bool) : List α → List (List α) → List (List α)
  | a::as, (ag::g)::gs => match eq a ag with
    | true  => groupByAux eq as ((a::ag::g)::gs)
    | false => groupByAux eq as ([a]::(ag::g).reverse::gs)
  | _, gs => gs.reverse

@[specialize] def groupBy (p : α → α → Bool) : List α → List (List α)
  | []    => []
  | a::as => groupByAux p as [[a]]

def lookup [BEq α] : α → List (α × β) → Option β
  | _, []        => none
  | a, (k,b)::es => match a == k with
    | true  => some b
    | false => lookup a es

def removeAll [BEq α] (xs ys : List α) : List α :=
  xs.filter (fun x => ys.notElem x)

def drop : Nat → List α → List α
  | 0,   a     => a
  | n+1, []    => []
  | n+1, a::as => drop n as

def take : Nat → List α → List α
  | 0,   a     => []
  | n+1, []    => []
  | n+1, a::as => a :: take n as

def takeWhile (p : α → Bool) : List α → List α
  | []       => []
  | hd :: tl => match p hd with
   | true  => hd :: takeWhile p tl
   | false => []

@[specialize] def foldr (f : α → β → β) (init : β) : List α → β
  | []     => init
  | a :: l => f a (foldr f init l)

@[inline] def any (l : List α) (p : α → Bool) : Bool :=
  foldr (fun a r => p a || r) false l

@[inline] def all (l : List α) (p : α → Bool) : Bool :=
  foldr (fun a r => p a && r) true l

def or  (bs : List Bool) : Bool := bs.any id

def and (bs : List Bool) : Bool := bs.all id

def zipWith (f : α → β → γ) : List α → List β → List γ
  | x::xs, y::ys => f x y :: zipWith f xs ys
  | _,     _     => []

def zip : List α → List β → List (Prod α β) :=
  zipWith Prod.mk

def unzip : List (α × β) → List α × List β
  | []          => ([], [])
  | (a, b) :: t => match unzip t with | (al, bl) => (a::al, b::bl)

def rangeAux : Nat → List Nat → List Nat
  | 0,   ns => ns
  | n+1, ns => rangeAux n (n::ns)

def range (n : Nat) : List Nat :=
  rangeAux n []

def iota : Nat → List Nat
  | 0       => []
  | m@(n+1) => m :: iota n

def enumFrom : Nat → List α → List (Nat × α)
  | n, [] => nil
  | n, x :: xs   => (n, x) :: enumFrom (n + 1) xs

def enum : List α → List (Nat × α) := enumFrom 0

def init : List α → List α
  | []   => []
  | [a]  => []
  | a::l => a::init l

def intersperse (sep : α) : List α → List α
  | []    => []
  | [x]   => [x]
  | x::xs => x :: sep :: intersperse sep xs

def intercalate (sep : List α) (xs : List (List α)) : List α :=
  join (intersperse sep xs)

@[inline] protected def bind {α : Type u} {β : Type v} (a : List α) (b : α → List β) : List β := join (map b a)

@[inline] protected def pure {α : Type u} (a : α) : List α := [a]

inductive lt [LT α] : List α → List α → Prop where
  | nil  (b : α) (bs : List α) : lt [] (b::bs)
  | head {a : α} (as : List α) {b : α} (bs : List α) : a < b → lt (a::as) (b::bs)
  | tail {a : α} {as : List α} {b : α} {bs : List α} : ¬ a < b → ¬ b < a → lt as bs → lt (a::as) (b::bs)

instance [LT α] : LT (List α) := ⟨List.lt⟩

instance hasDecidableLt [LT α] [h : DecidableRel (α:=α) (·<·)] : (l₁ l₂ : List α) → Decidable (l₁ < l₂)
  | [],    []    => isFalse (fun h => nomatch h)
  | [],    b::bs => isTrue (List.lt.nil _ _)
  | a::as, []    => isFalse (fun h => nomatch h)
  | a::as, b::bs =>
    match h a b with
    | isTrue h₁  => isTrue (List.lt.head _ _ h₁)
    | isFalse h₁ =>
      match h b a with
      | isTrue h₂  => isFalse (fun h => match h with
         | List.lt.head _ _ h₁' => absurd h₁' h₁
         | List.lt.tail _ h₂' _ => absurd h₂ h₂')
      | isFalse h₂ =>
        match hasDecidableLt as bs with
        | isTrue h₃  => isTrue (List.lt.tail h₁ h₂ h₃)
        | isFalse h₃ => isFalse (fun h => match h with
           | List.lt.head _ _ h₁' => absurd h₁' h₁
           | List.lt.tail _ _ h₃' => absurd h₃' h₃)

@[reducible] protected def le [LT α] (a b : List α) : Prop := ¬ b < a

instance [LT α] : LE (List α) := ⟨List.le⟩

instance [LT α] [h : DecidableRel ((· < ·) : α → α → Prop)] : (l₁ l₂ : List α) → Decidable (l₁ ≤ l₂) :=
  fun a b => inferInstanceAs (Decidable (Not _))

/--  `isPrefixOf l₁ l₂` returns `true` Iff `l₁` is a prefix of `l₂`. -/
def isPrefixOf [BEq α] : List α → List α → Bool
  | [],    _     => true
  | _,     []    => false
  | a::as, b::bs => a == b && isPrefixOf as bs

/--  `isSuffixOf l₁ l₂` returns `true` Iff `l₁` is a suffix of `l₂`. -/
def isSuffixOf [BEq α] (l₁ l₂ : List α) : Bool :=
  isPrefixOf l₁.reverse l₂.reverse

@[specialize] def isEqv : List α → List α → (α → α → Bool) → Bool
  | [],    [],    _   => true
  | a::as, b::bs, eqv => eqv a b && isEqv as bs eqv
  | _,     _,     eqv => false

protected def beq [BEq α] : List α → List α → Bool
  | [],    []    => true
  | a::as, b::bs => a == b && List.beq as bs
  | _,     _     => false

instance [BEq α] : BEq (List α) := ⟨List.beq⟩

@[simp] def replicate : (n : Nat) → (a : α) → List α
  | 0,   a => []
  | n+1, a => a :: replicate n a

def replicateTR {α : Type u} (n : Nat) (a : α) : List α :=
  let rec loop : Nat → List α → List α
    | 0, as => as
    | n+1, as => loop n (a::as)
  loop n []

theorem replicateTR_loop_replicate_eq (a : α) (m n : Nat) :
  replicateTR.loop a n (replicate m a) = replicate (n + m) a := by
  induction n generalizing m with simp [replicateTR.loop]
  | succ n ih => simp [Nat.succ_add]; exact ih (m+1)

@[csimp] theorem replicate_eq_replicateTR : @List.replicate = @List.replicateTR := by
  apply funext; intro α; apply funext; intro n; apply funext; intro a
  exact (replicateTR_loop_replicate_eq _ 0 n).symm

def dropLast {α} : List α → List α
  | []    => []
  | [a]   => []
  | a::as => a :: dropLast as

@[simp] theorem length_replicate (n : Nat) (a : α) : (replicate n a).length = n := by
  induction n <;> simp_all

@[simp] theorem length_concat (as : List α) (a : α) : (concat as a).length = as.length + 1 := by
  induction as with
  | nil => rfl
  | cons x xs ih => simp [concat, ih]

@[simp] theorem length_set (as : List α) (i : Nat) (a : α) : (as.set i a).length = as.length := by
  induction as generalizing i with
  | nil => rfl
  | cons x xs ih =>
    cases i with
    | zero => rfl
    | succ i => simp [set, ih]

@[simp] theorem length_dropLast (as : List α) : as.dropLast.length = as.length - 1 := by
  match as with
  | []       => rfl
  | [a]      => rfl
  | a::b::as =>
    have ih := length_dropLast (b::as)
    simp[dropLast, ih]
    rfl

@[simp] theorem length_append (as bs : List α) : (as ++ bs).length = as.length + bs.length := by
  induction as with
  | nil => simp
  | cons a as ih => simp [ih, Nat.succ_add]

@[simp] theorem length_reverse (as : List α) : (as.reverse).length = as.length := by
  induction as with
  | nil => rfl
  | cons a as ih => simp [ih]

def maximum? [LT α] [DecidableRel (@LT.lt α _)] : List α → Option α
  | []    => none
  | a::as => some <| as.foldl max a

def minimum? [LE α] [DecidableRel (@LE.le α _)] : List α → Option α
  | []    => none
  | a::as => some <| as.foldl min a

end List


import algebra.camera.basic

universe u

inductive exclusive (α : Type u)
| mk : α → exclusive
| bot : exclusive

namespace exclusive

lemma mk_injective {α : Type u} : function.injective (mk : α → exclusive α) :=
λ a b h, by cases h; refl

inductive eq_at {α : Type u} [ofe α] (n : ℕ) : exclusive α → exclusive α → Prop
| mk {a b : α} : a =[n] b → eq_at (mk a) (mk b)
| bot : eq_at bot bot

instance {α : Type u} [ofe α] : ofe (exclusive α) := {
  eq_at := eq_at,
  eq_at_reflexive := begin
    rintros n (a | a),
    exact eq_at.mk (eq_at_refl n a),
    exact eq_at.bot,
  end,
  eq_at_symmetric := begin
    rintros n (a | a) (b | b) (h | h),
    refine eq_at.mk _,
    symmetry, assumption,
    exact eq_at.bot,
  end,
  eq_at_transitive := begin
    rintros n (a | a) (b | b) (c | c) (hab | hab) (hbc | hbc),
    refine eq_at.mk _,
    transitivity b; assumption,
    exact eq_at.bot,
  end,
  eq_at_mono' := begin
    rintros m n hmn (a | a) (b | b) (h | h),
    exact eq_at.mk (eq_at_mono hmn ‹_›),
    exact eq_at.bot,
  end,
  eq_at_limit' := begin
    rintros (a | a) (b | b) h;
    cases h 0,
    refine congr_arg mk _,
    rw eq_at_limit,
    intro n,
    cases h n,
    assumption,
    refl,
  end,
}

lemma mk_eq_at {α : Type u} [ofe α] {n : ℕ} {a b : α} :
  mk a =[n] mk b → a =[n] b :=
λ h, by cases h; assumption

@[simp] lemma mk_eq_at_iff {α : Type u} [ofe α] {n : ℕ} {a b : α} :
  mk a =[n] mk b ↔ a =[n] b :=
⟨mk_eq_at, eq_at.mk⟩

@[simp] lemma exists_eq_iff_mk_eq {α : Type u} [ofe α] {n : ℕ} {a : α} {b : exclusive α} :
  mk a =[n] b ↔ ∃ b', b = mk b' ∧ a =[n] b' :=
begin
  split,
  { rintro (h | h),
    exact ⟨_, rfl, ‹_›⟩, },
  { rintro ⟨b', rfl, hb⟩,
    exact mk_eq_at_iff.mpr hb, },
end

instance {α : Type u} : comm_semigroup (exclusive α) := {
  mul := λ a b, bot,
  mul_assoc := λ a b c, rfl,
  mul_comm := λ a b, rfl,
}

@[simp] lemma mul_eq_bot {α : Type u} (a b : exclusive α) : a * b = bot := rfl

def core {α : Type u} : exclusive α → option (exclusive α)
| (mk a) := none
| bot := some bot

instance {α : Type u} [ofe α] : camera (exclusive α) := {
  validn := ⟨λ a, ⟨λ n, a ≠ bot, λ m n hmn h, h⟩, begin
    rintros n a b (h | h) m hmn,
    simp only [ne.def],
    simp only,
  end⟩,
  core := ⟨core, by rintros n a b (h | h); refl⟩,
  extend := λ n a b₁ b₂ h₁ h₂, ⟨b₁, b₂⟩,
  mul_is_nonexpansive := λ n a b h, by refl,
  core_mul_self := λ a ca h, by cases a; cases h; refl,
  core_core := λ a ca h, by cases a; cases h; refl,
  core_mono_some := λ a b ca h₁ h₂, by cases a; cases h₁; cases h₂.some_spec; exact ⟨bot, rfl⟩,
  core_mono := λ a b ca h₁ h₂, by cases a; cases h₁; cases h₂.some_spec; exact ⟨some bot, rfl⟩,
  validn_mul := λ a b n h, by cases h rfl,
  extend_mul_eq := λ n a b₁ b₂ h₁ h₂, by cases a; cases h₂; refl,
  extend_eq_at_left := λ n a b₁ b₂ h₁ h₂, by refl,
  extend_eq_at_right := λ n a b₁ b₂ h₁ h₂, by refl,
  ..exclusive.ofe,
  ..exclusive.comm_semigroup,
}

end exclusive


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.closed.cartesian
import Mathlib.category_theory.limits.preserves.shapes.binary_products
import Mathlib.category_theory.adjunction.fully_faithful
import Mathlib.PostPort

universes v u u' l

namespace Mathlib

/-!
# Cartesian closed functors

Define the exponential comparison morphisms for a functor which preserves binary products, and use
them to define a cartesian closed functor: one which (naturally) preserves exponentials.

Define the Frobenius morphism, and show it is an isomorphism iff the exponential comparison is an
isomorphism.

## TODO
Some of the results here are true more generally for closed objects and for closed monoidal
categories, and these could be generalised.

## References
https://ncatlab.org/nlab/show/cartesian+closed+functor
https://ncatlab.org/nlab/show/Frobenius+reciprocity

## Tags
Frobenius reciprocity, cartesian closed functor

-/

namespace category_theory

/--
The Frobenius morphism for an adjunction `L ⊣ F` at `A` is given by the morphism

    L(FA ⨯ B) ⟶ LFA ⨯ LB ⟶ A ⨯ LB

natural in `B`, where the first morphism is the product comparison and the latter uses the counit
of the adjunction.

We will show that if `C` and `D` are cartesian closed, then this morphism is an isomorphism for all
`A` iff `F` is a cartesian closed functor, i.e. it preserves exponentials.
-/
def frobenius_morphism {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) {L : D ⥤ C}
    (h : L ⊣ F) (A : C) :
    functor.obj limits.prod.functor (functor.obj F A) ⋙ L ⟶ L ⋙ functor.obj limits.prod.functor A :=
  limits.prod_comparison_nat_trans L (functor.obj F A) ≫
    whisker_left L (functor.map limits.prod.functor (nat_trans.app (adjunction.counit h) A))

/--
If `F` is full and faithful and has a left adjoint `L` which preserves binary products, then the
Frobenius morphism is an isomorphism.
-/
protected instance frobenius_morphism_iso_of_preserves_binary_products {C : Type u} [category C]
    {D : Type u'} [category D] [limits.has_finite_products C] [limits.has_finite_products D]
    (F : C ⥤ D) {L : D ⥤ C} (h : L ⊣ F) (A : C)
    [limits.preserves_limits_of_shape (discrete limits.walking_pair) L] [full F] [faithful F] :
    is_iso (frobenius_morphism F h A) :=
  nat_iso.is_iso_of_is_iso_app (frobenius_morphism F h A)

/--
The exponential comparison map.
`F` is a cartesian closed functor if this is an iso for all `A`.
-/
def exp_comparison {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F]
    (A : C) : exp A ⋙ F ⟶ F ⋙ exp (functor.obj F A) :=
  coe_fn (transfer_nat_trans (exp.adjunction A) (exp.adjunction (functor.obj F A)))
    (iso.inv (limits.prod_comparison_nat_iso F A))

theorem exp_comparison_ev {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (A : C)
    (B : C) :
    limits.prod.map 𝟙 (nat_trans.app (exp_comparison F A) B) ≫
          nat_trans.app (ev (functor.obj F A)) (functor.obj F B) =
        inv (limits.prod_comparison F A (functor.obj (exp A) B)) ≫
          functor.map F (nat_trans.app (ev A) B) :=
  sorry

theorem coev_exp_comparison {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (A : C)
    (B : C) :
    functor.map F (nat_trans.app (coev A) B) ≫ nat_trans.app (exp_comparison F A) (A ⨯ B) =
        nat_trans.app (coev (functor.obj F A)) (functor.obj F B) ≫
          functor.map (exp (functor.obj F A)) (inv (limits.prod_comparison F A B)) :=
  sorry

theorem uncurry_exp_comparison {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (A : C)
    (B : C) :
    cartesian_closed.uncurry (nat_trans.app (exp_comparison F A) B) =
        inv (limits.prod_comparison F A (functor.obj (exp A) B)) ≫
          functor.map F (nat_trans.app (ev A) B) :=
  sorry

/-- The exponential comparison map is natural in `A`. -/
theorem exp_comparison_whisker_left {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] {A : C}
    {A' : C} (f : A' ⟶ A) :
    exp_comparison F A ≫ whisker_left F (pre (functor.map F f)) =
        whisker_right (pre f) F ≫ exp_comparison F A' :=
  sorry

/--
The functor `F` is cartesian closed (ie preserves exponentials) if each natural transformation
`exp_comparison F A` is an isomorphism
-/
class cartesian_closed_functor {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) [cartesian_closed C]
    [cartesian_closed D] [limits.preserves_limits_of_shape (discrete limits.walking_pair) F]
    where
  comparison_iso : (A : C) → is_iso (exp_comparison F A)

theorem frobenius_morphism_mate {C : Type u} [category C] {D : Type u'} [category D]
    [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D) {L : D ⥤ C}
    [cartesian_closed C] [cartesian_closed D]
    [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (h : L ⊣ F) (A : C) :
    coe_fn
          (transfer_nat_trans_self
            (adjunction.comp (functor.obj limits.prod.functor A) (exp A) h (exp.adjunction A))
            (adjunction.comp L F (exp.adjunction (functor.obj F A)) h))
          (frobenius_morphism F h A) =
        exp_comparison F A :=
  sorry

/--
If the exponential comparison transformation (at `A`) is an isomorphism, then the Frobenius morphism
at `A` is an isomorphism.
-/
def frobenius_morphism_iso_of_exp_comparison_iso {C : Type u} [category C] {D : Type u'}
    [category D] [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D)
    {L : D ⥤ C} [cartesian_closed C] [cartesian_closed D]
    [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (h : L ⊣ F) (A : C)
    [i : is_iso (exp_comparison F A)] : is_iso (frobenius_morphism F h A) :=
  transfer_nat_trans_self_of_iso
    (adjunction.comp (functor.obj limits.prod.functor A) (exp A) h (exp.adjunction A))
    (adjunction.comp L F (exp.adjunction (functor.obj F A)) h) (frobenius_morphism F h A)

/--
If the Frobenius morphism at `A` is an isomorphism, then the exponential comparison transformation
(at `A`) is an isomorphism.
-/
def exp_comparison_iso_of_frobenius_morphism_iso {C : Type u} [category C] {D : Type u'}
    [category D] [limits.has_finite_products C] [limits.has_finite_products D] (F : C ⥤ D)
    {L : D ⥤ C} [cartesian_closed C] [cartesian_closed D]
    [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (h : L ⊣ F) (A : C)
    [i : is_iso (frobenius_morphism F h A)] : is_iso (exp_comparison F A) :=
  eq.mpr sorry
    (category_theory.transfer_nat_trans_self_iso
      (adjunction.comp (functor.obj limits.prod.functor A) (exp A) h (exp.adjunction A))
      (adjunction.comp L F (exp.adjunction (functor.obj F A)) h) (frobenius_morphism F h A))

/--
If `F` is full and faithful, and has a left adjoint which preserves binary products, then it is
cartesian closed.

TODO: Show the converse, that if `F` is cartesian closed and its left adjoint preserves binary
products, then it is full and faithful.
-/
def cartesian_closed_functor_of_left_adjoint_preserves_binary_products {C : Type u} [category C]
    {D : Type u'} [category D] [limits.has_finite_products C] [limits.has_finite_products D]
    (F : C ⥤ D) {L : D ⥤ C} [cartesian_closed C] [cartesian_closed D]
    [limits.preserves_limits_of_shape (discrete limits.walking_pair) F] (h : L ⊣ F) [full F]
    [faithful F] [limits.preserves_limits_of_shape (discrete limits.walking_pair) L] :
    cartesian_closed_functor F :=
  cartesian_closed_functor.mk fun (A : C) => exp_comparison_iso_of_frobenius_morphism_iso F h A

end Mathlib